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
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
-- 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
\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"
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
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
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)
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
]
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)
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)
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 =
.|. (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
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
[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}
import ByteCodeInstr
import ByteCodeItbls
-import ByteCodeFFI
import ByteCodeAsm
import ByteCodeLink
+import ByteCodeFFI
+#ifdef USE_LIBFFI
+import LibFFI
+#endif
import Outputable
import Name
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 )
| 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
(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)
-- 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
-- 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
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 (
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)
--
-- 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
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
| 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
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- libffi bindings
+--
+-- (c) The University of Glasgow 2008
+--
+-----------------------------------------------------------------------------
+
+#ifndef USE_LIBFFI
+
+module LibFFI () where
+
+#else
+
+#include <ffi.h>
+
+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
import PrelNames
import TysWiredIn
-import Constants
import Outputable
import Panic
| 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
PrimRep(..),
tyConPrimRep,
- sizeofPrimRep,
+ primRepSizeW,
AlgTyConRhs(..), visibleDataCons,
TyConParent(..),
| 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}
%************************************************************************
#include <errno.h>
#endif
+#ifdef USE_LIBFFI
+#include <ffi.h>
+#endif
/* --------------------------------------------------------------------------
* The bytecode interpreter
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
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
// 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;
projects / ghc-hetmet.git / commitdiff