make CAFs atomic, to fix #5558

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

6 files changed, 150 insertions, 82 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 }
diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h
index e745b0460b..fef8e00598 100644
--- a/includes/rts/storage/GC.h
+++ b/includes/rts/storage/GC.h
@@ -170,8 +170,8 @@ void performMajorGC(void);
    The CAF table - used to let us revert CAFs in GHCi
    -------------------------------------------------------------------------- */
 
-void newCAF     (StgRegTable *reg, StgClosure *);
-void newDynCAF  (StgRegTable *reg, StgClosure *);
+StgWord newCAF    (StgRegTable *reg, StgClosure *caf, StgClosure *bh);
+StgWord newDynCAF (StgRegTable *reg, StgClosure *caf, StgClosure *bh);
 void revertCAFs (void);
 
 // Request that all CAFs are retained indefinitely.
diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index f8a9e559bf..82e89a5470 100644
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -229,21 +229,47 @@ freeStorage (rtsBool free_heap)
 
    The entry code for every CAF does the following:
      
-      - builds a BLACKHOLE in the heap
-      - pushes an update frame pointing to the BLACKHOLE
-      - calls newCaf, below
-      - updates the CAF with a static indirection to the BLACKHOLE
-      
+      - builds a CAF_BLACKHOLE in the heap
+
+      - calls newCaf, which atomically updates the CAF with
+        IND_STATIC pointing to the CAF_BLACKHOLE
+
+      - if newCaf returns zero, it re-enters the CAF (see Note [atomic
+        CAF entry])
+
+      - pushes an update frame pointing to the CAF_BLACKHOLE
+
    Why do we build an BLACKHOLE in the heap rather than just updating
    the thunk directly?  It's so that we only need one kind of update
-   frame - otherwise we'd need a static version of the update frame too.
+   frame - otherwise we'd need a static version of the update frame
+   too, and various other parts of the RTS that deal with update
+   frames would also need special cases for static update frames.
 
    newCaf() does the following:
        
+      - it updates the CAF with an IND_STATIC pointing to the
+        CAF_BLACKHOLE, atomically.
+
       - it puts the CAF on the oldest generation's mutable list.
         This is so that we treat the CAF as a root when collecting
 	younger generations.
 
+   ------------------
+   Note [atomic CAF entry]
+
+   With THREADED_RTS, newCaf() is required to be atomic (see
+   #5558). This is because if two threads happened to enter the same
+   CAF simultaneously, they would create two distinct CAF_BLACKHOLEs,
+   and so the normal threadPaused() machinery for detecting duplicate
+   evaluation will not detect this.  Hence in lockCAF() below, we
+   atomically lock the CAF with WHITEHOLE before updating it with
+   IND_STATIC, and return zero if another thread locked the CAF first.
+   In the event that we lost the race, CAF entry code will re-enter
+   the CAF and block on the other thread's CAF_BLACKHOLE.
+
+   ------------------
+   Note [GHCi CAFs]
+
    For GHCI, we have additional requirements when dealing with CAFs:
 
       - we must *retain* all dynamically-loaded CAFs ever entered,
@@ -264,36 +290,76 @@ freeStorage (rtsBool free_heap)
 
    -------------------------------------------------------------------------- */
 
-void
-newCAF(StgRegTable *reg, StgClosure* caf)
+STATIC_INLINE StgWord lockCAF (StgClosure *caf, StgClosure *bh)
 {
-  if(keepCAFs)
-  {
-    // HACK:
-    // If we are in GHCi _and_ we are using dynamic libraries,
-    // then we can't redirect newCAF calls to newDynCAF (see below),
-    // so we make newCAF behave almost like newDynCAF.
-    // The dynamic libraries might be used by both the interpreted
-    // program and GHCi itself, so they must not be reverted.
-    // This also means that in GHCi with dynamic libraries, CAFs are not
-    // garbage collected. If this turns out to be a problem, we could
-    // do another hack here and do an address range test on caf to figure
-    // out whether it is from a dynamic library.
-    ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
-
-    ACQUIRE_SM_LOCK; // caf_list is global, locked by sm_mutex
-    ((StgIndStatic *)caf)->static_link = caf_list;
-    caf_list = caf;
-    RELEASE_SM_LOCK;
-  }
-  else
-  {
-    // Put this CAF on the mutable list for the old generation.
-    ((StgIndStatic *)caf)->saved_info = NULL;
-    if (oldest_gen->no != 0) {
-        recordMutableCap(caf, regTableToCapability(reg), oldest_gen->no);
+    const StgInfoTable *orig_info;
+
+    orig_info = caf->header.info;
+
+#ifdef THREADED_RTS
+    const StgInfoTable *cur_info;
+
+    if (orig_info == &stg_IND_STATIC_info ||
+        orig_info == &stg_WHITEHOLE_info) {
+        // already claimed by another thread; re-enter the CAF
+        return 0;
     }
-  }
+
+    cur_info = (const StgInfoTable *)
+        cas((StgVolatilePtr)&caf->header.info,
+            (StgWord)orig_info,
+            (StgWord)&stg_WHITEHOLE_info);
+
+    if (cur_info != orig_info) {
+        // already claimed by another thread; re-enter the CAF
+        return 0;
+    }
+
+    // successfully claimed by us; overwrite with IND_STATIC
+#endif
+
+    // For the benefit of revertCAFs(), save the original info pointer
+    ((StgIndStatic *)caf)->saved_info  = orig_info;
+
+    ((StgIndStatic*)caf)->indirectee = bh;
+    write_barrier();
+    SET_INFO(caf,&stg_IND_STATIC_info);
+
+    return 1;
+}
+
+StgWord
+newCAF(StgRegTable *reg, StgClosure *caf, StgClosure *bh)
+{
+    if (lockCAF(caf,bh) == 0) return 0;
+
+    if(keepCAFs)
+    {
+        // HACK:
+        // If we are in GHCi _and_ we are using dynamic libraries,
+        // then we can't redirect newCAF calls to newDynCAF (see below),
+        // so we make newCAF behave almost like newDynCAF.
+        // The dynamic libraries might be used by both the interpreted
+        // program and GHCi itself, so they must not be reverted.
+        // This also means that in GHCi with dynamic libraries, CAFs are not
+        // garbage collected. If this turns out to be a problem, we could
+        // do another hack here and do an address range test on caf to figure
+        // out whether it is from a dynamic library.
+
+        ACQUIRE_SM_LOCK; // caf_list is global, locked by sm_mutex
+        ((StgIndStatic *)caf)->static_link = caf_list;
+        caf_list = caf;
+        RELEASE_SM_LOCK;
+    }
+    else
+    {
+        // Put this CAF on the mutable list for the old generation.
+        ((StgIndStatic *)caf)->saved_info = NULL;
+        if (oldest_gen->no != 0) {
+            recordMutableCap(caf, regTableToCapability(reg), oldest_gen->no);
+        }
+    }
+    return 1;
 }
 
 // External API for setting the keepCAFs flag. see #3900.
@@ -312,16 +378,19 @@ setKeepCAFs (void)
 //
 // The linker hackily arranges that references to newCaf from dynamic
 // code end up pointing to newDynCAF.
-void
-newDynCAF (StgRegTable *reg STG_UNUSED, StgClosure *caf)
+StgWord
+newDynCAF (StgRegTable *reg STG_UNUSED, StgClosure *caf, StgClosure *bh)
 {
+    if (lockCAF(caf,bh) == 0) return 0;
+
     ACQUIRE_SM_LOCK;
 
-    ((StgIndStatic *)caf)->saved_info  = (StgInfoTable *)caf->header.info;
     ((StgIndStatic *)caf)->static_link = revertible_caf_list;
     revertible_caf_list = caf;
 
     RELEASE_SM_LOCK;
+
+    return 1;
 }
 
 /* -----------------------------------------------------------------------------