summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs1
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs61
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs42
3 files changed, 99 insertions, 5 deletions
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 44316cacb0..9e192a0ac8 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -631,6 +631,7 @@ emitBlackHoleCode node = do
-- work with profiling.
when eager_blackholing $ do
+ whenUpdRemSetEnabled dflags $ emitUpdRemSetPushThunk node
emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
-- See Note [Heap memory barriers] in SMP.h.
emitPrimCall [] MO_WriteBarrier []
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index cdbc8d9fd9..155cdcbf80 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -42,6 +42,7 @@ import BlockId
import MkGraph
import StgSyn
import Cmm
+import Module ( rtsUnitId )
import Type ( Type, tyConAppTyCon )
import TyCon
import CLabel
@@ -339,14 +340,20 @@ dispatchPrimop dflags = \case
emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
WriteMutVarOp -> \[mutv, var] -> OpDest_AllDone $ \res@[] -> do
+ old_val <- CmmLocal <$> newTemp (cmmExprType dflags var)
+ emitAssign old_val (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
+
-- Without this write barrier, other CPUs may see this pointer before
-- the writes for the closure it points to have occurred.
+ -- Note that this also must come after we read the old value to ensure
+ -- that the read of old_val comes before another core's write to the
+ -- MutVar's value.
emitPrimCall res MO_WriteBarrier []
emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var
emitCCall
[{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
- [(baseExpr, AddrHint), (mutv,AddrHint)]
+ [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]
-- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
@@ -1983,17 +1990,21 @@ doWritePtrArrayOp :: CmmExpr
doWritePtrArrayOp addr idx val
= do dflags <- getDynFlags
let ty = cmmExprType dflags val
+ hdr_size = arrPtrsHdrSize dflags
+ -- Update remembered set for non-moving collector
+ whenUpdRemSetEnabled dflags
+ $ emitUpdRemSetPush (cmmLoadIndexOffExpr dflags hdr_size ty addr ty idx)
-- This write barrier is to ensure that the heap writes to the object
-- referred to by val have happened before we write val into the array.
-- See #12469 for details.
emitPrimCall [] MO_WriteBarrier []
- mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val
+ mkBasicIndexedWrite hdr_size Nothing addr ty idx val
emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
- -- the write barrier. We must write a byte into the mark table:
- -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
+ -- the write barrier. We must write a byte into the mark table:
+ -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
emit $ mkStore (
cmmOffsetExpr dflags
- (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
+ (cmmOffsetExprW dflags (cmmOffsetB dflags addr hdr_size)
(loadArrPtrsSize dflags addr))
(CmmMachOp (mo_wordUShr dflags) [idx,
mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])
@@ -2584,6 +2595,9 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n =
dst <- assignTempE dst0
dst_off <- assignTempE dst_off0
+ -- Nonmoving collector write barrier
+ emitCopyUpdRemSetPush dflags (arrPtrsHdrSizeW dflags) dst dst_off n
+
-- Set the dirty bit in the header.
emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
@@ -2646,6 +2660,9 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n =
src <- assignTempE src0
dst <- assignTempE dst0
+ -- Nonmoving collector write barrier
+ emitCopyUpdRemSetPush dflags (smallArrPtrsHdrSizeW dflags) dst dst_off n
+
-- Set the dirty bit in the header.
emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
@@ -2774,6 +2791,12 @@ doWriteSmallPtrArrayOp :: CmmExpr
doWriteSmallPtrArrayOp addr idx val = do
dflags <- getDynFlags
let ty = cmmExprType dflags val
+
+ -- Update remembered set for non-moving collector
+ tmp <- newTemp ty
+ mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx
+ whenUpdRemSetEnabled dflags $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))
+
emitPrimCall [] MO_WriteBarrier [] -- #12469
mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val
emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
@@ -2953,3 +2976,31 @@ emitCtzCall res x width = do
[ res ]
(MO_Ctz width)
[ x ]
+
+---------------------------------------------------------------------------
+-- Pushing to the update remembered set
+---------------------------------------------------------------------------
+
+-- | Push a range of pointer-array elements that are about to be copied over to
+-- the update remembered set.
+emitCopyUpdRemSetPush :: DynFlags
+ -> WordOff -- ^ array header size
+ -> CmmExpr -- ^ destination array
+ -> CmmExpr -- ^ offset in destination array (in words)
+ -> Int -- ^ number of elements to copy
+ -> FCode ()
+emitCopyUpdRemSetPush _dflags _hdr_size _dst _dst_off 0 = return ()
+emitCopyUpdRemSetPush dflags hdr_size dst dst_off n =
+ whenUpdRemSetEnabled dflags $ do
+ updfr_off <- getUpdFrameOff
+ graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off []
+ emit graph
+ where
+ lbl = mkLblExpr $ mkPrimCallLabel
+ $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId
+ args =
+ [ mkIntExpr dflags hdr_size
+ , dst
+ , dst_off
+ , mkIntExpr dflags n
+ ]
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index 30e37bb930..0b3a8d8b08 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -39,6 +39,11 @@ module GHC.StgToCmm.Utils (
mkWordCLit,
newStringCLit, newByteStringCLit,
blankWord,
+
+ -- * Update remembered set operations
+ whenUpdRemSetEnabled,
+ emitUpdRemSetPush,
+ emitUpdRemSetPushThunk,
) where
#include "HsVersions.h"
@@ -576,3 +581,40 @@ assignTemp' e
let reg = CmmLocal lreg
emitAssign reg e
return (CmmReg reg)
+
+
+---------------------------------------------------------------------------
+-- Pushing to the update remembered set
+---------------------------------------------------------------------------
+
+whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode ()
+whenUpdRemSetEnabled dflags code = do
+ do_it <- getCode code
+ the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
+ emit the_if
+ where
+ enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord dflags)
+ zero = zeroExpr dflags
+ is_enabled = cmmNeWord dflags enabled zero
+
+-- | Emit code to add an entry to a now-overwritten pointer to the update
+-- remembered set.
+emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten
+ -> FCode ()
+emitUpdRemSetPush ptr = do
+ emitRtsCall
+ rtsUnitId
+ (fsLit "updateRemembSetPushClosure_")
+ [(CmmReg (CmmGlobal BaseReg), AddrHint),
+ (ptr, AddrHint)]
+ False
+
+emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
+ -> FCode ()
+emitUpdRemSetPushThunk ptr = do
+ emitRtsCall
+ rtsUnitId
+ (fsLit "updateRemembSetPushThunk_")
+ [(CmmReg (CmmGlobal BaseReg), AddrHint),
+ (ptr, AddrHint)]
+ False
View Lorry Controller Status