diff --git a/docs/source/backends/index.rst b/docs/source/backends/index.rst index 2d235a6cb..290836c3e 100644 --- a/docs/source/backends/index.rst +++ b/docs/source/backends/index.rst @@ -65,7 +65,7 @@ running ``:set profile`` at the REPL. The profile data generated will depend on the back end you are using. Currently, the Chez and Racket back ends support generating profile data. -There are five code generators provided in Idris 2, and (later) there will be +There are five code generators provided in Idris 2, and there is a system for plugging in new code generators for a variety of targets. The default is to compile via Chez Scheme, with an alternative via Racket or Gambit. You can set the code generator at the REPL with the `:set codegen` command, @@ -86,3 +86,11 @@ There are also external code generators that aren't part of the main Idris 2 repository and can be found on Idris 2 wiki: `External backends `_ + +There is work in progress support for generating +libraries for other languages from idris2 code. + +.. toctree:: + :maxdepth: 1 + + libraries diff --git a/docs/source/backends/libraries.rst b/docs/source/backends/libraries.rst new file mode 100644 index 000000000..48ff662de --- /dev/null +++ b/docs/source/backends/libraries.rst @@ -0,0 +1,32 @@ +*************** +Libraries +*************** + +This pragma tells the backend what name to use for a given function. + +.. code-block:: idris + + %nomangle + foo : Int -> Int + foo x = x + 1 + +On backends that support this feature, the function will be called ``foo`` +rather than being mangled, with the namespace. + +If the name you want to use isn't a valid idris identifier, you can use a different name +for the idris name and name that appears in the compiled code, e.g. + +.. code-block:: idris + + %nomangle "$_baz" + baz : Int + baz = 42 + +You can also specificy different names for different backends, in a similar way to %foreign + +.. code-block:: idris + + %nomangle "refc:idr_add_one" + "node:add_one" + plusOne : Bits32 -> Bits32 + plusOne x = x + 1 diff --git a/idris2api.ipkg b/idris2api.ipkg index 10ac9ddae..96b8fa667 100644 --- a/idris2api.ipkg +++ b/idris2api.ipkg @@ -14,6 +14,7 @@ modules = Compiler.Generated, Compiler.Inline, Compiler.LambdaLift, + Compiler.NoMangle, Compiler.Opts.CSE, Compiler.Separate, Compiler.VMCode, @@ -155,6 +156,7 @@ modules = Libraries.Data.List.Lazy, Libraries.Data.List1, Libraries.Data.NameMap, + Libraries.Data.NameMap.Traversable, Libraries.Data.PosMap, Libraries.Data.Primitives, Libraries.Data.SortedMap, diff --git a/libs/base/Language/Reflection/TTImp.idr b/libs/base/Language/Reflection/TTImp.idr index 6a89ef5de..9fd1b984f 100644 --- a/libs/base/Language/Reflection/TTImp.idr +++ b/libs/base/Language/Reflection/TTImp.idr @@ -90,6 +90,11 @@ mutual Unique : AltType UniqueDefault : TTImp -> AltType + public export + data NoMangleDirective : Type where + CommonName : String -> NoMangleDirective + BackendNames : List (String, String) -> NoMangleDirective + public export data FnOpt : Type where Inline : FnOpt @@ -108,6 +113,8 @@ mutual Totality : TotalReq -> FnOpt Macro : FnOpt SpecArgs : List Name -> FnOpt + ||| Keep the user provided name during codegen + NoMangle : NoMangleDirective -> FnOpt public export data ITy : Type where diff --git a/src/Compiler/Common.idr b/src/Compiler/Common.idr index 238807832..1cd6ccb49 100644 --- a/src/Compiler/Common.idr +++ b/src/Compiler/Common.idr @@ -5,6 +5,7 @@ import Compiler.ANF import Compiler.CompileExpr import Compiler.Inline import Compiler.LambdaLift +import Compiler.NoMangle import Compiler.Opts.CSE import Compiler.VMCode @@ -150,6 +151,7 @@ getMinimalDef (Coded ns bin) pure (def, Just (ns, bin)) -- ||| Recursively get all calls in a function definition +-- ||| Note: this only checks resolved names getAllDesc : {auto c : Ref Ctxt Defs} -> List Name -> -- calls to check IOArray (Int, Maybe (Namespace, Binary)) -> @@ -274,13 +276,14 @@ getCompileData doLazyAnnots phase_in tm_in "Found names: " ++ concat (intersperse ", " $ map show $ keys ns) tm <- toFullNames tm_in natHackNames' <- traverse toResolvedNames natHackNames + noMangleNames <- getAllNoMangle -- make an array of Bools to hold which names we've found (quicker -- to check than a NameMap!) asize <- getNextEntry arr <- coreLift $ newArray asize defs <- get Ctxt - logTime "++ Get names" $ getAllDesc (natHackNames' ++ keys ns) arr defs + logTime "++ Get names" $ getAllDesc (natHackNames' ++ noMangleNames ++ keys ns) arr defs let entries = catMaybes !(coreLift (toList arr)) let allNs = map (Resolved . fst) entries diff --git a/src/Compiler/ES/Codegen.idr b/src/Compiler/ES/Codegen.idr index 87e43d194..31ec6e0a0 100644 --- a/src/Compiler/ES/Codegen.idr +++ b/src/Compiler/ES/Codegen.idr @@ -12,9 +12,11 @@ import Compiler.ES.Doc import Compiler.ES.ToAst import Compiler.ES.TailRec import Compiler.ES.State +import Compiler.NoMangle import Libraries.Data.SortedMap import Libraries.Utils.Hex import Libraries.Data.String.Extra +import Libraries.Data.NameMap import Data.Vect @@ -71,15 +73,18 @@ jsIdent s = concatMap okchar (unpack s) then cast c else "x" ++ asHex (cast c) +jsReservedNames : List String +jsReservedNames = + [ "var", "switch" + , "return", "const" + , "function", "break" + , "continue" + ] + keywordSafe : String -> String -keywordSafe "var" = "var$" -keywordSafe "switch" = "switch$" -keywordSafe "return" = "return$" -keywordSafe "const" = "const$" -keywordSafe "function" = "function$" -keywordSafe "break" = "break$" -keywordSafe "continue" = "continue$" -keywordSafe s = s +keywordSafe s = if s `elem` jsReservedNames + then s ++ "$" + else s -------------------------------------------------------------------------------- -- JS Name @@ -90,19 +95,25 @@ jsUserName (Basic n) = keywordSafe $ jsIdent n jsUserName (Field n) = "rf__" ++ jsIdent n jsUserName Underscore = keywordSafe $ jsIdent "_" -jsName : Name -> String -jsName (NS ns n) = jsIdent (showNSWithSep "_" ns) ++ "_" ++ jsName n -jsName (UN n) = jsUserName n -jsName (MN n i) = jsIdent n ++ "_" ++ show i -jsName (PV n d) = "pat__" ++ jsName n -jsName (DN _ n) = jsName n -jsName (Nested (i, x) n) = "n__" ++ show i ++ "_" ++ show x ++ "_" ++ jsName n -jsName (CaseBlock x y) = "case__" ++ jsIdent x ++ "_" ++ show y -jsName (WithBlock x y) = "with__" ++ jsIdent x ++ "_" ++ show y -jsName (Resolved i) = "fn__" ++ show i +jsMangleName : Name -> String +jsMangleName (NS ns n) = jsIdent (showNSWithSep "_" ns) ++ "_" ++ jsMangleName n +jsMangleName (UN n) = jsUserName n +jsMangleName (MN n i) = jsIdent n ++ "_" ++ show i +jsMangleName (PV n d) = "pat__" ++ jsMangleName n +jsMangleName (DN _ n) = jsMangleName n +jsMangleName (Nested (i, x) n) = "n__" ++ show i ++ "_" ++ show x ++ "_" ++ jsMangleName n +jsMangleName (CaseBlock x y) = "case__" ++ jsIdent x ++ "_" ++ show y +jsMangleName (WithBlock x y) = "with__" ++ jsIdent x ++ "_" ++ show y +jsMangleName (Resolved i) = "fn__" ++ show i -jsNameDoc : Name -> Doc -jsNameDoc = Text . jsName +parameters (noMangle : NoMangleMap) + jsName : Name -> String + jsName n = case isNoMangle noMangle n of + Just name => name + Nothing => jsMangleName n + + jsNameDoc : Name -> Doc + jsNameDoc = Text . jsName mainExpr : Name mainExpr = MN "__mainExpression" 0 @@ -111,14 +122,15 @@ mainExpr = MN "__mainExpression" 0 -- Pretty Printing -------------------------------------------------------------------------------- -var : Var -> Doc -var (VName x) = jsNameDoc x -var (VLoc x) = Text $ "$" ++ asHex (cast x) -var (VRef x) = Text $ "$R" ++ asHex (cast x) +parameters (noMangle : NoMangleMap) + var : Var -> Doc + var (VName x) = jsNameDoc noMangle x + var (VLoc x) = Text $ "$" ++ asHex (cast x) + var (VRef x) = Text $ "$R" ++ asHex (cast x) -minimal : Minimal -> Doc -minimal (MVar v) = var v -minimal (MProjection n v) = minimal v <+> ".a" <+> shown n + minimal : Minimal -> Doc + minimal (MVar v) = var v + minimal (MProjection n v) = minimal v <+> ".a" <+> shown n tag2es : Either Int Name -> Doc tag2es (Left x) = shown x @@ -472,11 +484,12 @@ searchForeign knownBackends decls = -- generate a toplevel function definition. makeForeign : {auto d : Ref Ctxt Defs} -> {auto c : Ref ESs ESSt} + -> {auto nm : Ref NoMangleMap NoMangleMap} -> (name : Name) -> (ffDecl : String) -> Core Doc makeForeign n x = do - nd <- var <$> getOrRegisterRef n + nd <- var !(get NoMangleMap) <$> getOrRegisterRef n let (ty, def) = readCCPart x case ty of "lambda" => pure . constant nd . paren $ Text def @@ -506,6 +519,7 @@ makeForeign n x = do -- to extract a declaration for one of the supported backends. foreignDecl : {auto d : Ref Ctxt Defs} -> {auto c : Ref ESs ESSt} + -> {auto nm : Ref NoMangleMap NoMangleMap} -> Name -> List String -> Core Doc @@ -602,9 +616,9 @@ switch sc alts def = -- creates an argument list for a (possibly multi-argument) -- anonymous function. An empty argument list is treated -- as a delayed computation (prefixed by `() =>`). -lambdaArgs : List Var -> Doc -lambdaArgs [] = "()" <+> lambdaArrow -lambdaArgs xs = hcat $ (<+> lambdaArrow) . var <$> xs +lambdaArgs : (noMangle : NoMangleMap) -> List Var -> Doc +lambdaArgs noMangle [] = "()" <+> lambdaArrow +lambdaArgs noMangle xs = hcat $ (<+> lambdaArrow) . var noMangle <$> xs insertBreak : (r : Effect) -> (Doc, Doc) -> (Doc, Doc) insertBreak Returns x = x @@ -612,12 +626,20 @@ insertBreak (ErrorWithout _) (pat, exp) = (pat, vcat [exp, "break;"]) mutual -- converts an `Exp` to JS code - exp : {auto c : Ref ESs ESSt} -> Exp -> Core Doc - exp (EMinimal x) = pure $ minimal x - exp (ELam xs (Return $ y@(ECon _ _ _))) = - map (\e => lambdaArgs xs <+> paren e) (exp y) - exp (ELam xs (Return $ y)) = (lambdaArgs xs <+> ) <$> exp y - exp (ELam xs y) = (lambdaArgs xs <+>) . block <$> stmt y + exp : {auto c : Ref ESs ESSt} + -> {auto nm : Ref NoMangleMap NoMangleMap} + -> Exp + -> Core Doc + exp (EMinimal x) = pure $ minimal !(get NoMangleMap) x + exp (ELam xs (Return $ y@(ECon _ _ _))) = do + nm <- get NoMangleMap + map (\e => lambdaArgs nm xs <+> paren e) (exp y) + exp (ELam xs (Return $ y)) = do + nm <- get NoMangleMap + (lambdaArgs nm xs <+> ) <$> exp y + exp (ELam xs y) = do + nm <- get NoMangleMap + (lambdaArgs nm xs <+>) . block <$> stmt y exp (EApp x xs) = do o <- exp x args <- traverse exp xs @@ -631,18 +653,27 @@ mutual exp EErased = pure "undefined" -- converts a `Stmt e` to JS code. - stmt : {e : _} -> {auto c : Ref ESs ESSt} -> Stmt e -> Core Doc + stmt : {e : _} + -> {auto c : Ref ESs ESSt} + -> {auto nm : Ref NoMangleMap NoMangleMap} + -> Stmt e + -> Core Doc stmt (Return y) = (\e => "return" <++> e <+> ";") <$> exp y - stmt (Const v x) = constant (var v) <$> exp x - stmt (Declare v s) = - (\d => vcat ["let" <++> var v <+> ";",d]) <$> stmt s - stmt (Assign v x) = - (\d => hcat [var v,softEq,d,";"]) <$> exp x + stmt (Const v x) = do + nm <- get NoMangleMap + constant (var nm v) <$> exp x + stmt (Declare v s) = do + nm <- get NoMangleMap + (\d => vcat ["let" <++> var nm v <+> ";",d]) <$> stmt s + stmt (Assign v x) = do + nm <- get NoMangleMap + (\d => hcat [var nm v,softEq,d,";"]) <$> exp x stmt (ConSwitch r sc alts def) = do as <- traverse (map (insertBreak r) . alt) alts d <- traverseOpt stmt def - pure $ switch (minimal sc <+> ".h") as d + nm <- get NoMangleMap + pure $ switch (minimal nm sc <+> ".h") as d where alt : {r : _} -> EConAlt r -> Core (Doc,Doc) alt (MkEConAlt _ RECORD b) = ("undefined",) <$> stmt b @@ -678,7 +709,10 @@ printDoc Compact y = compact y printDoc Minimal y = compact y -- generate code for the given toplevel function. -def : {auto c : Ref ESs ESSt} -> Function -> Core String +def : {auto c : Ref ESs ESSt} + -> {auto nm : Ref NoMangleMap NoMangleMap} + -> Function + -> Core String def (MkFunction n as body) = do reset ref <- getOrRegisterRef n @@ -689,14 +723,15 @@ def (MkFunction n as body) = do -- zero argument toplevel functions are converted to -- lazily evaluated constants. [] => pure $ printDoc mde $ - constant (var ref) ( + constant (var !(get NoMangleMap) ref) ( "__lazy(" <+> function neutral [] b <+> ")" ) - _ => pure $ printDoc mde $ function (var ref) (map var args) b + _ => pure $ printDoc mde $ function (var !(get NoMangleMap) ref) (map (var !(get NoMangleMap)) args) b -- generate code for the given foreign function definition foreign : {auto c : Ref ESs ESSt} -> {auto d : Ref Ctxt Defs} + -> {auto nm : Ref NoMangleMap NoMangleMap} -> (Name,FC,NamedDef) -> Core (List String) foreign (n, _, MkNmForeign path _ _) = pure . pretty <$> foreignDecl n path @@ -707,11 +742,24 @@ foreign _ = pure [] tailRec : Name tailRec = UN $ Basic "__tailRec" +validJSName : String -> Bool +validJSName name = + not (name `elem` jsReservedNames) + && all validNameChar (unpack name) + && (case strM name of + StrNil => True + StrCons head _ => not $ isDigit head) + where + validNameChar : Char -> Bool + validNameChar c = isAlphaNum c || c == '_' || c == '$' + ||| Compiles the given `ClosedTerm` for the list of supported ||| backends to JS code. export compileToES : Ref Ctxt Defs -> (cg : CG) -> ClosedTerm -> List String -> Core String compileToES c cg tm ccTypes = do + _ <- initNoMangle "javascript" validJSName + cdata <- getCompileData False Cases tm -- read a derive the codegen mode to use from @@ -722,7 +770,7 @@ compileToES c cg tm ccTypes = do else Pretty -- initialize the state used in the code generator - s <- newRef ESs $ init mode (isArg mode) isFun ccTypes + s <- newRef ESs $ init mode (isArg mode) isFun ccTypes !(get NoMangleMap) -- register the toplevel `__tailRec` function to make sure -- it is not mangled in `Minimal` mode @@ -743,7 +791,7 @@ compileToES c cg tm ccTypes = do foreigns <- concat <$> traverse foreign allDefs -- lookup the (possibly mangled) name of the main function - mainName <- compact . var <$> getOrRegisterRef mainExpr + mainName <- compact . var !(get NoMangleMap) <$> getOrRegisterRef mainExpr -- main function and list of all declarations let main = "try{" diff --git a/src/Compiler/ES/State.idr b/src/Compiler/ES/State.idr index c41f9e260..275c97644 100644 --- a/src/Compiler/ES/State.idr +++ b/src/Compiler/ES/State.idr @@ -4,6 +4,7 @@ module Compiler.ES.State import Core.Context import Compiler.ES.Ast +import Compiler.NoMangle import Libraries.Data.SortedMap %default total @@ -105,6 +106,9 @@ record ESSt where ||| `["browser","javascript"]`. ccTypes : List String + ||| %nomangle names + noMangleMap : NoMangleMap + -------------------------------------------------------------------------------- -- Local Variables -------------------------------------------------------------------------------- @@ -174,10 +178,12 @@ nextRef = do put ESs $ record { ref $= (+1) } st pure $ VRef st.ref -registerRef : {auto c : Ref ESs ESSt} -> (name : Name) -> Core Var +registerRef : {auto c : Ref ESs ESSt} + -> (name : Name) + -> Core Var registerRef n = do st <- get ESs - if keepRefName n st.mode + if keepRefName n st.mode || isJust (isNoMangle st.noMangleMap n) then let v = VName n in addRef n v >> pure v else do v <- nextRef addRef n v @@ -188,7 +194,9 @@ registerRef n = do ||| The name will be replace with an index if the current ||| `GCMode` is set to `Minimal`. export -getOrRegisterRef : {auto c : Ref ESs ESSt} -> Name -> Core Var +getOrRegisterRef : {auto c : Ref ESs ESSt} + -> Name + -> Core Var getOrRegisterRef n = do Nothing <- lookup n . refs <$> get ESs | Just v => pure v @@ -226,9 +234,10 @@ init : (mode : CGMode) -> (isArg : Exp -> Bool) -> (isFun : Exp -> Bool) -> (types : List String) + -> (noMangle : NoMangleMap) -> ESSt -init mode isArg isFun ccs = - MkESSt mode isArg isFun 0 0 empty empty empty ccs +init mode isArg isFun ccs noMangle = + MkESSt mode isArg isFun 0 0 empty empty empty ccs noMangle ||| Reset the local state before defining a new toplevel ||| function. diff --git a/src/Compiler/NoMangle.idr b/src/Compiler/NoMangle.idr new file mode 100644 index 000000000..54d56b39d --- /dev/null +++ b/src/Compiler/NoMangle.idr @@ -0,0 +1,81 @@ +||| Utilities for dealing with %nomangle functions +module Compiler.NoMangle + +import Core.Core +import Core.Context +import Libraries.Data.NameMap +import Libraries.Data.NameMap.Traversable + +export +record NoMangleMap where + constructor MkNMMap + map : NameMap (Maybe String) + +findNoMangle : List DefFlag -> Maybe NoMangleDirective +findNoMangle [] = Nothing +findNoMangle (NoMangle x :: _) = Just x +findNoMangle (_ :: xs) = findNoMangle xs + +||| Get a map of all %nomangle names +||| Errors for all invalid names, so the backend can skip checking +||| or adding escape characters. +||| @ backend what backend is this being used in? +||| @ valid a validator to check a name is valid +||| for the given backend +export +initNoMangle : + {auto d : Ref Ctxt Defs} -> + (backend : String) -> + (valid : String -> Bool) -> + Core (Ref NoMangleMap NoMangleMap) +initNoMangle backend valid = do + defs <- get Ctxt + let ctxt = defs.gamma + map <- traverseNameMap + (\nm, res => do + Just gdef <- lookupCtxtExact (Resolved res) ctxt + | Nothing => pure Nothing + let Just ns = findNoMangle gdef.flags + | Nothing => pure Nothing + name <- case ns of + CommonName name => pure name + BackendNames ns => + maybe + (throw (InternalError "missing %nomangle name for \{show nm} on \{backend} backend")) + pure + (lookupBackend ns) + let True = valid name + | False => throw (InternalError "\{show name} is not a valid name on the \{backend} backend") + pure $ Just name + ) ctxt.resolvedAs + newRef NoMangleMap $ MkNMMap map + where + lookupBackend : List (String, String) -> Maybe String + lookupBackend [] = Nothing + lookupBackend ((b, n) :: ns) = if b == backend then Just n else lookupBackend ns + +export +isNoMangle : NoMangleMap -> Name -> Maybe String +isNoMangle nm n = join $ lookup n nm.map + +export +lookupNoMangle : + {auto nm : Ref NoMangleMap NoMangleMap} -> + Name -> + Core (Maybe String) +lookupNoMangle n = pure $ isNoMangle !(get NoMangleMap) n + +export +getAllNoMangle : {auto c : Ref Ctxt Defs} -> Core (List Name) +getAllNoMangle = do + defs <- get Ctxt + foldlNames (addNames defs) (pure []) defs.gamma.resolvedAs + where + addNames : Defs -> Core (List Name) -> Name -> Int -> Core (List Name) + addNames defs acc _ res = do + Just gdef <- lookupCtxtExact (Resolved res) defs.gamma + | Nothing => acc + let Just name = findNoMangle gdef.flags + | Nothing => acc + ns <- acc + pure $ (Resolved res) :: ns diff --git a/src/Core/Context/Context.idr b/src/Core/Context/Context.idr index 450194798..7d1c99779 100644 --- a/src/Core/Context/Context.idr +++ b/src/Core/Context/Context.idr @@ -191,6 +191,11 @@ Show Clause where show (MkClause {vars} env lhs rhs) = show vars ++ ": " ++ show lhs ++ " = " ++ show rhs +public export +data NoMangleDirective : Type where + CommonName : String -> NoMangleDirective + BackendNames : List (String, String) -> NoMangleDirective + public export data DefFlag = Inline @@ -222,6 +227,8 @@ data DefFlag | Identity Nat -- Is it the identity function at runtime? -- The nat represents which argument the function evaluates to + | NoMangle NoMangleDirective + -- use the user provided name directly (backend, name) export Eq DefFlag where @@ -237,6 +244,7 @@ Eq DefFlag where (==) AllGuarded AllGuarded = True (==) (ConType x) (ConType y) = x == y (==) (Identity x) (Identity y) = x == y + (==) (NoMangle _) (NoMangle _) = True (==) _ _ = False export @@ -253,6 +261,7 @@ Show DefFlag where show AllGuarded = "allguarded" show (ConType ci) = "contype " ++ show ci show (Identity x) = "identity " ++ show x + show (NoMangle _) = "nomangle" public export data SizeChange = Smaller | Same | Unknown diff --git a/src/Core/TTC.idr b/src/Core/TTC.idr index a2cb80218..f076d69e5 100644 --- a/src/Core/TTC.idr +++ b/src/Core/TTC.idr @@ -1016,6 +1016,16 @@ TTC TotalReq where 2 => pure PartialOK _ => corrupt "TotalReq" +TTC NoMangleDirective where + toBuf b (CommonName n) = do tag 0; toBuf b n + toBuf b (BackendNames ns) = do tag 1; toBuf b ns + + fromBuf b + = case !getTag of + 0 => do n <- fromBuf b; pure (CommonName n) + 1 => do ns <- fromBuf b; pure (BackendNames ns) + _ => corrupt "NoMangleDirective" + TTC DefFlag where toBuf b Inline = tag 2 toBuf b NoInline = tag 13 @@ -1029,6 +1039,7 @@ TTC DefFlag where toBuf b AllGuarded = tag 10 toBuf b (ConType ci) = do tag 11; toBuf b ci toBuf b (Identity x) = do tag 12; toBuf b x + toBuf b (NoMangle x) = do tag 14; toBuf b x fromBuf b = case !getTag of @@ -1044,6 +1055,7 @@ TTC DefFlag where 11 => do ci <- fromBuf b; pure (ConType ci) 12 => do x <- fromBuf b; pure (Identity x) 13 => pure NoInline + 14 => do x <- fromBuf b; pure (NoMangle x) _ => corrupt "DefFlag" export diff --git a/src/Idris/Parser.idr b/src/Idris/Parser.idr index fa17e8b49..d1907cb5c 100644 --- a/src/Idris/Parser.idr +++ b/src/Idris/Parser.idr @@ -1399,6 +1399,32 @@ fnDirectOpt fname <|> do pragma "foreign" cs <- block (expr pdef fname) pure $ PForeign cs + <|> do pragma "nomangle" + commit + ns <- many (strBegin *> strLit <* strEnd) + ns' <- parseNoMangle ns + pure $ IFnOpt (NoMangle ns') + where + parseNames : List String -> List (Maybe String, String) + parseNames = map + (\x => case split (== ':') x of + name ::: [] => (Nothing, name) + bck ::: ns => (Just bck, concat ns)) + + parseNoMangle : List String -> EmptyRule (Maybe NoMangleDirective) + parseNoMangle [] = pure Nothing + parseNoMangle ns = case parseNames ns of + [(Nothing, name)] => pure $ Just $ CommonName name + ns => + let ns = the (Either String (List (String, String))) $ + traverse + (\case + (Nothing, _) => Left "expected backend specifier and name, found name" + (Just b, name) => Right (b, name)) + ns + in case ns of + Left msg => fail msg + Right ns => pure $ Just $ BackendNames ns builtinDecl : OriginDesc -> IndentInfo -> Rule PDecl builtinDecl fname indents diff --git a/src/Libraries/Data/NameMap.idr b/src/Libraries/Data/NameMap.idr index 1fa3ca5d7..5858f343a 100644 --- a/src/Libraries/Data/NameMap.idr +++ b/src/Libraries/Data/NameMap.idr @@ -383,3 +383,13 @@ export mapMaybeM : Monad m => (Name -> m (Maybe a)) -> NameMap v -> m (NameMap a) mapMaybeM test Empty = pure Empty mapMaybeM test (M _ t) = treeMapMaybeM test t + +treeFoldl : (acc -> Name -> v -> acc) -> acc -> Tree _ v -> acc +treeFoldl f z (Leaf k v) = f z k v +treeFoldl f z (Branch2 l _ r) = treeFoldl f (treeFoldl f z l) r +treeFoldl f z (Branch3 l _ m _ r) = treeFoldl f (treeFoldl f (treeFoldl f z l) m) r + +export +foldlNames : (acc -> Name -> v -> acc) -> acc -> NameMap v -> acc +foldlNames f z Empty = z +foldlNames f z (M _ t) = treeFoldl f z t diff --git a/src/Libraries/Data/NameMap/Traversable.idr b/src/Libraries/Data/NameMap/Traversable.idr new file mode 100644 index 000000000..192efab68 --- /dev/null +++ b/src/Libraries/Data/NameMap/Traversable.idr @@ -0,0 +1,22 @@ +module Libraries.Data.NameMap.Traversable + +import Core.Core +import Core.Name +import Libraries.Data.NameMap + +treeTraverse : (Name -> a -> Core b) -> Tree h a -> Core (Tree h b) +treeTraverse f (Leaf k v) = Leaf k <$> f k v +treeTraverse f (Branch2 l k r) = + (\l', r' => Branch2 l' k r') + <$> treeTraverse f l + <*> treeTraverse f r +treeTraverse f (Branch3 l k1 m k2 r) = + (\l', m', r' => Branch3 l' k1 m' k2 r') + <$> treeTraverse f l + <*> treeTraverse f m + <*> treeTraverse f r + +export +traverseNameMap : (Name -> a -> Core b) -> NameMap a -> Core (NameMap b) +traverseNameMap f Empty = pure Empty +traverseNameMap f (M h t) = M h <$> treeTraverse f t diff --git a/src/TTImp/ProcessType.idr b/src/TTImp/ProcessType.idr index 598c51369..4fab2a39c 100644 --- a/src/TTImp/ProcessType.idr +++ b/src/TTImp/ProcessType.idr @@ -21,6 +21,7 @@ import TTImp.TTImp import TTImp.Utils import Data.List +import Data.List1 import Data.String import Libraries.Data.NameMap @@ -43,6 +44,7 @@ processFnOpt : {auto c : Ref Ctxt Defs} -> Name -> FnOpt -> Core () processFnOpt fc _ ndef Inline = do throwIfHasFlag fc ndef NoInline "%noinline and %inline are mutually exclusive" + throwIfHasFlag fc ndef (NoMangle (CommonName "")) "%nomangle and %inline are mutually exclusive" setFlag fc ndef Inline processFnOpt fc _ ndef NoInline = do throwIfHasFlag fc ndef Inline "%inline and %noinline are mutually exclusive" @@ -72,6 +74,18 @@ processFnOpt fc _ ndef (Totality tot) = setFlag fc ndef (SetTotal tot) processFnOpt fc _ ndef Macro = setFlag fc ndef Macro +processFnOpt fc True ndef (NoMangle mname) = do + throwIfHasFlag fc ndef Inline "%inline and %nomangle are mutually exclusive" + name <- case mname of + Nothing => case userNameRoot !(getFullName ndef) of + Nothing => throw (GenericMsg fc "Unable to find user name root of \{show ndef}") + Just (Basic name) => pure $ CommonName name + Just (Field name) => pure $ CommonName name + Just Underscore => throw (GenericMsg fc "Unable to set '_' as %nomangle") + Just name => pure name + setFlag fc ndef (NoMangle name) + setFlag fc ndef NoInline +processFnOpt fc False ndef (NoMangle _) = throw (GenericMsg fc "Unable to set %nomangle for non-global functions") processFnOpt fc _ ndef (SpecArgs ns) = do defs <- get Ctxt Just gdef <- lookupCtxtExact ndef (gamma defs) diff --git a/src/TTImp/Reflect.idr b/src/TTImp/Reflect.idr index 6e2e64923..faf450c96 100644 --- a/src/TTImp/Reflect.idr +++ b/src/TTImp/Reflect.idr @@ -271,6 +271,19 @@ mutual _ => cantReify val "AltType" reify defs val = cantReify val "AltType" + export + Reify NoMangleDirective where + reify defs val@(NDCon _ n _ _ args) + = case (dropAllNS !(full (gamma defs) n), args) of + (UN (Basic "CommonName"), [(_, name)]) + => do n <- reify defs !(evalClosure defs name) + pure $ CommonName n + (UN (Basic "BackendNames"), [(_, names)]) + => do ns <- reify defs !(evalClosure defs names) + pure $ BackendNames ns + _ => cantReify val "NoMangleDirective" + reify defs val = cantReify val "NoMangleDirective" + export Reify FnOpt where reify defs val@(NDCon _ n _ _ args) @@ -296,6 +309,9 @@ mutual (UN (Basic "SpecArgs"), [(_, x)]) => do x' <- reify defs !(evalClosure defs x) pure (SpecArgs x') + (UN (Basic "NoMangle"), [(_, n)]) + => do ds <- reify defs !(evalClosure defs n) + pure (NoMangle ds) _ => cantReify val "FnOpt" reify defs val = cantReify val "FnOpt" @@ -637,6 +653,15 @@ mutual = do x' <- reflect fc defs lhs env x appCon fc defs (reflectionttimp "UniqueDefault") [x'] + export + Reflect NoMangleDirective where + reflect fc defs lhs env (CommonName n) + = do n' <- reflect fc defs lhs env n + appCon fc defs (reflectionttimp "CommonName") [n'] + reflect fc defs lhs env (BackendNames ns) + = do ns' <- reflect fc defs lhs env ns + appCon fc defs (reflectionttimp "BackendNames") [ns'] + export Reflect FnOpt where reflect fc defs lhs env Inline = getCon fc defs (reflectionttimp "Inline") @@ -660,6 +685,9 @@ mutual reflect fc defs lhs env (SpecArgs r) = do r' <- reflect fc defs lhs env r appCon fc defs (reflectionttimp "SpecArgs") [r'] + reflect fc defs lhs env (NoMangle n) + = do n' <- reflect fc defs lhs env n + appCon fc defs (reflectionttimp "NoMangle") [n'] export Reflect ImpTy where diff --git a/src/TTImp/TTImp.idr b/src/TTImp/TTImp.idr index 63ad2e8fe..a93627cb9 100644 --- a/src/TTImp/TTImp.idr +++ b/src/TTImp/TTImp.idr @@ -230,12 +230,18 @@ mutual Totality : TotalReq -> FnOpt' nm Macro : FnOpt' nm SpecArgs : List Name -> FnOpt' nm + NoMangle : Maybe NoMangleDirective -> FnOpt' nm public export isTotalityReq : FnOpt' nm -> Bool isTotalityReq (Totality _) = True isTotalityReq _ = False + export + Show NoMangleDirective where + show (CommonName name) = "\"\{name}\"" + show (BackendNames ns) = showSep " " (map (\(b, n) => "\"\{b}:\{n}\"") ns) + export covering Show nm => Show (FnOpt' nm) where @@ -252,6 +258,14 @@ mutual show (Totality PartialOK) = "partial" show Macro = "%macro" show (SpecArgs ns) = "%spec " ++ showSep " " (map show ns) + show (NoMangle Nothing) = "%nomangle" + show (NoMangle (Just ns)) = "%nomangle \{show ns}" + + export + Eq NoMangleDirective where + CommonName x == CommonName y = x == y + BackendNames xs == BackendNames ys = xs == ys + _ == _ = False export Eq FnOpt where @@ -266,6 +280,7 @@ mutual (Totality tot_lhs) == (Totality tot_rhs) = tot_lhs == tot_rhs Macro == Macro = True (SpecArgs ns) == (SpecArgs ns') = ns == ns' + (NoMangle x) == (NoMangle y) = x == y _ == _ = False public export @@ -1232,6 +1247,19 @@ mutual con <- fromBuf b; fs <- fromBuf b pure (MkImpRecord fc n ps con fs) + export + TTC NoMangleDirective where + toBuf b (CommonName n) + = do tag 0; toBuf b n + toBuf b (BackendNames ns) + = do tag 1; toBuf b ns + + fromBuf b + = case !getTag of + 0 => do n <- fromBuf b; pure (CommonName n) + 1 => do ns <- fromBuf b; pure (BackendNames ns) + _ => corrupt "NoMangleDirective" + export TTC FnOpt where toBuf b Inline = tag 0 @@ -1247,6 +1275,7 @@ mutual toBuf b (Totality PartialOK) = tag 8 toBuf b Macro = tag 9 toBuf b (SpecArgs ns) = do tag 10; toBuf b ns + toBuf b (NoMangle name) = do tag 13; toBuf b name fromBuf b = case !getTag of @@ -1263,6 +1292,7 @@ mutual 10 => do ns <- fromBuf b; pure (SpecArgs ns) 11 => pure TCInline 12 => pure NoInline + 13 => do name <- fromBuf b; pure (NoMangle name) _ => corrupt "FnOpt" export diff --git a/src/TTImp/TTImp/Functor.idr b/src/TTImp/TTImp/Functor.idr index f7103d3eb..a893a0e98 100644 --- a/src/TTImp/TTImp/Functor.idr +++ b/src/TTImp/TTImp/Functor.idr @@ -121,6 +121,7 @@ mutual map f (Totality tot) = Totality tot map f Macro = Macro map f (SpecArgs ns) = SpecArgs ns + map f (NoMangle name) = (NoMangle name) export Functor ImpTy' where diff --git a/tests/Main.idr b/tests/Main.idr index e001b1fbe..20dd49cc0 100644 --- a/tests/Main.idr +++ b/tests/Main.idr @@ -284,6 +284,7 @@ nodeTests = MkTestPool "Node backend" [] (Just Node) , "integers" , "fix1839" , "tailrec_libs" + , "nomangle001", "nomangle002" ] vmcodeInterpTests : IO TestPool diff --git a/tests/node/nomangle001/expected b/tests/node/nomangle001/expected new file mode 100644 index 000000000..dbb7f743e --- /dev/null +++ b/tests/node/nomangle001/expected @@ -0,0 +1,6 @@ +function foo($0) { +function $_baz($0) { +function another_name($0) { +function foo($0){return $0;} +function $_baz($0){return $0;} +function another_name($0){return $0;} diff --git a/tests/node/nomangle001/nomangle.idr b/tests/node/nomangle001/nomangle.idr new file mode 100644 index 000000000..ceea85c3e --- /dev/null +++ b/tests/node/nomangle001/nomangle.idr @@ -0,0 +1,16 @@ + +%nomangle +foo : Int -> Int +foo x = x + +%nomangle "$_baz" +baz : Int -> Int +baz x = x + +%nomangle "refc:idr_another_name" + "javascript:another_name" +anotherName : Int -> Int +anotherName x = x + +main : IO () +main = pure () diff --git a/tests/node/nomangle001/run b/tests/node/nomangle001/run new file mode 100644 index 000000000..1177a59c0 --- /dev/null +++ b/tests/node/nomangle001/run @@ -0,0 +1,7 @@ +rm -rf build + +$1 nomangle.idr --no-color --no-banner --console-width 0 -o test1 --cg node +$1 nomangle.idr --no-color --no-banner --console-width 0 -o test2 --cg node --directive minimal + +cat build/exec/test1 | grep -e foo -e baz -e another_name +cat build/exec/test2 | grep -e foo -e baz -e another_name diff --git a/tests/node/nomangle002/expected b/tests/node/nomangle002/expected new file mode 100644 index 000000000..5700e0f8a --- /dev/null +++ b/tests/node/nomangle002/expected @@ -0,0 +1,2 @@ +Error: INTERNAL ERROR: "continue" is not a valid name on the javascript backend +Error: INTERNAL ERROR: missing %nomangle name for Main.break on javascript backend diff --git a/tests/node/nomangle002/nomangle1.idr b/tests/node/nomangle002/nomangle1.idr new file mode 100644 index 000000000..d321dcd5b --- /dev/null +++ b/tests/node/nomangle002/nomangle1.idr @@ -0,0 +1,7 @@ + +%nomangle +continue : Int -> Int +continue x = x + 1 + +main : IO () +main = pure () diff --git a/tests/node/nomangle002/nomangle2.idr b/tests/node/nomangle002/nomangle2.idr new file mode 100644 index 000000000..51777c175 --- /dev/null +++ b/tests/node/nomangle002/nomangle2.idr @@ -0,0 +1,11 @@ + +%nomangle +continue : Int -> Int +continue x = x + 1 + +%nomangle "refc:break" +break : Int -> Int +break x = x + 1 + +main : IO () +main = pure () diff --git a/tests/node/nomangle002/run b/tests/node/nomangle002/run new file mode 100644 index 000000000..2bf8b50e5 --- /dev/null +++ b/tests/node/nomangle002/run @@ -0,0 +1,4 @@ +rm -rf build + +$1 nomangle1.idr --no-color --no-banner --console-width 0 -o test --cg node +$1 nomangle2.idr --no-color --no-banner --console-width 0 -o test --cg node