ByteCodeGen: Generate bytecode from Core
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
import ByteCodeInstr
import ByteCodeItbls
-import ByteCodeFFI
import ByteCodeAsm
import ByteCodeLink
+import ByteCodeFFI
+import LibFFI
import Outputable
import Name
import Constants
import Data.List ( intersperse, sortBy, zip4, zip6, partition )
-import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
- withForeignPtr, castFunPtrToPtr )
-import Foreign.C ( CInt )
+import Foreign
+import Foreign.C
import Control.Exception ( throwDyn )
import GHC.Exts ( Int(..), ByteArray# )
import Control.Monad ( when )
import Data.Char ( ord, chr )
+import UniqSupply
+import BreakArray
+import Data.Maybe
+import Module
+import IdInfo
+
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
byteCodeGen :: DynFlags
-> [CoreBind]
-> [TyCon]
+ -> ModBreaks
-> IO CompiledByteCode
-byteCodeGen dflags binds tycs
+byteCodeGen dflags binds tycs modBreaks
= do showPass dflags "ByteCodeGen"
let flatBinds = [ (bndr, freeVars rhs)
| (bndr, rhs) <- flattenBinds binds]
- (BcM_State final_ctr mallocd, proto_bcos)
- <- runBc (mapM schemeTopBind flatBinds)
+ us <- mkSplitUniqSupply 'y'
+ (BcM_State _us final_ctr mallocd _, proto_bcos)
+ <- runBc us modBreaks (mapM schemeTopBind flatBinds)
when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
- (BcM_State final_ctr mallocd, proto_bco)
- <- runBc (schemeTopBind (invented_id, freeVars expr))
+ -- the uniques are needed to generate fresh variables when we introduce new
+ -- let bindings for ticked expressions
+ us <- mkSplitUniqSupply 'y'
+ (BcM_State _us final_ctr mallocd _ , proto_bco)
+ <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
when (notNull mallocd)
(panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
-> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
-> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
- is_ret mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
maybe_with_stack_check
- | is_ret = peep_d
- -- don't do stack checks at return points;
+ | is_ret && stack_usage < aP_STACK_SPLIM = peep_d
+ -- don't do stack checks at return points,
-- everything is aggregated up to the top BCO
- -- (which must be a function)
- | stack_overest >= iNTERP_STACK_CHECK_THRESH
- = STKCHECK stack_overest : peep_d
+ -- (which must be a function).
+ -- That is, unless the stack usage is >= AP_STACK_SPLIM,
+ -- see bug #1466.
+ | stack_usage >= iNTERP_STACK_CHECK_THRESH
+ = STKCHECK stack_usage : peep_d
| otherwise
= peep_d -- the supposedly common case
-- We assume that this sum doesn't wrap
- stack_overest = sum (map bciStackUse peep_d)
+ stack_usage = sum (map bciStackUse peep_d)
-- Merge local pushes
peep_d = peep (fromOL instrs_ordlist)
schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
-schemeTopBind (id, rhs)
+schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
- isNullaryRepDataCon data_con
- = -- Special case for the worker of a nullary data con.
+ isNullaryRepDataCon data_con = do
+ -- Special case for the worker of a nullary data con.
-- It'll look like this: Nil = /\a -> Nil a
-- If we feed it into schemeR, we'll get
-- Nil = Nil
-- because mkConAppCode treats nullary constructor applications
-- by just re-using the single top-level definition. So
-- for the worker itself, we must allocate it directly.
+ -- ioToBc (putStrLn $ "top level BCO")
emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
- (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
= schemeR [{- No free variables -}] (id, rhs)
+
-- -----------------------------------------------------------------------------
-- schemeR
-- top-level things, which have no free vars.
-> (Id, AnnExpr Id VarSet)
-> BcM (ProtoBCO Name)
-schemeR fvs (nm, rhs)
+schemeR fvs (nm, rhs)
{-
| trace (showSDoc (
(char ' '
-}
= schemeR_wrk fvs nm rhs (collect [] rhs)
+collect :: [Var] -> AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
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)
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
= let
all_args = reverse args ++ fvs
bitmap_size = length bits
bitmap = mkBitmap bits
in do
- body_code <- schemeE szw_args 0 p_init body
+ body_code <- schemeER_wrk szw_args p_init body
+
emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
arity bitmap_size bitmap False{-not alts-})
+-- introduce break instructions for ticked expressions
+schemeER_wrk :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeER_wrk d p rhs
+ | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
+ code <- schemeE d 0 p newRhs
+ arr <- getBreakArray
+ let idOffSets = getVarOffSets d p tickInfo
+ let tickNumber = tickInfo_number tickInfo
+ let breakInfo = BreakInfo
+ { breakInfo_module = tickInfo_module tickInfo
+ , breakInfo_number = tickNumber
+ , breakInfo_vars = idOffSets
+ , breakInfo_resty = exprType (deAnnotate' newRhs)
+ }
+ let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo
+ return $ breakInstr `consOL` code
+ | otherwise = schemeE d 0 p rhs
+
+getVarOffSets :: Int -> BCEnv -> TickInfo -> [(Id, Int)]
+getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
+
+getOffSet :: Int -> BCEnv -> Id -> Maybe (Id, Int)
+getOffSet d env id
+ = case lookupBCEnv_maybe env id of
+ Nothing -> Nothing
+ Just offset -> Just (id, d - offset)
fvsToEnv :: BCEnv -> VarSet -> [Id]
-- Takes the free variables of a right-hand side, and
-- -----------------------------------------------------------------------------
-- schemeE
+data TickInfo
+ = TickInfo
+ { tickInfo_number :: Int -- the (module) unique number of the tick
+ , tickInfo_module :: Module -- the origin of the ticked expression
+ , tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression
+ }
+
+instance Outputable TickInfo where
+ ppr info = text "TickInfo" <+>
+ parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
+ ppr (tickInfo_locals info))
+
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
return (push_code `appOL` more_push_code)
alloc_code = toOL (zipWith mkAlloc sizes arities)
- where mkAlloc sz 0 = ALLOC_AP sz
+ where mkAlloc sz 0
+ | is_tick = ALLOC_AP_NOUPD sz
+ | otherwise = ALLOC_AP sz
mkAlloc sz arity = ALLOC_PAP arity sz
+ is_tick = case binds of
+ AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
+ _other -> False
+
compile_bind d' fvs x rhs size arity off = do
bco <- schemeR fvs (x,rhs)
build_thunk d' fvs size bco off arity
thunk_codes <- sequence compile_binds
return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
-
+-- introduce a let binding for a ticked case expression. This rule
+-- *should* only fire when the expression was not already let-bound
+-- (the code gen for let bindings should take care of that). Todo: we
+-- call exprFreeVars on a deAnnotated expression, this may not be the
+-- best way to calculate the free vars but it seemed like the least
+-- intrusive thing to do
+schemeE d s p exp@(AnnCase {})
+ | Just (tickInfo,rhs) <- isTickedExp' exp
+ = if isUnLiftedType ty
+ then schemeE d s p (snd rhs)
+ else do
+ id <- newId ty
+ -- Todo: is emptyVarSet correct on the next line?
+ let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
+ schemeE d s p letExp
+ where exp' = deAnnotate' exp
+ fvs = exprFreeVars exp'
+ ty = exprType exp'
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
-- envt (it won't be bound now) because we never look such things up.
= --trace "automagic mashing of case alts (# VoidArg, a #)" $
- doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
= --trace "automagic mashing of case alts (# a, VoidArg #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
-- to
-- case .... of a { DEFAULT -> ... }
= --trace "automagic mashing of case alts (# a #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+ = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
schemeE d s p (AnnNote note (_, body))
= schemeE d s p body
= pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' other))
+{-
+ Ticked Expressions
+ ------------------
+
+ A ticked expression looks like this:
+
+ case tick<n> var1 ... varN of DEFAULT -> e
+
+ (*) <n> is the number of the tick, which is unique within a module
+ (*) var1 ... varN are the local variables in scope at the tick site
+
+ If we find a ticked expression we return:
+
+ Just ((n, [var1 ... varN]), e)
+
+ otherwise we return Nothing.
+
+ The idea is that the "case tick<n> ..." is really just an annotation on
+ the code. When we find such a thing, we pull out the useful information,
+ and then compile the code as if it was just the expression "e".
+
+-}
+
+isTickedExp :: AnnExpr Id a -> Maybe (TickInfo, AnnExpr Id a)
+isTickedExp (annot, expr) = isTickedExp' expr
+
+isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
+isTickedExp' (AnnCase scrut _bndr _type alts)
+ | Just tickInfo <- isTickedScrut scrut,
+ [(DEFAULT, _bndr, rhs)] <- alts
+ = Just (tickInfo, rhs)
+ where
+ isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
+ isTickedScrut expr
+ | Var id <- f,
+ Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
+ = Just $ TickInfo { tickInfo_number = tickNumber
+ , tickInfo_module = modName
+ , tickInfo_locals = idsOfArgs args
+ }
+ | otherwise = Nothing
+ where
+ (f, args) = collectArgs $ deAnnotate expr
+ idsOfArgs :: [Expr Id] -> [Id]
+ idsOfArgs = catMaybes . map exprId
+ exprId :: Expr Id -> Maybe Id
+ exprId (Var id) = Just id
+ exprId other = Nothing
+
+isTickedExp' other = Nothing
-- Compile code to do a tail call. Specifically, push the fn,
-- slide the on-stack app back down to the sequel depth,
-> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
-> Bool -- True <=> is an unboxed tuple case, don't enter the result
-> BcM BCInstrList
-doCase d s p (_,scrut)
- bndr alts is_unboxed_tuple
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
= let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
-- given an alt, return a discr and code for it.
- codeALt alt@(DEFAULT, _, (_,rhs))
+ codeAlt alt@(DEFAULT, _, (_,rhs))
= 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
where
real_bndrs = filter (not.isTyVar) bndrs
-
my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-}
my_discr (DataAlt dc, binds, rhs)
| isUnboxedTupleCon dc
in do
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
+
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
| 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
+ -- 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
+
+ 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
(pprCoreExpr (deAnnotate (undefined, other)))
foreign import ccall unsafe "memcpy"
- memcpy :: Ptr a -> Ptr b -> CInt -> IO ()
+ memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
-- -----------------------------------------------------------------------------
idSizeW :: Id -> Int
idSizeW id = cgRepSizeW (typeCgRep (idType id))
+-- See bug #1257
unboxedTupleException :: a
unboxedTupleException
= throwDyn
- (Panic
- ("Bytecode generator can't handle unboxed tuples. Possibly due\n" ++
- "\tto foreign import/export decls in source. Workaround:\n" ++
- "\tcompile this module to a .o file, then restart session."))
+ (ProgramError
+ ("Error: bytecode compiler can't handle unboxed tuples.\n"++
+ " Possibly due to foreign import/export decls in source.\n"++
+ " Workaround: use -fobject-code, or compile this module to .o separately."))
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
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
data BcM_State
= BcM_State {
+ uniqSupply :: UniqSupply, -- for generating fresh variable names
nextlabel :: Int, -- for generating local labels
- malloced :: [BcPtr] } -- thunks malloced for current BCO
+ malloced :: [BcPtr], -- thunks malloced for current BCO
-- Should be free()d when it is GCd
+ breakArray :: BreakArray -- array of breakpoint flags
+ }
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
x <- io
return (st, x)
-runBc :: BcM r -> IO (BcM_State, r)
-runBc (BcM m) = m (BcM_State 0 [])
+runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
+runBc us modBreaks (BcM m)
+ = m (BcM_State us 0 [] breakArray)
+ where
+ breakArray = modBreaks_flags modBreaks
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+
+getBreakArray :: BcM BreakArray
+getBreakArray = BcM $ \st -> return (st, breakArray st)
+
+newUnique :: BcM Unique
+newUnique = BcM $
+ \st -> case splitUniqSupply (uniqSupply st) of
+ (us1, us2) -> let newState = st { uniqSupply = us2 }
+ in return (newState, uniqFromSupply us1)
+
+newId :: Type -> BcM Id
+newId ty = do
+ uniq <- newUnique
+ return $ mkSysLocal tickFS uniq ty
+
+tickFS = FSLIT("ticked")
\end{code}
projects / ghc-hetmet.git / blobdiff