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.

compiler/cmm/CmmCvt.hs

@@ -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
+

compiler/cmm/CmmLint.hs

@@ -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 ()

compiler/cmm/CmmOpt.hs

@@ -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
 

compiler/cmm/CmmParse.y

@@ -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

compiler/cmm/OldCmm.hs

@@ -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

compiler/cmm/OldPprCmm.hs

@@ -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
+

compiler/cmm/PprC.hs

@@ -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 ()

compiler/codeGen/CgClosure.lhs

@@ -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

compiler/codeGen/CgCon.lhs

@@ -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))

compiler/codeGen/CgExpr.lhs

@@ -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
 

compiler/codeGen/CgHeapery.lhs

@@ -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")))

compiler/codeGen/CgInfoTbls.hs

@@ -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) }
 
 -----------------------------------------------------------------------------
 --

compiler/codeGen/CgMonad.lhs

@@ -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

compiler/codeGen/CgTailCall.lhs

@@ -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