From 787b08bdea84cca4bf9490d87c059453bffc5ad2 Mon Sep 17 00:00:00 2001
From: "dias@cs.tufts.edu" <unknown>
Date: Fri, 18 Sep 2009 19:07:53 +0000
Subject: [PATCH] Keep Touch'd variables live through the back end When we
 used derived pointers into the middle of an object, we need
 to keep the pointer to the start of the object live. We use
 a "fat machine instruction" with the primitive MO_Touch to
 propagate this information through the back end.

---
 compiler/cmm/Cmm.hs               |    1 +
 compiler/cmm/CmmCvt.hs            |    1 +
 compiler/cmm/ZipCfgCmmRep.hs      |   14 +++++++-------
 compiler/codeGen/StgCmmForeign.hs |    4 ++--
 compiler/codeGen/StgCmmPrim.hs    |    8 ++++----
 5 files changed, 15 insertions(+), 13 deletions(-)

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 4b18e46..c48269e 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -384,6 +384,7 @@ data CallishMachOp
   | MO_F32_Exp
   | MO_F32_Sqrt
   | MO_WriteBarrier
+  | MO_Touch         -- Keep variables live (when using interior pointers)
   deriving (Eq, Show)
 
 pprCallishMachOp :: CallishMachOp -> SDoc
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index 7f5de60..4d41325 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -115,6 +115,7 @@ ofZgraph g = ListGraph $ swallow blocks
           mid (MidComment s)  = CmmComment s
           mid (MidAssign l r) = CmmAssign l r
           mid (MidStore  l r) = CmmStore  l r
+          mid (MidForeignCall _ (PrimTarget MO_Touch) _ _) = CmmNop
           mid (MidForeignCall _ target ress args)
 		= CmmCall (cmm_target target)
 			  (add_hints conv Results   ress) 
diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 451450e..a061be8 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -114,13 +114,13 @@ data Last
 	  -- the call goes into a loop.
 	}
 
-data MidCallTarget	-- The target of a MidUnsafeCall
-  = ForeignTarget 	-- A foreign procedure
-	CmmExpr			-- Its address
-	ForeignConvention	-- Its calling convention
+data MidCallTarget        -- The target of a MidUnsafeCall
+  = ForeignTarget         -- A foreign procedure
+        CmmExpr                  -- Its address
+        ForeignConvention        -- Its calling convention
 
-  | PrimTarget		-- A possibly-side-effecting machine operation
-	CallishMachOp		-- Which one
+  | PrimTarget            -- A possibly-side-effecting machine operation
+        CallishMachOp            -- Which one
   deriving Eq
 
 data Convention
@@ -277,8 +277,8 @@ instance UserOfLocalRegs MidCallTarget where
   foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
 
 instance UserOfSlots MidCallTarget where
+  foldSlotsUsed  f z (ForeignTarget e _) = foldSlotsUsed f z e
   foldSlotsUsed _f z (PrimTarget _)      = z
-  foldSlotsUsed f  z (ForeignTarget e _) = foldSlotsUsed f z e
 
 instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
   foldRegsUsed f z (Just x) = foldRegsUsed f z x
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index fae4f2f..89a2b27 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -97,9 +97,9 @@ emitCCall hinted_results fn hinted_args
     fc = ForeignConvention CCallConv arg_hints result_hints
     
 
-emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
+emitPrimCall :: CmmFormals -> CallishMachOp -> CmmActuals -> FCode ()
 emitPrimCall res op args
-  = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
+  = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn
 
 -- alternative entry point, used by CmmParse
 emitForeignCall
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index e5ff8f7..3318ec9 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -232,8 +232,8 @@ emitPrimOp [res] SizeofMutableByteArrayOp [arg]
 
 
 --  #define touchzh(o)                  /* nothing */
-emitPrimOp [] TouchOp [_arg]
-   = nopC
+emitPrimOp res@[] TouchOp args@[_arg]
+   = do emitPrimCall res MO_Touch args
 
 --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 emitPrimOp [res] ByteArrayContents_Char [arg]
@@ -413,9 +413,9 @@ emitPrimOp [res] op [arg]
    = emit (mkAssign (CmmLocal res) $
 	   CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]])
 
-emitPrimOp [res] op args
+emitPrimOp r@[res] op args
    | Just prim <- callishOp op
-   = do emitPrimCall res prim args
+   = do emitPrimCall r prim args
 
    | Just mop <- translateOp op
    = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
-- 
1.7.10.4