Commit 937eb1f1 authored by Simon Marlow's avatar Simon Marlow
Browse files

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
parent 8ded597b
......@@ -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
......
......@@ -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
......
......@@ -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}
......@@ -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
......
......@@ -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
......
-----------------------------------------------------------------------------
--
-- 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
......@@ -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
......
......@@ -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