summaryrefslogtreecommitdiff
path: root/compiler/codeGen
diff options
context:
space:
mode:
authordias@eecs.harvard.edu <unknown>2008-10-13 13:25:56 +0000
committerdias@eecs.harvard.edu <unknown>2008-10-13 13:25:56 +0000
commite6243a818496aad82b6f47511d3bd9bc800f747d (patch)
treea955151d25ddca7966ba8d23192ef62a47d84acf /compiler/codeGen
parent176fa33f17dd78355cc572e006d2ab26898e2c69 (diff)
downloadhaskell-e6243a818496aad82b6f47511d3bd9bc800f747d.tar.gz
Big collection of patches for the new codegen branch.
o Fixed bug that emitted the copy-in code for closure entry in the wrong place -- at the initialization of the closure. o Refactored some of the closure entry code. o Added code to check that no LocalRegs are live-in to a procedure -- trip up some buggy programs earlier o Fixed environment bindings for thunks -- we weren't (re)binding the free variables in a thunk o Fixed a bug in proc-point splitting that dropped some updates to the entry block in a procedure. o Fixed improper calls to code that generates CmmLit's for strings o New invariant on cg_loc in CgIdInfo: the expression is always tagged o Code to load free vars on entry to a thunk was (wrongly) placed before the heap check. o Some of the StgCmm code was redundantly passing around Id's along with CgIdInfo's; no more. o Initialize the LocalReg's that point to a closure before allocating and initializing the closure itself -- otherwise, we have problems with recursive closure bindings o BlockEnv and BlockSet types are now abstract. o Update frames: - push arguments in Old call area - keep track of the return sp in the FCode monad - keep the return sp in every call, tail call, and return (because it might be different at different call sites, e.g. tail calls to the gc after a heap check are performed before pushing the update frame) - set the sp appropriately on returns and tail calls o Reduce call, tail call, and return to a single LastCall node o Added slow entry code, using different calling conventions on entry and tail call o More fixes to the calling convention code. The tricky stuff is all about the closure environment: it must be passed in R1, but in non-closures, there is no such argument, so we can't treat all arguments the same way: the closure environment is special. Maybe the right step forward would be to define a different calling convention for closure arguments. o Let-no-escapes need to be emitted out-of-line -- otherwise, we drop code. o Respect RTS requirement of word alignment for pointers My stack allocation can pack sub-word values into a single word on the stack, but it wasn't requiring word-alignment for pointers. It does now, by word-aligning both pointer registers and call areas. o CmmLint was over-aggresively ruling out non-word-aligned memory references, which may be kosher now that we can spill small values into a single word. o Wrong label order on a conditional branch when compiling switches. o void args weren't dropped in many cases. To help prevent this kind of mistake, I defined a NonVoid wrapper, which I'm applying only to Id's for now, although there are probably other good candidates. o A little code refactoring: separate modules for procpoint analysis splitting, stack layout, and building infotables. o Stack limit check: insert along with the heap limit check, using a symbolic constant (a special CmmLit), then replace it when the stack layout is known. o Removed last node: MidAddToContext o Adding block id as a literal: means that the lowering of the calling conventions no longer has to produce labels early, which was inhibiting common-block elimination. Will also make it easier for the non-procpoint-splitting path. o Info tables: don't try to describe the update frame! o Over aggressive use of NonVoid!!!! Don't drop the non-void args before setting the type of the closure!!! o Sanity checking: Added a pass to stub dead dead slots on the stack (only ~10 lines with the dataflow framework) o More sanity checking: Check that incoming pointer arguments are non-stubbed. Note: these checks are still subject to dead-code removal, but they should still be quite helpful. o Better sanity checking: why stop at function arguments? Instead, in mkAssign, check that _any_ assignment to a pointer type is non-null -- the sooner the crash, the easier it is to debug. Still need to add the debugging flag to turn these checks on explicitly. o Fixed yet another calling convention bug. This time, the calls to the GC were wrong. I've added a new convention for GC calls and invoked it where appropriate. We should really straighten out the calling convention stuff: some of the code (and documentation) is spread across the compiler, and there's some magical use of the node register that should really be handled (not avoided) by calling conventions. o Switch bug: the arms in mkCmmLitSwitch weren't returning to a single join point. o Environment shadowing problem in Stg->Cmm: When a closure f is bound at the top-level, we should not bind f to the node register on entry to the closure. Why? Because if the body of f contains a let-bound closure g that refers to f, we want to make sure that it refers to the static closure for f. Normally, this would all be fine, because when we compile a closure, we rebind free variables in the environment. But f doesn't look like a free variable because it's a static value. So, the binding for f remains in the environment when we compile g, inconveniently referring to the wrong thing. Now, I bind the variable in the local environment only if the closure is not bound at the top level. It's still okay to make assumptions about the node holding the closure environment; we just won't find the binding in the environment, so code that names the closure will now directly get the label of the static closure, not the node register holding a pointer to the static closure. o Don't generate bogus Cmm code containing SRTs during the STG -> Cmm pass! The tables made reference to some labels that don't exist when we compute and generate the tables in the back end. o Safe foreign calls need some special treatment (at least until we have the integrated codegen). In particular: o they need info tables o they are not procpoints -- the successor had better be in the same procedure o we cannot (yet) implement the calling conventions early, which means we have to carry the calling-conv info all the way to the end o We weren't following the old convention when registering a module. Now, we use update frames to push any new modules that have to be registered and enter the youngest one on the stack. We also use the update frame machinery to specify that the return should pop the return address off the stack. o At each safe foreign call, an infotable must be at the bottom of the stack, and the TSO->sp must point to it. o More problems with void args in a direct call to a function: We were checking the args (minus voids) to check whether the call was saturated, which caused problems when the function really wasn't saturated because it took an extra void argument. o Forgot to distinguish integer != from floating != during Stg->Cmm o Updating slotEnv and areaMap to include safe foreign calls The dataflow analyses that produce the slotEnv and areaMap give results for each basic block, but we also need the results for a safe foreign call, which is a middle node. After running the dataflow analysis, we have another pass that updates the results to includ any safe foreign calls. o Added a static flag for the debugging technique that inserts instructions to stub dead slots on the stack and crashes when a stubbed value is loaded into a pointer-typed LocalReg. o C back end expects to see return continuations before their call sites. Sorted the flowgraphs appropriately after splitting. o PrimOp calling conventions are special -- unlimited registers, no stack Yet another calling convention... o More void value problems: if the RHS of a case arm is a void-typed variable, don't try to return it. o When calling some primOp, they may allocate memory; if so, we need to do a heap check when we return from the call.
Diffstat (limited to 'compiler/codeGen')
-rw-r--r--compiler/codeGen/CgInfoTbls.hs6
-rw-r--r--compiler/codeGen/StgCmm.hs81
-rw-r--r--compiler/codeGen/StgCmmBind.hs320
-rw-r--r--compiler/codeGen/StgCmmClosure.hs71
-rw-r--r--compiler/codeGen/StgCmmCon.hs26
-rw-r--r--compiler/codeGen/StgCmmEnv.hs71
-rw-r--r--compiler/codeGen/StgCmmExpr.hs126
-rw-r--r--compiler/codeGen/StgCmmForeign.hs129
-rw-r--r--compiler/codeGen/StgCmmHeap.hs132
-rw-r--r--compiler/codeGen/StgCmmLayout.hs112
-rw-r--r--compiler/codeGen/StgCmmMonad.hs103
-rw-r--r--compiler/codeGen/StgCmmPrim.hs8
-rw-r--r--compiler/codeGen/StgCmmProf.hs5
-rw-r--r--compiler/codeGen/StgCmmUtils.hs42
14 files changed, 719 insertions, 513 deletions
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 9fbe4fb36d..9719d71dd2 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -94,12 +94,12 @@ mkCmmInfo cl_info = do
info = ConstrInfo (ptrs, nptrs)
(fromIntegral (dataConTagZ con))
conName
- return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
+ return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
ClosureInfo { closureName = name,
closureLFInfo = lf_info,
closureSRT = srt } ->
- return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
+ return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
where
info =
case lf_info of
@@ -152,7 +152,7 @@ emitReturnTarget name stmts
; let info = CmmInfo
gc_target
Nothing
- (CmmInfoTable
+ (CmmInfoTable False
(ProfilingInfo zeroCLit zeroCLit)
rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
(ContInfo frame srt_info))
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 56cd1d5555..0fc6c4c5a8 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -104,43 +104,25 @@ variable. -}
cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
cgTopBinding dflags (StgNonRec id rhs, _srts)
= do { id' <- maybeExternaliseId dflags id
- --; mapM_ (mkSRT [id']) srts
- ; (id,info) <- cgTopRhs id' rhs
- ; addBindC id info -- Add the *un-externalised* Id to the envt,
- -- so we find it when we look up occurrences
+ ; info <- cgTopRhs id' rhs
+ ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
+ -- so we find it when we look up occurrences
}
cgTopBinding dflags (StgRec pairs, _srts)
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
- --; mapM_ (mkSRT bndrs') srts
; fixC (\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; return () }
---mkSRT :: [Id] -> (Id,[Id]) -> FCode ()
---mkSRT these (id,ids)
--- | null ids = nopC
--- | otherwise
--- = do { ids <- mapFCs remap ids
--- ; id <- remap id
--- ; emitRODataLits (mkSRTLabel (idName id) (idCafInfo id))
--- (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
--- }
--- where
--- -- Sigh, better map all the ids against the environment in
--- -- case they've been externalised (see maybeExternaliseId below).
--- remap id = case filter (==id) these of
--- (id':_) -> returnFC id'
--- [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
-
-- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- statics "error" call in initC. I DON'T UNDERSTAND WHY!
-cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
-- The Id is passed along for setting up a binding...
-- It's already been externalised if necessary
@@ -153,7 +135,6 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
-
---------------------------------------------------------------
-- Module initialisation code
---------------------------------------------------------------
@@ -213,14 +194,17 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
-- In this way, Hpc enabled modules can interact seamlessly with
-- not Hpc enabled moduled, provided Main is compiled with Hpc.
- ; emitSimpleProc real_init_lbl $ withFreshLabel "ret_block" $ \retId -> catAGraphs
- [ check_already_done retId
+ ; updfr_sz <- getUpdFrameOff
+ ; tail <- getCode (pushUpdateFrame imports
+ (do updfr_sz' <- getUpdFrameOff
+ emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz')))
+ ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs
+ [ check_already_done retId updfr_sz
, init_prof
, init_hpc
- , catAGraphs $ map (registerImport way) all_imported_mods
- , mkBranch retId ]
+ , tail])
-- Make the "plain" procedure jump to the "real" init procedure
- ; emitSimpleProc plain_init_lbl jump_to_init
+ ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz)
-- When compiling the module in which the 'main' function lives,
-- (that is, this_mod == main_mod)
@@ -233,14 +217,14 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
; whenC (this_mod == main_mod)
- (emitSimpleProc plain_main_init_lbl rec_descent_init)
+ (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz))
}
where
plain_init_lbl = mkPlainModuleInitLabel this_mod
real_init_lbl = mkModuleInitLabel this_mod way
plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
- jump_to_init = mkJump (mkLblExpr real_init_lbl) []
+ jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz
-- Main refers to GHC.TopHandler.runIO, so make sure we call the
@@ -249,34 +233,30 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
| this_mod == main_mod = [gHC_TOP_HANDLER]
| otherwise = []
all_imported_mods = imported_mods ++ extra_imported_mods
+ imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way))
+ (filter (gHC_PRIM /=) all_imported_mods)
mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
- check_already_done retId
+ check_already_done retId updfr_sz
= mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
- (mkLabel retId Nothing <*> mkReturn []) mkNop
+ (mkLabel retId emptyStackInfo
+ <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
<*> -- Set mod_reg to 1 to record that we've been here
mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
-- The return-code pops the work stack by
- -- incrementing Sp, and then jumpd to the popped item
- ret_code = mkAssign spReg (cmmRegOffW spReg 1)
- <*> mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) []
-
- rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
- then jump_to_init
- else ret_code
-
------------------------
-registerImport :: String -> Module -> CmmAGraph
-registerImport way mod
- | mod == gHC_PRIM
- = mkNop
- | otherwise -- Push the init procedure onto the work stack
- = mkCmmCall init_lbl [] [] NoC_SRT
- where
- init_lbl = mkLblExpr $ mkModuleInitLabel mod way
+ -- incrementing Sp, and then jumps to the popped item
+ ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord
+ ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)
+ -- mkAssign spReg (cmmRegOffW spReg 1) <*>
+ -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz
+ pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord)
+ rec_descent_init updfr_sz =
+ if opt_SccProfilingOn || isHpcUsed hpc_info
+ then jump_to_init updfr_sz
+ else ret_code updfr_sz
---------------------------------------------------------------
-- Generating static stuff for algebraic data types
@@ -351,8 +331,7 @@ cgDataCon data_con
(dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
emit_info cl_info ticky_code
- = do { code_blks <- getCode (mk_code ticky_code)
- ; emitClosureCodeAndInfoTable cl_info [] code_blks }
+ = emitClosureAndInfoTable cl_info [] $ mk_code ticky_code
mk_code ticky_code
= -- NB: We don't set CC when entering data (WDP 94/06)
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 0e8d853969..04676787fe 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -9,11 +9,13 @@
module StgCmmBind (
cgTopRhsClosure,
cgBind,
- emitBlackHoleCode
+ emitBlackHoleCode,
+ pushUpdateFrame
) where
#include "HsVersions.h"
+import StgCmmExpr
import StgCmmMonad
import StgCmmExpr
import StgCmmEnv
@@ -35,6 +37,7 @@ import CLabel
import StgSyn
import CostCentre
import Id
+import Monad (foldM, liftM)
import Name
import Module
import ListSetOps
@@ -59,11 +62,11 @@ cgTopRhsClosure :: Id
-> StgBinderInfo
-> UpdateFlag
-> SRT
- -> [Id] -- Args
+ -> [Id] -- Args
-> StgExpr
- -> FCode (Id, CgIdInfo)
+ -> FCode CgIdInfo
-cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
+cgTopRhsClosure id ccs _ upd_flag srt args body = do
{ -- LAY OUT THE OBJECT
let name = idName id
; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
@@ -77,12 +80,15 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep
- ; forkClosureBody $ do
- { node <- bindToReg id lf_info
- ; closureCodeBody binder_info closure_info
- ccs srt_info node args body }
+ ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
+ (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
+ (addIdReps [])
+ -- Don't drop the non-void args until the closure info has been made
+ ; forkClosureBody (closureCodeBody True id closure_info ccs srt_info
+ (nonVoidIds args) (length args) body fv_details)
- ; returnFC (id, cg_id_info) }
+ ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $
+ returnFC cg_id_info }
------------------------------------------------------------------------
-- Non-top-level bindings
@@ -90,36 +96,77 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
cgBind :: StgBinding -> FCode ()
cgBind (StgNonRec name rhs)
- = do { (name, info) <- cgRhs name rhs
- ; addBindC name info }
+ = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
+ ; addBindC (cg_id info) info
+ ; emit (init <*> body) }
cgBind (StgRec pairs)
- = do { new_binds <- fixC (\ new_binds ->
- do { addBindsC new_binds
- ; listFCs [ cgRhs b e | (b,e) <- pairs ] })
- ; addBindsC new_binds }
+ = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
+ do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
+ ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
+ ; addBindsC new_binds
+ ; emit (catAGraphs inits <*> body) }
+
+{- Recursive let-bindings are tricky.
+ Consider the following pseudocode:
+ let x = \_ -> ... y ...
+ y = \_ -> ... z ...
+ z = \_ -> ... x ...
+ in ...
+ For each binding, we need to allocate a closure, and each closure must
+ capture the address of the other closures.
+ We want to generate the following C-- code:
+ // Initialization Code
+ x = hp - 24; // heap address of x's closure
+ y = hp - 40; // heap address of x's closure
+ z = hp - 64; // heap address of x's closure
+ // allocate and initialize x
+ m[hp-8] = ...
+ m[hp-16] = y // the closure for x captures y
+ m[hp-24] = x_info;
+ // allocate and initialize y
+ m[hp-32] = z; // the closure for y captures z
+ m[hp-40] = y_info;
+ // allocate and initialize z
+ ...
+
+ For each closure, we must generate not only the code to allocate and
+ initialize the closure itself, but also some Initialization Code that
+ sets a variable holding the closure pointer.
+ The complication here is that we don't know the heap offsets a priori,
+ which has two consequences:
+ 1. we need a fixpoint
+ 2. we can't trivially separate the Initialization Code from the
+ code that compiles the right-hand-sides
+
+ Note: We don't need this complication with let-no-escapes, because
+ in that case, the names are bound to labels in the environment,
+ and we don't need to emit any code to witness that binding.
+-}
--------------------
-cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
-- The Id is passed along so a binding can be set up
+ -- The returned values are the binding for the environment
+ -- and the Initialization Code that witnesses the binding
cgRhs name (StgRhsCon maybe_cc con args)
- = do { idinfo <- buildDynCon name maybe_cc con args
- ; return (name, idinfo) }
+ = buildDynCon name maybe_cc con args
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
- = mkRhsClosure name cc bi fvs upd_flag srt args body
+ = pprTrace "cgRhs closure" (ppr name <+> ppr args) $
+ mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
------------------------------------------------------------------------
-- Non-constructor right hand sides
------------------------------------------------------------------------
mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
- -> [Id] -- Free vars
+ -> [NonVoid Id] -- Free vars
-> UpdateFlag -> SRT
- -> [Id] -- Args
+ -> [Id] -- Args
-> StgExpr
- -> FCode (Id, CgIdInfo)
+ -> FCode (CgIdInfo, CmmAGraph)
{- mkRhsClosure looks for two special forms of the right-hand side:
a) selector thunks
@@ -158,7 +205,7 @@ for semi-obvious reasons.
---------- Note [Selectors] ------------------
mkRhsClosure bndr cc bi
- [the_fv] -- Just one free var
+ [NonVoid the_fv] -- Just one free var
upd_flag -- Updatable thunk
_srt
[] -- A thunk
@@ -184,7 +231,7 @@ mkRhsClosure bndr cc bi
(isUpdatable upd_flag)
(_, params_w_offsets) = layOutDynConstr con (addIdReps params)
-- Just want the layout
- maybe_offset = assocMaybe params_w_offsets selectee
+ maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
@@ -197,7 +244,7 @@ mkRhsClosure bndr cc bi
body@(StgApp fun_id args)
| args `lengthIs` (arity-1)
- && all isFollowableArg (map idCgRep fvs)
+ && all isFollowableArg (map (idCgRep . stripNV) fvs)
&& isUpdatable upd_flag
&& arity <= mAX_SPEC_AP_SIZE
@@ -211,19 +258,19 @@ mkRhsClosure bndr cc bi
arity = length fvs
---------- Default case ------------------
-mkRhsClosure bndr cc bi fvs upd_flag srt args body
+mkRhsClosure bndr cc _ fvs upd_flag srt args body
= do { -- LAY OUT THE OBJECT
-- If the binder is itself a free variable, then don't store
-- it in the closure. Instead, just bind it to Node on entry.
-- NB we can be sure that Node will point to it, because we
- -- havn't told mkClosureLFInfo about this; so if the binder
+ -- haven't told mkClosureLFInfo about this; so if the binder
-- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-- stored in the closure itself, so it will make sure that
-- Node points to it...
; let
is_elem = isIn "cgRhsClosure"
- bndr_is_a_fv = bndr `is_elem` fvs
- reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
+ bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
+ reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
| otherwise = fvs
@@ -233,43 +280,35 @@ mkRhsClosure bndr cc bi fvs upd_flag srt args body
; c_srt <- getSRTInfo srt
; let name = idName bndr
descr = closureDescription mod_name name
- fv_details :: [(Id, VirtualHpOffset)]
+ fv_details :: [(NonVoid Id, VirtualHpOffset)]
(tot_wds, ptr_wds, fv_details)
= mkVirtHeapOffsets (isLFThunk lf_info)
- (addIdReps reduced_fvs)
+ (addIdReps (map stripNV reduced_fvs))
closure_info = mkClosureInfo False -- Not static
bndr lf_info tot_wds ptr_wds
c_srt descr
-- BUILD ITS INFO TABLE AND CODE
- ; forkClosureBody $ do
- { -- Bind the binder itself
- -- It does no harm to have it in the envt even if
- -- it's not a free variable; and we need a reg for it
- node <- bindToReg bndr lf_info
-
- -- Bind the free variables
- ; mapCs (bind_fv node) fv_details
-
- -- And compile the body
- ; closureCodeBody bi closure_info cc c_srt node args body }
+ ; forkClosureBody $
+ -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
+ -- (b) ignore Sequel from context; use empty Sequel
+ -- And compile the body
+ closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args)
+ (length args) body fv_details
-- BUILD THE OBJECT
; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
; emit (mkComment $ mkFastString "calling allocDynClosure")
- ; tmp <- allocDynClosure closure_info use_cc blame_cc
- (mapFst StgVarArg fv_details)
+ ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
+ ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
+ (map toVarArg fv_details)
-- RETURN
- ; return (bndr, regIdInfo bndr lf_info tmp) }
- where
- -- A function closure pointer may be tagged, so we
- -- must take it into account when accessing the free variables.
- tag = tagForArity (length args)
+ ; return $ (regIdInfo bndr lf_info tmp, init) }
- bind_fv node (id, off)
- = do { reg <- rebindToReg id
- ; emit $ mkTaggedObjectLoad reg node off tag }
+-- Use with care; if used inappropriately, it could break invariants.
+stripNV :: NonVoid a -> a
+stripNV (NonVoid a) = a
-------------------------
cgStdThunk
@@ -279,7 +318,7 @@ cgStdThunk
-> StgExpr
-> LambdaFormInfo
-> [StgArg] -- payload
- -> FCode (Id, CgIdInfo)
+ -> FCode (CgIdInfo, CmmAGraph)
cgStdThunk bndr cc _bndr_info body lf_info payload
= do -- AHA! A STANDARD-FORM THUNK
@@ -297,35 +336,36 @@ cgStdThunk bndr cc _bndr_info body lf_info payload
; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
-- BUILD THE OBJECT
- ; tmp <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
+ ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
-- RETURN
- ; returnFC (bndr, regIdInfo bndr lf_info tmp) }
+ ; returnFC $ (regIdInfo bndr lf_info tmp, init) }
mkClosureLFInfo :: Id -- The binder
-> TopLevelFlag -- True of top level
- -> [Id] -- Free vars
+ -> [NonVoid Id] -- Free vars
-> UpdateFlag -- Update flag
- -> [Id] -- Args
+ -> [Id] -- Args
-> FCode LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args
- | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
+ | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
| otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
- ; return (mkLFReEntrant top fvs args arg_descr) }
+ ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
------------------------------------------------------------------------
-- The code for closures}
------------------------------------------------------------------------
-closureCodeBody :: StgBinderInfo -- XXX: unused?
+closureCodeBody :: Bool -- whether this is a top-level binding
+ -> Id -- the closure's name
-> ClosureInfo -- Lots of information about this closure
-> CostCentreStack -- Optional cost centre attached to closure
-> C_SRT
- -> LocalReg -- The closure itself; first argument
- -- The Id is in scope already, bound to this reg
- -> [Id]
+ -> [NonVoid Id] -- incoming args to the closure
+ -> Int -- arity, including void args
-> StgExpr
+ -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables
-> FCode ()
{- There are two main cases for the code for closures.
@@ -341,41 +381,50 @@ closureCodeBody :: StgBinderInfo -- XXX: unused?
argSatisfactionCheck (by calling fetchAndReschedule).
There info if Node points to closure is available. -- HWL -}
-closureCodeBody _binder_info cl_info cc srt node args body
- | null args -- No args i.e. thunk
- = do { code <- getCode $ thunkCode cl_info cc srt node body
- ; emitClosureCodeAndInfoTable cl_info [node] code }
+closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
+ | length args == 0 -- No args i.e. thunk
+ = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
+ (\ (node, _) -> thunkCode cl_info fv_details cc srt node arity body)
-closureCodeBody _binder_info cl_info cc srt node args body
+closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
= ASSERT( length args > 0 )
do { -- Allocate the global ticky counter,
-- and establish the ticky-counter
-- label for this block
let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
- ; emitTickyCounter cl_info args
+ ; emitTickyCounter cl_info (map stripNV args)
; setTickyCtrLabel ticky_ctr_lbl $ do
--- -- XXX: no slow-entry code for now
--- -- Emit the slow-entry code
--- { reg_save_code <- mkSlowEntryCode cl_info reg_args
-
-- Emit the main entry code
- ; let node_points = nodeMustPointToIt (closureLFInfo cl_info)
- ; arg_regs <- bindArgsToRegs args
- ; blks <- forkProc $ getCode $ do
- { enterCostCentre cl_info cc body
+ ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
+ -- Emit the slow-entry code (for entering a closure through a PAP)
+ { mkSlowEntryCode cl_info arg_regs
+
+ ; let lf_info = closureLFInfo cl_info
+ node_points = nodeMustPointToIt lf_info
; tickyEnterFun cl_info
; whenC node_points (ldvEnterClosure cl_info)
; granYield arg_regs node_points
-- Main payload
- ; entryHeapCheck node arg_regs srt $
- cgExpr body }
+ ; entryHeapCheck node arity arg_regs srt $ do
+ { enterCostCentre cl_info cc body
+ ; fv_bindings <- mapM bind_fv fv_details
+ ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
+ ; cgExpr body }} -- heap check, to reduce live vars over check
- ; emitClosureCodeAndInfoTable cl_info (node:arg_regs) blks
}
-{-
+-- A function closure pointer may be tagged, so we
+-- must take it into account when accessing the free variables.
+bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
+
+load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
+load_fvs node lf_info = mapCs (\ (reg, off) ->
+ pprTrace "get tag for" (ppr reg <+> ppr tag) $ emit $ mkTaggedObjectLoad reg node off tag)
+ where tag = lfDynTag lf_info
+
-----------------------------------------
-- The "slow entry" code for a function. This entry point takes its
-- arguments on the stack. It loads the arguments into registers
@@ -383,76 +432,53 @@ closureCodeBody _binder_info cl_info cc srt node args body
-- normal entry point. The function's closure is assumed to be in
-- R1/node.
--
--- The slow entry point is used in two places:
---
--- (a) unknown calls: eg. stg_PAP_entry
--- (b) returning from a heap-check failure
+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry
-mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
+mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
-- If this function doesn't have a specialised ArgDescr, we need
--- to generate the function's arg bitmap, slow-entry code, and
--- register-save code for the heap-check failure
--- Here, we emit the slow-entry code, and
--- return the register-save assignments
-mkSlowEntryCode cl_info reg_args
+-- to generate the function's arg bitmap and slow-entry code.
+-- Here, we emit the slow-entry code.
+mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node'
| Just (_, ArgGen _) <- closureFunInfo cl_info
- = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
- ; return save_stmts }
- | otherwise = return noStmts
+ = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl
+ arg_regs jump
+ | otherwise = return ()
where
- name = closureName cl_info
- slow_lbl = mkSlowEntryLabel name
-
- load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
- save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
-
- reps_w_regs :: [(CgRep,GlobalReg)]
- reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
- (final_stk_offset, stk_offsets)
- = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
- 0 reps_w_regs
-
- load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
- mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
- (CmmLoad (cmmRegOffW spReg offset)
- (argMachRep rep))
-
- save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
- mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegType reg )
- CmmStore (cmmRegOffW spReg offset)
- (CmmReg (CmmGlobal reg))
-
- stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
- stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
- jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
--}
+ caf_refs = clHasCafRefs cl_info
+ name = closureName cl_info
+ slow_lbl = mkSlowEntryLabel name caf_refs
+ fast_lbl = enterLocalIdLabel name caf_refs
+ jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
+ initUpdFrameOff
+mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
-----------------------------------------
-thunkCode :: ClosureInfo -> CostCentreStack -> C_SRT -> LocalReg -> StgExpr -> FCode ()
-thunkCode cl_info cc srt node body
+thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
+ C_SRT -> LocalReg -> Int -> StgExpr -> FCode ()
+thunkCode cl_info fv_details cc srt node arity body
= do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
-
; tickyEnterThunk cl_info
; ldvEnterClosure cl_info -- NB: Node always points when profiling
; granThunk node_points
-- Heap overflow check
- ; entryHeapCheck node [] srt $ do
+ ; entryHeapCheck node arity [] srt $ do
{ -- Overwrite with black hole if necessary
-- but *after* the heap-overflow check
whenC (blackHoleOnEntry cl_info && node_points)
(blackHoleIt cl_info)
-- Push update frame
- ; setupUpdate cl_info node
-
+ ; setupUpdate cl_info node $
-- We only enter cc after setting up update so
-- that cc of enclosing scope will be recorded
-- in update frame CAF/DICT functions will be
-- subsumed by this enclosing cc
- ; enterCostCentre cl_info cc body
-
- ; cgExpr body } }
+ do { enterCostCentre cl_info cc body
+ ; let lf_info = closureLFInfo cl_info
+ ; fv_bindings <- mapM bind_fv fv_details
+ ; load_fvs node lf_info fv_bindings
+ ; cgExpr body }}}
------------------------------------------------------------------------
@@ -491,18 +517,20 @@ emitBlackHoleCode is_single_entry
eager_blackholing = False
-setupUpdate :: ClosureInfo -> LocalReg -> FCode ()
+setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
-- extracted by a subsequent enterCostCentre
-setupUpdate closure_info node
+setupUpdate closure_info node body
| closureReEntrant closure_info
- = return ()
+ = body
| not (isStaticClosure closure_info)
= if closureUpdReqd closure_info
- then do { tickyPushUpdateFrame; pushUpdateFrame node }
- else tickyUpdateFrameOmitted
+ then do { tickyPushUpdateFrame;
+ ; pushUpdateFrame [CmmReg (CmmLocal node),
+ mkLblExpr mkUpdInfoLabel] body }
+ else do { tickyUpdateFrameOmitted; body}
| otherwise -- A static closure
= do { tickyUpdateBhCaf closure_info
@@ -510,14 +538,23 @@ setupUpdate closure_info node
; if closureUpdReqd closure_info
then do -- Blackhole the (updatable) CAF:
{ upd_closure <- link_caf closure_info True
- ; pushUpdateFrame upd_closure }
- else tickyUpdateFrameOmitted
+ ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
+ mkLblExpr mkUpdInfoLabel] body }
+ else do {tickyUpdateFrameOmitted; body}
}
-pushUpdateFrame :: LocalReg -> FCode ()
-pushUpdateFrame cl_reg
- = emit (mkAddToContext (mkLblExpr mkUpdInfoLabel)
- [CmmReg (CmmLocal cl_reg)])
+-- Push the update frame on the stack in the Entry area,
+-- leaving room for the return address that is already
+-- at the old end of the area.
+pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
+pushUpdateFrame es body
+ = do updfr <- getUpdFrameOff
+ offset <- foldM push updfr es
+ withUpdFrameOff offset body
+ where push off e =
+ do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
+ return base
+ where base = off + widthInBytes (cmmExprWidth e)
-----------------------------------------------------------------------------
-- Entering a CAF
@@ -565,7 +602,8 @@ link_caf cl_info is_upd = do
{ -- Alloc black hole specifying CC_HDR(Node) as the cost centre
; let use_cc = costCentreFrom (CmmReg nodeReg)
blame_cc = use_cc
- ; hp_rel <- allocDynClosure bh_cl_info use_cc blame_cc []
+ ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc []
+ ; emit init
-- Call the RTS function newCAF to add the CAF to the CafList
-- so that the garbage collector can find them
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index c32d7cd857..b4251636b9 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -73,7 +73,7 @@ import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..))
import StgSyn
import SMRep
-import Cmm ( ClosureTypeInfo(..) )
+import Cmm ( ClosureTypeInfo(..), ConstrDescription )
import CmmExpr
import CLabel
@@ -236,7 +236,7 @@ mkLFLetNoEscape = LFLetNoEscape
-------------
mkLFReEntrant :: TopLevelFlag -- True of top level
- -> [Id] -- Free vars
+ -> [Id] -- Free vars
-> [Id] -- Args
-> ArgDescr -- Argument descriptor
-> LambdaFormInfo
@@ -335,8 +335,10 @@ tagForArity arity | isSmallFamily arity = arity
| otherwise = 0
lfDynTag :: LambdaFormInfo -> DynTag
-lfDynTag (LFCon con) = tagForCon con
-lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
+-- Return the tag in the low order bits of a variable bound
+-- to this LambdaForm
+lfDynTag (LFCon con) = pprTrace "tagForCon" (ppr con <+> ppr (tagForCon con)) $ tagForCon con
+lfDynTag (LFReEntrant _ arity _ _) = pprTrace "reentrant" (ppr arity) $ tagForArity arity
lfDynTag _other = 0
@@ -506,7 +508,8 @@ getCallMethod name caf (LFReEntrant _ arity _ _) n_args
| n_args == 0 = ASSERT( arity /= 0 )
ReturnIt -- No args at all
| n_args < arity = SlowCall -- Not enough args
- | otherwise = DirectEntry (enterIdLabel name caf) arity
+ | otherwise = pprTrace "getCallMethod" (ppr name <+> ppr arity) $
+ DirectEntry (enterIdLabel name caf) arity
getCallMethod _name _ LFUnLifted n_args
= ASSERT( n_args == 0 ) ReturnIt
@@ -675,7 +678,8 @@ data ClosureInfo
closureSMRep :: !SMRep, -- representation used by storage mgr
closureSRT :: !C_SRT, -- What SRT applies to this closure
closureType :: !Type, -- Type of closure (ToDo: remove)
- closureDescr :: !String -- closure description (for profiling)
+ closureDescr :: !String, -- closure description (for profiling)
+ closureCafs :: !CafInfo -- whether the closure may have CAFs
}
-- Constructor closures don't have a unique info table label (they use
@@ -720,7 +724,8 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
closureSMRep = sm_rep,
closureSRT = srt_info,
closureType = idType id,
- closureDescr = descr }
+ closureDescr = descr,
+ closureCafs = idCafInfo id }
where
name = idName id
sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
@@ -743,39 +748,49 @@ mkConInfo is_static data_con tot_wds ptr_wds
cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
- closureType = ty })
+ closureType = ty,
+ closureCafs = cafs })
= ClosureInfo { closureName = nm,
closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
closureSMRep = BlackHoleRep,
closureSRT = NoC_SRT,
closureType = ty,
- closureDescr = "" }
+ closureDescr = "",
+ closureCafs = cafs }
cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
seCafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
- closureType = ty })
+ closureType = ty,
+ closureCafs = cafs })
= ClosureInfo { closureName = nm,
closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
closureSMRep = BlackHoleRep,
closureSRT = NoC_SRT,
closureType = ty,
- closureDescr = "" }
+ closureDescr = "",
+ closureCafs = cafs }
seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
--------------------------------------
-- Extracting ClosureTypeInfo
--------------------------------------
-closureTypeInfo :: ClosureInfo -> ClosureTypeInfo
-closureTypeInfo cl_info
+-- JD: I've added the continuation arguments not for fun but because
+-- I don't want to pipe the monad in here (circular module dependencies),
+-- and I don't want to pull this code out of this module, which would
+-- require us to expose a bunch of abstract types.
+
+closureTypeInfo ::
+ ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) ->
+ (ClosureTypeInfo -> a) -> a
+closureTypeInfo cl_info k_with_con_name k_simple
= case cl_info of
ConInfo { closureCon = con }
- -> ConstrInfo (ptrs, nptrs)
- (fromIntegral (dataConTagZ con))
- con_name
+ -> k_with_con_name (ConstrInfo (ptrs, nptrs)
+ (fromIntegral (dataConTagZ con))) con info_lbl
where
- con_name = panic "closureTypeInfo"
+ --con_name = panic "closureTypeInfo"
-- Was:
-- cstr <- mkByteStringCLit $ dataConIdentity con
-- con_name = makeRelativeRefTo info_lbl cstr
@@ -783,23 +798,23 @@ closureTypeInfo cl_info
ClosureInfo { closureName = name,
closureLFInfo = LFReEntrant _ arity _ arg_descr,
closureSRT = srt }
- -> FunInfo (ptrs, nptrs)
- srt
- (fromIntegral arity)
- arg_descr
- (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
+ -> k_simple $ FunInfo (ptrs, nptrs)
+ srt
+ (fromIntegral arity)
+ arg_descr
+ (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _,
closureSRT = srt }
- -> ThunkSelectorInfo (fromIntegral offset) srt
+ -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt
ClosureInfo { closureLFInfo = LFThunk {},
closureSRT = srt }
- -> ThunkInfo (ptrs, nptrs) srt
+ -> k_simple $ ThunkInfo (ptrs, nptrs) srt
_ -> panic "unexpected lambda form in mkCmmInfo"
where
--- info_lbl = infoTableLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info
ptrs = fromIntegral $ closurePtrsSize cl_info
size = fromIntegral $ closureNonHdrSize cl_info
nptrs = size - ptrs
@@ -1092,9 +1107,7 @@ getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk?
-- SRTs/CAFs
--------------------------------------
--- This is horrible, but we need to know whether a closure may have CAFs.
+-- We need to know whether a closure may have CAFs.
clHasCafRefs :: ClosureInfo -> CafInfo
-clHasCafRefs (ClosureInfo {closureSRT = srt}) =
- case srt of NoC_SRT -> NoCafRefs
- _ -> MayHaveCafRefs
+clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs
clHasCafRefs (ConInfo {}) = NoCafRefs
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index de1d77ad20..e818bd742c 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -27,6 +27,7 @@ import StgCmmProf
import Cmm
import CLabel
+import MkZipCfgCmm (CmmAGraph, mkNop)
import SMRep
import CostCentre
import Constants
@@ -47,7 +48,7 @@ import Char ( ord )
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
-> [StgArg] -- Args
- -> FCode (Id, CgIdInfo)
+ -> FCode CgIdInfo
cgTopRhsCon id con args
= do {
#if mingw32_TARGET_OS
@@ -67,7 +68,7 @@ cgTopRhsCon id con args
= layOutStaticConstr con (addArgReps args)
get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
- ; return lit }
+ ; return lit }
; payload <- mapM get_lit nv_args_w_offsets
-- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
@@ -83,7 +84,7 @@ cgTopRhsCon id con args
; emitDataLits closure_label closure_rep
-- RETURN
- ; return (id, litIdInfo id lf_info (CmmLabel closure_label)) }
+ ; return $ litIdInfo id lf_info (CmmLabel closure_label) }
---------------------------------------------------------------
@@ -96,7 +97,8 @@ buildDynCon :: Id -- Name of the thing to which this constr will
-- current CCS if currentOrSubsumedCCS
-> DataCon -- The data constructor
-> [StgArg] -- Its args
- -> FCode CgIdInfo -- Return details about how to find it
+ -> FCode (CgIdInfo, CmmAGraph)
+ -- Return details about how to find it and initialization code
{- We used to pass a boolean indicating whether all the
args were of size zero, so we could use a static
@@ -121,7 +123,8 @@ premature looking at the args will cause the compiler to black-hole!
buildDynCon binder _cc con []
= return (litIdInfo binder (mkConLFInfo con)
- (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))))
+ (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
+ mkNop)
-------- buildDynCon: Charlike and Intlike constructors -----------
{- The following three paragraphs about @Char@-like and @Int@-like
@@ -155,7 +158,7 @@ buildDynCon binder _cc con [arg]
offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
-- INTLIKE closures consist of a header and one word payload
intlike_amode = cmmLabelOffW intlike_lbl offsetW
- ; return (litIdInfo binder (mkConLFInfo con) intlike_amode) }
+ ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) }
buildDynCon binder _cc con [arg]
| maybeCharLikeCon con
@@ -167,14 +170,14 @@ buildDynCon binder _cc con [arg]
offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
-- CHARLIKE closures consist of a header and one word payload
charlike_amode = cmmLabelOffW charlike_lbl offsetW
- ; return (litIdInfo binder (mkConLFInfo con) charlike_amode) }
+ ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
-------- buildDynCon: the general case -----------
buildDynCon binder ccs con args
= do { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args)
-- No void args in args_w_offsets
- ; tmp <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
- ; return (regIdInfo binder lf_info tmp) }
+ ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
+ ; return (regIdInfo binder lf_info tmp, init) }
where
lf_info = mkConLFInfo con
@@ -204,10 +207,11 @@ bindConArgs (DataAlt con) base args
-- The binding below forces the masking out of the tag bits
-- when accessing the constructor field.
- bind_arg :: (Id, VirtualHpOffset) -> FCode LocalReg
+ bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
bind_arg (arg, offset)
= do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag
- ; bindArgToReg arg }
+ ; pprTrace "bind_arg gets tag" (ppr arg <+> ppr tag) $
+ bindArgToReg arg }
bindConArgs _other_con _base args
= ASSERT( null args ) return []
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index c43bf80174..67d82f08cd 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -14,6 +14,8 @@ module StgCmmEnv (
litIdInfo, lneIdInfo, regIdInfo,
idInfoToAmode,
+ NonVoid(..), isVoidId, nonVoidIds,
+
addBindC, addBindsC,
bindArgsToRegs, bindToReg, rebindToReg,
@@ -25,6 +27,7 @@ module StgCmmEnv (
#include "HsVersions.h"
+import TyCon
import StgCmmMonad
import StgCmmUtils
import StgCmmClosure
@@ -39,11 +42,28 @@ import PprCmm ( {- instance Outputable -} )
import Id
import VarEnv
import Maybes
+import Monad
import Name
import StgSyn
import Outputable
+-------------------------------------
+-- Non-void types
+-------------------------------------
+-- We frequently need the invariant that an Id or a an argument
+-- is of a non-void type. This type is a witness to the invariant.
+
+newtype NonVoid a = NonVoid a
+ deriving (Eq, Show)
+
+instance (Outputable a) => Outputable (NonVoid a) where
+ ppr (NonVoid a) = ppr a
+
+isVoidId :: Id -> Bool
+isVoidId = isVoidRep . idPrimRep
+nonVoidIds :: [Id] -> [NonVoid Id]
+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
-------------------------------------
-- Manipulating CgIdInfo
@@ -65,15 +85,16 @@ lneIdInfo id regs
blk_id = mkBlockId (idUnique id)
litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
-litIdInfo id lf_info lit = mkCgIdInfo id lf_info (CmmLit lit)
+litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit)
+ mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info))
regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo
-regIdInfo id lf_info reg = mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))
+regIdInfo id lf_info reg =
+ mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
idInfoToAmode :: CgIdInfo -> CmmExpr
-- Returns a CmmExpr for the *tagged* pointer
-idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e, cg_tag = tag })
- = addDynTag e tag
+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
idInfoToAmode cg_info
= pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
@@ -105,10 +126,10 @@ addBindC name stuff_to_bind = do
binds <- getBinds
setBinds $ extendVarEnv binds name stuff_to_bind
-addBindsC :: [(Id, CgIdInfo)] -> FCode ()
+addBindsC :: [CgIdInfo] -> FCode ()
addBindsC new_bindings = do
binds <- getBinds
- let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
+ let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
binds
new_bindings
setBinds new_binds
@@ -155,10 +176,11 @@ cgLookupPanic id
--------------------
-getArgAmode :: StgArg -> FCode CmmExpr
-getArgAmode (StgVarArg var) = do { info <- getCgIdInfo var; return (idInfoToAmode info) }
-getArgAmode (StgLitArg lit) = return (CmmLit (mkSimpleLit lit))
-getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
+getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+getArgAmode (NonVoid (StgVarArg var)) =
+ do { info <- getCgIdInfo var; return (idInfoToAmode info) }
+getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
+getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg"
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- NB: Filters out void args,
@@ -166,7 +188,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [] = return []
getNonVoidArgAmodes (arg:args)
| isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
- | otherwise = do { amode <- getArgAmode arg
+ | otherwise = do { amode <- getArgAmode (NonVoid arg)
; amodes <- getNonVoidArgAmodes args
; return ( amode : amodes ) }
@@ -175,27 +197,27 @@ getNonVoidArgAmodes (arg:args)
-- Interface functions for binding and re-binding names
------------------------------------------------------------------------
-bindToReg :: Id -> LambdaFormInfo -> FCode LocalReg
+bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
-- Bind an Id to a fresh LocalReg
-bindToReg id lf_info
- = do { let reg = idToReg id
- ; addBindC id (regIdInfo id lf_info reg)
+bindToReg nvid@(NonVoid id) lf_info
+ = do { let reg = idToReg nvid
+ ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
; return reg }
-rebindToReg :: Id -> FCode LocalReg
+rebindToReg :: NonVoid Id -> FCode LocalReg
-- Like bindToReg, but the Id is already in scope, so
-- get its LF info from the envt
-rebindToReg id
+rebindToReg nvid@(NonVoid id)
= do { info <- getCgIdInfo id
- ; bindToReg id (cgIdInfoLF info) }
+ ; bindToReg nvid (cgIdInfoLF info) }
-bindArgToReg :: Id -> FCode LocalReg
-bindArgToReg id = bindToReg id (mkLFArgument id)
+bindArgToReg :: NonVoid Id -> FCode LocalReg
+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
-bindArgsToRegs :: [Id] -> FCode [LocalReg]
+bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs args = mapM bindArgToReg args
-idToReg :: Id -> LocalReg
+idToReg :: NonVoid Id -> LocalReg
-- Make a register from an Id, typically a function argument,
-- free variable, or case binder
--
@@ -203,7 +225,8 @@ idToReg :: Id -> LocalReg
--
-- By now the Ids should be uniquely named; else one would worry
-- about accidental collision
-idToReg id = LocalReg (idUnique id)
- (primRepCmmType (idPrimRep id))
+idToReg (NonVoid id) = LocalReg (idUnique id)
+ (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
+ _ -> primRepCmmType (idPrimRep id))
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 74c69b7216..379f1cde37 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -33,7 +33,9 @@ import Cmm()
import CmmExpr
import CoreSyn
import DataCon
+import ForeignCall
import Id
+import PrimOp
import TyCon
import CostCentre ( CostCentreStack, currentCCS )
import Maybes
@@ -50,16 +52,16 @@ cgExpr :: StgExpr -> FCode ()
cgExpr (StgApp fun args) = cgIdApp fun args
cgExpr (StgOpApp op args ty) = cgOpApp op args ty
cgExpr (StgConApp con args) = cgConApp con args
-
cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr }
cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr }
-cgExpr (StgLit lit) = emitReturn [CmmLit (mkSimpleLit lit)]
+cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
+ emitReturn [CmmLit cmm_lit]
-cgExpr (StgLet binds expr) = do { emit (mkComment $ mkFastString "calling cgBind"); cgBind binds; emit (mkComment $ mkFastString "calling cgExpr"); cgExpr expr }
+cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr }
-cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts)
- = cgCase expr bndr srt alt_type alts
+cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
+ cgCase expr bndr srt alt_type alts
cgExpr (StgLam {}) = panic "cgExpr: StgLam"
@@ -68,7 +70,7 @@ cgExpr (StgLam {}) = panic "cgExpr: StgLam"
------------------------------------------------------------------------
{- Generating code for a let-no-escape binding, aka join point is very
-very similar to whatwe do for a case expression. The duality is
+very similar to what we do for a case expression. The duality is
between
let-no-escape x = b
in e
@@ -86,8 +88,8 @@ cgLneBinds :: StgBinding -> FCode ()
cgLneBinds (StgNonRec bndr rhs)
= do { local_cc <- saveCurrentCostCentre
-- See Note [Saving the current cost centre]
- ; (bndr,info) <- cgLetNoEscapeRhs local_cc bndr rhs
- ; addBindC bndr info }
+ ; info <- cgLetNoEscapeRhs local_cc bndr rhs
+ ; addBindC (cg_id info) info }
cgLneBinds (StgRec pairs)
= do { local_cc <- saveCurrentCostCentre
@@ -98,16 +100,24 @@ cgLneBinds (StgRec pairs)
; addBindsC new_bindings }
+
-------------------------
-cgLetNoEscapeRhs
+cgLetNoEscapeRhs, cgLetNoEscapeRhsBody
:: Maybe LocalReg -- Saved cost centre
-> Id
-> StgRhs
- -> FCode (Id, CgIdInfo)
-
-cgLetNoEscapeRhs local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
- = cgLetNoEscapeClosure bndr local_cc cc srt args body
-cgLetNoEscapeRhs local_cc bndr (StgRhsCon cc con args)
+ -> FCode CgIdInfo
+
+cgLetNoEscapeRhs local_cc bndr rhs =
+ do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs
+ ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
+ ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body)
+ ; return info
+ }
+
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
+ = cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
= cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args)
-- For a constructor RHS we want to generate a single chunk of
-- code which can be jumped to from many places, which will
@@ -120,9 +130,9 @@ cgLetNoEscapeClosure
-> Maybe LocalReg -- Slot for saved current cost centre
-> CostCentreStack -- XXX: *** NOT USED *** why not?
-> SRT
- -> [Id] -- Args (as in \ args -> body)
+ -> [NonVoid Id] -- Args (as in \ args -> body)
-> StgExpr -- Body (as in above)
- -> FCode (Id, CgIdInfo)
+ -> FCode CgIdInfo
cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body
= do { arg_regs <- forkProc $ do
@@ -133,7 +143,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body
-- Using altHeapCheck just reduces
-- instructions to save on stack
; return arg_regs }
- ; return (bndr, lneIdInfo bndr arg_regs) }
+ ; return $ lneIdInfo bndr arg_regs}
------------------------------------------------------------------------
@@ -253,6 +263,11 @@ data GcPlan
-------------------------------------
cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
+-- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
+ -- | isBoolTy (idType bndr)
+ -- , isDeadBndr bndr
+ -- =
+
cgCase scrut bndr srt alt_type alts
= do { up_hp_usg <- getVirtHp -- Upstream heap usage
; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
@@ -270,7 +285,7 @@ cgCase scrut bndr srt alt_type alts
; restoreCurrentCostCentre mb_cc
; bindArgsToRegs ret_bndrs
- ; cgAlts gc_plan bndr alt_type alts }
+ ; cgAlts gc_plan (NonVoid bndr) alt_type alts }
-----------------
maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
@@ -279,17 +294,25 @@ maybeSaveCostCentre simple_scrut
| otherwise = return Nothing
-
-----------------
isSimpleScrut :: StgExpr -> AltType -> Bool
--- Simple scrutinee, does not allocate
-isSimpleScrut (StgOpApp _ _ _) _ = True
-isSimpleScrut (StgLit _) _ = True
-isSimpleScrut (StgApp _ []) (PrimAlt _) = True
+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate
+-- heap usage from alternatives into the stuff before the case
+-- NB: if you get this wrong, and claim that the expression doesn't allocate
+-- when it does, you'll deeply mess up allocation
+isSimpleScrut (StgOpApp op _ _) _ = isSimpleOp op
+isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... }
+isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... }
isSimpleScrut _ _ = False
+isSimpleOp :: StgOp -> Bool
+-- True iff the op cannot block or allocate
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe)
+isSimpleOp (StgFCallOp (DNCall _) _) = False -- Safe!
+isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op)
+
-----------------
-chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [Id]
+chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
-- These are the binders of a case that are assigned
-- by the evaluation of the scrutinee
-- Only non-void ones come back
@@ -300,19 +323,16 @@ chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)]
= nonVoidIds ids -- 'bndr' is not assigned!
chooseReturnBndrs bndr (AlgAlt _) _alts
- = [bndr] -- Only 'bndr' is assigned
+ = nonVoidIds [bndr] -- Only 'bndr' is assigned
chooseReturnBndrs bndr PolyAlt _alts
- = [bndr] -- Only 'bndr' is assigned
+ = nonVoidIds [bndr] -- Only 'bndr' is assigned
chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
-- UbxTupALt has only one alternative
-nonVoidIds :: [Id] -> [Id]
-nonVoidIds ids = [id | id <- ids, not (isVoidRep (idPrimRep id))]
-
-------------------------------------
-cgAlts :: GcPlan -> Id -> AltType -> [StgAlt] -> FCode ()
+cgAlts :: GcPlan -> NonVoid Id -> AltType -> [StgAlt] -> FCode ()
-- At this point the result of the case are in the binders
cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)]
= maybeAltHeapCheck gc_plan (cgExpr rhs)
@@ -347,7 +367,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
| (DataAlt con, cmm) <- tagged_cmms ]
-- Is the constructor tag in the node reg?
- ; if isSmallFamily fam_sz
+ ; if isSmallFamily fam_sz
then let -- Yes, bndr_reg has constr. tag in ls bits
tag_expr = cmmConstrTag1 (CmmReg bndr_reg)
branches' = [(tag+1,branch) | (tag,branch) <- branches]
@@ -366,7 +386,7 @@ cgAlts _ _ _ _ = panic "cgAlts"
-- UbxTupAlt and PolyAlt have only one alternative
-------------------
-cgAltRhss :: GcPlan -> Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
+cgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
cgAltRhss gc_plan bndr alts
= forkAlts (map cg_alt alts)
where
@@ -375,7 +395,7 @@ cgAltRhss gc_plan bndr alts
cg_alt (con, bndrs, _uses, rhs)
= getCodeR $
maybeAltHeapCheck gc_plan $
- do { bindConArgs con base_reg bndrs
+ do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs
; cgExpr rhs
; return con }
@@ -392,19 +412,28 @@ maybeAltHeapCheck (GcInAlts regs srt) code
cgConApp :: DataCon -> [StgArg] -> FCode ()
cgConApp con stg_args
+ | isUnboxedTupleCon con -- Unboxed tuple: assign and return
+ = do { arg_exprs <- getNonVoidArgAmodes stg_args
+ ; tickyUnboxedTupleReturn (length arg_exprs)
+ ; emitReturn arg_exprs }
+
+ | otherwise -- Boxed constructors; allocate and return
= ASSERT( stg_args `lengthIs` dataConRepArity con )
- do { idinfo <- buildDynCon (dataConWorkId con) currentCCS con stg_args
+ do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args
-- The first "con" says that the name bound to this closure is
-- is "con", which is a bit of a fudge, but it only affects profiling
+ ; emit init
; emitReturn [idInfoToAmode idinfo] }
+
cgIdApp :: Id -> [StgArg] -> FCode ()
+cgIdApp fun_id [] | isVoidId fun_id = emitReturn []
cgIdApp fun_id args
= do { fun_info <- getCgIdInfo fun_id
- ; case maybeLetNoEscape fun_info of
- Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
- Nothing -> cgTailCall fun_id fun_info args }
+ ; case maybeLetNoEscape fun_info of
+ Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
+ Nothing -> cgTailCall fun_id fun_info args }
cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ()
cgLneJump blk_id lne_regs args -- Join point; discard sequel
@@ -416,35 +445,40 @@ cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
cgTailCall fun_id fun_info args
= case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of
- -- A value in WHNF, so we can just return it.
+ -- A value in WHNF, so we can just return it.
ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
EnterIt -> ASSERT( null args ) -- Discarding arguments
- do { [ret,call] <- forkAlts [
+ do { let fun' = CmmLoad fun (cmmExprType fun)
+ ; [ret,call] <- forkAlts [
getCode $ emitReturn [fun], -- Is tagged; no need to untag
- getCode $ emitCall (entryCode fun) [fun]] -- Not tagged
+ getCode $ do emit (mkAssign nodeReg fun)
+ emitCall Native (entryCode fun') []] -- Not tagged
; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
SlowCall -> do -- A slow function call via the RTS apply routines
{ tickySlowCall lf_info args
+ ; emit $ mkComment $ mkFastString "slowCall"
; slowCall fun args }
-- A direct function call (possibly with some left-over arguments)
DirectEntry lbl arity -> do
{ tickyDirectCall arity args
; if node_points then
- do call <- getCode $ directCall lbl arity args
- emit (mkAssign nodeReg fun <*> call)
+ do emit $ mkComment $ mkFastString "directEntry"
+ emit (mkAssign nodeReg fun)
+ directCall lbl arity args
-- directCall lbl (arity+1) (StgVarArg fun_id : args))
-- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>))
- else directCall lbl arity args }
+ else do emit $ mkComment $ mkFastString "directEntry else"
+ directCall lbl arity args }
JumpToIt {} -> panic "cgTailCall" -- ???
where
- fun_name = idName fun_id
- fun = idInfoToAmode fun_info
- lf_info = cgIdInfoLF fun_info
+ fun_name = idName fun_id
+ fun = idInfoToAmode fun_info
+ lf_info = cgIdInfoLF fun_info
node_points = nodeMustPointToIt lf_info
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 2d5d79e6ff..2a6b794e2d 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -10,11 +10,10 @@
-----------------------------------------------------------------------------
module StgCmmForeign (
- cgForeignCall,
+ cgForeignCall, loadThreadState, saveThreadState,
emitPrimCall, emitCCall,
emitSaveThreadState, -- will be needed by the Cmm parser
emitLoadThreadState, -- ditto
- emitCloseNursery,
emitOpenNursery,
) where
@@ -27,18 +26,23 @@ import StgCmmMonad
import StgCmmUtils
import StgCmmClosure
-import MkZipCfgCmm
+import BlockId
import Cmm
import CmmUtils
+import MkZipCfg
+import MkZipCfgCmm hiding (CmmAGraph)
import Type
import TysPrim
+import UniqSupply
import CLabel
import SMRep
import ForeignCall
import Constants
import StaticFlags
+import FastString
import Maybes
import Outputable
+import ZipCfgCmmRep
import Control.Monad
@@ -64,8 +68,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
DynamicTarget -> case args of fn:rest -> (rest, fn)
call_target = ForeignTarget cmm_target fc
- ; srt <- getSRTInfo (panic "emitForeignCall") -- SLPJ: Not sure what SRT
- -- is right here
+ ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT
+ -- is right here
+ -- JD: Does it matter in the new codegen?
; emitForeignCall safety results call_target call_args srt CmmMayReturn }
where
-- in the stdcall calling convention, the symbol needs @size appended
@@ -111,50 +116,18 @@ emitForeignCall
-> CmmReturnInfo -- This can say "never returns"
-- only RTS procedures do this
-> FCode ()
-emitForeignCall safety results target args _srt _ret
- | not (playSafe safety) = trace "emitForeignCall; ret is undone" $ do
+emitForeignCall safety results target args _srt ret
+ | not (playSafe safety) = do -- trace "emitForeignCall; ret is undone" $ do
let (caller_save, caller_load) = callerSaveVolatileRegs
+ updfr_off <- getUpdFrameOff
emit caller_save
- emit (mkUnsafeCall target results args)
+ emit $ mkUnsafeCall target results args
emit caller_load
- | otherwise = panic "ToDo: emitForeignCall'"
-
-{-
| otherwise = do
- -- Both 'id' and 'new_base' are KindNonPtr because they're
- -- RTS only objects and are not subject to garbage collection
- id <- newTemp bWord
- new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
+ updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target
- let (caller_save, caller_load) = callerSaveVolatileRegs
- emitSaveThreadState
- emit caller_save
- -- The CmmUnsafe arguments are only correct because this part
- -- of the code hasn't been moved into the CPS pass yet.
- -- Once that happens, this function will just emit a (CmmSafe srt) call,
- -- and the CPS will will be the one to convert that
- -- to this sequence of three CmmUnsafe calls.
- emit (mkCmmCall (CmmCallee suspendThread CCallConv)
- [ (id,AddrHint) ]
- [ (CmmReg (CmmGlobal BaseReg), AddrHint) ]
- CmmUnsafe
- ret)
- emit (mkCmmCall temp_target results args CmmUnsafe ret)
- emit (mkCmmCall (CmmCallee resumeThread CCallConv)
- [ (new_base, AddrHint) ]
- [ (CmmReg (CmmLocal id), AddrHint) ]
- CmmUnsafe
- ret )
- -- Assign the result to BaseReg: we
- -- might now have a different Capability!
- emit (mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
- emit caller_load
- emitLoadThreadState
-
-suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
-resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
--}
+ emit $ mkSafeCall temp_target results args updfr_off
{-
@@ -170,23 +143,23 @@ load_args_into_temps = mapM arg_assign_temp
where arg_assign_temp (e,hint) = do
tmp <- maybe_assign_temp e
return (tmp,hint)
+-}
-load_target_into_temp (CmmCallee expr conv) = do
+load_target_into_temp (ForeignTarget expr conv) = do
tmp <- maybe_assign_temp expr
- return (CmmCallee tmp conv)
-load_target_into_temp other_target =
+ return (ForeignTarget tmp conv)
+load_target_into_temp other_target@(PrimTarget _) =
return other_target
maybe_assign_temp e
| hasNoGlobalRegs e = return e
- | otherwise = do
+ | otherwise = do
-- don't use assignTemp, it uses its own notion of "trivial"
-- expressions, which are wrong here.
-- this is a NonPtr because it only duplicates an existing
reg <- newTemp (cmmExprType e) --TODO FIXME NOW
emit (mkAssign (CmmLocal reg) e)
return (CmmReg (CmmLocal reg))
--}
-- -----------------------------------------------------------------------------
-- Save/restore the thread state in the TSO
@@ -194,23 +167,34 @@ maybe_assign_temp e
-- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world.
-emitSaveThreadState :: FCode ()
-emitSaveThreadState = do
+saveThreadState :: CmmAGraph
+saveThreadState =
-- CurrentTSO->sp = Sp;
- emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
- emitCloseNursery
+ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
+ <*> closeNursery
+ -- and save the current cost centre stack in the TSO when profiling:
+ <*> if opt_SccProfilingOn then
+ mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
+ else mkNop
+
+emitSaveThreadState :: BlockId -> FCode ()
+emitSaveThreadState bid = do
+ -- CurrentTSO->sp = Sp;
+ emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
+ (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
+ emit closeNursery
-- and save the current cost centre stack in the TSO when profiling:
when opt_SccProfilingOn $
emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
-- CurrentNursery->free = Hp+1;
-emitCloseNursery :: FCode ()
-emitCloseNursery = emit $ mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
+closeNursery :: CmmAGraph
+closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
-emitLoadThreadState :: FCode ()
-emitLoadThreadState = do
- tso <- newTemp gcWord -- TODO FIXME NOW
- emit $ catAGraphs [
+loadThreadState :: LocalReg -> CmmAGraph
+loadThreadState tso = do
+ -- tso <- newTemp gcWord -- TODO FIXME NOW
+ catAGraphs [
-- tso = CurrentTSO;
mkAssign (CmmLocal tso) stgCurrentTSO,
-- Sp = tso->sp;
@@ -218,16 +202,18 @@ emitLoadThreadState = do
bWord),
-- SpLim = tso->stack + RESERVED_STACK_WORDS;
mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
- rESERVED_STACK_WORDS)
- ]
- emitOpenNursery
- -- and load the current cost centre stack from the TSO when profiling:
- when opt_SccProfilingOn $
- emit (mkStore curCCSAddr
- (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType))
-
-emitOpenNursery :: FCode ()
-emitOpenNursery = emit $ catAGraphs [
+ rESERVED_STACK_WORDS),
+ openNursery,
+ -- and load the current cost centre stack from the TSO when profiling:
+ if opt_SccProfilingOn then
+ mkStore curCCSAddr
+ (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
+ else mkNop]
+emitLoadThreadState :: LocalReg -> FCode ()
+emitLoadThreadState tso = emit $ loadThreadState tso
+
+openNursery :: CmmAGraph
+openNursery = catAGraphs [
-- Hp = CurrentNursery->free - 1;
mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
@@ -246,7 +232,8 @@ emitOpenNursery = emit $ catAGraphs [
)
)
]
-
+emitOpenNursery :: FCode ()
+emitOpenNursery = emit openNursery
nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
@@ -285,7 +272,7 @@ currentNursery = CmmGlobal CurrentNursery
getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
-- (a) Drop void args
--- (b) Add foriegn-call shim code
+-- (b) Add foreign-call shim code
-- It's (b) that makes this differ from getNonVoidArgAmodes
getFCallArgs args
@@ -295,7 +282,7 @@ getFCallArgs args
get arg | isVoidRep arg_rep
= return Nothing
| otherwise
- = do { cmm <- getArgAmode arg
+ = do { cmm <- getArgAmode (NonVoid arg)
; return (Just (add_shim arg_ty cmm, hint)) }
where
arg_ty = stgArgType arg
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 6a8a4354e1..3f803d1d65 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -51,14 +51,14 @@ import Data.List
layOutDynConstr, layOutStaticConstr
:: DataCon -> [(PrimRep, a)]
- -> (ClosureInfo, [(a, VirtualHpOffset)])
+ -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
-- No Void arguments in result
layOutDynConstr = layOutConstr False
layOutStaticConstr = layOutConstr True
layOutConstr :: Bool -> DataCon -> [(PrimRep, a)]
- -> (ClosureInfo, [(a, VirtualHpOffset)])
+ -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
layOutConstr is_static data_con args
= (mkConInfo is_static data_con tot_wds ptr_wds,
things_w_offsets)
@@ -78,13 +78,16 @@ allocDynClosure
-> CmmExpr -- Cost Centre to blame for this alloc
-- (usually the same; sometimes "OVERHEAD")
- -> [(StgArg, VirtualHpOffset)] -- Offsets from start of the object
- -- ie Info ptr has offset zero.
- -- No void args in here
- -> FCode LocalReg
+ -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of the object
+ -- ie Info ptr has offset zero.
+ -- No void args in here
+ -> FCode (LocalReg, CmmAGraph)
-- allocDynClosure allocates the thing in the heap,
-- and modifies the virtual Hp to account for this.
+-- The second return value is the graph that sets the value of the
+-- returned LocalReg, which should point to the closure after executing
+-- the graph.
-- Note [Return a LocalReg]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -132,7 +135,7 @@ allocDynClosure cl_info use_cc _blame_cc args_w_offsets
-- Assign to a temporary and return
-- Note [Return a LocalReg]
; hp_rel <- getHpRelOffset info_offset
- ; assignTemp hp_rel }
+ ; getCodeR $ assignTemp hp_rel }
emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
emitSetDynHdr base info_ptr ccs
@@ -210,7 +213,7 @@ mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
= [CmmLabel info_lbl]
++ variable_header_words
- ++ payload
+ ++ concatMap padLitToWord payload
++ padding_wds
++ static_link_field
++ saved_info_field
@@ -221,6 +224,19 @@ mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_fi
++ staticProfHdr ccs
++ staticTickyHdr
+-- JD: Simon had ellided this padding, but without it the C back end asserts failure.
+-- Maybe it's a bad assertion, and this padding is indeed unnecessary?
+padLitToWord :: CmmLit -> [CmmLit]
+padLitToWord lit = lit : padding pad_length
+ where width = typeWidth (cmmLitType lit)
+ pad_length = wORD_SIZE - widthInBytes width :: Int
+
+ padding n | n <= 0 = []
+ | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1)
+ | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)
+ | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)
+ | otherwise = CmmInt 0 W64 : padding (n-8)
+
-----------------------------------------------------------
-- Heap overflow checking
-----------------------------------------------------------
@@ -286,7 +302,7 @@ These are used in the following circumstances
Here, the info table needed by the call
to gc_1p should be the *same* as the
one for the call to f; the C-- optimiser
- spots this sharing opportunity
+ spots this sharing opportunity)
(b) No canned sequence for results of f
Note second info table
@@ -318,24 +334,30 @@ These are used in the following circumstances
--------------------------------------------------------------
-- A heap/stack check at a function or thunk entry point.
-entryHeapCheck :: LocalReg -- Function
- -> [LocalReg] -- Args (empty for thunk)
+entryHeapCheck :: LocalReg -- Function (closure environment)
+ -> Int -- Arity -- not same as length args b/c of voids
+ -> [LocalReg] -- Non-void args (empty for thunk)
-> C_SRT
-> FCode ()
-> FCode ()
-entryHeapCheck fun args srt code
- = heapCheck gc_call code -- The 'fun' keeps relevant CAFs alive
+entryHeapCheck fun arity args srt code
+ = do updfr_sz <- getUpdFrameOff
+ heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive
where
- gc_call
- | null args = mkJump (CmmReg (CmmGlobal GCEnter1)) [CmmReg (CmmLocal fun)]
- | otherwise = case gc_lbl args of
- Just lbl -> mkJump (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
- (map (CmmReg . CmmLocal) (fun:args))
- Nothing -> mkCmmCall generic_gc [] [] srt
+ fun_expr = CmmReg (CmmLocal fun)
+ -- JD: ugh... we should only do the following for dynamic closures
+ args' = fun_expr : map (CmmReg . CmmLocal) args
+ gc_call updfr_sz
+ | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) args' updfr_sz
+ | otherwise = case gc_lbl (fun : args) of
+ Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
+ args' updfr_sz
+ Nothing -> mkCall generic_gc GC [] [] updfr_sz
gc_lbl :: [LocalReg] -> Maybe LitString
- gc_lbl [reg]
+{-
+ gc_lbl [reg]
| isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
| isFloatType ty = case width of
W32 -> Just (sLit "stg_gc_f1") -- "stg_gc_fun_f1"
@@ -348,6 +370,7 @@ entryHeapCheck fun args srt code
where
ty = localRegType reg
width = typeWidth ty
+-}
gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
@@ -360,19 +383,19 @@ entryHeapCheck fun args srt code
altHeapCheck :: [LocalReg] -> C_SRT -> FCode a -> FCode a
altHeapCheck regs srt code
- = heapCheck gc_call code
+ = do updfr_sz <- getUpdFrameOff
+ heapCheck False (gc_call updfr_sz) code
where
- gc_call
- | null regs = mkCmmCall generic_gc [] [] srt
+ gc_call updfr_sz
+ | null regs = mkCall generic_gc GC [] [] updfr_sz
| Just gc_lbl <- rts_label regs -- Canned call
- = mkCmmCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl)))
- regs
- (map (CmmReg . CmmLocal) regs)
- srt
+ = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) GC
+ regs (map (CmmReg . CmmLocal) regs) updfr_sz
| otherwise -- No canned call, and non-empty live vars
- = mkCmmCall generic_gc [] [] srt
+ = mkCall generic_gc GC [] [] updfr_sz
+{-
rts_label [reg]
| isGcPtrType ty = Just (sLit "stg_gc_unpt_r1")
| isFloatType ty = case width of
@@ -381,23 +404,26 @@ altHeapCheck regs srt code
_other -> Nothing
| otherwise = case width of
W32 -> Just (sLit "stg_gc_unbx_r1")
- W64 -> Just (sLit "stg_gc_unbx_l1")
+ W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
_other -> Nothing -- Narrow cases
where
ty = localRegType reg
width = typeWidth ty
+-}
rts_label _ = Nothing
generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls
-generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
+generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs")))
+-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
+-- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
-------------------------------
-heapCheck :: CmmAGraph -> FCode a -> FCode a
-heapCheck do_gc code
+heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a
+heapCheck checkStack do_gc code
= getHeapUsage $ \ hpHw ->
- do { emit (do_checks hpHw do_gc)
+ do { emit $ do_checks checkStack hpHw do_gc
-- Emit heap checks, but be sure to do it lazily so
-- that the conditionals on hpHw don't cause a black hole
; tickyAllocHeap hpHw
@@ -405,20 +431,27 @@ heapCheck do_gc code
; setRealHp hpHw
; code }
-do_checks :: WordOff -- Heap headroom
- -> CmmAGraph -- What to do on failure
- -> CmmAGraph
-do_checks 0 _
- = mkNop
-do_checks alloc do_gc
- = withFreshLabel "gc" $ \ blk_id ->
- mkLabel blk_id Nothing
- <*> mkAssign hpReg bump_hp
- <*> mkCmmIfThen hp_oflo
- (save_alloc
- <*> do_gc
- <*> mkBranch blk_id)
- -- Bump heap pointer, and test for heap exhaustion
+do_checks :: Bool -- Should we check the stack?
+ -> WordOff -- Heap headroom
+ -> CmmAGraph -- What to do on failure
+ -> CmmAGraph
+do_checks checkStack alloc do_gc
+ = withFreshLabel "gc" $ \ loop_id ->
+ withFreshLabel "gc" $ \ gc_id ->
+ mkLabel loop_id emptyStackInfo
+ <*> (let hpCheck = if alloc == 0 then mkNop
+ else mkAssign hpReg bump_hp <*>
+ mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
+ in if checkStack then
+ mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
+ else hpCheck)
+ <*> mkComment (mkFastString "outOfLine should follow:")
+ <*> outOfLine (mkLabel gc_id emptyStackInfo
+ <*> mkComment (mkFastString "outOfLine here")
+ <*> do_gc
+ <*> mkBranch loop_id)
+ -- Test for stack pointer exhaustion, then
+ -- bump heap pointer, and test for heap exhaustion
-- Note that we don't move the heap pointer unless the
-- stack check succeeds. Otherwise we might end up
-- with slop at the end of the current block, which can
@@ -427,6 +460,11 @@ do_checks alloc do_gc
alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes
bump_hp = cmmOffsetExprB (CmmReg hpReg) alloc_lit
+ -- Sp overflow if (Sp - CmmHighStack < SpLim)
+ sp_oflo = CmmMachOp mo_wordULt
+ [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg)))
+ [CmmReg spReg, CmmLit CmmHighStackMark],
+ CmmReg spLimReg]
-- Hp overflow if (Hp > HpLim)
-- (Hp has been incremented by now)
-- HpLim points to the LAST WORD of valid allocation space.
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index f8d39646d6..1269897f4e 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -17,7 +17,8 @@ module StgCmmLayout (
mkArgDescr,
emitCall, emitReturn,
- emitClosureCodeAndInfoTable,
+ emitClosureProcAndInfoTable,
+ emitClosureAndInfoTable,
slowCall, directCall,
@@ -47,6 +48,7 @@ import CmmUtils
import Cmm
import CLabel
import StgSyn
+import DataCon
import Id
import Name
import TyCon ( PrimRep(..) )
@@ -62,7 +64,7 @@ import Constants
import Util
import Data.List
import Outputable
-import FastString ( LitString, sLit )
+import FastString ( mkFastString, LitString, sLit )
------------------------------------------------------------------------
-- Call and return sequences
@@ -77,21 +79,24 @@ emitReturn :: [CmmExpr] -> FCode ()
-- p=x; q=y;
emitReturn results
= do { adjustHpBackwards
- ; sequel <- getSequel;
+ ; sequel <- getSequel;
+ ; updfr_off <- getUpdFrameOff
; case sequel of
- Return _ -> emit (mkReturn results)
- AssignTo regs _ -> emit (mkMultiAssign regs results)
+ Return _ -> emit (mkReturnSimple results updfr_off)
+ AssignTo regs _ -> emit (mkMultiAssign regs results)
}
-emitCall :: CmmExpr -> [CmmExpr] -> FCode ()
+emitCall :: Convention -> CmmExpr -> [CmmExpr] -> FCode ()
-- (cgCall fun args) makes a call to the entry-code of 'fun',
-- passing 'args', and returning the results to the current sequel
-emitCall fun args
+emitCall conv fun args
= do { adjustHpBackwards
- ; sequel <- getSequel;
+ ; sequel <- getSequel
+ ; updfr_off <- getUpdFrameOff
+ ; emit $ mkComment $ mkFastString "emitcall"
; case sequel of
- Return _ -> emit (mkJump fun args)
- AssignTo res_regs srt -> emit (mkCmmCall fun res_regs args srt)
+ Return _ -> emit (mkForeignJump conv fun args updfr_off)
+ AssignTo res_regs srt -> emit (mkCall fun conv res_regs args updfr_off)
}
adjustHpBackwards :: FCode ()
@@ -132,7 +137,7 @@ directCall :: CLabel -> Arity -> [StgArg] -> FCode ()
-- Both arity and args include void args
directCall lbl arity stg_args
= do { cmm_args <- getNonVoidArgAmodes stg_args
- ; direct_call lbl arity cmm_args (argsLReps stg_args) }
+ ; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) }
slowCall :: CmmExpr -> [StgArg] -> FCode ()
-- (slowCall fun args) applies fun to args, returning the results to Sequel
@@ -141,36 +146,42 @@ slowCall fun stg_args
; slow_call fun cmm_args (argsLReps stg_args) }
--------------
-direct_call :: CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode ()
--- NB1: (length args) maybe less than (length reps), because
+direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode ()
+-- NB1: (length args) may be less than (length reps), because
-- the args exclude the void ones
-- NB2: 'arity' refers to the *reps*
-direct_call lbl arity args reps
- | null rest_args
- = ASSERT( arity == length args)
- emitCall target args
+direct_call caller lbl arity args reps
+ | debugIsOn && arity > length reps -- Too few args
+ = -- Caller should ensure that there enough args!
+ pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps)
+ <+> ppr args <+> ppr reps )
- | otherwise
+ | null rest_reps -- Precisely the right number of arguments
+ = emitCall Native target args
+
+ | otherwise -- Over-saturated call
= ASSERT( arity == length initial_reps )
do { pap_id <- newTemp gcWord
; let srt = pprTrace "Urk! SRT for over-sat call"
(ppr lbl) NoC_SRT
-- XXX: what if rest_args contains static refs?
; withSequel (AssignTo [pap_id] srt)
- (emitCall target args)
+ (emitCall Native target fast_args)
; slow_call (CmmReg (CmmLocal pap_id))
rest_args rest_reps }
where
target = CmmLit (CmmLabel lbl)
(initial_reps, rest_reps) = splitAt arity reps
arg_arity = count isNonV initial_reps
- (_, rest_args) = splitAt arg_arity args
+ (fast_args, rest_args) = splitAt arg_arity args
--------------
slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode ()
slow_call fun args reps
- = direct_call (mkRtsApFastLabel rts_fun) (arity+1)
- (fun : args) (P : reps)
+ = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
+ emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
+ " with pat " ++ showSDoc (ptext rts_fun))
+ emit (mkAssign nodeReg fun <*> call)
where
(rts_fun, arity) = slowCallPattern reps
@@ -207,6 +218,13 @@ data LRep = P -- GC Ptr
| V -- Void
| F -- Float
| D -- Double
+instance Outputable LRep where
+ ppr P = text "P"
+ ppr N = text "N"
+ ppr L = text "L"
+ ppr V = text "V"
+ ppr F = text "F"
+ ppr D = text "D"
toLRep :: PrimRep -> LRep
toLRep VoidRep = V
@@ -254,7 +272,7 @@ mkVirtHeapOffsets
-> [(PrimRep,a)] -- Things to make offsets for
-> (WordOff, -- _Total_ number of words allocated
WordOff, -- Number of words allocated for *pointers*
- [(a, VirtualHpOffset)])
+ [(NonVoid a, VirtualHpOffset)])
-- Things with their offsets from start of object in order of
-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
@@ -279,7 +297,7 @@ mkVirtHeapOffsets is_thunk things
computeOffset wds_so_far (rep, thing)
= (wds_so_far + lRepSizeW (toLRep rep),
- (thing, hdr_size + wds_so_far))
+ (NonVoid thing, hdr_size + wds_so_far))
-------------------------------------------------------------------------
@@ -437,12 +455,36 @@ mkRegLiveness regs ptrs nptrs
-- Here we make an info table of type 'CmmInfo'. The concrete
-- representation as a list of 'CmmAddr' is handled later
-- in the pipeline by 'cmmToRawCmm'.
-
-emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals
- -> CmmAGraph -> FCode ()
-emitClosureCodeAndInfoTable cl_info args body
- = do { info <- mkCmmInfo cl_info
- ; emitProc info (infoLblToEntryLbl info_lbl) args body }
+-- When loading the free variables, a function closure pointer may be tagged,
+-- so we must take it into account.
+
+emitClosureProcAndInfoTable :: Bool -- top-level?
+ -> Id -- name of the closure
+ -> ClosureInfo -- lots of info abt the closure
+ -> [NonVoid Id] -- incoming arguments
+ -> ((LocalReg, [LocalReg]) -> FCode ()) -- function body
+ -> FCode ()
+emitClosureProcAndInfoTable top_lvl bndr cl_info args body
+ = do { let lf_info = closureLFInfo cl_info
+ -- Bind the binder itself, but only if it's not a top-level
+ -- binding. We need non-top let-bindings to refer to the
+ -- top-level binding, which this binding would incorrectly shadow.
+ ; node <- if top_lvl then return $ idToReg (NonVoid bndr)
+ else bindToReg (NonVoid bndr) lf_info
+ ; arg_regs <-
+ pprTrace "bindArgsToRegs" (ppr args) $
+ bindArgsToRegs args
+ ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs)
+ }
+
+-- Data constructors need closures, but not with all the argument handling
+-- needed for functions. The shared part goes here.
+emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable cl_info args body
+ = do { info <- mkCmmInfo cl_info
+ ; blks <- getCode body
+ ; emitProc info (infoLblToEntryLbl info_lbl) args blks
+ }
where
info_lbl = infoTableLabelFromCI cl_info
@@ -450,14 +492,18 @@ emitClosureCodeAndInfoTable cl_info args body
-- Not used for return points. (The 'smRepClosureTypeInt' call would panic.)
mkCmmInfo :: ClosureInfo -> FCode CmmInfo
mkCmmInfo cl_info
- = do { prof <- if opt_SccProfilingOn then
+ = do { info <- closureTypeInfo cl_info k_with_con_name return
+ ; prof <- if opt_SccProfilingOn then
do fd_lit <- mkStringCLit (closureTypeDescr cl_info)
ad_lit <- mkStringCLit (closureValDescr cl_info)
return $ ProfilingInfo fd_lit ad_lit
else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
- ; return (CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)) }
+ ; return (CmmInfo gc_target Nothing
+ (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) }
where
- info = closureTypeInfo cl_info
+ k_with_con_name con_info con info_lbl =
+ do cstr <- mkByteStringCLit $ dataConIdentity con
+ return $ con_info $ makeRelativeRefTo info_lbl cstr
cl_type = smRepClosureTypeInt (closureSMRep cl_info)
-- The gc_target is to inform the CPS pass when it inserts a stack check.
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 365263941e..2249a463df 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -13,7 +13,7 @@ module StgCmmMonad (
returnFC, fixC, nopC, whenC,
newUnique, newUniqSupply,
- emit, emitData, emitProc, emitSimpleProc,
+ emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
getCmm, cgStmtsToBlocks,
getCodeR, getCode, getHeapUsage,
@@ -28,6 +28,8 @@ module StgCmmMonad (
setSRTLabel, getSRTLabel,
setTickyCtrLabel, getTickyCtrLabel,
+ withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
+
HeapUsage(..), VirtualHpOffset, initHpUsage,
getHpUsage, setHpUsage, heapHWM,
setVirtHp, getVirtHp, setRealHp,
@@ -50,6 +52,7 @@ module StgCmmMonad (
import StgCmmClosure
import DynFlags
import MkZipCfgCmm
+import ZipCfgCmmRep (UpdFrameOffset)
import BlockId
import Cmm
import CLabel
@@ -157,12 +160,13 @@ fixC fcode = FCode (
data CgInfoDownwards -- information only passed *downwards* by the monad
= MkCgInfoDown {
- cgd_dflags :: DynFlags,
- cgd_mod :: Module, -- Module being compiled
- cgd_statics :: CgBindings, -- [Id -> info] : static environment
- cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT
- cgd_ticky :: CLabel, -- Current destination for ticky counts
- cgd_sequel :: Sequel -- What to do at end of basic block
+ cgd_dflags :: DynFlags,
+ cgd_mod :: Module, -- Module being compiled
+ cgd_statics :: CgBindings, -- [Id -> info] : static environment
+ cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT
+ cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
+ cgd_ticky :: CLabel, -- Current destination for ticky counts
+ cgd_sequel :: Sequel -- What to do at end of basic block
}
type CgBindings = IdEnv CgIdInfo
@@ -173,10 +177,10 @@ data CgIdInfo
-- Can differ from the Id at occurrence sites by
-- virtue of being externalised, for splittable C
, cg_lf :: LambdaFormInfo
- , cg_loc :: CgLoc
+ , cg_loc :: CgLoc -- CmmExpr for the *tagged* value
, cg_rep :: PrimRep -- Cache for (idPrimRep id)
, cg_tag :: {-# UNPACK #-} !DynTag -- Cache for (lfDynTag cg_lf)
- }
+ }
data CgLoc
= CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning
@@ -206,21 +210,28 @@ data Sequel
[LocalReg] -- Put result(s) in these regs and fall through
-- NB: no void arguments here
C_SRT -- Here are the statics live in the continuation
-
+ -- E.g. case (case x# of 0# -> a; DEFAULT -> b) of {
+ -- r -> <blah>
+ -- When compiling the nested case, remember to put the
+ -- result in r, and fall through
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
- = MkCgInfoDown { cgd_dflags = dflags,
- cgd_mod = mod,
- cgd_statics = emptyVarEnv,
- cgd_srt_lbl = error "initC: srt_lbl",
- cgd_ticky = mkTopTickyCtrLabel,
- cgd_sequel = initSequel }
+ = MkCgInfoDown { cgd_dflags = dflags,
+ cgd_mod = mod,
+ cgd_statics = emptyVarEnv,
+ cgd_srt_lbl = error "initC: srt_lbl",
+ cgd_updfr_off = initUpdFrameOff,
+ cgd_ticky = mkTopTickyCtrLabel,
+ cgd_sequel = initSequel }
initSequel :: Sequel
initSequel = Return False
+initUpdFrameOff :: UpdFrameOffset
+initUpdFrameOff = widthInBytes wordWidth -- space for the RA
+
--------------------------------------------------------
-- The code generator state
@@ -240,7 +251,7 @@ data CgState
-- the info-down part
cgs_hp_usg :: HeapUsage,
-
+
cgs_uniqs :: UniqSupply }
data HeapUsage =
@@ -253,10 +264,10 @@ type VirtualHpOffset = WordOff
initCgState :: UniqSupply -> CgState
initCgState uniqs
- = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL,
- cgs_binds = emptyVarEnv,
- cgs_hp_usg = initHpUsage,
- cgs_uniqs = uniqs }
+ = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL,
+ cgs_binds = emptyVarEnv,
+ cgs_hp_usg = initHpUsage,
+ cgs_uniqs = uniqs }
stateIncUsage :: CgState -> CgState -> CgState
-- stateIncUsage@ e1 e2 incorporates in e1
@@ -408,6 +419,26 @@ setSRTLabel srt_lbl code
withInfoDown code (info { cgd_srt_lbl = srt_lbl})
-- ----------------------------------------------------------------------------
+-- Get/set the size of the update frame
+
+-- We keep track of the size of the update frame so that we
+-- can set the stack pointer to the proper address on return
+-- (or tail call) from the closure.
+-- There should be at most one update frame for each closure.
+-- Note: I'm including the size of the original return address
+-- in the size of the update frame -- hence the default case on `get'.
+
+withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
+withUpdFrameOff size code
+ = do { info <- getInfoDown
+ ; withInfoDown code (info {cgd_updfr_off = size }) }
+
+getUpdFrameOff :: FCode UpdFrameOffset
+getUpdFrameOff
+ = do { info <- getInfoDown
+ ; return $ cgd_updfr_off info }
+
+-- ----------------------------------------------------------------------------
-- Get/set the current ticky counter label
getTickyCtrLabel :: FCode CLabel
@@ -440,7 +471,8 @@ forkClosureBody body_code
= do { info <- getInfoDown
; us <- newUniqSupply
; state <- getState
- ; let body_info_down = info { cgd_sequel = initSequel }
+ ; let body_info_down = info { cgd_sequel = initSequel
+ , cgd_updfr_off = initUpdFrameOff }
fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
((),fork_state_out)
= doFCode body_code body_info_down fork_state_in
@@ -455,8 +487,9 @@ forkStatics body_code
= do { info <- getInfoDown
; us <- newUniqSupply
; state <- getState
- ; let rhs_info_down = info { cgd_statics = cgs_binds state,
- cgd_sequel = initSequel }
+ ; let rhs_info_down = info { cgd_statics = cgs_binds state
+ , cgd_sequel = initSequel
+ , cgd_updfr_off = initUpdFrameOff }
(result, fork_state_out) = doFCode body_code rhs_info_down
(initCgState us)
; setState (state `addCodeBlocksFrom` fork_state_out)
@@ -473,9 +506,9 @@ forkProc body_code
= do { info_down <- getInfoDown
; us <- newUniqSupply
; state <- getState
- ; let fork_state_in = (initCgState us)
- { cgs_binds = cgs_binds state }
- (result, fork_state_out) = doFCode body_code info_down fork_state_in
+ ; let info_down' = info_down { cgd_sequel = initSequel }
+ fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+ (result, fork_state_out) = doFCode body_code info_down' fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out
; return result }
@@ -562,20 +595,22 @@ emitData sect lits
where
data_block = CmmData sect lits
-emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
-emitProc info lbl args blocks
+emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
+ CmmAGraph -> FCode ()
+emitProcWithConvention conv info lbl args blocks
= do { us <- newUniqSupply
- ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) Native args
+ ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks
- -- ; blks <- cgStmtsToBlocks blocks
; let proc_block = CmmProc info lbl args blks
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
+emitProc = emitProcWithConvention Native
+
emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
--- Emit a procedure whose body is the specified code; no info table
-emitSimpleProc lbl code
- = emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
+emitSimpleProc lbl code =
+ emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
getCmm :: FCode () -> FCode CmmZ
-- Get all the CmmTops (there should be no stmts)
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 96467fe781..69409084d1 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -66,7 +66,9 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty
cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
= ASSERT(isEnumerationTyCon tycon)
- do { amode <- getArgAmode arg
+ do { args' <- getNonVoidArgAmodes [arg]
+ ; let amode = case args' of [amode] -> amode
+ _ -> panic "TagToEnumOp had void arg"
; emitReturn [tagToClosure tycon amode] }
where
-- If you're reading this code in the attempt to figure
@@ -79,8 +81,8 @@ cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
cgOpApp (StgPrimOp primop) args res_ty
| primOpOutOfLine primop
= do { cmm_args <- getNonVoidArgAmodes args
- ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
- ; emitCall fun cmm_args }
+ ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
+ ; pprTrace "cgOpApp" (ppr primop) $ emitCall PrimOp fun cmm_args }
| ReturnsPrim VoidRep <- result_info
= do cgPrimOp [] primop args
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index f442295d25..1a18b99ac8 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -37,6 +37,7 @@ module StgCmmProf (
-- For REP_xxx constants, which are MachReps
import StgCmmClosure
+import StgCmmEnv
import StgCmmUtils
import StgCmmMonad
import SMRep
@@ -185,10 +186,10 @@ profAlloc words ccs
-- Setting the cost centre in a new closure
chooseDynCostCentres :: CostCentreStack
- -> [Id] -- Args
+ -> [Id] -- Args
-> StgExpr -- Body
-> FCode (CmmExpr, CmmExpr)
--- Called when alllcating a closure
+-- Called when allocating a closure
-- Tells which cost centre to put in the object, and which
-- to blame the cost of allocation on
chooseDynCostCentres ccs args body = do
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 6cfca5f05f..057e5597e8 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -52,6 +52,7 @@ import BlockId
import Cmm
import CmmExpr
import MkZipCfgCmm
+import ZipCfg hiding (last, unzip, zip)
import CLabel
import CmmUtils
import PprCmm ( {- instances -} )
@@ -307,15 +308,17 @@ emitRtsCall'
-> FCode ()
emitRtsCall' res fun args _vols safe
= --error "emitRtsCall'"
- do { emit caller_save
- ; emit call
+ do { updfr_off <- getUpdFrameOff
+ ; emit caller_save
+ ; emit $ call updfr_off
; emit caller_load }
where
- call = if safe then
- mkCall fun_expr CCallConv res' args' undefined
- else
- mkUnsafeCall (ForeignTarget fun_expr
- (ForeignConvention CCallConv arg_hints res_hints)) res' args'
+ call updfr_off =
+ if safe then
+ mkCall fun_expr Native res' args' updfr_off
+ else
+ mkUnsafeCall (ForeignTarget fun_expr
+ (ForeignConvention CCallConv arg_hints res_hints)) res' args'
(args', arg_hints) = unzip args
(res', res_hints) = unzip res
(caller_save, caller_load) = callerSaveVolatileRegs
@@ -633,7 +636,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
mk_switch tag_expr' (sortLe le branches) mb_deflt
lo_tag hi_tag via_C
-- Sort the branches before calling mk_switch
- <*> mkLabel join_lbl Nothing
+ <*> mkLabel join_lbl emptyStackInfo
where
(t1,_) `le` (t2,_) = t1 <= t2
@@ -706,9 +709,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
| Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
= mkCmmIfThenElse
(cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
+ (mkBranch deflt)
(mk_switch tag_expr branches mb_deflt
lo_tag highest_branch via_C)
- (mkBranch deflt)
| otherwise -- Use an if-tree
= mkCmmIfThenElse
@@ -788,6 +791,7 @@ mkCmmLitSwitch scrut branches deflt
label_code join_lbl deflt $ \ deflt ->
label_branches join_lbl branches $ \ branches ->
mk_lit_switch scrut' deflt (sortLe le branches)
+ <*> mkLabel join_lbl emptyStackInfo
where
le (t1,_) (t2,_) = t1 <= t2
@@ -795,12 +799,12 @@ mk_lit_switch :: CmmExpr -> BlockId
-> [(Literal,BlockId)]
-> CmmAGraph
mk_lit_switch scrut deflt [(lit,blk)]
- = mkCbranch
- (CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit])
- deflt blk
+ = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk
where
cmm_lit = mkSimpleLit lit
- rep = typeWidth (cmmLitType cmm_lit)
+ cmm_ty = cmmLitType cmm_lit
+ rep = typeWidth cmm_ty
+ ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
mk_lit_switch scrut deflt_blk_id branches
= mkCmmIfThenElse cond
@@ -846,7 +850,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
-- [L: code; goto J] fun L
label_code join_lbl code thing_inside
= withFreshLabel "switch" $ \lbl ->
- outOfLine (mkLabel lbl Nothing <*> code <*> mkBranch join_lbl)
+ outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl)
<*> thing_inside lbl
@@ -881,10 +885,12 @@ getSRTInfo (SRT off len bmp)
= do { id <- newUnique
; top_srt <- getSRTLabel
; let srt_desc_lbl = mkLargeSRTLabel id
- ; emitRODataLits srt_desc_lbl
- ( cmmLabelOffW top_srt off
- : mkWordCLit (fromIntegral len)
- : map mkWordCLit bmp)
+ -- JD: We're not constructing and emitting SRTs in the back end,
+ -- which renders this code wrong (and it now names a now-non-existent label).
+ -- ; emitRODataLits srt_desc_lbl
+ -- ( cmmLabelOffW top_srt off
+ -- : mkWordCLit (fromIntegral len)
+ -- : map mkWordCLit bmp)
; return (C_SRT srt_desc_lbl 0 srt_escape) }
| otherwise
View Lorry Controller Status