%
-% (c) The University of Glasgow 2002
+% (c) The University of Glasgow 2002-2006
%
-\section[ByteCodeGen]{Generate bytecode from Core}
+
+ByteCodeGen: Generate bytecode from Core
\begin{code}
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
import ByteCodeInstr
-import ByteCodeFFI ( mkMarshalCode, moan64 )
-import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO,
- assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH )
-import ByteCodeLink ( lookupStaticPtr )
+import ByteCodeItbls
+import ByteCodeFFI
+import ByteCodeAsm
+import ByteCodeLink
import Outputable
-import Name ( Name, getName, mkSystemVarName )
+import Name
import Id
import FiniteMap
-import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
-import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses )
-import CoreUtils ( exprType )
+import ForeignCall
+import HscTypes
+import CoreUtils
import CoreSyn
-import PprCore ( pprCoreExpr )
-import Literal ( Literal(..), literalType )
-import PrimOp ( PrimOp(..) )
-import CoreFVs ( freeVars )
-import Type ( isUnLiftedType, splitTyConApp_maybe )
-import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
- dataConRepArity )
-import TyCon ( TyCon, tyConFamilySize, isDataTyCon,
- tyConDataCons, isUnboxedTupleTyCon )
-import Class ( Class, classTyCon )
-import Type ( Type, repType, splitFunTys, dropForAlls, pprType )
+import PprCore
+import Literal
+import PrimOp
+import CoreFVs
+import Type
+import DataCon
+import TyCon
+import Class
+import Type
import Util
-import DataCon ( dataConRepArity )
-import Var ( isTyVar )
-import VarSet ( VarSet, varSetElems )
-import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon,
- byteArrayPrimTyCon, mutableByteArrayPrimTyCon
- )
-import DynFlags ( DynFlags, DynFlag(..) )
-import ErrUtils ( showPass, dumpIfSet_dyn )
-import Unique ( mkPseudoUniqueE )
-import FastString ( FastString(..), unpackFS )
-import Panic ( GhcException(..) )
-import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord,
- CgRep(..), cgRepSizeW, isFollowableArg, idCgRep )
-import Bitmap ( intsToReverseBitmap, mkBitmap )
+import DataCon
+import Var
+import VarSet
+import TysPrim
+import DynFlags
+import ErrUtils
+import Unique
+import FastString
+import Panic
+import SMRep
+import Bitmap
import OrdList
-import Constants ( wORD_SIZE )
+import Constants
import Data.List ( intersperse, sortBy, zip4, zip6, partition )
import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
- withForeignPtr )
+ withForeignPtr, castFunPtrToPtr )
import Foreign.C ( CInt )
import Control.Exception ( throwDyn )
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
- invented_id = mkLocalId invented_name (panic "invented_id's type")
+ invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
(BcM_State final_ctr mallocd, proto_bco)
<- runBc (schemeTopBind (invented_id, freeVars expr))
-> Int
-> [StgWord]
-> Bool -- True <=> is a return point, rather than a function
- -> [Ptr ()]
+ -> [BcPtr]
-> ProtoBCO name
mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
is_ret mallocd_blocks
-- don't do stack checks at return points;
-- everything is aggregated up to the top BCO
-- (which must be a function)
- | stack_overest >= 65535
- = pprPanic "mkProtoBCO: stack use won't fit in 16 bits"
- (int stack_overest)
| stack_overest >= iNTERP_STACK_CHECK_THRESH
= STKCHECK stack_overest : peep_d
| otherwise
= peep_d -- the supposedly common case
+ -- We assume that this sum doesn't wrap
stack_overest = sum (map bciStackUse peep_d)
-- Merge local pushes
= schemeR_wrk fvs nm rhs (collect [] rhs)
collect xs (_, AnnNote note e) = collect xs e
+collect xs (_, AnnCast e _) = collect xs e
collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e
collect xs (_, not_lambda) = (reverse xs, not_lambda)
bits = argBits (reverse (map idCgRep all_args))
bitmap_size = length bits
bitmap = mkBitmap bits
- in
- schemeE szw_args 0 p_init body `thenBc` \ body_code ->
+ in do
+ body_code <- schemeE szw_args 0 p_init body
emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
arity bitmap_size bitmap False{-not alts-})
schemeT d s p e
| otherwise
- = -- Returning an unlifted value.
- -- Heave it on the stack, SLIDE, and RETURN.
- pushAtom d p (AnnVar v) `thenBc` \ (push, szw) ->
- returnBc (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX v_rep) -- go
+ = do -- Returning an unlifted value.
+ -- Heave it on the stack, SLIDE, and RETURN.
+ (push, szw) <- pushAtom d p (AnnVar v)
+ return (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX v_rep) -- go
where
v_type = idType v
v_rep = typeCgRep v_type
schemeE d s p (AnnLit literal)
- = pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) ->
- let l_rep = typeCgRep (literalType literal)
- in returnBc (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX l_rep) -- go
-
+ = do (push, szw) <- pushAtom d p (AnnLit literal)
+ let l_rep = typeCgRep (literalType literal)
+ return (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX l_rep) -- go
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
| (AnnVar v, args_r_to_l) <- splitApp rhs,
Just data_con <- isDataConWorkId_maybe v,
dataConRepArity data_con == length args_r_to_l
- = -- Special case for a non-recursive let whose RHS is a
+ = do -- Special case for a non-recursive let whose RHS is a
-- saturatred constructor application.
-- Just allocate the constructor and carry on
- mkConAppCode d s p data_con args_r_to_l `thenBc` \ alloc_code ->
- schemeE (d+1) s (addToFM p x d) body `thenBc` \ body_code ->
- returnBc (alloc_code `appOL` body_code)
+ alloc_code <- mkConAppCode d s p data_con args_r_to_l
+ body_code <- schemeE (d+1) s (addToFM p x d) body
+ return (alloc_code `appOL` body_code)
-- General case for let. Generates correct, if inefficient, code in
-- all situations.
-- ToDo: don't build thunks for things with no free variables
build_thunk dd [] size bco off arity
- = returnBc (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
+ = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
where
mkap | arity == 0 = MKAP
| otherwise = MKPAP
build_thunk dd (fv:fvs) size bco off arity = do
(push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
- returnBc (push_code `appOL` more_push_code)
+ return (push_code `appOL` more_push_code)
alloc_code = toOL (zipWith mkAlloc sizes arities)
where mkAlloc sz 0 = ALLOC_AP sz
in do
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
- returnBc (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
+ return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
schemeE d s p (AnnCast (_, body) _)
= schemeE d s p body
--- XXX - audreyt - After FC landed, this case of explicit eta-reduction
--- seems needed to make "data D = D deriving Typeable" work in GHCi.
--- however, how did AnnLam with a var (LocalId) survive until this place?
-schemeE d s p (AnnLam var (_, AnnApp (_, body) (_, AnnVar inner)))
- | var == inner
- = schemeE d s p body
-
schemeE d s p other
= pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' other))
-- Case 0
| Just (arg, constr_names) <- maybe_is_tagToEnum_call
- = pushAtom d p arg `thenBc` \ (push, arg_words) ->
- implement_tagToId constr_names `thenBc` \ tagToId_sequence ->
- returnBc (push `appOL` tagToId_sequence
- `appOL` mkSLIDE 1 (d+arg_words-s)
- `snocOL` ENTER)
+ = do (push, arg_words) <- pushAtom d p arg
+ tagToId_sequence <- implement_tagToId constr_names
+ return (push `appOL` tagToId_sequence
+ `appOL` mkSLIDE 1 (d+arg_words-s)
+ `snocOL` ENTER)
-- Case 1
| Just (CCall ccall_spec) <- isFCallId_maybe fn
-- Case 3: Ordinary data constructor
| Just con <- maybe_saturated_dcon
- = mkConAppCode d s p con args_r_to_l `thenBc` \ alloc_con ->
- returnBc (alloc_con `appOL`
- mkSLIDE 1 (d - s) `snocOL`
- ENTER)
+ = do alloc_con <- mkConAppCode d s p con args_r_to_l
+ return (alloc_con `appOL`
+ mkSLIDE 1 (d - s) `snocOL`
+ ENTER)
-- Case 4: Tail call of function
| otherwise
mkConAppCode orig_d s p con [] -- Nullary constructor
= ASSERT( isNullaryRepDataCon con )
- returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
+ return (unitOL (PUSH_G (getName (dataConWorkId con))))
-- Instead of doing a PACK, which would allocate a fresh
-- copy of this constructor, use the single shared version.
(ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
do_pushery d (arg:args)
- = pushAtom d p arg `thenBc` \ (push, arg_words) ->
- do_pushery (d+arg_words) args `thenBc` \ more_push_code ->
- returnBc (push `appOL` more_push_code)
+ = do (push, arg_words) <- pushAtom d p arg
+ more_push_code <- do_pushery (d+arg_words) args
+ return (push `appOL` more_push_code)
do_pushery d []
- = returnBc (unitOL (PACK con n_arg_words))
+ = return (unitOL (PACK con n_arg_words))
where
n_arg_words = d - orig_d
-> AnnExpr' Id VarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = do
(push, sz) <- pushAtom d p arg
- returnBc (push `appOL`
+ return (push `appOL`
mkSLIDE sz (d-s) `snocOL`
RETURN_UBX (atomRep arg))
ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
ASSERT( sz == 1 ) return ()
- returnBc (push_fn `appOL` (
+ return (push_fn `appOL` (
mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
unitOL ENTER))
do_pushes d args reps = do
(next_d, push_code) <- push_seq d these_args
instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
-- ^^^ for the PUSH_APPLY_ instruction
- returnBc (push_code `appOL` (push_apply `consOL` instrs))
+ return (push_code `appOL` (push_apply `consOL` instrs))
push_seq d [] = return (d, nilOL)
push_seq d (arg:args) = do
-- given an alt, return a discr and code for it.
codeALt alt@(DEFAULT, _, (_,rhs))
- = schemeE d_alts s p_alts rhs `thenBc` \ rhs_code ->
- returnBc (NoDiscr, rhs_code)
+ = do rhs_code <- schemeE d_alts s p_alts rhs
+ return (NoDiscr, rhs_code)
codeAlt alt@(discr, bndrs, (_,rhs))
-- primitive or nullary constructor alt: no need to UNPACK
| null real_bndrs = do
rhs_code <- schemeE d_alts s p_alts rhs
- returnBc (my_discr alt, rhs_code)
+ return (my_discr alt, rhs_code)
-- algebraic alt with some binders
| ASSERT(isAlgCase) otherwise =
let
-- things that are pointers, whereas in CgBindery the code builds the
-- bitmap from the free slots and unboxed bindings.
-- (ToDo: merge?)
- bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots)
+ --
+ -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
+ -- The bitmap must cover the portion of the stack up to the sequel only.
+ -- Previously we were building a bitmap for the whole depth (d), but we
+ -- really want a bitmap up to depth (d-s). This affects compilation of
+ -- case-of-case expressions, which is the only time we can be compiling a
+ -- case expression with s /= 0.
+ bitmap_size = d-s
+ bitmap = intsToReverseBitmap bitmap_size{-size-}
+ (sortLe (<=) (filter (< bitmap_size) rel_slots))
where
binds = fmToList p
rel_slots = concat (map spread binds)
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
- 0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}
+ 0{-no arity-} bitmap_size bitmap True{-is alts-}
-- in
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
-- "\n bitmap = " ++ show bitmap) $ do
let push_alts
| isAlgCase = PUSH_ALTS alt_bco'
| otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
- returnBc (push_alts `consOL` scrut_code)
+ return (push_alts `consOL` scrut_code)
-- -----------------------------------------------------------------------------
-- depth to the first word of the bits for that arg, and the
-- CgRep of what was actually pushed.
- pargs d [] = returnBc []
+ pargs d [] = return []
pargs d (a:az)
= let arg_ty = repType (exprType (deAnnotate' a))
-- contains.
Just (t, _)
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
- -> pargs (d + addr_sizeW) az `thenBc` \ rest ->
- parg_ArrayishRep arrPtrsHdrSize d p a
- `thenBc` \ code ->
- returnBc ((code,NonPtrArg):rest)
+ -> do rest <- pargs (d + addr_sizeW) az
+ code <- parg_ArrayishRep arrPtrsHdrSize d p a
+ return ((code,NonPtrArg):rest)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
- -> pargs (d + addr_sizeW) az `thenBc` \ rest ->
- parg_ArrayishRep arrWordsHdrSize d p a
- `thenBc` \ code ->
- returnBc ((code,NonPtrArg):rest)
+ -> do rest <- pargs (d + addr_sizeW) az
+ code <- parg_ArrayishRep arrWordsHdrSize d p a
+ return ((code,NonPtrArg):rest)
-- Default case: push taggedly, but otherwise intact.
other
- -> pushAtom d p a `thenBc` \ (code_a, sz_a) ->
- pargs (d+sz_a) az `thenBc` \ rest ->
- returnBc ((code_a, atomRep a) : rest)
+ -> do (code_a, sz_a) <- pushAtom d p a
+ rest <- pargs (d+sz_a) az
+ return ((code_a, atomRep 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
-- point to the payload.
parg_ArrayishRep hdrSize d p a
- = pushAtom d p a `thenBc` \ (push_fo, _) ->
- -- The ptr points at the header. Advance it over the
- -- header and then pretend this is an Addr#.
- returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize)
+ = do (push_fo, _) <- pushAtom d p a
+ -- The ptr points at the header. Advance it over the
+ -- header and then pretend this is an Addr#.
+ return (push_fo `snocOL` SWIZZLE 0 hdrSize)
- in
- pargs d0 args_r_to_l `thenBc` \ code_n_reps ->
+ in do
+ code_n_reps <- pargs d0 args_r_to_l
let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
get_target_info
= case target of
DynamicTarget
- -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
+ -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
StaticTarget target
- -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
- returnBc (True, res)
- in
- get_target_info `thenBc` \ (is_static, static_target_addr) ->
+ -> do res <- ioToBc (lookupStaticPtr target)
+ return (True, res)
+ -- in
+ (is_static, static_target_addr) <- get_target_info
let
-- Get the arg reps, zapping the leading Addr# in the dynamic case
arg1_offW = r_sizeW + addr_sizeW
args_offW = map (arg1_offW +)
(init (scanl (+) 0 (map cgRepSizeW a_reps)))
- in
- ioToBc (mkMarshalCode cconv
- (r_offW, r_rep) addr_offW
- (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
- recordMallocBc addr_of_marshaller `thenBc_`
+ -- 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
-- Offset of the next stack frame down the stack. The CCALL
-- instruction needs to describe the chunk of stack containing
stk_offset = d_after_r - s
-- do the call
- do_call = unitOL (CCALL stk_offset (castPtr addr_of_marshaller))
+ 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
- in
+ --in
--trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $
- returnBc (
+ return (
push_args `appOL`
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
)
NonPtrArg -> MachWord 0
DoubleArg -> MachDouble 0
FloatArg -> MachFloat 0
+ LongArg -> MachWord64 0
_ -> moan64 "mkDummyLiteral" (ppr pr)
implement_tagToId :: [Name] -> BcM BCInstrList
implement_tagToId names
= ASSERT( notNull names )
- getLabelsBc (length names) `thenBc` \ labels ->
- getLabelBc `thenBc` \ label_fail ->
- getLabelBc `thenBc` \ label_exit ->
- zip4 labels (tail labels ++ [label_fail])
- [0 ..] names `bind` \ infos ->
- map (mkStep label_exit) infos `bind` \ steps ->
- returnBc (concatOL steps
- `appOL`
- toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
+ do labels <- getLabelsBc (length names)
+ label_fail <- getLabelBc
+ label_exit <- getLabelBc
+ let infos = zip4 labels (tail labels ++ [label_fail])
+ [0 ..] names
+ steps = map (mkStep label_exit) infos
+ return (concatOL steps
+ `appOL`
+ toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
where
mkStep l_exit (my_label, next_label, n, name_for_n)
= toOL [LABEL my_label,
pushAtom d p (AnnVar v)
| idCgRep v == VoidArg
- = returnBc (nilOL, 0)
+ = return (nilOL, 0)
| isFCallId v
= pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
| Just primop <- isPrimOpId_maybe v
- = returnBc (unitOL (PUSH_PRIMOP primop), 1)
+ = return (unitOL (PUSH_PRIMOP primop), 1)
| Just d_v <- lookupBCEnv_maybe p v -- v is a local variable
- = returnBc (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
+ = return (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
-- d - d_v the number of words between the TOS
-- and the 1st slot of the object
--
| otherwise -- v must be a global variable
= ASSERT(sz == 1)
- returnBc (unitOL (PUSH_G (getName v)), sz)
+ return (unitOL (PUSH_G (getName v)), sz)
where
sz = idSizeW v
where
code rep
= let size_host_words = cgRepSizeW rep
- in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
+ in return (unitOL (PUSH_UBX (Left lit) size_host_words),
size_host_words)
pushStr s
-- by virtue of the global FastString table, but
-- to be on the safe side we copy the string into
-- a malloc'd area of memory.
- ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
- recordMallocBc ptr `thenBc_`
- ioToBc (
- withForeignPtr fp $ \p -> do
- memcpy ptr p (fromIntegral n)
- pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
- return ptr
- )
- in
- getMallocvilleAddr `thenBc` \ addr ->
+ do ptr <- ioToBc (mallocBytes (n+1))
+ recordMallocBc ptr
+ ioToBc (
+ withForeignPtr fp $ \p -> do
+ memcpy ptr p (fromIntegral n)
+ pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
+ return ptr
+ )
+ in do
+ addr <- getMallocvilleAddr
-- Get the addr on the stack, untaggedly
- returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
+ return (unitOL (PUSH_UBX (Right addr) 1), 1)
+
+pushAtom d p (AnnCast e _)
+ = pushAtom d p (snd e)
pushAtom d p other
= pprPanic "ByteCodeGen.pushAtom"
(filter (not.isNoDiscr.fst) raw_ways)
mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
- mkTree [] range_lo range_hi = returnBc the_default
+ mkTree [] range_lo range_hi = return the_default
mkTree [val] range_lo range_hi
| range_lo `eqAlt` range_hi
- = returnBc (snd val)
+ = return (snd val)
| otherwise
- = getLabelBc `thenBc` \ label_neq ->
- returnBc (mkTestEQ (fst val) label_neq
- `consOL` (snd val
- `appOL` unitOL (LABEL label_neq)
- `appOL` the_default))
+ = do label_neq <- getLabelBc
+ return (mkTestEQ (fst val) label_neq
+ `consOL` (snd val
+ `appOL` unitOL (LABEL label_neq)
+ `appOL` the_default))
mkTree vals range_lo range_hi
= let n = length vals `div` 2
vals_lo = take n vals
vals_hi = drop n vals
v_mid = fst (head vals_hi)
- in
- getLabelBc `thenBc` \ label_geq ->
- mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
- mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
- returnBc (mkTestLT v_mid label_geq
+ in do
+ label_geq <- getLabelBc
+ code_lo <- mkTree vals_lo range_lo (dec v_mid)
+ code_hi <- mkTree vals_hi v_mid range_hi
+ return (mkTestLT v_mid label_geq
`consOL` (code_lo
`appOL` unitOL (LABEL label_geq)
`appOL` code_hi))
| otherwise = case splitApp f of
(f', as) -> (f', a:as)
splitApp (AnnNote n (_,e)) = splitApp e
+splitApp (AnnCast (_,e) _) = splitApp e
splitApp e = (e, [])
isVoidArgAtom :: AnnExpr' id ann -> Bool
isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg
isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e
+isVoidArgAtom (AnnCast (_,e) _) = isVoidArgAtom e
isVoidArgAtom _ = False
atomRep :: AnnExpr' Id ann -> CgRep
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)))
isPtrAtom :: AnnExpr' Id ann -> Bool
-- -----------------------------------------------------------------------------
-- The bytecode generator's monad
+type BcPtr = Either ItblPtr (Ptr ())
+
data BcM_State
= BcM_State {
nextlabel :: Int, -- for generating local labels
- malloced :: [Ptr ()] } -- ptrs malloced for current BCO
+ malloced :: [BcPtr] } -- thunks malloced for current BCO
-- Should be free()d when it is GCd
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
(>>) = thenBc_
return = returnBc
-emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
= BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
recordMallocBc :: Ptr a -> BcM ()
recordMallocBc a
- = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ())
+ = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
+
+recordItblMallocBc :: ItblPtr -> BcM ()
+recordItblMallocBc a
+ = BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
getLabelBc :: BcM Int
getLabelBc