From: Simon Marlow Date: Mon, 4 Feb 2008 16:10:53 +0000 (+0000) Subject: Support for using libffi to implement FFI calls in GHCi (#631) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=937eb1f1386f12c729c6d819417fe81bc4786b9f Support for using libffi to implement FFI calls in GHCi (#631) This means that an unregisterised build on a platform not directly supported by GHC can now have full FFI support using libffi. Also in this commit: - use PrimRep rather than CgRep to describe FFI args in the byte code generator. No functional changes, but PrimRep is more correct. - change TyCon.sizeofPrimRep to primRepSizeW, which is more useful --- diff --git a/compiler/Makefile b/compiler/Makefile index 0d866f6..bc7099d 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -418,6 +418,11 @@ ALL_DIRS += javaGen SRC_HC_OPTS += -DJAVA endif +ifeq ($(UseLibFFI),YES) +SRC_HC_OPTS += -DUSE_LIBFFI +SRC_HSC2HS_OPTS += -DUSE_LIBFFI +endif + ifeq "$(BootingFromHc)" "YES" # HC files are always from a self-booted compiler bootstrapped = YES diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 9da0e34..36bb477 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -390,12 +390,13 @@ mkBits findLabel st proto_insns literal st (MachLabel fs _) = litlabel st fs literal st (MachWord w) = int st (fromIntegral w) literal st (MachInt j) = int st (fromIntegral j) + literal st MachNullAddr = int st (fromIntegral 0) literal st (MachFloat r) = float st (fromRational r) literal st (MachDouble r) = double st (fromRational r) literal st (MachChar c) = int st (ord c) literal st (MachInt64 ii) = int64 st (fromIntegral ii) literal st (MachWord64 ii) = int64 st (fromIntegral ii) - literal st other = pprPanic "ByteCodeLink.literal" (ppr other) + literal st other = pprPanic "ByteCodeAsm.literal" (ppr other) push_alts NonPtrArg = bci_PUSH_ALTS_N diff --git a/compiler/ghci/ByteCodeFFI.lhs b/compiler/ghci/ByteCodeFFI.lhs index c29b74a..286eaf8 100644 --- a/compiler/ghci/ByteCodeFFI.lhs +++ b/compiler/ghci/ByteCodeFFI.lhs @@ -12,10 +12,22 @@ ByteCodeGen: Generate machine-code sequences for foreign import -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +#ifdef USE_LIBFFI + +module ByteCodeFFI ( moan64, newExec ) where + +import Outputable +import System.IO +import Foreign +import Foreign.C + +#else + module ByteCodeFFI ( mkMarshalCode, moan64, newExec ) where #include "HsVersions.h" +import TyCon import Outputable import SMRep import ForeignCall @@ -44,21 +56,6 @@ import System.IO ( hPutStrLn, stderr ) \begin{code} -moan64 :: String -> SDoc -> a -moan64 msg pp_rep - = unsafePerformIO ( - hPutStrLn stderr ( - "\nGHCi's bytecode generation machinery can't handle 64-bit\n" ++ - "code properly yet. You can work around this for the time being\n" ++ - "by compiling this module and all those it imports to object code,\n" ++ - "and re-starting your GHCi session. The panic below contains information,\n" ++ - "intended for the GHC implementors, about the exact place where GHC gave up.\n" - ) - ) - `seq` - pprPanic msg pp_rep - - -- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc. #include "nativeGen/NCG.h" @@ -78,27 +75,15 @@ itself expects only to be called using the ccall convention -- that is, we don't clear our own (single) arg off the C stack. -} mkMarshalCode :: CCallConv - -> (Int, CgRep) -> Int -> [(Int, CgRep)] + -> (Int, PrimRep) -> Int -> [(Int, PrimRep)] -> IO (FunPtr ()) mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps = let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps in newExec bytes -newExec :: Storable a => [a] -> IO (FunPtr ()) -newExec code - = do ptr <- _allocateExec (fromIntegral $ codeSize undefined code) - pokeArray ptr code - return (castPtrToFunPtr ptr) - where - codeSize :: Storable a => a -> [a] -> Int - codeSize dummy array = sizeOf(dummy) * length array - -foreign import ccall unsafe "allocateExec" - _allocateExec :: CUInt -> IO (Ptr a) - mkMarshalCode_wrk :: CCallConv - -> (Int, CgRep) -> Int -> [(Int, CgRep)] + -> (Int, PrimRep) -> Int -> [(Int, PrimRep)] -> [Word8] mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps @@ -111,7 +96,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps offsets_to_pushW = concat [ -- reversed because x86 is little-endian - reverse [a_offW .. a_offW + cgRepSizeW a_rep - 1] + reverse [a_offW .. a_offW + primRepSizeW a_rep - 1] -- reversed because args are pushed L -> R onto C stack | (a_offW, a_rep) <- reverse arg_offs_n_reps @@ -267,11 +252,14 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps f64 = fstpl_offesimem 0 in case r_rep of - NonPtrArg -> i32 - DoubleArg -> f64 - FloatArg -> f32 - LongArg -> i64 - VoidArg -> [] + VoidRep -> [] + IntRep -> i32 + WordRep -> i32 + Int64Rep -> i64 + Word64Rep -> i64 + AddrRep -> i32 + FloatRep -> f32 + DoubleRep -> f64 other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(x86)" (ppr r_rep) @@ -489,7 +477,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps offsets_to_pushW = concat - [ [a_offW .. a_offW + cgRepSizeW a_rep - 1] + [ [a_offW .. a_offW + primRepSizeW a_rep - 1] | (a_offW, a_rep) <- arg_offs_n_reps ] @@ -640,10 +628,12 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps f64 = [mkSTF f0 i0 0, mkSTF f1 i0 4] in case r_rep of - NonPtrArg -> i32 - DoubleArg -> f64 - FloatArg -> f32 - VoidArg -> [] + VoidRep -> [] + IntRep -> i32 + WordRep -> i32 + AddrRep -> i32 + FloatRep -> f32 + DoubleRep -> f64 other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(sparc)" (ppr r_rep) @@ -668,7 +658,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps result_off = r_offW * bytes_per_word linkageArea = 24 - parameterArea = sum [ cgRepSizeW a_rep * bytes_per_word + parameterArea = sum [ primRepSizeW a_rep * bytes_per_word | (_, a_rep) <- arg_offs_n_reps ] savedRegisterArea = 4 frameSize = padTo16 (linkageArea + max parameterArea 32 + savedRegisterArea) @@ -680,7 +670,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps pass_parameters ((a_offW, a_rep):args) nextFPR offsetW = let haskellArgOffset = a_offW * bytes_per_word - offsetW' = offsetW + cgRepSizeW a_rep + offsetW' = offsetW + primRepSizeW a_rep pass_word w | offsetW + w < 8 = @@ -708,7 +698,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps .|. (fromIntegral nextFPR `shiftL` 21)) : pass_parameters args (nextFPR+1) offsetW' _ -> - concatMap pass_word [0 .. cgRepSizeW a_rep - 1] + concatMap pass_word [0 .. primRepSizeW a_rep - 1] ++ pass_parameters args nextFPR offsetW' gather_result = case r_rep of @@ -719,12 +709,12 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps DoubleArg -> [0xd83f0000 .|. (fromIntegral result_off .&. 0xFFFF)] -- stfd f1, result_off(r31) - _ | cgRepSizeW r_rep == 2 -> + _ | primRepSizeW r_rep == 2 -> [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF), 0x909f0000 .|. (fromIntegral (result_off+4) .&. 0xFFFF)] -- stw r3, result_off(r31) -- stw r4, result_off+4(r31) - _ | cgRepSizeW r_rep == 1 -> + _ | primRepSizeW r_rep == 1 -> [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF)] -- stw r3, result_off(r31) in @@ -862,5 +852,33 @@ lit32 i = let w32 = (fromIntegral i) :: Word32 [w32, w32 `shiftR` 8, w32 `shiftR` 16, w32 `shiftR` 24] #endif + +#endif /* !USE_LIBFFI */ + +moan64 :: String -> SDoc -> a +moan64 msg pp_rep + = unsafePerformIO ( + hPutStrLn stderr ( + "\nGHCi's bytecode generation machinery can't handle 64-bit\n" ++ + "code properly yet. You can work around this for the time being\n" ++ + "by compiling this module and all those it imports to object code,\n" ++ + "and re-starting your GHCi session. The panic below contains information,\n" ++ + "intended for the GHC implementors, about the exact place where GHC gave up.\n" + ) + ) + `seq` + pprPanic msg pp_rep + +newExec :: Storable a => [a] -> IO (FunPtr ()) +newExec code + = do ptr <- _allocateExec (fromIntegral $ codeSize undefined code) + pokeArray ptr code + return (castPtrToFunPtr ptr) + where + codeSize :: Storable a => a -> [a] -> Int + codeSize dummy array = sizeOf(dummy) * length array + +foreign import ccall unsafe "allocateExec" + _allocateExec :: CUInt -> IO (Ptr a) \end{code} diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index bb0f591..2e0079e 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -18,9 +18,12 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where import ByteCodeInstr import ByteCodeItbls -import ByteCodeFFI import ByteCodeAsm import ByteCodeLink +import ByteCodeFFI +#ifdef USE_LIBFFI +import LibFFI +#endif import Outputable import Name @@ -55,8 +58,7 @@ import OrdList import Constants import Data.List ( intersperse, sortBy, zip4, zip6, partition ) -import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8, - withForeignPtr, castFunPtrToPtr, nullPtr, plusPtr ) +import Foreign import Foreign.C import Control.Exception ( throwDyn ) @@ -932,18 +934,18 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l | t == arrayPrimTyCon || t == mutableArrayPrimTyCon -> do rest <- pargs (d + addr_sizeW) az code <- parg_ArrayishRep arrPtrsHdrSize d p a - return ((code,NonPtrArg):rest) + return ((code,AddrRep):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> do rest <- pargs (d + addr_sizeW) az code <- parg_ArrayishRep arrWordsHdrSize d p a - return ((code,NonPtrArg):rest) + return ((code,AddrRep):rest) -- Default case: push taggedly, but otherwise intact. other -> do (code_a, sz_a) <- pushAtom d p a rest <- pargs (d+sz_a) az - return ((code_a, atomRep a) : rest) + return ((code_a, atomPrimRep a) : rest) -- Do magic for Ptr/Byte arrays. Push a ptr to the array on -- the stack but then advance it over the headers, so as to @@ -960,9 +962,9 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps push_args = concatOL pushs_arg - d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l) + d_after_args = d0 + sum (map primRepSizeW a_reps_pushed_r_to_l) a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep = panic "ByteCodeGen.generateCCall: missing or invalid World token?" | otherwise = reverse (tail a_reps_pushed_r_to_l) @@ -974,7 +976,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Get the result rep. (returns_void, r_rep) = case maybe_getCCallReturnRep (idType fn) of - Nothing -> (True, VoidArg) + Nothing -> (True, VoidRep) Just rr -> (False, rr) {- Because the Haskell stack grows down, the a_reps refer to @@ -1040,7 +1042,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Push the return placeholder. For a call returning nothing, -- this is a VoidArg (tag). - r_sizeW = cgRepSizeW r_rep + r_sizeW = primRepSizeW r_rep d_after_r = d_after_Addr + r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void @@ -1052,24 +1054,36 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l addr_offW = r_sizeW arg1_offW = r_sizeW + addr_sizeW args_offW = map (arg1_offW +) - (init (scanl (+) 0 (map cgRepSizeW a_reps))) - -- in - addr_of_marshaller <- ioToBc (mkMarshalCode cconv - (r_offW, r_rep) addr_offW - (zip args_offW a_reps)) - recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) - let + (init (scanl (+) 0 (map primRepSizeW a_reps))) + -- Offset of the next stack frame down the stack. The CCALL -- instruction needs to describe the chunk of stack containing -- the ccall args to the GC, so it needs to know how large it -- is. See comment in Interpreter.c with the CCALL instruction. stk_offset = d_after_r - s + -- in +#if !defined(USE_LIBFFI) + -- In the native case, we build marshalling code and attach the + -- address of that to the CCALL instruction + addr_of_marshaller <- ioToBc (mkMarshalCode cconv + (r_offW, r_rep) addr_offW + (zip args_offW a_reps)) +#else + -- the only difference in libffi mode is that we prepare a cif + -- describing the call type by calling libffi, and we attach the + -- address of this to the CCALL instruction. + token <- ioToBc $ prepForeignCall cconv a_reps r_rep + let addr_of_marshaller = castPtrToFunPtr token +#endif + + recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) + let -- do the call do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)) -- slide and return wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) - `snocOL` RETURN_UBX r_rep + `snocOL` RETURN_UBX (primRepToCgRep r_rep) --in --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $ return ( @@ -1077,17 +1091,19 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup ) - -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack. -mkDummyLiteral :: CgRep -> Literal +mkDummyLiteral :: PrimRep -> Literal mkDummyLiteral pr = case pr of - NonPtrArg -> MachWord 0 - DoubleArg -> MachDouble 0 - FloatArg -> MachFloat 0 - LongArg -> MachWord64 0 - _ -> moan64 "mkDummyLiteral" (ppr pr) + IntRep -> MachInt 0 + WordRep -> MachWord 0 + AddrRep -> MachNullAddr + DoubleRep -> MachDouble 0 + FloatRep -> MachFloat 0 + Int64Rep -> MachInt64 0 + Word64Rep -> MachWord64 0 + _ -> panic "mkDummyLiteral" -- Convert (eg) @@ -1104,21 +1120,21 @@ mkDummyLiteral pr -- -- to Nothing -maybe_getCCallReturnRep :: Type -> Maybe CgRep +maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) (r_tycon, r_reps) = case splitTyConApp_maybe (repType r_ty) of - (Just (tyc, tys)) -> (tyc, map typeCgRep tys) + (Just (tyc, tys)) -> (tyc, map typePrimRep tys) Nothing -> blargh - ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps) - || r_reps == [VoidArg] ) + ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) + || r_reps == [VoidRep] ) && isUnboxedTupleTyCon r_tycon && case maybe_r_rep_to_go of Nothing -> True - Just r_rep -> r_rep /= PtrArg + Just r_rep -> r_rep /= PtrRep -- if it was, it would be impossible -- to create a valid return value -- placeholder on the stack @@ -1420,19 +1436,22 @@ isTypeAtom (AnnType _) = True isTypeAtom _ = False isVoidArgAtom :: AnnExpr' id ann -> Bool -isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg +isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e isVoidArgAtom (AnnCast (_,e) _) = isVoidArgAtom e isVoidArgAtom _ = False +atomPrimRep :: AnnExpr' Id ann -> PrimRep +atomPrimRep (AnnVar v) = typePrimRep (idType v) +atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnNote n b) = atomPrimRep (snd b) +atomPrimRep (AnnApp f (_, AnnType _)) = atomPrimRep (snd f) +atomPrimRep (AnnLam x e) | isTyVar x = atomPrimRep (snd e) +atomPrimRep (AnnCast b _) = atomPrimRep (snd b) +atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) + atomRep :: AnnExpr' Id ann -> CgRep -atomRep (AnnVar v) = typeCgRep (idType v) -atomRep (AnnLit l) = typeCgRep (literalType l) -atomRep (AnnNote n b) = atomRep (snd b) -atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f) -atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) -atomRep (AnnCast b _) = atomRep (snd b) -atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) +atomRep e = primRepToCgRep (atomPrimRep e) isPtrAtom :: AnnExpr' Id ann -> Bool isPtrAtom e = atomRep e == PtrArg diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index d5e5e8e..1d629c0 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -131,7 +131,7 @@ data BCInstr | CASEFAIL | JMP LocalLabel - -- For doing calls to C (via glue code generated by ByteCodeFFI) + -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi) | CCALL Int -- stack frame size (Ptr ()) -- addr of the glue code diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc new file mode 100644 index 0000000..3708238 --- /dev/null +++ b/compiler/ghci/LibFFI.hsc @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- +-- libffi bindings +-- +-- (c) The University of Glasgow 2008 +-- +----------------------------------------------------------------------------- + +#ifndef USE_LIBFFI + +module LibFFI () where + +#else + +#include + +module LibFFI ( + ForeignCallToken, + prepForeignCall + ) where + +import TyCon +import ForeignCall +import Panic +import Outputable +import Constants + +import Foreign +import Foreign.C +import Text.Printf +import Control.Exception + +---------------------------------------------------------------------------- + +type ForeignCallToken = C_ffi_cif + +prepForeignCall + :: CCallConv + -> [PrimRep] -- arg types + -> PrimRep -- result type + -> IO (Ptr ForeignCallToken) -- token for making calls + -- (must be freed by caller) +prepForeignCall cconv arg_types result_type + = do + let n_args = length arg_types + arg_arr <- mallocArray n_args + let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType ty) + mapM_ init_arg (zip arg_types [0..]) + cif <- mallocBytes (#const sizeof(ffi_cif)) + let abi = convToABI cconv + let res_ty = primRepToFFIType result_type + r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr + if (r /= fFI_OK) + then throwDyn (InstallationError + (printf "prepForeignCallFailed: %d" (show r))) + else return cif + +convToABI :: CCallConv -> C_ffi_abi +convToABI CCallConv = fFI_DEFAULT_ABI +#ifdef mingw32_HOST_OS +convToABI StdCallConv = fFI_STDCALL +#endif +convToABI _ = panic "convToABI: convention not supported" + +-- c.f. DsForeign.primTyDescChar +primRepToFFIType :: PrimRep -> Ptr C_ffi_type +primRepToFFIType r + = case r of + VoidRep -> ffi_type_void + IntRep -> signed_word + WordRep -> unsigned_word + Int64Rep -> ffi_type_sint64 + Word64Rep -> ffi_type_uint64 + AddrRep -> ffi_type_pointer + FloatRep -> ffi_type_float + DoubleRep -> ffi_type_double + _ -> panic "primRepToFFIType" + where + (signed_word, unsigned_word) + | wORD_SIZE == 4 = (ffi_type_sint32, ffi_type_uint32) + | wORD_SIZE == 8 = (ffi_type_sint64, ffi_type_uint64) + | otherwise = panic "primTyDescChar" + + +data C_ffi_type +data C_ffi_cif + +type C_ffi_status = (#type ffi_status) +type C_ffi_abi = (#type ffi_abi) + +foreign import ccall "&ffi_type_void" ffi_type_void :: Ptr C_ffi_type +--foreign import ccall "&ffi_type_uint8" ffi_type_uint8 :: Ptr C_ffi_type +--foreign import ccall "&ffi_type_sint8" ffi_type_sint8 :: Ptr C_ffi_type +--foreign import ccall "&ffi_type_uint16" ffi_type_uint16 :: Ptr C_ffi_type +--foreign import ccall "&ffi_type_sint16" ffi_type_sint16 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_uint32" ffi_type_uint32 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_sint32" ffi_type_sint32 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_uint64" ffi_type_uint64 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_sint64" ffi_type_sint64 :: Ptr C_ffi_type +foreign import ccall "&ffi_type_float" ffi_type_float :: Ptr C_ffi_type +foreign import ccall "&ffi_type_double" ffi_type_double :: Ptr C_ffi_type +foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type + +fFI_OK :: C_ffi_status +fFI_OK = (#const FFI_OK) +--fFI_BAD_ABI :: C_ffi_status +--fFI_BAD_ABI = (#const FFI_BAD_ABI) +--fFI_BAD_TYPEDEF :: C_ffi_status +--fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF) + +fFI_DEFAULT_ABI :: C_ffi_abi +fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI) +#ifdef mingw32_HOST_OS +fFI_STDCALL :: C_ffi_abi +fFI_STDCALL = (#const FFI_STDCALL) +#endif + +-- ffi_status ffi_prep_cif(ffi_cif *cif, +-- ffi_abi abi, +-- unsigned int nargs, +-- ffi_type *rtype, +-- ffi_type **atypes); + +foreign import ccall "ffi_prep_cif" + ffi_prep_cif :: Ptr C_ffi_cif -- cif + -> C_ffi_abi -- abi + -> CUInt -- nargs + -> Ptr C_ffi_type -- result type + -> Ptr (Ptr C_ffi_type) -- arg types + -> IO C_ffi_status + +-- Currently unused: + +-- void ffi_call(ffi_cif *cif, +-- void (*fn)(), +-- void *rvalue, +-- void **avalue); + +-- foreign import ccall "ffi_call" +-- ffi_call :: Ptr C_ffi_cif -- cif +-- -> FunPtr (IO ()) -- function to call +-- -> Ptr () -- put result here +-- -> Ptr (Ptr ()) -- arg values +-- -> IO () + +#endif diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index b5d67cf..9e2ef17 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -67,7 +67,6 @@ import TysPrim import PrelNames import TysWiredIn -import Constants import Outputable import Panic @@ -260,11 +259,11 @@ extractUnboxed tt clos = go tt (nonPtrs clos) | otherwise = pprPanic "Expected a TcTyCon" (ppr t) go [] _ = [] go (t:tt) xx - | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx + | (x, rest) <- splitAt (sizeofType t) xx = x : go tt rest -sizeofTyCon :: TyCon -> Int -sizeofTyCon = sizeofPrimRep . tyConPrimRep +sizeofTyCon :: TyCon -> Int -- in *words* +sizeofTyCon = primRepSizeW . tyConPrimRep ----------------------------------- -- * Traversals for Terms diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 88a6209..ddcb665 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -11,7 +11,7 @@ module TyCon( PrimRep(..), tyConPrimRep, - sizeofPrimRep, + primRepSizeW, AlgTyConRhs(..), visibleDataCons, TyConParent(..), @@ -455,19 +455,22 @@ data PrimRep | AddrRep -- a pointer, but not to a Haskell value | FloatRep | DoubleRep - deriving( Eq ) - --- Size of a PrimRep, in bytes -sizeofPrimRep :: PrimRep -> Int -sizeofPrimRep IntRep = wORD_SIZE -sizeofPrimRep WordRep = wORD_SIZE -sizeofPrimRep Int64Rep = wORD64_SIZE -sizeofPrimRep Word64Rep= wORD64_SIZE -sizeofPrimRep FloatRep = 4 -sizeofPrimRep DoubleRep= 8 -sizeofPrimRep AddrRep = wORD_SIZE -sizeofPrimRep PtrRep = wORD_SIZE -sizeofPrimRep VoidRep = 0 + deriving( Eq, Show ) + +instance Outputable PrimRep where + ppr r = text (show r) + +-- Size of a PrimRep, in words +primRepSizeW :: PrimRep -> Int +primRepSizeW IntRep = 1 +primRepSizeW WordRep = 1 +primRepSizeW Int64Rep = wORD64_SIZE `quot` wORD_SIZE +primRepSizeW Word64Rep= wORD64_SIZE `quot` wORD_SIZE +primRepSizeW FloatRep = 1 -- NB. might not take a full word +primRepSizeW DoubleRep= dOUBLE_SIZE `quot` wORD_SIZE +primRepSizeW AddrRep = 1 +primRepSizeW PtrRep = 1 +primRepSizeW VoidRep = 0 \end{code} %************************************************************************ diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 0ca8ddf..3962856 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -28,6 +28,9 @@ #include #endif +#ifdef USE_LIBFFI +#include +#endif /* -------------------------------------------------------------------------- * The bytecode interpreter @@ -1321,14 +1324,68 @@ run_BCO: RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE + sizeofW(StgRetDyn); -#ifdef THREADED_RTS - // Threaded RTS: - // Arguments on the TSO stack are not good, because garbage - // collection might move the TSO as soon as we call - // suspendThread below. + /* the stack looks like this: + + | | <- Sp + stk_offset + +-------------+ + | | + | args | + | | <- Sp + ret_size + 1 + +-------------+ + | C fun | <- Sp + ret_size + +-------------+ + | ret | <- Sp + +-------------+ + + ret is a placeholder for the return address, and may be + up to 2 words. + + We need to copy the args out of the TSO, because when + we call suspendThread() we no longer own the TSO stack, + and it may move at any time - indeed suspendThread() + itself may do stack squeezing and move our args. + So we make a copy of the argument block. + */ + +#ifdef USE_LIBFFI +#define ROUND_UP_WDS(p) ((((StgWord)(p)) + sizeof(W_)-1)/sizeof(W_)) + + ffi_cif *cif = (ffi_cif *)marshall_fn; + nat nargs = cif->nargs; + nat ret_size; + nat i; + StgPtr p; + W_ ret[2]; // max needed + W_ *arguments[stk_offset]; // max needed + void *argptrs[nargs]; + void (*fn)(void); + + if (cif->rtype->type == FFI_TYPE_VOID) { + // necessary because cif->rtype->size == 1 for void, + // but the bytecode generator has not pushed a + // placeholder in this case. + ret_size = 0; + } else { + ret_size = ROUND_UP_WDS(cif->rtype->size); + } + + memcpy(arguments, Sp+ret_size+1, + sizeof(W_) * (stk_offset-1-ret_size)); + + // libffi expects the args as an array of pointers to + // values, so we have to construct this array before making + // the call. + p = (StgPtr)arguments; + for (i = 0; i < nargs; i++) { + argptrs[i] = (void *)p; + // get the size from the cif + p += ROUND_UP_WDS(cif->arg_types[i]->size); + } + // this is the function we're going to call + fn = (void(*)(void))Sp[ret_size]; +#else W_ arguments[stk_offset]; - memcpy(arguments, Sp, sizeof(W_) * stk_offset); #endif @@ -1357,17 +1414,10 @@ run_BCO: SAVE_STACK_POINTERS; tok = suspendThread(&cap->r); -#ifndef THREADED_RTS - // Careful: - // suspendThread might have shifted the stack - // around (stack squeezing), so we have to grab the real - // Sp out of the TSO to find the ccall args again. - - marshall_fn ( (void*)(cap->r.rCurrentTSO->sp + ret_dyn_size) ); -#else - // Threaded RTS: // We already made a copy of the arguments above. - +#ifdef USE_LIBFFI + ffi_call(cif, fn, ret, argptrs); +#else marshall_fn ( arguments ); #endif @@ -1389,12 +1439,12 @@ run_BCO: // Save the Haskell thread's current value of errno cap->r.rCurrentTSO->saved_errno = errno; -#ifdef THREADED_RTS - // Threaded RTS: - // Copy the "arguments", which might include a return value, - // back to the TSO stack. It would of course be enough to - // just copy the return value, but we don't know the offset. - memcpy(Sp, arguments, sizeof(W_) * stk_offset); + // Copy the return value back to the TSO stack. It is at + // most 2 words large, and resides at arguments[0]. +#ifdef USE_LIBFFI + memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size)); +#else + memcpy(Sp, arguments, sizeof(W_) * stg_min(stk_offset,2)); #endif goto nextInsn;