Commit 5123ae93 authored by Simon Marlow's avatar Simon Marlow
Browse files

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.
parent a0685661
......@@ -275,6 +275,11 @@ ifeq "$(RelocatableBuild)" "YES"
@echo "cRelocatableBuild = True" >> $(CONFIG_HS)
else
@echo "cRelocatableBuild = False" >> $(CONFIG_HS)
endif
ifeq "$(UseLibFFI)" "YES"
@echo "cLibFFI = True" >> $(CONFIG_HS)
else
@echo "cLibFFI = False" >> $(CONFIG_HS)
endif
@echo done.
......
......@@ -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}
......@@ -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
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment