Commit 4384e146 authored by dterei's avatar dterei

Track STG live register information for use in LLVM

We now carry around with CmmJump statements a list of
the STG registers that are live at that jump site.
This is used by the LLVM backend so it can avoid
unnesecarily passing around dead registers, improving
perfromance. This gives us the framework to finally
fix trac #4308.
parent 43178674
......@@ -105,8 +105,10 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
, Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
| otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
CmmCall e _ _ _ _ -> [Old.CmmJump e]
-- ToDo: STG Live
CmmCall e _ _ _ _ -> [Old.CmmJump e Nothing]
CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
Old.BasicBlock _ stmts -> stmts
where Just block = mapLookup bid $ toBlockMap g
......@@ -143,7 +143,7 @@ lintCmmStmt platform labels = lint
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
text " :: " <> ppr erep)
lint (CmmJump e) = lintCmmExpr platform e >> return ()
lint (CmmJump e _) = lintCmmExpr platform e >> return ()
lint (CmmReturn) = return ()
lint (CmmBranch id) = checkTarget id
checkTarget id = if setMember id labels then return ()
......
......@@ -65,7 +65,7 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
stmt m (CmmBranch b) = b:m
stmt m (CmmCondBranch e b) = b:(expr m e)
stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
stmt m (CmmJump e) = expr m e
stmt m (CmmJump e _) = expr m e
stmt m (CmmReturn) = m
actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
-- We have to do a deep fold into CmmExpr because
......@@ -273,7 +273,7 @@ inlineStmt u a (CmmCall target regs es ret)
es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
inlineStmt u a (CmmJump e) = CmmJump (inlineExpr u a e)
inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live
inlineStmt _ _ other_stmt = other_stmt
inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
......@@ -669,7 +669,7 @@ cmmLoopifyForC (CmmProc (Just info@(Statics info_lbl _)) entry_lbl
where blocks' = [ BasicBlock id (map do_stmt stmts)
| BasicBlock id stmts <- blocks ]
do_stmt (CmmJump (CmmLit (CmmLabel lbl))) | lbl == jump_lbl
do_stmt (CmmJump (CmmLit (CmmLabel lbl)) _) | lbl == jump_lbl
= CmmBranch top_id
do_stmt stmt = stmt
......
......@@ -411,8 +411,8 @@ stmt :: { ExtCode }
{ do as <- sequence $5; doSwitch $2 $3 as $6 }
| 'goto' NAME ';'
{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
| 'jump' expr ';'
{ do e <- $2; stmtEC (CmmJump e) }
| 'jump' expr vols ';'
{ do e <- $2; stmtEC (CmmJump e $3) }
| 'return' ';'
{ stmtEC CmmReturn }
| 'if' bool_expr 'goto' NAME
......@@ -940,12 +940,12 @@ doStore rep addr_code val_code
emitRetUT :: [(CgRep,CmmExpr)] -> Code
emitRetUT args = do
tickyUnboxedTupleReturn (length args) -- TICK
(sp, stmts) <- pushUnboxedTuple 0 args
(sp, stmts, live) <- pushUnboxedTuple 0 args
emitSimultaneously stmts -- NB. the args might overlap with the stack slots
-- or regs that we assign to, so better use
-- simultaneous assignments here (#3546)
when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord))
stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live)
-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions
......
......@@ -146,32 +146,46 @@ data CmmStmt
= CmmNop
| CmmComment FastString
| CmmAssign CmmReg CmmExpr -- Assign to register
| CmmAssign CmmReg CmmExpr -- Assign to register
| CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
| CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
| CmmCall -- A call (foreign, native or primitive), with
CmmCallTarget
[HintedCmmFormal] -- zero or more results
[HintedCmmActual] -- zero or more arguments
CmmReturnInfo
-- Some care is necessary when handling the arguments of these, see
-- [Register parameter passing] and the hack in cmm/CmmOpt.hs
| CmmCall -- A call (foreign, native or primitive), with
CmmCallTarget
[HintedCmmFormal] -- zero or more results
[HintedCmmActual] -- zero or more arguments
CmmReturnInfo
-- Some care is necessary when handling the arguments of these, see
-- [Register parameter passing] and the hack in cmm/CmmOpt.hs
| CmmBranch BlockId -- branch to another BB in this fn
| CmmCondBranch CmmExpr BlockId -- conditional branch
| CmmSwitch CmmExpr [Maybe BlockId] -- Table branch
-- The scrutinee is zero-based;
-- zero -> first block
-- one -> second block etc
-- Undefined outside range, and when there's a Nothing
| CmmJump CmmExpr -- Jump to another C-- function,
| CmmReturn -- Return from a native C-- function,
| CmmSwitch -- Table branch
CmmExpr -- The scrutinee is zero-based;
[Maybe BlockId] -- zero -> first block
-- one -> second block etc
-- Undefined outside range, and when
-- there's a Nothing
| CmmJump -- Jump to another C-- function,
CmmExpr -- Target
(Maybe [GlobalReg]) -- Live registers at call site;
-- Nothing -> no information, assume
-- all live
-- Just .. -> info on liveness, []
-- means no live registers
-- This isn't all 'live' registers, just
-- the argument STG registers that are live
-- AND also possibly mapped to machine
-- registers. (So Sp, Hp, HpLim... ect
-- are never included here as they are
-- always live, only R2.., D1.. are
-- on this list)
| CmmReturn -- Return from a native C-- function,
data CmmHinted a
= CmmHinted {
......@@ -201,7 +215,7 @@ instance UserOfLocalRegs CmmStmt where
stmt (CmmBranch _) = id
stmt (CmmCondBranch e _) = gen e
stmt (CmmSwitch e _) = gen e
stmt (CmmJump e) = gen e
stmt (CmmJump e _) = gen e
stmt (CmmReturn) = id
gen :: UserOfLocalRegs a => a -> b -> b
......
......@@ -32,12 +32,11 @@
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
--
module OldPprCmm
( pprStmt
, module PprCmmDecl
, module PprCmmExpr
)
where
module OldPprCmm (
pprStmt,
module PprCmmDecl,
module PprCmmExpr
) where
import BlockId
import CLabel
......@@ -46,7 +45,6 @@ import OldCmm
import PprCmmDecl
import PprCmmExpr
import BasicTypes
import ForeignCall
import Outputable
......@@ -109,7 +107,7 @@ pprStmt platform stmt = case stmt of
-- ;
CmmNop -> semi
-- // text
-- // text
CmmComment s -> text "//" <+> ftext s
-- reg = expr;
......@@ -153,7 +151,7 @@ pprStmt platform stmt = case stmt of
CmmBranch ident -> genBranch ident
CmmCondBranch expr ident -> genCondBranch platform expr ident
CmmJump expr -> genJump platform expr
CmmJump expr live -> genJump platform expr live
CmmReturn -> genReturn platform
CmmSwitch arg ids -> genSwitch platform arg ids
......@@ -176,7 +174,6 @@ pprUpdateFrame platform (UpdateFrame expr args) =
, space
, parens ( commafy $ map (pprPlatform platform) args ) ]
-- --------------------------------------------------------------------------
-- goto local label. [1], section 6.6
--
......@@ -203,17 +200,17 @@ genCondBranch platform expr ident =
--
-- jump foo(a, b, c);
--
genJump :: Platform -> CmmExpr -> SDoc
genJump platform expr =
genJump :: Platform -> CmmExpr -> Maybe [GlobalReg] -> SDoc
genJump platform expr live =
hcat [ ptext (sLit "jump")
, space
, if isTrivialCmmExpr expr
then pprExpr platform expr
else case expr of
CmmLoad (CmmReg _) _ -> pprExpr platform expr
_ -> parens (pprExpr platform expr)
, semi ]
_ -> parens (pprExpr platform expr)
, semi <+> ptext (sLit "// ")
, maybe empty ppr live]
-- --------------------------------------------------------------------------
-- Return from a function. [1], Section 6.8.2 of version 1.128
......@@ -264,3 +261,4 @@ genSwitch platform expr maybe_ids
commafy :: [SDoc] -> SDoc
commafy xs = fsep $ punctuate comma xs
......@@ -248,7 +248,7 @@ pprStmt platform stmt = case stmt of
CmmBranch ident -> pprBranch ident
CmmCondBranch expr ident -> pprCondBranch platform expr ident
CmmJump lbl -> mkJMP_(pprExpr platform lbl) <> semi
CmmJump lbl _ -> mkJMP_(pprExpr platform lbl) <> semi
CmmSwitch arg ids -> pprSwitch platform arg ids
pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
......@@ -930,7 +930,7 @@ te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.hintlessCmm) rs >>
mapM_ (te_Expr.hintlessCmm) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
te_Stmt (CmmJump e) = te_Expr e
te_Stmt (CmmJump e _) = te_Expr e
te_Stmt _ = return ()
te_Expr :: CmmExpr -> TE ()
......
......@@ -362,6 +362,7 @@ mkSlowEntryCode cl_info reg_args
= 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)
......@@ -374,7 +375,8 @@ mkSlowEntryCode cl_info reg_args
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 (entryLabelFromCI cl_info))
live_regs = Just $ map snd reps_w_regs
jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info)) live_regs
\end{code}
......@@ -412,6 +414,7 @@ funWrapper :: ClosureInfo -- Closure whose code body this is
-> Code
funWrapper closure_info arg_regs reg_save_code fun_body = do
{ let node_points = nodeMustPointToIt (closureLFInfo closure_info)
live = Just $ map snd arg_regs
{-
-- Debugging: check that R1 has the correct tag
......@@ -431,8 +434,7 @@ funWrapper closure_info arg_regs reg_save_code fun_body = do
; granYield arg_regs node_points
-- Heap and/or stack checks wrap the function body
; funEntryChecks closure_info reg_save_code
fun_body
; funEntryChecks closure_info reg_save_code live fun_body
}
\end{code}
......@@ -590,7 +592,7 @@ link_caf cl_info _is_upd = do
-- assuming lots of things, like the stack pointer hasn't
-- moved since we entered the CAF.
let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in
stmtC (CmmJump target)
stmtC (CmmJump target $ Just [node])
; returnFC hp_rel }
where
......
......@@ -116,7 +116,7 @@ buildDynCon :: Id -- Name of the thing to which this constr will
-> CostCentreStack -- Where to grab cost centre from;
-- current CCS if currentOrSubsumedCCS
-> DataCon -- The data constructor
-> [(CgRep,CmmExpr)] -- Its args
-> [(CgRep,CmmExpr)] -- Its args
-> FCode CgIdInfo -- Return details about how to find it
buildDynCon binder ccs con args
= do dflags <- getDynFlags
......@@ -348,12 +348,15 @@ cgReturnDataCon con amodes
| otherwise -> build_it_then (jump_to deflt_lbl) }
_otherwise -- The usual case
-> build_it_then emitReturnInstr
-> build_it_then $ emitReturnInstr node_live
}
where
node_live = Just [node]
enter_it = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)),
CmmJump (entryCode (closureInfoPtr (CmmReg nodeReg)))]
jump_to lbl = stmtC (CmmJump (CmmLit lbl))
CmmJump (entryCode $ closureInfoPtr $ CmmReg nodeReg)
node_live
]
jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live
build_it_then return_code
= do { -- BUILD THE OBJECT IN THE HEAP
-- The first "con" says that the name bound to this
......@@ -472,7 +475,7 @@ cgDataCon data_con
-- The case continuation code is expecting a tagged pointer
; stmtC (CmmAssign nodeReg
(tagCons data_con (CmmReg nodeReg)))
; performReturn emitReturnInstr }
; performReturn $ emitReturnInstr (Just []) }
-- noStmts: Ptr to thing already in Node
; whenC (not (isNullaryRepDataCon data_con))
......
......@@ -149,7 +149,7 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
; amode' <- assignTemp amode -- We're going to use it twice,
-- so save in a temp if non-trivial
; stmtC (CmmAssign nodeReg (tagToClosure tycon amode'))
; performReturn emitReturnInstr }
; performReturn $ emitReturnInstr (Just [node]) }
where
-- If you're reading this code in the attempt to figure
-- out why the compiler panic'ed here, it is probably because
......@@ -172,7 +172,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty)
| ReturnsPrim VoidRep <- result_info
= do cgPrimOp [] primop args emptyVarSet
performReturn emitReturnInstr
-- ToDo: STG Live -- worried about this
performReturn $ emitReturnInstr (Just [])
| ReturnsPrim rep <- result_info
= do res <- newTemp (typeCmmType res_ty)
......@@ -191,7 +192,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty)
stmtC (CmmAssign nodeReg
(tagToClosure tycon
(CmmReg (CmmLocal tag_reg))))
performReturn emitReturnInstr
-- ToDo: STG Live -- worried about this
performReturn $ emitReturnInstr (Just [node])
where
result_info = getPrimOpResultInfo primop
......
......@@ -54,6 +54,7 @@ import Outputable
import FastString
import Data.List
import Data.Maybe (fromMaybe)
\end{code}
......@@ -273,21 +274,22 @@ an automatic context switch is done.
A heap/stack check at a function or thunk entry point.
\begin{code}
funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code
funEntryChecks cl_info reg_save_code code
= hpStkCheck cl_info True reg_save_code code
funEntryChecks :: ClosureInfo -> CmmStmts -> Maybe [GlobalReg] -> Code -> Code
funEntryChecks cl_info reg_save_code live code
= hpStkCheck cl_info True reg_save_code live code
thunkEntryChecks :: ClosureInfo -> Code -> Code
thunkEntryChecks cl_info code
= hpStkCheck cl_info False noStmts code
= hpStkCheck cl_info False noStmts (Just [node]) code
hpStkCheck :: ClosureInfo -- Function closure
-> Bool -- Is a function? (not a thunk)
-> CmmStmts -- Register saves
-> Maybe [GlobalReg] -- Live registers
-> Code
-> Code
hpStkCheck cl_info is_fun reg_save_code code
hpStkCheck cl_info is_fun reg_save_code live code
= getFinalStackHW $ \ spHw -> do
{ sp <- getRealSp
; let stk_words = spHw - sp
......@@ -295,17 +297,18 @@ hpStkCheck cl_info is_fun reg_save_code code
{ -- Emit heap checks, but be sure to do it lazily so
-- that the conditionals on hpHw don't cause a black hole
codeOnly $ do
{ do_checks stk_words hpHw full_save_code rts_label
{ do_checks stk_words hpHw full_save_code rts_label full_live
; tickyAllocHeap hpHw }
; setRealHp hpHw
; code }
}
where
node_asst
(node_asst, full_live)
| nodeMustPointToIt (closureLFInfo cl_info)
= noStmts
= (noStmts, live)
| otherwise
= oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
= (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
,Just $ node : fromMaybe [] live)
-- Strictly speaking, we should tag node here. But if
-- node doesn't point to the closure, the code for the closure
-- cannot depend on the value of R1 anyway, so we're safe.
......@@ -349,12 +352,17 @@ altHeapCheck alt_type code
{ codeOnly $ do
{ do_checks 0 {- no stack chk -} hpHw
noStmts {- nothign to save -}
(rts_label alt_type)
rts_label live
; tickyAllocHeap hpHw }
; setRealHp hpHw
; code }
where
rts_label PolyAlt = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1")))
(rts_label, live) = gc_info alt_type
mkL l = CmmLit . CmmLabel $ mkCmmCodeLabel rtsPackageId (fsLit l)
gc_info PolyAlt = (mkL "stg_gc_unpt_r1" , Just [node])
-- Do *not* enter R1 after a heap check in
-- a polymorphic case. It might be a function
-- and the entry code for a function (currently)
......@@ -362,22 +370,21 @@ altHeapCheck alt_type code
--
-- However R1 is guaranteed to be a pointer
rts_label (AlgAlt _) = stg_gc_enter1
gc_info (AlgAlt _) = (stg_gc_enter1, Just [node])
-- Enter R1 after the heap check; it's a pointer
rts_label (PrimAlt tc)
= CmmLit $ CmmLabel $
case primRepToCgRep (tyConPrimRep tc) of
VoidArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")
FloatArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_f1")
DoubleArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_d1")
LongArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_l1")
gc_info (PrimAlt tc)
= case primRepToCgRep (tyConPrimRep tc) of
VoidArg -> (mkL "stg_gc_noregs", Just [])
FloatArg -> (mkL "stg_gc_f1", Just [FloatReg 1])
DoubleArg -> (mkL "stg_gc_d1", Just [DoubleReg 1])
LongArg -> (mkL "stg_gc_l1", Just [LongReg 1])
-- R1 is boxed but unlifted:
PtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1")
PtrArg -> (mkL "stg_gc_unpt_r1", Just [node])
-- R1 is unboxed:
NonPtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unbx_r1")
NonPtrArg -> (mkL "stg_gc_unbx_r1", Just [node])
rts_label (UbxTupAlt _) = panic "altHeapCheck"
gc_info (UbxTupAlt _) = panic "altHeapCheck"
\end{code}
......@@ -404,7 +411,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
| otherwise
= initHeapUsage $ \ hpHw -> do
{ codeOnly $ do { do_checks 0 {- no stack check -} hpHw
full_fail_code rts_label
full_fail_code rts_label live
; tickyAllocHeap hpHw }
; setRealHp hpHw
; code }
......@@ -413,6 +420,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho!
(CmmLit (mkWordCLit liveness))
liveness = mkRegLiveness regs ptrs nptrs
live = Just $ map snd regs
rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
\end{code}
......@@ -434,14 +442,15 @@ again on re-entry because someone else might have stolen the resource
in the meantime.
\begin{code}
do_checks :: WordOff -- Stack headroom
-> WordOff -- Heap headroom
-> CmmStmts -- Assignments to perform on failure
-> CmmExpr -- Rts address to jump to on failure
do_checks :: WordOff -- Stack headroom
-> WordOff -- Heap headroom
-> CmmStmts -- Assignments to perform on failure
-> CmmExpr -- Rts address to jump to on failure
-> Maybe [GlobalReg] -- Live registers
-> Code
do_checks 0 0 _ _ = nopC
do_checks 0 0 _ _ _ = nopC
do_checks _ hp _ _
do_checks _ hp _ _ _
| hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W
= sorry (unlines [
"Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.",
......@@ -450,21 +459,22 @@ do_checks _ hp _ _
"Suggestion: read data from a file instead of having large static data",
"structures in the code."])
do_checks stk hp reg_save_code rts_lbl
do_checks stk hp reg_save_code rts_lbl live
= do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE)))
(CmmLit (mkIntCLit (hp*wORD_SIZE)))
(stk /= 0) (hp /= 0) reg_save_code rts_lbl
(stk /= 0) (hp /= 0) reg_save_code rts_lbl live
-- The offsets are now in *bytes*
do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Code
do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr
-> Maybe [GlobalReg] -> Code
do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live
= do { doGranAllocate hp_expr
-- The failure block: this saves the registers and jumps to
-- the appropriate RTS stub.
; exit_blk_id <- forkLabelledCode $ do {
; emitStmts reg_save_code
; stmtC (CmmJump rts_lbl) }
; stmtC (CmmJump rts_lbl live) }
-- In the case of a heap-check failure, we must also set
-- HpAlloc. NB. HpAlloc is *only* set if Hp has been
......@@ -514,7 +524,8 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl
\begin{code}
hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
hpChkGen bytes liveness reentry
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns
stg_gc_gen (Just activeStgRegs)
where
assigns = mkStmts [ mk_vanilla_assignment 9 liveness,
mk_vanilla_assignment 10 reentry ]
......@@ -523,12 +534,14 @@ hpChkGen bytes liveness reentry
-- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
hpChkNodePointsAssignSp0 bytes sp0
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1
= do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign
stg_gc_enter1 (Just [node])
where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
stkChkGen bytes liveness reentry
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns
stg_gc_gen (Just activeStgRegs)
where
assigns = mkStmts [ mk_vanilla_assignment 9 liveness,
mk_vanilla_assignment 10 reentry ]
......@@ -539,7 +552,8 @@ mk_vanilla_assignment n e
stkChkNodePoints :: CmmExpr -> Code
stkChkNodePoints bytes
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1
= do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts
stg_gc_enter1 (Just [node])
stg_gc_gen :: CmmExpr
stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen")))
......
......@@ -250,10 +250,10 @@ emitAlgReturnTarget name branches mb_deflt fam_sz
-- global labels, so we can't use them at the 'call site'
--------------------------------
emitReturnInstr :: Code
emitReturnInstr
= do { info_amode <- getSequelAmode
; stmtC (CmmJump (entryCode info_amode)) }
emitReturnInstr :: Maybe [GlobalReg] -> Code
emitReturnInstr live
= do { info_amode <- getSequelAmode
; stmtC (CmmJump (entryCode info_amode) live) }
-----------------------------------------------------------------------------
--
......
......@@ -249,7 +249,7 @@ flattenCgStmts id stmts =
where (block,blocks) = flatten ss
isJump :: CmmStmt -> Bool
isJump (CmmJump _ ) = True
isJump (CmmJump _ _) = True
isJump (CmmBranch _ ) = True
isJump (CmmSwitch _ _) = True
isJump (CmmReturn ) = True
......
......@@ -45,6 +45,7 @@ import Outputable
import StaticFlags
import Control.Monad
import Data.Maybe
-----------------------------------------------------------------------------
-- Tail Calls
......@@ -103,17 +104,19 @@ performTailCall fun_info arg_amodes pending_assts
-- to make the heap check easier. The tail-call sequence
-- is very similar to returning an unboxed tuple, so we
-- share some code.
do { (final_sp, arg_assts) <- pushUnboxedTuple join_sp arg_amodes
do { (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes
; emitSimultaneously (pending_assts `plusStmts` arg_assts)
; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info))
; doFinalJump final_sp True {- Is LNE -} (jumpToLbl lbl) }
; doFinalJump final_sp True $ jumpToLbl lbl (Just live) }
| otherwise
= do { fun_amode <- idInfoToAmode fun_info
; let assignSt = CmmAssign nodeReg fun_amode
node_asst = oneStmt assignSt
opt_node_asst | nodeMustPointToIt lf_info = node_asst
| otherwise = noStmts
node_live = Just [node]
(opt_node_asst, opt_node_live)
| nodeMustPointToIt lf_info = (node_asst, node_live)
| otherwise = (noStmts, Just [])
; EndOfBlockInfo sp _ <- getEndOfBlockInfo
; dflags <- getDynFlags
......@@ -122,8 +125,8 @@ performTailCall fun_info arg_amodes pending_assts
-- Node must always point to things we enter
EnterIt -> do
{ emitSimultaneously (node_asst `plusStmts` pending_assts)
; let target = entryCode (closureInfoPtr (CmmReg nodeReg))
enterClosure = stmtC (CmmJump target)
; let target = entryCode (closureInfoPtr (CmmReg nodeReg))
enterClosure = stmtC (CmmJump target node_live)
-- If this is a scrutinee
-- let's check if the closure is a constructor
-- so we can directly jump to the alternatives switch
......@@ -137,18 +140,18 @@ performTailCall fun_info arg_amodes pending_assts
-- As with any return, Node must point to it.
ReturnIt -> do
{ emitSimultaneously (node_asst `plusStmts` pending_assts)
; doFinalJump sp False emitReturnInstr }
; doFinalJump sp False $ emitReturnInstr node_live }
-- A real constructor. Don't bother entering it,
-- just do the right sort of return instead.
-- As with any return, Node must point to it.
ReturnCon _ -> do
{ emitSimultaneously (node_asst `plusStmts` pending_assts)
; doFinalJump sp False emitReturnInstr }
; doFinalJump sp False $ emitReturnInstr node_live }
JumpToIt lbl -> do
{ emitSimultaneously (opt_node_asst `plusStmts` pending_assts)
; doFinalJump sp False (jumpToLbl lbl) }
; doFinalJump sp False $ jumpToLbl lbl opt_node_live }
-- A slow function call via the RTS apply routines
-- Node must definitely point to the thing
......@@ -163,7 +166,7 @@ performTailCall fun_info arg_amodes pending_assts
; let (apply_lbl, args, extra_args)
= constructSlowCall arg_amodes
; directCall sp apply_lbl args extra_args