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.

5 files changed, 180 insertions, 37 deletions

diff --git a/compiler/Makefile b/compiler/Makefile
index db21ae863c..04c7778ba9 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -276,6 +276,11 @@ ifeq "$(RelocatableBuild)" "YES"
 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)
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 84ae740dca..19c5d4922f 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -45,6 +45,8 @@ import BasicTypes
 import SrcLoc
 import Outputable
 import FastString
+import Config
+import Constants
 
 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
-		 , [MachRep]    -- primitive arguments expected by stub function
+		 , String       -- string describing type to pass to createAdj.
 		 , 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  	
-		`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
@@ -365,18 +367,12 @@ dsFExportDynamic id cconv
       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")
       
-      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.
@@ -435,12 +431,11 @@ mkFExportCBits :: FastString
 	       -> 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 
- = (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
@@ -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
-  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 ..] ]
 
+  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
@@ -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
 
-  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)))
 
@@ -519,30 +538,33 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
     fun_proto  $$
     vcat 
      [ lbrace
-     ,   text "Capability *cap;"
+     ,   ptext SLIT("Capability *cap;")
      ,   declareResult
      ,   declareCResult
      ,   text "cap = rts_lock();"
 	  -- create the application + perform it.
-     ,   text "cap=rts_evalIO" <> parens (
+     ,   ptext SLIT("cap=rts_evalIO") <> parens (
 		cap <>
-		text "rts_apply" <> parens (
+		ptext SLIT("rts_apply") <> parens (
 		    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
-     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+     ,   ptext SLIT("rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)
 						<> comma <> text "cap") <> semi
      ,   assignCResult
-     ,   text "rts_unlock(cap);"
+     ,   ptext SLIT("rts_unlock(cap);")
      ,   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
      ]
 
@@ -628,4 +650,26 @@ getPrimTyOf 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}
diff --git a/rts/Adjustor.c b/rts/Adjustor.c
index 841c6603be..03fb5d9acd 100644
--- a/rts/Adjustor.c
+++ b/rts/Adjustor.c
@@ -6,7 +6,7 @@
  * ---------------------------------------------------------------------------*/
 
 /* 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. 
 
@@ -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
-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.
 */
 
@@ -42,6 +42,89 @@ Haskell side.
 #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
@@ -220,6 +303,7 @@ static int totalArgumentSize(char *typeString)
                 // on 32-bit platforms, Double and Int64 occupy two words.
             case 'd':
             case 'l':
+            case 'L':
                 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++) {
-	    if (*c == 'i' || *c == 'l') i++;
+	    if (*c != 'f' && *c != 'd') i++;
 	    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
             {
-                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;
                 }
-                else if(t == 'i' && src_gpr <= 10)
+                else if((t == 'w' || t == 'W') && src_gpr <= 10)
                 {
                     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;
-                    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;
                 }
-                else if(t == 'i' && dst_gpr <= 10)
+                else if((t == 'w' || t == 'W') && dst_gpr <= 10)
                 {
                     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;
-                    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.
 
-                    if(typeString[i] == 'l')
+                    if(typeString[i] == 'l' || typeString[i] == 'L')
                     {
                             // mr dst+1, src+1
                         *code++ = 0x7c000378
@@ -717,7 +801,7 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for
                 }
                 else
                 {
-                    if(typeString[i] == 'l')
+                    if(typeString[i] == 'l' || typeString[i] == 'L')
                     {
                             // 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');
 
-                if(typeString[i] == 'l')
+                if(typeString[i] == 'l' || typeString[i] == 'L')
                 {
                     // lwz r0, src_offset(r1)
                         *code++ = 0x80010000
@@ -1086,3 +1170,5 @@ if ( *(unsigned char*)ptr != 0xe8 ) {
 
  freeExec(ptr);
 }
+
+#endif // !USE_LIBFFI
diff --git a/rts/Makefile b/rts/Makefile
index 943f3fe863..74a37fdcb9 100644
--- a/rts/Makefile
+++ b/rts/Makefile
@@ -148,6 +148,11 @@ SRC_CC_OPTS += -DNOSMP
 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
diff --git a/rts/package.conf.in b/rts/package.conf.in
index d57ef62039..187ae4056c 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -56,6 +56,9 @@ extra-libraries:		"m"		/* for ldexp() */
 #if USE_PAPI
 			     , "papi"
 #endif
+#ifdef USE_LIBFFI
+			      , "ffi"
+#endif
 
 #ifdef INSTALLING
 include-dirs:		INCLUDE_DIR GMP_INCLUDE_DIRS