make CAFs atomic, to fix #5558

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

1 files changed, 12 insertions, 13 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}