import TyCon
import CostCentre
import Outputable
-import FastString( LitString, mkFastString, sLit )
+import Module
+import FastString( mkFastString, FastString, fsLit )
import Constants
-import Data.List
-----------------------------------------------------------
--------------------------------------------------------------
-- A heap/stack check at a function or thunk entry point.
-entryHeapCheck :: LocalReg -- Function (closure environment)
+entryHeapCheck :: Maybe LocalReg -- Function (closure environment)
-> Int -- Arity -- not same as length args b/c of voids
-> [LocalReg] -- Non-void args (empty for thunk)
-> FCode ()
= do updfr_sz <- getUpdFrameOff
heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive
where
- fun_expr = CmmReg (CmmLocal fun)
- -- JD: ugh... we should only do the following for dynamic closures
- args' = fun_expr : map (CmmReg . CmmLocal) args
+ args' = case fun of Just f -> f : args
+ Nothing -> args
+ arg_exprs = 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
+ | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
+ | otherwise = case gc_lbl args' of
+ Just _lbl -> panic "StgCmmHeap.entryHeapCheck: gc_lbl not finished"
+ -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
+ -- arg_exprs updfr_sz
+ Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz
+
+ gc_lbl :: [LocalReg] -> Maybe FastString
{-
gc_lbl [reg]
| isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
- gc_lbl_ptrs :: [Bool] -> Maybe LitString
+ gc_lbl_ptrs :: [Bool] -> Maybe FastString
-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
--gc_lbl_ptrs [True,True] = Just (sLit "stg_gc_fun_2p")
--gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p")
heapCheck False (gc_call updfr_sz) code
where
gc_call updfr_sz
- | null regs = mkCall generic_gc GC [] [] updfr_sz
+ | null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz
- | Just gc_lbl <- rts_label regs -- Canned call
- = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) GC
- regs (map (CmmReg . CmmLocal) regs) updfr_sz
+ | Just _gc_lbl <- rts_label regs -- Canned call
+ = panic "StgCmmHeap.altHeapCheck: rts_label not finished"
+ -- mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC)
+ -- regs (map (CmmReg . CmmLocal) regs) updfr_sz
| otherwise -- No canned call, and non-empty live vars
- = mkCall generic_gc GC [] [] updfr_sz
+ = mkCall generic_gc (GC, GC) [] [] updfr_sz
{-
rts_label [reg]
generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls
-generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs")))
+generic_gc = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")))
-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
-- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
do_checks checkStack alloc do_gc
= withFreshLabel "gc" $ \ loop_id ->
withFreshLabel "gc" $ \ gc_id ->
- mkLabel loop_id emptyStackInfo
+ mkLabel loop_id
<*> (let hpCheck = if alloc == 0 then mkNop
else mkAssign hpReg bump_hp <*>
mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
else hpCheck)
<*> mkComment (mkFastString "outOfLine should follow:")
- <*> outOfLine (mkLabel gc_id emptyStackInfo
+ <*> outOfLine (mkLabel gc_id
<*> mkComment (mkFastString "outOfLine here")
<*> do_gc
<*> mkBranch loop_id)