From: Simon Marlow Date: Thu, 3 Jan 2008 17:02:36 +0000 (+0000) Subject: Optionally use libffi to implement 'foreign import "wrapper"' (#793) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5123ae93cfc5cdfcecc84340a9517580ad900d64;hp=a068566188bba9d808dfbe1b00c735b6c6952194 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 --- 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 84ae740..19c5d49 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 841c660..03fb5d9 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 +#if defined(USE_LIBFFI) + +#include +#include + +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 #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 943f3fe..74a37fd 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 d57ef62..187ae40 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