make CAFs atomic, to fix #5558

See Note [atomic CAFs] in rts/sm/Storage.c

4 files changed, 42 insertions, 43 deletions

diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 2f312016c7..51bc00650f 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -572,27 +572,26 @@ link_caf cl_info _is_upd = do
 	-- so that the garbage collector can find them
 	-- This must be done *before* the info table pointer is overwritten, 
 	-- because the old info table ptr is needed for reversion
-  ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
+  ; ret <- newTemp bWord
+  ; emitRtsCallGen [CmmHinted ret NoHint] rtsPackageId (fsLit "newCAF")
       [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
-        CmmHinted (CmmReg nodeReg) AddrHint ]
-      [node] False
+        CmmHinted (CmmReg nodeReg) AddrHint,
+        CmmHinted hp_rel AddrHint ]
+      (Just [node]) False
 	-- node is live, so save it.
 
-	-- Overwrite the closure with a (static) indirection 
-	-- to the newly-allocated black hole
-  ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
-	   , CmmStore (CmmReg nodeReg) ind_static_info ]
+  -- see Note [atomic CAF entry] in rts/sm/Storage.c
+  ; emitIf (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) $
+        -- re-enter R1.  Doing this directly is slightly dodgy; we're
+        -- 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 [])
 
   ; returnFC hp_rel }
   where
     bh_cl_info :: ClosureInfo
     bh_cl_info = cafBlackHoleClosureInfo cl_info
-
-    ind_static_info :: CmmExpr
-    ind_static_info = mkLblExpr mkIndStaticInfoLabel
-
-    off_indirectee :: WordOff
-    off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
 \end{code}
 
 
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index a71702cb4c..5c52eeb2c6 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -13,6 +13,7 @@ module CgUtils (
         emitRODataLits, mkRODataLits,
         emitIf, emitIfThenElse,
         emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
+        emitRtsCallGen,
         assignTemp, assignTemp_, newTemp,
         emitSimultaneously,
         emitSwitch, emitLitSwitch,
@@ -235,22 +236,23 @@ emitRtsCall
    -> Bool                      -- ^ whether this is a safe call
    -> Code                      -- ^ cmm code
 
-emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
+emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args Nothing safe
    -- The 'Nothing' says "save all global registers"
 
 emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
 emitRtsCallWithVols pkg fun args vols safe
-   = emitRtsCall' [] pkg fun args (Just vols) safe
+   = emitRtsCallGen [] pkg fun args (Just vols) safe
 
 emitRtsCallWithResult
    :: LocalReg -> ForeignHint
    -> PackageId -> FastString
    -> [CmmHinted CmmExpr] -> Bool -> Code
+
 emitRtsCallWithResult res hint pkg fun args safe
-   = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe
+   = emitRtsCallGen [CmmHinted res hint] pkg fun args Nothing safe
 
 -- Make a call to an RTS C procedure
-emitRtsCall'
+emitRtsCallGen
    :: [CmmHinted LocalReg]
    -> PackageId
    -> FastString
@@ -258,7 +260,7 @@ emitRtsCall'
    -> Maybe [GlobalReg]
    -> Bool -- True <=> CmmSafe call
    -> Code
-emitRtsCall' res pkg fun args vols safe = do
+emitRtsCallGen res pkg fun args vols safe = do
   safety <- if safe
             then getSRTInfo >>= (return . CmmSafe)
             else return CmmUnsafe
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 1bf9366f50..9f66684603 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -644,25 +644,24 @@ link_caf _is_upd = do
 	-- so that the garbage collector can find them
 	-- This must be done *before* the info table pointer is overwritten,
 	-- because the old info table ptr is needed for reversion
-  ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
+  ; ret <- newTemp bWord
+  ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF")
       [ (CmmReg (CmmGlobal BaseReg),  AddrHint),
-        (CmmReg nodeReg, AddrHint) ]
-      [node] False
-	-- node is live, so save it.
-
-	-- Overwrite the closure with a (static) indirection
-	-- to the newly-allocated black hole
-  ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
-	  mkStore (CmmReg nodeReg) ind_static_info)
+        (CmmReg nodeReg, AddrHint),
+        (CmmReg (CmmLocal hp_rel), AddrHint) ]
+      (Just [node]) False
+        -- node is live, so save it.
+
+  -- see Note [atomic CAF entry] in rts/sm/Storage.c
+  ; emit $ mkCmmIfThen
+      (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) $
+        -- re-enter R1.  Doing this directly is slightly dodgy; we're
+        -- assuming lots of things, like the stack pointer hasn't
+        -- moved since we entered the CAF.
+        let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in
+        mkJump target [] 0
 
   ; return hp_rel }
-  where
-    ind_static_info :: CmmExpr
-    ind_static_info = mkLblExpr mkIndStaticInfoLabel
-
-    off_indirectee :: WordOff
-    off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
-
 
 ------------------------------------------------------------------------
 --		Profiling
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 509a1ebbb4..ddb87e4ffe 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -10,8 +10,8 @@ module StgCmmUtils (
 	cgLit, mkSimpleLit,
 	emitDataLits, mkDataLits,
         emitRODataLits, mkRODataLits,
-	emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
-	assignTemp, newTemp, withTemp,
+        emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, emitRtsCallGen,
+        assignTemp, newTemp, withTemp,
 
 	newUnboxedTupleRegs,
 
@@ -171,20 +171,20 @@ tagToClosure tycon tag
 -------------------------------------------------------------------------
 
 emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
+emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args Nothing safe
    -- The 'Nothing' says "save all global registers"
 
 emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
 emitRtsCallWithVols pkg fun args vols safe
-   = emitRtsCall' [] pkg fun args (Just vols) safe
+   = emitRtsCallGen [] pkg fun args (Just vols) safe
 
 emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
 	-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 emitRtsCallWithResult res hint pkg fun args safe
-   = emitRtsCall' [(res,hint)] pkg fun args Nothing safe
+   = emitRtsCallGen [(res,hint)] pkg fun args Nothing safe
 
 -- Make a call to an RTS C procedure
-emitRtsCall'
+emitRtsCallGen
    :: [(LocalReg,ForeignHint)]
    -> PackageId
    -> FastString
@@ -192,9 +192,8 @@ emitRtsCall'
    -> Maybe [GlobalReg]
    -> Bool -- True <=> CmmSafe call
    -> FCode ()
-emitRtsCall' res pkg fun args _vols safe
-  = --error "emitRtsCall'"
-    do { updfr_off <- getUpdFrameOff
+emitRtsCallGen res pkg fun args _vols safe
+  = do { updfr_off <- getUpdFrameOff
        ; emit caller_save
        ; emit $ call updfr_off
        ; emit caller_load }