From 53094e3027dc1fc44b0a981f45013e0da20368e1 Mon Sep 17 00:00:00 2001 From: Niklas Larsson Date: Mon, 10 May 2021 10:00:46 +0200 Subject: [PATCH] Choose foreign string based on priority Instead of taking the first applicable string, the backends submit an ordered list of preferred prefixes and get the first match. --- src/Compiler/Common.idr | 34 +++++++++++++++++++++------------- src/Compiler/Scheme/Chez.idr | 9 ++++----- src/Compiler/Scheme/Gambit.idr | 9 ++++----- src/Compiler/Scheme/Racket.idr | 9 ++++----- 4 files changed, 33 insertions(+), 28 deletions(-) diff --git a/src/Compiler/Common.idr b/src/Compiler/Common.idr index a9d481df5..1bf9e664b 100644 --- a/src/Compiler/Common.idr +++ b/src/Compiler/Common.idr @@ -342,23 +342,20 @@ exists f | Left err => pure False closeFile ok pure True - --- Parse a calling convention into a backend/target for the call, and --- a comma separated list of any other location data. +-- Select the most preferred target from an ordered list of choices and +-- parse the calling convention into a backend/target for the call, and +-- a comma separated list of any other location data. For example +-- the chez backend would supply ["scheme,chez", "scheme", "C"]. For a function with +-- more than one string, a string with "scheme" would be preferred over one +-- with "C" and "scheme,chez" would be preferred to both. -- e.g. "scheme:display" - call the scheme function 'display' -- "C:puts,libc,stdio.h" - call the C function 'puts' which is in -- the library libc and the header stdio.h --- Returns Nothing if the string is empty (which a backend can interpret --- however it likes) +-- Returns Nothing if there is no match. export -parseCC : String -> Maybe (String, List String) -parseCC "" = Nothing -parseCC str - = case span (/= ':') str of - (target, "") => Just (trim target, []) - (target, opts) => Just (trim target, - map trim (getOpts - (assert_total (strTail opts)))) +parseCC : List String -> List String -> Maybe (String, List String) +parseCC [] _ = Nothing +parseCC (target::ts) strs = findTarget target strs <|> parseCC ts strs where getOpts : String -> List String getOpts "" = [] @@ -366,6 +363,17 @@ parseCC str = case span (/= ',') str of (opt, "") => [opt] (opt, rest) => opt :: getOpts (assert_total (strTail rest)) + hasTarget : String -> String -> Bool + hasTarget target str = case span (/= ':') str of + (targetSpec, _) => targetSpec == target + findTarget : String -> List String -> Maybe (String, List String) + findTarget target [] = Nothing + findTarget target (s::xs) = if hasTarget target s + then case span (/= ':') s of + (t, "") => Just (trim t, []) + (t, opts) => Just (trim t, map trim (getOpts + (assert_total (strTail opts)))) + else findTarget target xs export dylib_suffix : String diff --git a/src/Compiler/Scheme/Chez.idr b/src/Compiler/Scheme/Chez.idr index 598df91f1..a733d1b9d 100644 --- a/src/Compiler/Scheme/Chez.idr +++ b/src/Compiler/Scheme/Chez.idr @@ -272,10 +272,9 @@ schemeCall fc sfn argns ret useCC : {auto c : Ref Ctxt Defs} -> {auto l : Ref Loaded (List String)} -> String -> FC -> List String -> List (Name, CFType) -> CFType -> Core (String, String) -useCC appdir fc [] args ret = throw (NoForeignCC fc) -useCC appdir fc (cc :: ccs) args ret - = case parseCC cc of - Nothing => useCC appdir fc ccs args ret +useCC appdir fc ccs args ret + = case parseCC ["scheme,chez", "scheme", "C"] ccs of + Nothing => throw (NoForeignCC fc) Just ("scheme,chez", [sfn]) => do body <- schemeCall fc sfn (map fst args) ret pure ("", body) @@ -284,7 +283,7 @@ useCC appdir fc (cc :: ccs) args ret pure ("", body) Just ("C", [cfn, clib]) => cCall appdir fc cfn clib args ret Just ("C", [cfn, clib, chdr]) => cCall appdir fc cfn clib args ret - _ => useCC appdir fc ccs args ret + _ => throw (NoForeignCC fc) -- For every foreign arg type, return a name, and whether to pass it to the -- foreign call (we don't pass '%World') diff --git a/src/Compiler/Scheme/Gambit.idr b/src/Compiler/Scheme/Gambit.idr index 0b8b6f640..37406587b 100644 --- a/src/Compiler/Scheme/Gambit.idr +++ b/src/Compiler/Scheme/Gambit.idr @@ -301,15 +301,14 @@ schemeCall fc sfn argns ret useCC : {auto c : Ref Ctxt Defs} -> {auto l : Ref Loaded (List String)} -> FC -> List String -> List (Name, CFType) -> CFType -> Core (Maybe String, (String, String)) -useCC fc [] args ret = throw (NoForeignCC fc) -useCC fc (cc :: ccs) args ret - = case parseCC cc of - Nothing => useCC fc ccs args ret +useCC fc ccs args ret + = case parseCC ["scheme,gambit", "scheme", "C"] ccs of + Nothing => throw (NoForeignCC fc) Just ("scheme,gambit", [sfn]) => pure (Nothing, (!(schemeCall fc sfn (map fst args) ret), "")) Just ("scheme", [sfn]) => pure (Nothing, (!(schemeCall fc sfn (map fst args) ret), "")) Just ("C", [cfn, clib]) => pure (Just clib, !(cCall fc cfn (fnWrapName cfn) clib args ret)) Just ("C", [cfn, clib, chdr]) => pure (Just clib, !(cCall fc cfn (fnWrapName cfn) clib args ret)) - _ => useCC fc ccs args ret + _ => throw (NoForeignCC fc) where fnWrapName : String -> String -> String fnWrapName cfn schemeArgName = schemeArgName ++ "-" ++ cfn ++ "-cFunWrap" diff --git a/src/Compiler/Scheme/Racket.idr b/src/Compiler/Scheme/Racket.idr index 19d80f1c0..8d67d8e61 100644 --- a/src/Compiler/Scheme/Racket.idr +++ b/src/Compiler/Scheme/Racket.idr @@ -260,10 +260,9 @@ useCC : {auto f : Ref Done (List String) } -> {auto c : Ref Ctxt Defs} -> {auto l : Ref Loaded (List String)} -> String -> FC -> List String -> List (Name, CFType) -> CFType -> Core (String, String) -useCC appdir fc [] args ret = throw (NoForeignCC fc) -useCC appdir fc (cc :: ccs) args ret - = case parseCC cc of - Nothing => useCC appdir fc ccs args ret +useCC appdir fc ccs args ret + = case parseCC ["scheme,racket", "scheme", "C"] ccs of + Nothing => throw (NoForeignCC fc) Just ("scheme,racket", [sfn]) => do body <- schemeCall fc sfn (map fst args) ret pure ("", body) @@ -272,7 +271,7 @@ useCC appdir fc (cc :: ccs) args ret pure ("", body) Just ("C", [cfn, clib]) => cCall appdir fc cfn clib args ret Just ("C", [cfn, clib, chdr]) => cCall appdir fc cfn clib args ret - _ => useCC appdir fc ccs args ret + _ => throw (NoForeignCC fc) -- For every foreign arg type, return a name, and whether to pass it to the -- foreign call (we don't pass '%World')