diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2023-04-24 06:03:12 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2023-04-24 06:03:12 -0400 |
| commit | 5946bdf1054038b676e6214cd8be0c20ec4d4fbc (patch) | |
| tree | f1d18085b9dbec6aea640c24b4a435c2594efe52 | |
| parent | d0f300cf0609013b43ae0e93550484de4170b47a (diff) | |
| download | haskell-5946bdf1054038b676e6214cd8be0c20ec4d4fbc.tar.gz | |
codeGen: Ensure that TSAN is aware of writeArray# write barriers
| -rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 23 |
1 files changed, 14 insertions, 9 deletions
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index d222c783b3..e626ccdca4 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -2101,7 +2101,7 @@ doWriteOffAddrOp :: Maybe MachOp -> [CmmExpr] -> FCode () doWriteOffAddrOp castOp idx_ty [] [addr,idx, val] - = mkBasicIndexedWrite 0 addr idx_ty idx (maybeCast castOp val) + = mkBasicIndexedWrite False 0 addr idx_ty idx (maybeCast castOp val) doWriteOffAddrOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp" @@ -2115,7 +2115,7 @@ doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal] platform <- getPlatform let val = maybeCast castOp rawVal doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val) - mkBasicIndexedWrite (arrWordsHdrSize profile) addr idx_ty idx val + mkBasicIndexedWrite False (arrWordsHdrSize profile) addr idx_ty idx val doWriteByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" @@ -2137,8 +2137,7 @@ doWritePtrArrayOp addr idx val -- 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 hdr_size addr ty idx val + mkBasicIndexedWrite True hdr_size addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: @@ -2167,16 +2166,22 @@ mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx emitAssign (CmmLocal res) (CmmMachOp cast [ cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx]) -mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes +mkBasicIndexedWrite :: Bool -- Should this imply a release barrier + -> ByteOff -- Initial offset in bytes -> CmmExpr -- Base address -> CmmType -- Type of element by which we are indexing -> CmmExpr -- Index -> CmmExpr -- Value to write -> FCode () -mkBasicIndexedWrite off base idx_ty idx val +mkBasicIndexedWrite barrier off base idx_ty idx val = do platform <- getPlatform let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty - emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val + addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx + if barrier + then let w = typeWidth idx_ty + op = MO_AtomicWrite w MemOrderRelease + in emitPrimCall [] op [addr, val] + else emitStore' alignment addr val -- ---------------------------------------------------------------------------- -- Misc utils @@ -3008,8 +3013,8 @@ doWriteSmallPtrArrayOp addr idx val = do mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) - emitPrimCall [] MO_WriteBarrier [] -- #12469 - mkBasicIndexedWrite (smallArrPtrsHdrSize profile) addr ty idx val + -- Barrier necessary due to #12469 + mkBasicIndexedWrite True (smallArrPtrsHdrSize profile) addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ |