From a8264f8f057c27fe69fc09666a5ebe83eaa0eb94 Mon Sep 17 00:00:00 2001 From: Robert Wright Date: Thu, 17 Jun 2021 17:23:29 +0100 Subject: [PATCH] Add ability to extend RefC backend to create further backends --- docs/source/backends/refc.rst | 68 +++++++++++++++++++++++++++++++++++ idris2api.ipkg | 1 + src/Compiler/RefC.idr | 4 +++ src/Compiler/RefC/RefC.idr | 36 +++++++++++++------ support/refc/runtime.c | 10 ++++++ support/refc/runtime.h | 2 ++ 6 files changed, 111 insertions(+), 10 deletions(-) create mode 100644 src/Compiler/RefC.idr diff --git a/docs/source/backends/refc.rst b/docs/source/backends/refc.rst index 9256b4abf..38c22952d 100644 --- a/docs/source/backends/refc.rst +++ b/docs/source/backends/refc.rst @@ -33,3 +33,71 @@ Also note that, if you link with any dynamic libraries for interfacing with C, you will need to arrange for them to be accessible via ``LD_LIBRARY_PATH`` when running the executable. The default Idris 2 support libraries are statically linked. + +Extending RefC +============== + +RefC can be extended to produce a new backend for languages that support C +foreign functions. For example, a +`Python backend for Idris `_. + +In your backend, use the ``Compiler.RefC`` functions ``generateCSourceFile``, +``compileCObjectFile {asLibrary = True}``, and +``compileCFile {asShared = True}`` to generate a ``.so`` shared object file. + +.. code-block:: idris + + _ <- generateCSourceFile defs cSourceFile + _ <- compileCObjectFile {asLibrary = True} cSourceFile cObjectFile + _ <- compileCFile {asShared = True} cObjectFile cSharedObjectFile + +To run a compiled Idris program, call the ``int main(int argc, char *argv[])`` +function in the compiled ``.so`` file, with the arguments you wish to pass to +the running program. + +For example, in Python: + +.. code-block:: python + + import ctypes + import sys + + argc = len(sys.argv) + argv = (ctypes.c_char_p * argc)(*map(str.encode, sys.argv)) + + cdll = ctypes.CDLL("main.so") + cdll.main(argc, argv) + +Extending RefC FFIs +------------------- + +To make the generated C code recognize additional FFI languages beyond the +standard RefC FFIs, pass the ``additionalFFILangs`` option to +``generateCSourceFile``, with a list of the language identifiers your backend +recognizes. + +.. code-block:: idris + + _ <- generateCSourceFile {additionalFFILangs = ["python"]} defs cSourceFile + +This will generate stub FFI function pointers in the generated C file, which +your backend should set to the appropriate C functions before ``main`` is +called. + +Each ``%foreign "lang: funcName, opts"`` definition will produce a stub whose +name is given by ``cName (UN $ lang ++ "_" ++ funcName)``, of the appropriate +function pointer type. + +So the ``%foreign`` function + +.. code-block:: idris + + %foreign "python: abs" + abs : Int -> Int + +produces a stub ``python_abs``, which can be backpatched in Python by: + +.. code-block:: python + + abs_ptr = ctypes.CFUNCTYPE(ctypes.c_int64, ctypes.c_int64)(abs) + ctypes.c_void_p.in_dll(cdll, "python_abs").value = ctypes.cast(abs_ptr, ctypes.c_void_p).value diff --git a/idris2api.ipkg b/idris2api.ipkg index aa9427f71..7d5bb446b 100644 --- a/idris2api.ipkg +++ b/idris2api.ipkg @@ -23,6 +23,7 @@ modules = Compiler.ES.Node, Compiler.ES.TailRec, + Compiler.RefC, Compiler.RefC.CC, Compiler.RefC.RefC, diff --git a/src/Compiler/RefC.idr b/src/Compiler/RefC.idr new file mode 100644 index 000000000..84664ce90 --- /dev/null +++ b/src/Compiler/RefC.idr @@ -0,0 +1,4 @@ +module Compiler.RefC + +import public Compiler.RefC.CC +import public Compiler.RefC.RefC diff --git a/src/Compiler/RefC/RefC.idr b/src/Compiler/RefC/RefC.idr index db4127826..704ed7d09 100644 --- a/src/Compiler/RefC/RefC.idr +++ b/src/Compiler/RefC/RefC.idr @@ -62,6 +62,7 @@ showcCleanString (c ::cs) = (showcCleanStringChar c) . showcCleanString cs cCleanString : String -> String cCleanString cs = showcCleanString (unpack cs) "" +export cName : Name -> String cName (NS ns n) = cCleanString (showNSWithSep "_" ns) ++ "_" ++ cName n cName (UN n) = cCleanString n @@ -837,6 +838,13 @@ discardLastArgument : List ty -> List ty discardLastArgument [] = [] discardLastArgument xs@(_ :: _) = init xs +additionalFFIStub : Name -> List CFType -> CFType -> String +additionalFFIStub name argTypes (CFIORes retType) = additionalFFIStub name (discardLastArgument argTypes) retType +additionalFFIStub name argTypes retType = + cTypeOfCFType retType ++ + " (*" ++ cName name ++ ")(" ++ + (concat $ intersperse ", " $ map cTypeOfCFType argTypes) ++ ") = (void*)missing_ffi;\n" + createCFunctions : {auto c : Ref Ctxt Defs} -> {auto a : Ref ArgCounter Nat} -> {auto f : Ref FunctionDefinitions (List String)} @@ -844,6 +852,7 @@ createCFunctions : {auto c : Ref Ctxt Defs} -> {auto oft : Ref OutfileText Output} -> {auto il : Ref IndentLevel Nat} -> {auto h : Ref HeaderFiles (SortedSet String)} + -> {default [] additionalFFILangs : List String} -> Name -> ANFDef -> Core () @@ -887,11 +896,17 @@ createCFunctions n (MkACon tag arity nt) = do createCFunctions n (MkAForeign ccs fargs ret) = do - case parseCC ["RefC", "C"] ccs of - Just (_, fctName :: extLibOpts) => do - case extLibOpts of - [lib, header] => addHeader header - _ => pure () + case parseCC (additionalFFILangs ++ ["RefC", "C"]) ccs of + Just (lang, fctForeignName :: extLibOpts) => do + let isStandardFFI = Prelude.elem lang ["RefC", "C"] + let fctName = if isStandardFFI + then UN fctForeignName + else UN $ lang ++ "_" ++ fctForeignName + if isStandardFFI + then case extLibOpts of + [lib, header] => addHeader header + _ => pure () + else emit EmptyFC $ additionalFFIStub fctName fargs ret otherDefs <- get FunctionDefinitions let fnDef = "Value *" ++ (cName n) ++ "(" ++ showSep ", " (replicate (length fargs) "Value *") ++ ");" fn_arglist <- functionDefSignatureArglist n @@ -917,22 +932,22 @@ createCFunctions n (MkAForeign ccs fargs ret) = do emitFDef n typeVarNameArgList emit EmptyFC "{" increaseIndentation - emit EmptyFC $ " // ffi call to " ++ fctName + emit EmptyFC $ " // ffi call to " ++ cName fctName case ret of CFIORes CFUnit => do - emit EmptyFC $ fctName + emit EmptyFC $ cName fctName ++ "(" ++ showSep ", " (map (\(_, vn, vt) => extractValue vt vn) (discardLastArgument typeVarNameArgList)) ++ ");" emit EmptyFC "return NULL;" CFIORes ret => do - emit EmptyFC $ cTypeOfCFType ret ++ " retVal = " ++ fctName + emit EmptyFC $ cTypeOfCFType ret ++ " retVal = " ++ cName fctName ++ "(" ++ showSep ", " (map (\(_, vn, vt) => extractValue vt vn) (discardLastArgument typeVarNameArgList)) ++ ");" emit EmptyFC $ "return (Value*)" ++ packCFType ret "retVal" ++ ";" _ => do - emit EmptyFC $ cTypeOfCFType ret ++ " retVal = " ++ fctName + emit EmptyFC $ cTypeOfCFType ret ++ " retVal = " ++ cName fctName ++ "(" ++ showSep ", " (map (\(_, vn, vt) => extractValue vt vn) typeVarNameArgList) ++ ");" @@ -985,6 +1000,7 @@ executeExpr c _ tm export generateCSourceFile : {auto c : Ref Ctxt Defs} + -> {default [] additionalFFILangs : List String} -> List (Name, ANFDef) -> (outn : String) -> Core () @@ -995,7 +1011,7 @@ generateCSourceFile defs outn = _ <- newRef OutfileText DList.Nil _ <- newRef HeaderFiles empty _ <- newRef IndentLevel 0 - traverse_ (uncurry createCFunctions) defs + traverse_ (uncurry $ createCFunctions {additionalFFILangs}) defs header -- added after the definition traversal in order to add all encountered function defintions footer fileContent <- get OutfileText diff --git a/support/refc/runtime.c b/support/refc/runtime.c index 42252dd6f..7feb9b52c 100644 --- a/support/refc/runtime.c +++ b/support/refc/runtime.c @@ -1,5 +1,15 @@ #include "runtime.h" +void missing_ffi() +{ + fprintf( + stderr, + "Foreign function declared, but not defined.\n" + "Cannot call missing FFI - aborting.\n" + ); + exit(1); +} + void push_Arglist(Value_Arglist *arglist, Value *arg) { if (arglist->filled >= arglist->total) diff --git a/support/refc/runtime.h b/support/refc/runtime.h index 2b96ba4d1..6efe1b559 100644 --- a/support/refc/runtime.h +++ b/support/refc/runtime.h @@ -3,6 +3,8 @@ #include "cBackend.h" +void missing_ffi(); + Value *apply_closure(Value *, Value *arg); void push_Arglist(Value_Arglist *arglist, Value *arg);