From: Edward Z. Yang <ezyang@mit.edu>
Date: Wed, 23 Mar 2011 13:43:30 +0000 (+0000)
Subject: Immediately tag initialization code to prevent untagged spills.
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cb5260d444da0f74c2e06c7857dff2f163415ebd

Immediately tag initialization code to prevent untagged spills.

When allocating new objects on the heap, we previously returned
a CmmExpr containing the heap pointer as well as the tag expression,
which would be added to the code graph upon first usage.  Unfortunately,
this meant that untagged heap pointers living in registers might
be spilled to the stack, where they interacted poorly with garbage
collection (we saw this bug specifically with the compacting garbage
collector.)

This fix immediately tags the register containing the heap pointer,
so that unless we have extremely unfriendly spill code, the new pointer
will never be spilled to the stack untagged.

An alternate solution might have been to modify allocDynClosure to
tag the pointer upon the initial register allocation, but not all
invocations of allocDynClosure tag the resulting pointer, and
threading the consequent CgIdInfo for the cases that did would have
been annoying.
---

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index bfb749c..2947d33 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -301,7 +301,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
 				         (map toVarArg fv_details)
 
 	-- RETURN
-	; return $ (regIdInfo bndr lf_info tmp, init) }
+	; regIdInfo bndr lf_info tmp init }
 
 -- Use with care; if used inappropriately, it could break invariants.
 stripNV :: NonVoid a -> a
@@ -336,7 +336,7 @@ cgStdThunk bndr cc _bndr_info body lf_info payload
   ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
 
 	-- RETURN
-  ; returnFC $ (regIdInfo bndr lf_info tmp, init) }
+  ; regIdInfo bndr lf_info tmp init }
 
 mkClosureLFInfo :: Id		-- The binder
 		-> TopLevelFlag	-- True of top level
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 633d577..368bc53 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -193,7 +193,7 @@ buildDynCon binder ccs con args
   = do	{ let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args)
 		-- No void args in args_w_offsets
 	; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
- 	; return (regIdInfo binder lf_info tmp, init) }
+	; regIdInfo binder lf_info tmp init }
   where
     lf_info = mkConLFInfo con
 
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index 469f58d..369e199 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -37,6 +37,7 @@ import CLabel
 import BlockId
 import CmmExpr
 import CmmUtils
+import MkGraph (CmmAGraph, mkAssign, (<*>))
 import FastString
 import Id
 import VarEnv
@@ -86,9 +87,16 @@ litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
 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 (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
+-- Because the register may be spilled to the stack in untagged form, we
+-- modify the initialization code 'init' to immediately tag the
+-- register, and store a plain register in the CgIdInfo.  We allocate
+-- a new register in order to keep single-assignment and help out the
+-- inliner. -- EZY
+regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CmmAGraph -> FCode (CgIdInfo, CmmAGraph)
+regIdInfo id lf_info reg init = do
+  reg' <- newTemp (localRegType reg)
+  let init' = init <*> mkAssign (CmmLocal reg') (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
+  return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg')), init')
 
 idInfoToAmode :: CgIdInfo -> CmmExpr
 -- Returns a CmmExpr for the *tagged* pointer