--- /dev/null
+%
+% (c) The University of Glasgow 2000
+%
+\section[ByteCodeGen]{Generate bytecode from Core}
+
+\begin{code}
+module ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode ) where
+
+#include "HsVersions.h"
+
+import PrimRep ( PrimRep(..), getPrimRepSize, isFollowableRep )
+import Bits ( Bits(..), shiftR )
+import Word ( Word8, Word32 )
+import Addr ( Addr(..), writeWord8OffAddr )
+import Foreign ( Ptr(..), mallocBytes )
+import IOExts ( unsafePerformIO, trace )
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The sizes of things. These are platform-independent.}
+%* *
+%************************************************************************
+
+\begin{code}
+
+-- When I push one of these on the H stack, how much does Sp move by?
+taggedSizeW :: PrimRep -> Int
+taggedSizeW pr
+ | isFollowableRep pr = 1 {-it's a pointer, Jim-}
+ | otherwise = 1 {-the tag-} + getPrimRepSize pr
+
+-- The plain size of something, without tag.
+untaggedSizeW :: PrimRep -> Int
+untaggedSizeW pr
+ | isFollowableRep pr = 1
+ | otherwise = getPrimRepSize pr
+
+-- How big is this thing's tag?
+sizeOfTagW :: PrimRep -> Int
+sizeOfTagW pr
+ | isFollowableRep pr = 0
+ | otherwise = 1
+
+-- Blast a bunch of bytes into malloc'd memory and return the addr.
+sendBytesToMallocville :: [Word8] -> IO Addr
+sendBytesToMallocville bytes
+ = do let n = length bytes
+ (Ptr a#) <- mallocBytes n
+ mapM ( \(off,byte) -> writeWord8OffAddr (A# a#) off byte )
+ (zip [0 ..] bytes)
+ return (A# a#)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The platform-dependent marshall-code-generator.}
+%* *
+%************************************************************************
+
+\begin{code}
+
+{-
+Make a piece of code which expects to see the Haskell stack
+looking like this. It is given a pointer to the lowest word in
+the stack -- presumably the tag of the placeholder.
+
+ <arg_n>
+ ...
+ <arg_1>
+ Addr# address_of_C_fn
+ <placeholder-for-result#> (must be an unboxed type)
+-}
+mkMarshalCode :: (Int, PrimRep) -> Int -> [(Int, PrimRep)]
+ -> Addr
+mkMarshalCode (r_offW, r_rep) addr_offW arg_offs_n_reps
+ = let bytes = mkMarshalCode_wrk (r_offW, r_rep)
+ addr_offW arg_offs_n_reps
+ in unsafePerformIO (sendBytesToMallocville bytes)
+
+
+mkMarshalCode_wrk :: (Int, PrimRep) -> Int -> [(Int, PrimRep)]
+ -> [Word8]
+mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps
+
+ = let -- Don't change this without first consulting Intel Corp :-)
+ bytes_per_word = 4
+
+ -- addr and result bits offsetsW
+ offset_of_addr_bitsW = addr_offW + sizeOfTagW AddrRep
+ offset_of_res_bitsW = r_offW + sizeOfTagW r_rep
+
+ offsets_to_pushW
+ = concat
+ [ let -- where this arg's bits start
+ a_bits_offW = a_offW + sizeOfTagW a_rep
+ in
+ [a_bits_offW .. a_bits_offW + untaggedSizeW a_rep - 1]
+
+ | (a_offW, a_rep) <- reverse arg_offs_n_reps
+ ]
+
+ -- some helpers to assemble x86 insns.
+ movl_offespmem_esi offB -- movl offB(%esp), %esi
+ = [0x8B, 0xB4, 0x24] ++ lit32 offB
+ movl_offesimem_ecx offB -- movl offB(%esi), %ecx
+ = [0x8B, 0x8E] ++ lit32 offB
+ save_regs -- pushl all intregs except %esp
+ = [0x50, 0x53, 0x51, 0x52, 0x56, 0x57, 0x55]
+ restore_regs -- popl ditto
+ = [0x5D, 0x5F, 0x5E, 0x5A, 0x59, 0x5B, 0x58]
+ pushl_ecx -- pushl %ecx
+ = [0x51]
+ call_star_ecx -- call * %ecx
+ = [0xFF, 0xD1]
+ add_lit_esp lit -- addl $lit, %esp
+ = [0x81, 0xC4] ++ lit32 lit
+ movl_eax_offesimem offB -- movl %eax, offB(%esi)
+ = [0x89, 0x86] ++ lit32 offB
+ ret -- ret
+ = [0xC3]
+
+ lit32 :: Int -> [Word8]
+ lit32 i = let w32 = (fromIntegral i) :: Word32
+ in map (fromIntegral . ( .&. 0xFF))
+ [w32, w32 `shiftR` 8,
+ w32 `shiftR` 16, w32 `shiftR` 24]
+ {-
+ 2 0000 8BB42478 movl 0x12345678(%esp), %esi
+ 2 563412
+ 3 0007 8B8E7856 movl 0x12345678(%esi), %ecx
+ 3 3412
+ 4
+ 5 000d 50535152 pushl %eax ; pushl %ebx ; pushl %ecx ; pushl %edx
+ 6 0011 565755 pushl %esi ; pushl %edi ; pushl %ebp
+ 7
+ 8 0014 5D5F5E popl %ebp ; popl %edi ; popl %esi
+ 9 0017 5A595B58 popl %edx ; popl %ecx ; popl %ebx ; popl %eax
+ 10
+ 11 001b 51 pushl %ecx
+ 12 001c FFD1 call * %ecx
+ 13
+ 14 001e 81C47856 addl $0x12345678, %esp
+ 14 3412
+ 15 0024 89867856 movl %eax, 0x12345678(%esi)
+ 15 3412
+ 16 002a 89967856 movl %edx, 0x12345678(%esi)
+ 16 3412
+ 18
+ 19 0030 C3 ret
+ 20
+
+ -}
+
+ in
+ trace (show (map fst arg_offs_n_reps))
+ (
+ {- On entry, top of C stack 0(%esp) is the RA and 4(%esp) is
+ arg passed from the interpreter.
+
+ Push all callee saved regs. Push all of them anyway ...
+ pushl %eax
+ pushl %ebx
+ pushl %ecx
+ pushl %edx
+ pushl %esi
+ pushl %edi
+ pushl %ebp
+ -}
+ save_regs
+
+ {- Now 28+0(%esp) is RA and 28+4(%esp) is the arg (the H stack ptr).
+ We'll use %esi as a temporary to point at the H stack, and
+ %ecx as a temporary to copy via.
+
+ movl 28+4(%esp), %esi
+ -}
+ ++ movl_offespmem_esi 32
+
+ {- For each arg in args_offs_n_reps, examine the associated PrimRep
+ to determine how many payload (non-tag) words there are, and
+ whether or not there is a tag. This gives a bunch of offsets on
+ the H stack to copy to the C stack:
+
+ movl off1(%esi), %ecx
+ pushl %ecx
+ -}
+ ++ concatMap (\offW -> movl_offesimem_ecx (bytes_per_word * offW)
+ ++ pushl_ecx)
+ offsets_to_pushW
+
+ {- Get the addr to call into %ecx, bearing in mind that there's
+ an Addr# tag at the indicated location, and do the call:
+
+ movl 4*(1 /*tag*/ +addr_offW)(%esi), %ecx
+ call * %ecx
+ -}
+ ++ movl_offesimem_ecx (bytes_per_word * offset_of_addr_bitsW)
+ ++ call_star_ecx
+
+ {- Nuke the args just pushed and re-establish %esi at the
+ H-stack ptr:
+
+ addl $4*number_of_args_pushed, %esp (ccall only)
+ movl 28+4(%esp), %esi
+ -}
+ ++ add_lit_esp (bytes_per_word * length offsets_to_pushW)
+ ++ movl_offespmem_esi 32
+
+ {- Depending on what the return type is, get the result
+ from %eax or %edx:%eax or %st(0).
+
+ movl %eax, 4(%esi) -- assuming tagged result
+ or
+ movl %edx, 4(%esi)
+ movl %eax, 8(%esi)
+ or
+ fstpl 4(%esi)
+ or
+ fstps 4(%esi)
+ -}
+ ++ case r_rep of
+ IntRep -> movl_eax_offesimem 4
+
+ {- Restore all the pushed regs and go home.
+
+ pushl %ebp
+ pushl %edi
+ pushl %esi
+ pushl %edx
+ pushl %ecx
+ pushl %ebx
+ pushl %eax
+
+ ret
+ -}
+ ++ restore_regs
+ ++ ret
+ )
+\end{code}
+
import Outputable
import Name ( Name, getName )
import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
- idPrimRep, mkSysLocal, idName )
+ idPrimRep, mkSysLocal, idName, isFCallId_maybe )
+import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM,
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
dataConWrapId, isUnboxedTupleCon )
import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons,
- isFunTyCon )
+ isFunTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
+import Type ( Type, repType, splitRepFunTys )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
ClosureEnv, HValue, filterNameMap,
iNTERP_STACK_CHECK_THRESH )
+import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode )
+import Linker ( lookupSymbol )
import List ( intersperse, sortBy, zip4 )
import Foreign ( Ptr(..), mallocBytes )
-import Addr ( Addr(..), addrToInt, writeCharOffAddr )
+import Addr ( Addr(..), nullAddr, addrToInt, writeCharOffAddr )
import CTypes ( CInt )
import Exception ( throwDyn )
-- Delegate tail-calls to schemeT.
schemeE d s p e@(fvs, AnnApp f a)
= schemeT d s p (fvs, AnnApp f a)
+
schemeE d s p e@(fvs, AnnVar v)
| isFollowableRep v_rep
- = schemeT d s p (fvs, AnnVar v)
+ = -- Ptr-ish thing; push it in the normal way
+ schemeT d s p (fvs, AnnVar v)
| otherwise
= -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN.
[(DEFAULT, [], (fvs_rhs, rhs))])
| let isFunType var_type
- = case splitForAllTys var_type of
- (_, ty) -> case splitTyConApp_maybe ty of
- Just (tycon,_) | isFunTyCon tycon -> True
- _ -> False
- ty_bndr = idType bndr
+ = case splitTyConApp_maybe var_type of
+ Just (tycon,_) | isFunTyCon tycon -> True
+ _ -> False
+ ty_bndr = repType (idType bndr)
in isFunType ty_bndr || isTyVarTy ty_bndr
-- Nasty hack; treat
(schemeE d s p new_expr)
-schemeE d s p (fvs, AnnCase scrut bndr alts)
+schemeE d s p (fvs, AnnCase scrut bndr alts0)
= let
+ alts = case alts0 of
+ [(DataAlt dc, [bind1, bind2], rhs)]
+ | isUnboxedTupleCon dc
+ && VoidRep == typePrimRep (idType bind1)
+ -> [(DEFAULT, [bind2], rhs)]
+ other
+ -> alts0
+
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
-- When an alt is entered, it assumes the returned value is
-- 1. A nullary constructor. Push its closure on the stack
-- and SLIDE and RETURN.
--
--- 2. Application of a non-nullary constructor, by defn saturated.
+-- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat
+-- it simply as b -- since the representations are identical
+-- (the VoidRep takes up zero stack space).
+--
+-- 3. Application of a non-nullary constructor, by defn saturated.
-- Split the args into ptrs and non-ptrs, and push the nonptrs,
-- then the ptrs, and then do PACK and RETURN.
--
--- 3. Otherwise, it must be a function call. Push the args
+-- 4. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Int -- Stack depth
-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
-- = panic "schemeT ?!?!"
+-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
+-- = error "?!?!"
+
-- Handle case 0
| Just (arg, constr_names) <- maybe_is_tagToEnum_call
= pushAtom True d p arg `bind` \ (push, arg_words) ->
`snocOL` ENTER
)
- -- Cases 2 and 3
+ -- Handle case 2
+ | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
+ isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
+ in is_con_call && isUnboxedTupleCon con
+ && length args_r_to_l == 2
+ && isVoidRepAtom (last (args_r_to_l))
+ = trace ("schemeT: unboxed pair with Void first component") (
+ schemeT d s p (head args_r_to_l)
+ )
+
+ -- Cases 3 and 4
| otherwise
= if is_con_call && isUnboxedTupleCon con
then returnBc unboxedTupleException
- else returnBc code
+ else code `seq` returnBc code
where
-- Detect and extract relevant info for the tagToEnum kludge.
maybe_is_tagToEnum_call
= let extract_constr_Names ty
- = case splitTyConApp_maybe ty of
+ = case splitTyConApp_maybe (repType ty) of
(Just (tyc, [])) | isDataTyCon tyc
-> map getName (tyConDataCons tyc)
other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
chomp expr
= case snd expr of
AnnVar v -> ([], v)
- AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f)
+ AnnApp f a -> case chomp f of (az, f) -> (a:az, f)
AnnNote n e -> chomp e
other -> pprPanic "schemeT"
(ppr (deAnnotate (panic "schemeT.chomp", other)))
- args_r_to_l = filter (not.isTypeAtom) args_r_to_l_raw
+ args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
isTypeAtom (AnnType _) = True
isTypeAtom _ = False
| not is_con_call
= args_r_to_l
| otherwise
- = filter (not.isPtr) args_r_to_l ++ filter isPtr args_r_to_l
+ = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
where isPtr = isFollowableRep . atomRep
-- make code to push the args and then do the SLIDE-ENTER thing
- code = do_pushery d args_final_r_to_l
-
+ code = do_pushery d (map snd args_final_r_to_l)
tag_when_push = not is_con_call
- narg_words = sum (map (get_arg_szw . atomRep) args_r_to_l)
+ narg_words = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW
do_pushery d (arg:args)
= let (push, arg_words) = pushAtom tag_when_push d p arg
in push `appOL` do_pushery (d+arg_words) args
do_pushery d []
+
+ -- CCALL !
+ | Just (CCall (CCallSpec (StaticTarget target)
+ cconv safety)) <- isFCallId_maybe fn
+ = let -- Get the arg and result reps.
+ (a_reps, r_rep) = getCCallPrimReps (idType fn)
+ tys_str = showSDoc (ppr (a_reps, r_rep))
+ {-
+ Because the Haskell stack grows down, the a_reps refer to
+ lowest to highest addresses in that order. The args for the call
+ are on the stack. Now push an unboxed, tagged Addr# indicating
+ the C function to call. Then push a dummy placeholder for the
+ result. Finally, emit a CCALL insn with an offset pointing to the
+ Addr# just pushed, and a literal field holding the mallocville
+ address of the piece of marshalling code we generate.
+ So, just prior to the CCALL insn, the stack looks like this
+ (growing down, as usual):
+
+ <arg_n>
+ ...
+ <arg_1>
+ Addr# address_of_C_fn
+ <placeholder-for-result#> (must be an unboxed type)
+
+ The interpreter then calls the marshall code mentioned
+ in the CCALL insn, passing it (& <placeholder-for-result#>),
+ that is, the addr of the topmost word in the stack.
+ When this returns, the placeholder will have been
+ filled in. The placeholder is slid down to the sequel
+ depth, and we RETURN.
+
+ This arrangement makes it simple to do f-i-dynamic since the Addr#
+ value is the first arg anyway. It also has the virtue that the
+ stack is GC-understandable at all times.
+
+ The marshalling code is generated specifically for this
+ call site, and so knows exactly the (Haskell) stack
+ offsets of the args, fn address and placeholder. It
+ copies the args to the C stack, calls the stacked addr,
+ and parks the result back in the placeholder. The interpreter
+ calls it as a normal C call, assuming it has a signature
+ void marshall_code ( StgWord* ptr_to_top_of_stack )
+ -}
+
+ -- resolve static address
+ target_addr
+ = let unpacked = _UNPK_ target
+ in case unsafePerformIO (lookupSymbol unpacked) of
+ Just aa -> case aa of Ptr a# -> A# a#
+ Nothing -> panic ("interpreted ccall: can't resolve: "
+ ++ unpacked)
+
+ -- push the Addr#
+ addr_usizeW = untaggedSizeW AddrRep
+ addr_tsizeW = taggedSizeW AddrRep
+ push_Addr = toOL [PUSH_UBX (Right target_addr) addr_usizeW,
+ PUSH_TAG addr_usizeW]
+ d_after_Addr = d + addr_tsizeW
+ -- push the return placeholder
+ r_lit = mkDummyLiteral r_rep
+ r_usizeW = untaggedSizeW r_rep
+ r_tsizeW = 1{-tag-} + r_usizeW
+ push_r = toOL [PUSH_UBX (Left r_lit) r_usizeW,
+ PUSH_TAG r_usizeW]
+ d_after_r = d_after_Addr + r_tsizeW
+ -- do the call
+ do_call = unitOL (CCALL addr_of_marshaller)
+ -- slide and return
+ wrapup = mkSLIDE r_tsizeW
+ (d_after_r - r_tsizeW - s)
+ `snocOL` RETURN r_rep
+
+ -- generate the marshalling code we're going to call
+ r_offW = 0
+ addr_offW = r_tsizeW
+ arg1_offW = r_tsizeW + addr_tsizeW
+ args_offW = map (arg1_offW +)
+ (init (scanl (+) 0 (map taggedSizeW a_reps)))
+ addr_of_marshaller
+ = mkMarshalCode (r_offW, r_rep) addr_offW
+ (zip args_offW a_reps)
+ in
+ trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
+ target_addr
+ `seq`
+ (push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup)
+ )
+
+ | otherwise
= case maybe_dcon of
Just con -> PACK con narg_words `consOL` (
mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
= f x
+mkDummyLiteral :: PrimRep -> Literal
+mkDummyLiteral pr
+ = case pr of
+ IntRep -> MachInt 0
+ _ -> pprPanic "mkDummyLiteral" (ppr pr)
+
+
+-- Convert (eg)
+-- PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
+-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
+--
+-- to [IntRep] -> IntRep
+-- and check that the last arg is VoidRep'd and that an unboxed pair is
+-- returned wherein the first arg is VoidRep'd.
+
+getCCallPrimReps :: Type -> ([PrimRep], PrimRep)
+getCCallPrimReps fn_ty
+ = let (a_tys, r_ty) = splitRepFunTys fn_ty
+ a_reps = map typePrimRep a_tys
+ (r_tycon, r_reps)
+ = case splitTyConApp_maybe (repType r_ty) of
+ (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
+ Nothing -> blargh
+ ok = length a_reps >= 1 && VoidRep == last a_reps
+ && length r_reps == 2 && VoidRep == head r_reps
+ && isUnboxedTupleTyCon r_tycon
+ && PtrRep /= r_rep_to_go -- if it was, it would be impossible
+ -- to create a valid return value
+ -- placeholder on the stack
+ a_reps_to_go = init a_reps
+ r_rep_to_go = r_reps !! 1
+ blargh = pprPanic "getCCallPrimReps: can't handle:"
+ (pprType fn_ty)
+ in
+ --trace (showSDoc (ppr (a_reps, r_reps))) (
+ if ok then (a_reps_to_go, r_rep_to_go) else blargh
+ --)
+
atomRep (AnnVar v) = typePrimRep (idType v)
atomRep (AnnLit l) = literalPrimRep l
atomRep (AnnNote n b) = atomRep (snd b)
(unitOL (PUSH_TAG 0), 1)
| isFCallId v
- = pprPanic "pushAtom: byte code generator can't handle CCalls" (ppr v)
+ = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
| Just primop <- isPrimOpId_maybe v
= (unitOL (PUSH_G (Right primop)), 1)
where
code rep
= let size_host_words = untaggedSizeW rep
- in (unitOL (PUSH_UBX lit size_host_words), size_host_words)
+ in (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words)
pushStr s
= let mallocvilleAddr
return (A# a#)
)
_ -> panic "StgInterp.lit2expr: unhandled string constant type"
-
- addrLit
- = MachInt (toInteger (addrToInt mallocvilleAddr))
in
-- Get the addr on the stack, untaggedly
- (unitOL (PUSH_UBX addrLit 1), 1)
+ (unitOL (PUSH_UBX (Right mallocvilleAddr) 1), 1)
lookupBCEnv_maybe = lookupFM
--- When I push one of these on the stack, how much does Sp move by?
-taggedSizeW :: PrimRep -> Int
-taggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = 1{-the tag-} + getPrimRepSize pr
-
-
--- The plain size of something, without tag.
-untaggedSizeW :: PrimRep -> Int
-untaggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = getPrimRepSize pr
-
-
taggedIdSizeW, untaggedIdSizeW :: Id -> Int
taggedIdSizeW = taggedSizeW . typePrimRep . idType
untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
-> IO ([HValue], ItblEnv, ClosureEnv)
linkIModules gie gce mods
= do let (bcoss, ies) = unzip mods
- bcos = concat bcoss
- final_gie = foldr plusFM gie ies
+ bcos = concat bcoss
+ final_gie = foldr plusFM gie ies
(final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos
return (linked_bcos, final_gie, final_gce)
PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm)
(np, st3) <- ctoi_itbl st2 pk
instr3 st3 i_PUSH_AS p np
- PUSH_UBX lit nws -> do (np, st2) <- literal st lit
+ PUSH_UBX (Left lit) nws
+ -> do (np, st2) <- literal st lit
instr3 st2 i_PUSH_UBX np nws
+ PUSH_UBX (Right aa) nws
+ -> do (np, st2) <- addr st aa
+ instr3 st2 i_PUSH_UBX np nws
+
PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
SLIDE n by -> instr3 st i_SLIDE n by
ALLOC n -> instr2 st i_ALLOC n
TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l)
TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l)
CASEFAIL -> instr1 st i_CASEFAIL
- JMP l -> instr2 st i_JMP (findLabel l)
+ JMP l -> instr2 st i_JMP (findLabel l)
ENTER -> instr1 st i_ENTER
- RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
+ RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
instr2 st2 i_RETURN itbl_no
+ CCALL m_addr -> do (np, st2) <- addr st m_addr
+ instr2 st2 i_CCALL np
i2s :: Int -> Word16
i2s = fromIntegral
literal st (MachFloat r) = float st (fromRational r)
literal st (MachDouble r) = double st (fromRational r)
literal st (MachChar c) = int st c
+ literal st other = pprPanic "ByteCodeLink.mkBits" (ppr other)
ctoi_itbl st pk
= addr st ret_itbl_addr
case m of
Just (Ptr addr) -> case addrToHValue# addr of
(# hval #) -> return hval
- Nothing -> pprPanic "ByteCodeGen.lookupCE(primop)" (ppr primop)
+ Nothing -> pprPanic "ByteCodeLink.lookupCE(primop)" (ppr primop)
lookupCE ce (Left nm)
= case lookupFM ce nm of
Just aa -> return aa
case m of
Just (Ptr addr) -> case addrToHValue# addr of
(# hval #) -> return hval
- Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
+ Nothing -> pprPanic "ByteCodeLink.lookupCE" (ppr nm)
lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm
n <- lookupSymbol (nameToCLabel con_nm "static_info")
case n of
Just addr -> return addr
- Nothing -> pprPanic "ByteCodeGen.lookupIE" (ppr con_nm)
+ Nothing -> pprPanic "ByteCodeLink.lookupIE" (ppr con_nm)
-- HACKS!!! ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
i_RETURN = (bci_RETURN :: Int)
i_STKCHECK = (bci_STKCHECK :: Int)
i_JMP = (bci_JMP :: Int)
+i_CCALL = (bci_CCALL :: Int)
iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
projects / ghc-hetmet.git / commitdiff