Optionally use libffi to implement 'foreign import "wrapper"' (#793)

To enable this, set UseLibFFI=YES in mk/build.mk.

The main advantage here is that this reduces the porting effort for
new platforms: libffi works on more architectures than our current
adjustor code, and it is probably more heavily tested.  We could
potentially replace our existing code, but since it is probably faster
than libffi (just a guess, I'll measure later) and is already working,
it doesn't seem worthwhile.

Right now, you must have libffi installed on your system.  I used the
one supplied by Debian/Ubuntu.

diff --git a/compiler/Makefile b/compiler/Makefile
index db21ae8..04c7778 100644 (file)
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -276,6 +276,11 @@ ifeq "$(RelocatableBuild)" "YES"
 else
        @echo "cRelocatableBuild     = False"                 >> $(CONFIG_HS)
 endif
 else
        @echo "cRelocatableBuild     = False"                 >> $(CONFIG_HS)
 endif

+ifeq "$(UseLibFFI)" "YES"
+       @echo "cLibFFI               = True"                  >> $(CONFIG_HS)
+else
+       @echo "cLibFFI               = False"                 >> $(CONFIG_HS)
+endif

        @echo done.
 
 CLEAN_FILES += $(CONFIG_HS)
        @echo done.
 
 CLEAN_FILES += $(CONFIG_HS)

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 84ae740..19c5d49 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -45,6 +45,8 @@ import BasicTypes
 import SrcLoc
 import Outputable
 import FastString
 import SrcLoc
 import Outputable
 import FastString

+import Config
+import Constants

 
 import Data.Maybe
 import Data.List
 
 import Data.Maybe
 import Data.List

@@ -271,7 +273,7 @@ dsFExport :: Id                     -- Either the exported Id,
                                --         the first argument's stable pointer
          -> DsM ( SDoc         -- contents of Module_stub.h
                 , SDoc         -- contents of Module_stub.c
                                --         the first argument's stable pointer
          -> DsM ( SDoc         -- contents of Module_stub.h
                 , SDoc         -- contents of Module_stub.c

-                , [MachRep]    -- primitive arguments expected by stub function
+                , String       -- string describing type to pass to createAdj.

                 , Int          -- size of args to stub function
                 )
 
                 , Int          -- size of args to stub function
                 )
 

@@ -353,7 +355,7 @@ dsFExportDynamic id cconv
      dsLookupGlobalId bindIOName               `thenDs` \ bindIOId ->
      newSysLocalDs stable_ptr_ty               `thenDs` \ stbl_value ->
      dsFExport id export_ty fe_nm cconv True   
      dsLookupGlobalId bindIOName               `thenDs` \ bindIOId ->
      newSysLocalDs stable_ptr_ty               `thenDs` \ stbl_value ->
      dsFExport id export_ty fe_nm cconv True   

-               `thenDs` \ (h_code, c_code, arg_reps, args_size) ->
+               `thenDs` \ (h_code, c_code, typestring, args_size) ->

      let
        {-
         The arguments to the external function which will
      let
        {-
         The arguments to the external function which will

@@ -365,18 +367,12 @@ dsFExportDynamic id cconv
       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
                      , Var stbl_value
                      , mkLit (MachLabel fe_nm mb_sz_args)
       adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
                      , Var stbl_value
                      , mkLit (MachLabel fe_nm mb_sz_args)

-                      , mkLit (mkStringLit arg_type_info)
+                      , mkLit (mkStringLit typestring)

                      ]
         -- name of external entry point providing these services.
        -- (probably in the RTS.) 
       adjustor  = FSLIT("createAdjustor")
       
                      ]
         -- name of external entry point providing these services.
        -- (probably in the RTS.) 
       adjustor  = FSLIT("createAdjustor")
       

-      arg_type_info = map repCharCode arg_reps
-      repCharCode F32 = 'f'
-      repCharCode F64 = 'd'
-      repCharCode I64 = 'l'
-      repCharCode _   = 'i'
-

        -- Determine the number of bytes of arguments to the stub function,
        -- so that we can attach the '@N' suffix to its label if it is a
        -- stdcall on Windows.
        -- Determine the number of bytes of arguments to the stub function,
        -- so that we can attach the '@N' suffix to its label if it is a
        -- stdcall on Windows.

@@ -435,12 +431,11 @@ mkFExportCBits :: FastString
               -> CCallConv 
               -> (SDoc, 
                   SDoc,
               -> CCallConv 
               -> (SDoc, 
                   SDoc,

-                  [MachRep],   -- the argument reps
+                  String,      -- the argument reps

                   Int          -- total size of arguments
                  )
 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
                   Int          -- total size of arguments
                  )
 mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 

- = (header_bits, c_bits, 
-    [rep | (_,_,_,rep) <- arg_info],  -- just the real args
+ = (header_bits, c_bits, type_string,

     sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
     )
  where
     sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args
     )
  where

@@ -449,10 +444,29 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
                SDoc,           -- C type
                Type,           -- Haskell type
                MachRep)]       -- the MachRep
                SDoc,           -- C type
                Type,           -- Haskell type
                MachRep)]       -- the MachRep

-  arg_info  = [ (text ('a':show n), showStgType ty, ty, 
+  arg_info  = [ let stg_type = showStgType ty in
+                (arg_cname n stg_type,
+                 stg_type,
+                 ty, 

                 typeMachRep (getPrimTyOf ty))
              | (ty,n) <- zip arg_htys [1::Int ..] ]
 
                 typeMachRep (getPrimTyOf ty))
              | (ty,n) <- zip arg_htys [1::Int ..] ]
 

+  arg_cname n stg_ty
+        | libffi    = char '*' <> parens (stg_ty <> char '*') <> 
+                      ptext SLIT("args") <> brackets (int (n-1))
+        | otherwise = text ('a':show n)
+
+  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
+  libffi = cLibFFI && isNothing maybe_target
+
+  type_string
+      -- libffi needs to know the result type too:
+      | libffi    = primTyDescChar res_hty : arg_type_string
+      | otherwise = arg_type_string
+
+  arg_type_string = [primTyDescChar ty | (_,_,ty,_) <- arg_info]
+                -- just the real args
+

   -- add some auxiliary args; the stable ptr in the wrapper case, and
   -- a slot for the dummy return address in the wrapper + ccall case
   aug_arg_info
   -- add some auxiliary args; the stable ptr in the wrapper case, and
   -- a slot for the dummy return address in the wrapper + ccall case
   aug_arg_info

@@ -476,7 +490,12 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
 
   header_bits = ptext SLIT("extern") <+> fun_proto <> semi
 
 
   header_bits = ptext SLIT("extern") <+> fun_proto <> semi
 

-  fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
+  fun_proto
+    | libffi
+      = ptext SLIT("void") <+> ftext c_nm <> 
+          parens (ptext SLIT("void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))
+    | otherwise
+      = cResType <+> pprCconv <+> ftext c_nm <>

              parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm) 
                                                  aug_arg_info)))
 
              parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm) 
                                                  aug_arg_info)))
 

@@ -519,30 +538,33 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
     fun_proto  $$
     vcat 
      [ lbrace
     fun_proto  $$
     vcat 
      [ lbrace

-     ,   text "Capability *cap;"
+     ,   ptext SLIT("Capability *cap;")

      ,   declareResult
      ,   declareCResult
      ,   text "cap = rts_lock();"
          -- create the application + perform it.
      ,   declareResult
      ,   declareCResult
      ,   text "cap = rts_lock();"
          -- create the application + perform it.

-     ,   text "cap=rts_evalIO" <> parens (
+     ,   ptext SLIT("cap=rts_evalIO") <> parens (

                cap <>
                cap <>

-               text "rts_apply" <> parens (
+               ptext SLIT("rts_apply") <> parens (

                    cap <>
                    text "(HaskellObj)"
                    cap <>
                    text "(HaskellObj)"

-                <> text (if is_IO_res_ty 
-                               then "runIO_closure" 
-                               else "runNonIO_closure")
+                <> ptext (if is_IO_res_ty 
+                               then SLIT("runIO_closure")
+                               else SLIT("runNonIO_closure"))

                 <> comma
                 <> expr_to_run
                ) <+> comma
               <> text "&ret"
             ) <> semi
                 <> comma
                 <> expr_to_run
                ) <+> comma
               <> text "&ret"
             ) <> semi

-     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+     ,   ptext SLIT("rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)

                                                <> comma <> text "cap") <> semi
      ,   assignCResult
                                                <> comma <> text "cap") <> semi
      ,   assignCResult

-     ,   text "rts_unlock(cap);"
+     ,   ptext SLIT("rts_unlock(cap);")

      ,   if res_hty_is_unit then empty
      ,   if res_hty_is_unit then empty

-            else text "return cret;"
+            else if libffi 
+                  then char '*' <> parens (cResType <> char '*') <> 
+                       ptext SLIT("resp = cret;")
+                  else ptext SLIT("return cret;")

      , rbrace
      ]
 
      , rbrace
      ]
 

@@ -628,4 +650,26 @@ getPrimTyOf ty
      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
   where
        rep_ty = repType ty
      _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
   where
        rep_ty = repType ty

+
+-- represent a primitive type as a Char, for building a string that
+-- described the foreign function type.  The types are size-dependent,
+-- e.g. 'W' is a signed 32-bit integer.
+primTyDescChar :: Type -> Char
+primTyDescChar ty
+ | ty `coreEqType` unitTy = 'v'
+ | otherwise
+ = case typePrimRep (getPrimTyOf ty) of
+     IntRep     -> signed_word
+     WordRep     -> unsigned_word
+     Int64Rep    -> 'L'
+     Word64Rep   -> 'l'
+     AddrRep     -> unsigned_word
+     FloatRep    -> 'f'
+     DoubleRep   -> 'd'
+     _           -> pprPanic "primTyDescChar" (ppr ty)
+  where
+    (signed_word, unsigned_word)
+       | wORD_SIZE == 4  = ('W','w')
+       | wORD_SIZE == 8  = ('L','l')
+       | otherwise       = panic "primTyDescChar"

 \end{code}
 \end{code}

diff --git a/rts/Adjustor.c b/rts/Adjustor.c
index 841c660..03fb5d9 100644 (file)
--- a/rts/Adjustor.c
+++ b/rts/Adjustor.c
@@ -6,7 +6,7 @@
  * ---------------------------------------------------------------------------*/
 
 /* A little bit of background...
  * ---------------------------------------------------------------------------*/
 
 /* A little bit of background...

-
+   

 An adjustor thunk is a dynamically allocated code snippet that allows
 Haskell closures to be viewed as C function pointers. 
 
 An adjustor thunk is a dynamically allocated code snippet that allows
 Haskell closures to be viewed as C function pointers. 
 

@@ -32,7 +32,7 @@ action. User code should never have to invoke it explicitly.
 
 An adjustor thunk differs from a C function pointer in one respect: when
 the code is through with it, it has to be freed in order to release Haskell
 
 An adjustor thunk differs from a C function pointer in one respect: when
 the code is through with it, it has to be freed in order to release Haskell

-and C resources. Failure to do so result in memory leaks on both the C and
+and C resources. Failure to do so will result in memory leaks on both the C and

 Haskell side.
 */
 
 Haskell side.
 */
 

@@ -42,6 +42,89 @@ Haskell side.
 #include "RtsUtils.h"
 #include <stdlib.h>
 
 #include "RtsUtils.h"
 #include <stdlib.h>
 

+#if defined(USE_LIBFFI)
+
+#include <ffi.h>
+#include <string.h>
+
+void
+freeHaskellFunctionPtr(void* ptr)
+{
+    ffi_closure *cl;
+
+    cl = (ffi_closure*)ptr;
+    freeStablePtr(cl->user_data);
+    stgFree(cl->cif->arg_types);
+    stgFree(cl->cif);
+    freeExec(cl);
+}
+
+static ffi_type * char_to_ffi_type(char c)
+{
+    switch (c) {
+    case 'v':  return &ffi_type_void;
+    case 'f':  return &ffi_type_float;
+    case 'd':  return &ffi_type_double;
+    case 'L':  return &ffi_type_sint64;
+    case 'l':  return &ffi_type_uint64;
+    case 'W':  return &ffi_type_sint32;
+    case 'w':  return &ffi_type_uint32;
+    case 'S':  return &ffi_type_sint16;
+    case 's':  return &ffi_type_uint16;
+    case 'B':  return &ffi_type_sint8;
+    case 'b':  return &ffi_type_uint8;
+    default:   barf("char_to_ffi_type: unknown type '%c'", c);
+    }
+}
+
+void*
+createAdjustor (int cconv, 
+                StgStablePtr hptr,
+                StgFunPtr wptr,
+                char *typeString)
+{
+    ffi_cif *cif;
+    ffi_type **arg_types;
+    nat n_args, i;
+    ffi_type *result_type;
+    ffi_closure *cl;
+    int r, abi;
+
+    n_args = strlen(typeString) - 1;
+    cif = stgMallocBytes(sizeof(ffi_cif), "createAdjustor");
+    arg_types = stgMallocBytes(n_args * sizeof(ffi_type*), "createAdjustor");
+
+    result_type = char_to_ffi_type(typeString[0]);
+    for (i=0; i < n_args; i++) {
+        arg_types[i] = char_to_ffi_type(typeString[i+1]);
+    }
+    switch (cconv) {
+#ifdef mingw32_TARGET_OS
+    case 0: /* stdcall */
+        abi = FFI_STDCALL;
+        break;
+#endif
+    case 1: /* ccall */
+        abi = FFI_DEFAULT_ABI;
+        break;
+    default:
+        barf("createAdjustor: convention %d not supported on this platform", cconv);
+    }
+
+    r = ffi_prep_cif(cif, abi, n_args, result_type, arg_types);
+    if (r != FFI_OK) barf("ffi_prep_cif failed: %d", r);
+    
+    // ToDo: use ffi_closure_alloc()
+    cl = allocateExec(sizeof(ffi_closure));
+
+    r = ffi_prep_closure(cl, cif, (void*)wptr, hptr/*userdata*/);
+    if (r != FFI_OK) barf("ffi_prep_closure failed: %d", r);
+
+    return (void*)cl;
+}
+
+#else // To end of file...
+

 #if defined(_WIN32)
 #include <windows.h>
 #endif
 #if defined(_WIN32)
 #include <windows.h>
 #endif

@@ -220,6 +303,7 @@ static int totalArgumentSize(char *typeString)
                 // on 32-bit platforms, Double and Int64 occupy two words.
             case 'd':
             case 'l':
                 // on 32-bit platforms, Double and Int64 occupy two words.
             case 'd':
             case 'l':

+            case 'L':

                 if(sizeof(void*) == 4)
                 {
                     sz += 2;
                 if(sizeof(void*) == 4)
                 {
                     sz += 2;

@@ -424,7 +508,7 @@ createAdjustor(int cconv, StgStablePtr hptr,
        // determine whether we have 6 or more integer arguments,
        // and therefore need to flush one to the stack.
        for (c = typeString; *c != '\0'; c++) {
        // determine whether we have 6 or more integer arguments,
        // and therefore need to flush one to the stack.
        for (c = typeString; *c != '\0'; c++) {

-           if (*c == 'i' || *c == 'l') i++;
+           if (*c != 'f' && *c != 'd') i++;

            if (i == 6) break;
        }
 
            if (i == 6) break;
        }
 

@@ -618,48 +702,48 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for
                 src_locs[i] = dst_locs[i] = -32-(fpr++);
             else
             {
                 src_locs[i] = dst_locs[i] = -32-(fpr++);
             else
             {

-                if(t == 'l' && src_gpr <= 9)
+                if((t == 'l' || t == 'L') && src_gpr <= 9)

                 {
                     if((src_gpr & 1) == 0)
                         src_gpr++;
                     src_locs[i] = -src_gpr;
                     src_gpr += 2;
                 }
                 {
                     if((src_gpr & 1) == 0)
                         src_gpr++;
                     src_locs[i] = -src_gpr;
                     src_gpr += 2;
                 }

-                else if(t == 'i' && src_gpr <= 10)
+                else if((t == 'w' || t == 'W') && src_gpr <= 10)

                 {
                     src_locs[i] = -(src_gpr++);
                 }
                 else
                 {
                 {
                     src_locs[i] = -(src_gpr++);
                 }
                 else
                 {

-                    if(t == 'l' || t == 'd')
+                    if((t == 'l' || t == 'L' || t == 'd')

                     {
                         if(src_offset % 8)
                             src_offset += 4;
                     }
                     src_locs[i] = src_offset;
                     {
                         if(src_offset % 8)
                             src_offset += 4;
                     }
                     src_locs[i] = src_offset;

-                    src_offset += (t == 'l' || t == 'd') ? 8 : 4;
+                    src_offset += (t == 'l' || t == 'L' || t == 'd') ? 8 : 4;

                 }
 
                 }
 

-                if(t == 'l' && dst_gpr <= 9)
+                    if((t == 'l' || t == 'L') && dst_gpr <= 9)

                 {
                     if((dst_gpr & 1) == 0)
                         dst_gpr++;
                     dst_locs[i] = -dst_gpr;
                     dst_gpr += 2;
                 }
                 {
                     if((dst_gpr & 1) == 0)
                         dst_gpr++;
                     dst_locs[i] = -dst_gpr;
                     dst_gpr += 2;
                 }

-                else if(t == 'i' && dst_gpr <= 10)
+                else if((t == 'w' || t == 'W') && dst_gpr <= 10)

                 {
                     dst_locs[i] = -(dst_gpr++);
                 }
                 else
                 {
                 {
                     dst_locs[i] = -(dst_gpr++);
                 }
                 else
                 {

-                    if(t == 'l' || t == 'd')
+                    if(t == 'l' || t == 'L' || t == 'd')

                     {
                         if(dst_offset % 8)
                             dst_offset += 4;
                     }
                     dst_locs[i] = dst_offset;
                     {
                         if(dst_offset % 8)
                             dst_offset += 4;
                     }
                     dst_locs[i] = dst_offset;

-                    dst_offset += (t == 'l' || t == 'd') ? 8 : 4;
+                    dst_offset += (t == 'l' || t == 'L' || t == 'd') ? 8 : 4;

                 }
             }
         }
                 }
             }
         }

@@ -701,7 +785,7 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for
                     ASSERT(dst_locs[i] > -32);
                         // dst is in GPR, too.
 
                     ASSERT(dst_locs[i] > -32);
                         // dst is in GPR, too.
 

-                    if(typeString[i] == 'l')
+                    if(typeString[i] == 'l' || typeString[i] == 'L')

                     {
                             // mr dst+1, src+1
                         *code++ = 0x7c000378
                     {
                             // mr dst+1, src+1
                         *code++ = 0x7c000378

@@ -717,7 +801,7 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for
                 }
                 else
                 {
                 }
                 else
                 {

-                    if(typeString[i] == 'l')
+                    if(typeString[i] == 'l' || typeString[i] == 'L')

                     {
                             // stw src+1, dst_offset+4(r1)
                         *code++ = 0x90010000
                     {
                             // stw src+1, dst_offset+4(r1)
                         *code++ = 0x90010000

@@ -736,7 +820,7 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for
                 ASSERT(dst_locs[i] >= 0);
                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 
                 ASSERT(dst_locs[i] >= 0);
                 ASSERT(typeString[i] != 'f' && typeString[i] != 'd');
 

-                if(typeString[i] == 'l')
+                if(typeString[i] == 'l' || typeString[i] == 'L')

                 {
                     // lwz r0, src_offset(r1)
                         *code++ = 0x80010000
                 {
                     // lwz r0, src_offset(r1)
                         *code++ = 0x80010000

@@ -1086,3 +1170,5 @@ if ( *(unsigned char*)ptr != 0xe8 ) {
 
  freeExec(ptr);
 }
 
  freeExec(ptr);
 }

+
+#endif // !USE_LIBFFI

diff --git a/rts/Makefile b/rts/Makefile
index 943f3fe..74a37fd 100644 (file)
--- a/rts/Makefile
+++ b/rts/Makefile
@@ -148,6 +148,11 @@ SRC_CC_OPTS += -DNOSMP
 SRC_HC_OPTS += -optc-DNOSMP
 endif
 
 SRC_HC_OPTS += -optc-DNOSMP
 endif
 

+ifeq "$(UseLibFFI)" "YES"
+SRC_CC_OPTS += -DUSE_LIBFFI
+PACKAGE_CPP_OPTS += -DUSE_LIBFFI
+endif
+

 ifneq "$(DYNAMIC_RTS)" "YES"
 SRC_HC_OPTS += -static
 else
 ifneq "$(DYNAMIC_RTS)" "YES"
 SRC_HC_OPTS += -static
 else

diff --git a/rts/package.conf.in b/rts/package.conf.in
index d57ef62..187ae40 100644 (file)
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -56,6 +56,9 @@ extra-libraries:              "m"             /* for ldexp() */
 #if USE_PAPI
                             , "papi"
 #endif
 #if USE_PAPI
                             , "papi"
 #endif

+#ifdef USE_LIBFFI
+                             , "ffi"
+#endif

 
 #ifdef INSTALLING
 include-dirs:          INCLUDE_DIR GMP_INCLUDE_DIRS
 
 #ifdef INSTALLING
 include-dirs:          INCLUDE_DIR GMP_INCLUDE_DIRS