Merge in more HEAD, fix stuff up

8 files changed, 127 insertions, 94 deletions

diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 8e599c3fb5..d6537c27e5 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/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
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index 99690945cb..9049504dca 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/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))
diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs
index e69db9f61b..cb3a86ef7f 100644
--- a/compiler/codeGen/CgExpr.lhs
+++ b/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
 
diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
index d8ac298b58..dfe146dfc8 100644
--- a/compiler/codeGen/CgHeapery.lhs
+++ b/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")))
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 9f003a2302..1e80616887 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/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) }
 
 -----------------------------------------------------------------------------
 --
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index c05019e3ac..c0e3e3be8b 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/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
diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index 07be7f23fa..499529d841 100644
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/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 
+		; directCall sp apply_lbl args extra_args node_live
 			(node_asst `plusStmts` pending_assts)
 
 		}
@@ -179,7 +182,7 @@ performTailCall fun_info arg_amodes pending_assts
 		     -- The args beyond the arity go straight on the stack
 		     (arity_args, extra_args) = splitAt arity arg_amodes
      
-		; directCall sp lbl arity_args extra_args
+		; directCall sp lbl arity_args extra_args opt_node_live
 			(opt_node_asst `plusStmts` pending_assts)
 	        }
 	}
@@ -203,7 +206,8 @@ performTailCall fun_info arg_amodes pending_assts
                    -- No, enter the closure.
                    ; enterClosure
                    ; labelC is_constr
-                   ; stmtC (CmmJump (entryCode $ CmmLit (CmmLabel lbl)))
+                   ; stmtC (CmmJump (entryCode $
+                               CmmLit (CmmLabel lbl)) (Just [node]))
                    }
 {-
               -- This is a scrutinee for a case expression
@@ -243,9 +247,9 @@ performTailCall fun_info arg_amodes pending_assts
 -}
 
 directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)]
-           -> [(CgRep, CmmExpr)] -> CmmStmts
+           -> [(CgRep, CmmExpr)] -> Maybe [GlobalReg] -> CmmStmts
            -> Code
-directCall sp lbl args extra_args assts = do
+directCall sp lbl args extra_args live_node assts = do
   let
 	-- First chunk of args go in registers
 	(reg_arg_amodes, stk_args) = assignCallRegs args
@@ -255,14 +259,12 @@ directCall sp lbl args extra_args assts = do
 	slow_stk_args = slowArgs extra_args
 
 	reg_assts = assignToRegs reg_arg_amodes
+        live_args = map snd reg_arg_amodes
+        live_regs = Just $ (fromMaybe [] live_node) ++ live_args
   --
   (final_sp, stk_assts) <- mkStkAmodes sp (stk_args ++ slow_stk_args)
-
-  emitSimultaneously (reg_assts     `plusStmts`
-		      stk_assts     `plusStmts`
-		      assts)
-
-  doFinalJump final_sp False (jumpToLbl lbl)
+  emitSimultaneously $ reg_assts `plusStmts` stk_assts `plusStmts` assts
+  doFinalJump final_sp False $ jumpToLbl lbl live_regs
 
 -- -----------------------------------------------------------------------------
 -- The final clean-up before we do a jump at the end of a basic block.
@@ -296,20 +298,27 @@ performReturn :: Code	-- The code to execute to actually do the return
 
 performReturn finish_code
   = do  { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo
-	; doFinalJump args_sp False{-not a LNE-} finish_code }
+	; doFinalJump args_sp False finish_code }
 
 -- ----------------------------------------------------------------------------
 -- Primitive Returns
 -- Just load the return value into the right register, and return.
 
-performPrimReturn :: CgRep -> CmmExpr	-- The thing to return
-		  -> Code
-performPrimReturn rep amode
-  =  do { whenC (not (isVoidArg rep))
-		(stmtC (CmmAssign ret_reg amode))
-	; performReturn emitReturnInstr }
+performPrimReturn :: CgRep -> CmmExpr -> Code
+
+-- non-void return value
+performPrimReturn rep amode | not (isVoidArg rep)
+  = do { stmtC (CmmAssign ret_reg amode)
+       ; performReturn $ emitReturnInstr live_regs }
   where
-    ret_reg = dataReturnConvPrim rep
+    -- careful here as 'dataReturnConvPrim' will panic if given a Void rep
+    ret_reg@(CmmGlobal r) = dataReturnConvPrim rep
+    live_regs = Just [r]
+
+-- void return value
+performPrimReturn _ _
+  = performReturn $ emitReturnInstr (Just [])
+
 
 -- ---------------------------------------------------------------------------
 -- Unboxed tuple returns
@@ -329,19 +338,21 @@ returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code
 returnUnboxedTuple amodes
   = do 	{ (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo
 	; tickyUnboxedTupleReturn (length amodes)
-	; (final_sp, assts) <- pushUnboxedTuple args_sp amodes
+	; (final_sp, assts, live_regs) <- pushUnboxedTuple args_sp amodes
 	; emitSimultaneously assts
-	; doFinalJump final_sp False{-not a LNE-} emitReturnInstr }
+	; doFinalJump final_sp False $ emitReturnInstr (Just live_regs) }
 
 pushUnboxedTuple :: VirtualSpOffset		-- Sp at which to start pushing
 		 -> [(CgRep, CmmExpr)]		-- amodes of the components
 		 -> FCode (VirtualSpOffset,	-- final Sp
-			   CmmStmts)		-- assignments (regs+stack)
+			   CmmStmts,		-- assignments (regs+stack)
+                           [GlobalReg])         -- registers used (liveness)
 
 pushUnboxedTuple sp [] 
-  = return (sp, noStmts)
+  = return (sp, noStmts, [])
 pushUnboxedTuple sp amodes
   = do	{ let	(reg_arg_amodes, stk_arg_amodes) = assignReturnRegs amodes
+                live_regs = map snd reg_arg_amodes
 	
 		-- separate the rest of the args into pointers and non-pointers
 		(ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes
@@ -352,8 +363,8 @@ pushUnboxedTuple sp amodes
 	; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args
 
 	; returnFC (final_sp,
-	  	    reg_arg_assts `plusStmts` 
-		    ptr_assts `plusStmts` nptr_assts) }
+	  	    reg_arg_assts `plusStmts` ptr_assts `plusStmts` nptr_assts,
+                    live_regs) }
     
 		  
 -- -----------------------------------------------------------------------------
@@ -403,13 +414,14 @@ tailCallPrim lbl args
 		-- Hence the ASSERT( null leftovers )
 	  arg_amodes <- getArgAmodes args
 	; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes
-	      jump_to_primop = jumpToLbl lbl
+              live_regs = Just $ map snd arg_regs
+	      jump_to_primop = jumpToLbl lbl live_regs
 
 	; ASSERT(null leftovers) -- no stack-resident args
  	  emitSimultaneously (assignToRegs arg_regs)
 
 	; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo
-	; doFinalJump args_sp False{-not a LNE-} jump_to_primop }
+	; doFinalJump args_sp False jump_to_primop }
 
 -- -----------------------------------------------------------------------------
 -- Return Addresses
@@ -439,8 +451,8 @@ pushReturnAddress _ = nopC
 -- Misc.
 
 -- Passes no argument to the destination procedure
-jumpToLbl :: CLabel -> Code
-jumpToLbl lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl)))
+jumpToLbl :: CLabel -> Maybe [GlobalReg] -> Code
+jumpToLbl lbl live = stmtC $ CmmJump (CmmLit $ CmmLabel lbl) live
 
 assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts
 assignToRegs reg_args 
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 2a524a182c..2bd35c8796 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -1020,7 +1020,7 @@ fixStgRegStmt stmt
 
         CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
 
-        CmmJump addr -> CmmJump (fixStgRegExpr addr)
+        CmmJump addr live -> CmmJump (fixStgRegExpr addr) live
 
         -- CmmNop, CmmComment, CmmBranch, CmmReturn
         _other -> stmt