[Git][ghc/ghc][wip/tsan/codegen] 5 commits: codeGen: Introduce ThreadSanitizer instrumentation
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Sat Nov 5 14:41:47 UTC 2022
Ben Gamari pushed to branch wip/tsan/codegen at Glasgow Haskell Compiler / GHC
Commits:
70bb022f by Ben Gamari at 2022-11-05T10:25:44-04:00
codeGen: Introduce ThreadSanitizer instrumentation
This introduces a new Cmm pass which instruments the program with
ThreadSanitizer annotations, allowing full tracking of mutator memory
accesses via TSAN.
- - - - -
61f155e3 by Ben Gamari at 2022-11-05T10:26:55-04:00
cmm: Introduce MemoryOrderings
- - - - -
3132f8a7 by Ben Gamari at 2022-11-05T10:26:59-04:00
llvm: Respect memory specified orderings
- - - - -
e9541fd3 by Ben Gamari at 2022-11-05T10:36:38-04:00
cmm/Parser: Reduce some repetition
- - - - -
3fd980dd by Ben Gamari at 2022-11-05T10:41:04-04:00
cmm/Parser: Add syntax for ordered loads and stores
- - - - -
17 changed files:
- compiler/GHC/Cmm/Config.hs
- compiler/GHC/Cmm/Lexer.x
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Pipeline.hs
- + compiler/GHC/Cmm/ThreadSanitizer.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Driver/Config/Cmm.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/StgToCmm/ExtCode.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Cmm/Config.hs
=====================================
@@ -19,6 +19,7 @@ data CmmConfig = CmmConfig
, cmmDoLinting :: !Bool -- ^ Do Cmm Linting Optimization or not
, cmmOptElimCommonBlks :: !Bool -- ^ Eliminate common blocks or not
, cmmOptSink :: !Bool -- ^ Perform sink after stack layout or not
+ , cmmOptThreadSanitizer :: !Bool -- ^ Instrument memory accesses for ThreadSanitizer
, cmmGenStackUnwindInstr :: !Bool -- ^ Generate stack unwinding instructions (for debugging)
, cmmExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
, cmmDoCmmSwitchPlans :: !Bool -- ^ Should the Cmm pass replace Stg switch statements
=====================================
compiler/GHC/Cmm/Lexer.x
=====================================
@@ -94,6 +94,9 @@ $white_no_nl+ ;
"!=" { kw CmmT_Ne }
"&&" { kw CmmT_BoolAnd }
"||" { kw CmmT_BoolOr }
+ "%acquire" { kw CmmT_Acquire }
+ "%release" { kw CmmT_Release }
+ "%seq_cst" { kw CmmT_SeqCst }
"True" { kw CmmT_True }
"False" { kw CmmT_False }
@@ -183,6 +186,9 @@ data CmmToken
| CmmT_False
| CmmT_True
| CmmT_likely
+ | CmmT_Acquire
+ | CmmT_Release
+ | CmmT_SeqCst
deriving (Show)
-- -----------------------------------------------------------------------------
=====================================
compiler/GHC/Cmm/MachOp.hs
=====================================
@@ -24,6 +24,7 @@ module GHC.Cmm.MachOp
, machOpMemcpyishAlign
-- Atomic read-modify-write
+ , MemoryOrdering(..)
, AtomicMachOp(..)
)
where
@@ -668,8 +669,8 @@ data CallishMachOp
-- Atomic read-modify-write.
| MO_AtomicRMW Width AtomicMachOp
- | MO_AtomicRead Width
- | MO_AtomicWrite Width
+ | MO_AtomicRead Width MemoryOrdering
+ | MO_AtomicWrite Width MemoryOrdering
-- | Atomic compare-and-swap. Arguments are @[dest, expected, new]@.
-- Sequentially consistent.
-- Possible future refactoring: should this be an'MO_AtomicRMW' variant?
@@ -684,6 +685,13 @@ data CallishMachOp
| MO_ResumeThread
deriving (Eq, Show)
+-- | C11 memory ordering semantics.
+data MemoryOrdering
+ = MemOrderAcquire -- ^ acquire ordering
+ | MemOrderRelease -- ^ release ordering
+ | MemOrderSeqCst -- ^ sequentially consistent
+ deriving (Eq, Ord, Show)
+
-- | The operation to perform atomically.
data AtomicMachOp =
AMO_Add
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -313,6 +313,9 @@ import qualified Data.ByteString.Char8 as BS8
'True' { L _ (CmmT_True ) }
'False' { L _ (CmmT_False) }
'likely'{ L _ (CmmT_likely)}
+ 'acquire'{ L _ (CmmT_Acquire)}
+ 'release'{ L _ (CmmT_Release)}
+ 'seq_cst'{ L _ (CmmT_SeqCst)}
'CLOSURE' { L _ (CmmT_CLOSURE) }
'INFO_TABLE' { L _ (CmmT_INFO_TABLE) }
@@ -627,8 +630,10 @@ stmt :: { CmmParse () }
| lreg '=' expr ';'
{ do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
+ | mem_ordering type '[' expr ']' '=' expr ';'
+ { do mord <- $1; withSourceNote $3 $8 (doStore (Just mord) $2 $4 $7) }
| type '[' expr ']' '=' expr ';'
- { withSourceNote $2 $7 (doStore $1 $3 $6) }
+ { withSourceNote $2 $7 (doStore Nothing $1 $3 $6) }
-- Gah! We really want to say "foreign_results" but that causes
-- a shift/reduce conflict with assignment. We either
@@ -678,6 +683,13 @@ unwind_regs
| GLOBALREG '=' expr_or_unknown
{ do e <- $3; return [($1, e)] }
+-- | A memory ordering
+mem_ordering :: { CmmParse MemoryOrdering }
+mem_ordering
+ : 'release' { do return MemOrderRelease }
+ | 'acquire' { do return MemOrderAcquire }
+ | 'seq_cst' { do return MemOrderSeqCst }
+
-- | Used by unwind to indicate unknown unwinding values.
expr_or_unknown
:: { CmmParse (Maybe CmmExpr) }
@@ -953,6 +965,7 @@ exprMacros profile align_check = listToUFM [
platform = profilePlatform profile
-- we understand a subset of C-- primitives:
+machOps :: UniqFM FastString (Width -> MachOp)
machOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [
( "add", MO_Add ),
@@ -1074,37 +1087,31 @@ callishMachOps platform = listToUFM $
( "suspendThread", (MO_SuspendThread,) ),
( "resumeThread", (MO_ResumeThread,) ),
- ("prefetch0", (MO_Prefetch_Data 0,)),
- ("prefetch1", (MO_Prefetch_Data 1,)),
- ("prefetch2", (MO_Prefetch_Data 2,)),
- ("prefetch3", (MO_Prefetch_Data 3,)),
-
- ( "popcnt8", (MO_PopCnt W8,)),
- ( "popcnt16", (MO_PopCnt W16,)),
- ( "popcnt32", (MO_PopCnt W32,)),
- ( "popcnt64", (MO_PopCnt W64,)),
-
- ( "pdep8", (MO_Pdep W8,)),
- ( "pdep16", (MO_Pdep W16,)),
- ( "pdep32", (MO_Pdep W32,)),
- ( "pdep64", (MO_Pdep W64,)),
-
- ( "pext8", (MO_Pext W8,)),
- ( "pext16", (MO_Pext W16,)),
- ( "pext32", (MO_Pext W32,)),
- ( "pext64", (MO_Pext W64,)),
-
- ( "cmpxchg8", (MO_Cmpxchg W8,)),
- ( "cmpxchg16", (MO_Cmpxchg W16,)),
- ( "cmpxchg32", (MO_Cmpxchg W32,)),
- ( "cmpxchg64", (MO_Cmpxchg W64,)),
-
- ( "xchg8", (MO_Xchg W8,)),
- ( "xchg16", (MO_Xchg W16,)),
- ( "xchg32", (MO_Xchg W32,)),
- ( "xchg64", (MO_Xchg W64,))
+ ( "prefetch0", (MO_Prefetch_Data 0,)),
+ ( "prefetch1", (MO_Prefetch_Data 1,)),
+ ( "prefetch2", (MO_Prefetch_Data 2,)),
+ ( "prefetch3", (MO_Prefetch_Data 3,))
+ ] ++ concat
+ [ allWidths "popcnt" MO_PopCnt
+ , allWidths "pdep" MO_Pdep
+ , allWidths "pext" MO_Pext
+ , allWidths "cmpxchg" MO_Cmpxchg
+ , allWidths "xchg" MO_Xchg
+ , allWidths "load_acq" (\w -> MO_AtomicRead w MemOrderAcquire)
+ , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst)
+ , allWidths "store_rel" (\w -> MO_AtomicWrite w MemOrderRelease)
+ , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst)
]
where
+ allWidths
+ :: String
+ -> (Width -> CallishMachOp)
+ -> [(FastString, a -> (CallishMachOp, a))]
+ allWidths name f =
+ [ (mkFastString $ name ++ show (widthInBits w), (f w,))
+ | w <- [W8, W16, W32, W64]
+ ]
+
memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
memcpyLikeTweakArgs op args@(_:_) =
@@ -1348,8 +1355,12 @@ primCall results_code name args_code
let (p, args') = f args
code (emitPrimCall (map fst results) p args')
-doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse ()
-doStore rep addr_code val_code
+doStore :: Maybe MemoryOrdering
+ -> CmmType
+ -> CmmParse CmmExpr -- ^ address
+ -> CmmParse CmmExpr -- ^ value
+ -> CmmParse ()
+doStore mem_ord rep addr_code val_code
= do platform <- getPlatform
addr <- addr_code
val <- val_code
@@ -1363,7 +1374,7 @@ doStore rep addr_code val_code
let coerce_val
| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
| otherwise = val
- emitStore addr coerce_val
+ emitStore mem_ord addr coerce_val
-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Cmm.LayoutStack
import GHC.Cmm.ProcPoint
import GHC.Cmm.Sink
import GHC.Cmm.Switch.Implement
+import GHC.Cmm.ThreadSanitizer
import GHC.Types.Unique.Supply
@@ -160,6 +161,12 @@ cpsTop logger platform cfg proc =
-- See Note [unreachable blocks]
dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+ g <- {-# SCC "annotateTSAN" #-} return $
+ if cmmOptThreadSanitizer cfg
+ then map (annotateTSAN platform) g
+ else g
+ dumps Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g -- TODO: flag
+
return (Left (cafEnv, g))
where dump = dumpGraph logger platform (cmmDoLinting cfg)
=====================================
compiler/GHC/Cmm/ThreadSanitizer.hs
=====================================
@@ -0,0 +1,109 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | Annotate a CmmGraph with ThreadSanitizer instrumentation calls.
+module GHC.Cmm.ThreadSanitizer (annotateTSAN) where
+
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.CLabel
+import GHC.Cmm.Dataflow
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Data.FastString
+import GHC.Types.Basic
+import GHC.Types.ForeignCall
+
+annotateTSAN :: Platform -> CmmDecl -> CmmDecl
+annotateTSAN platform (CmmProc hdr lbl regs g) =
+ CmmProc hdr lbl regs (annotateGraph platform g)
+annotateTSAN _platform decl = decl
+
+annotateGraph :: Platform -> CmmGraph -> CmmGraph
+annotateGraph _platform graph =
+ modifyGraph (mapGraphBlocks annotateBlock) graph
+
+mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')
+ -> Block n e x -> Block n e x
+mapBlockList f (BlockCO n rest ) = f n `blockAppend` mapBlockList f rest
+mapBlockList f (BlockCC n rest m) = f n `blockAppend` mapBlockList f rest `blockAppend` f m
+mapBlockList f (BlockOC rest m) = mapBlockList f rest `blockAppend` f m
+mapBlockList _ BNil = BNil
+mapBlockList f (BMiddle blk) = f blk
+mapBlockList f (BCat a b) = mapBlockList f a `blockAppend` mapBlockList f b
+mapBlockList f (BSnoc a n) = mapBlockList f a `blockAppend` f n
+mapBlockList f (BCons n a) = f n `blockAppend` mapBlockList f a
+
+annotateBlock :: Block CmmNode e x -> Block CmmNode e x
+annotateBlock = mapBlockList annotateNode
+
+annotateNode :: CmmNode e x -> Block CmmNode e x
+annotateNode node@(CmmEntry{}) = BlockCO node BNil
+annotateNode node@(CmmComment{}) = BMiddle node
+annotateNode node@(CmmTick{}) = BMiddle node
+annotateNode node@(CmmUnwind{}) = BMiddle node
+annotateNode node@(CmmAssign{}) = annotateNodeOO node
+annotateNode node@(CmmStore dest _ty _align) =
+ blockFromList (map tsanLoad (collectLoadsNode node) ++ [tsanStore dest]) `blockSnoc` node
+annotateNode node@(CmmUnsafeForeignCall (PrimTarget op) _formals args) =
+ blockFromList (annotatePrim op args ++ foldMap annotateExpr args) `blockSnoc` node
+annotateNode node@(CmmUnsafeForeignCall{}) = annotateNodeOO node
+annotateNode node@(CmmBranch{}) = annotateNodeOC node
+annotateNode node@(CmmCondBranch{}) = annotateNodeOC node
+annotateNode node@(CmmSwitch{}) = annotateNodeOC node
+annotateNode node@(CmmCall{}) = annotateNodeOC node
+annotateNode node@(CmmForeignCall{}) = annotateNodeOC node
+
+annotateNodeOO :: CmmNode O O -> Block CmmNode O O
+annotateNodeOO node =
+ blockFromList (map tsanLoad (collectLoadsNode node)) `blockSnoc` node
+
+annotateNodeOC :: CmmNode O C -> Block CmmNode O C
+annotateNodeOC node =
+ blockFromList (map tsanLoad (collectLoadsNode node)) `blockJoinTail` node
+
+annotateExpr :: CmmExpr -> [CmmNode O O]
+annotateExpr expr =
+ map tsanLoad (collectExprLoads expr)
+
+annotatePrim :: CallishMachOp -> [CmmActual] -> [CmmNode O O]
+annotatePrim MO_ReadBarrier _args = [] -- TODO
+annotatePrim MO_WriteBarrier _args = [] -- TODO
+annotatePrim (MO_AtomicRMW _w _op) _args = [] -- TODO
+annotatePrim (MO_AtomicRead _w _) _args = [] -- TODO
+annotatePrim (MO_AtomicWrite _w _) _args = [] -- TODO
+annotatePrim (MO_Cmpxchg _w) _args = [] -- TODO
+annotatePrim (MO_Xchg _w) _args = [] -- TODO
+annotatePrim _ _ = []
+
+collectLoadsNode :: CmmNode e x -> [CmmExpr]
+collectLoadsNode node =
+ foldExp (\exp rest -> collectExprLoads exp ++ rest) node []
+
+-- | Collect all of the memory locations loaded from by a 'CmmExpr'.
+collectExprLoads :: CmmExpr -> [CmmExpr]
+collectExprLoads (CmmLit _) = []
+collectExprLoads (CmmLoad e _ty _align) = [e]
+collectExprLoads (CmmReg _) = []
+collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args -- TODO
+collectExprLoads (CmmStackSlot _ _) = []
+collectExprLoads (CmmRegOff _ _) = []
+
+tsanStore :: CmmExpr -> CmmNode O O
+tsanStore dest =
+ CmmUnsafeForeignCall ftarget [] [dest]
+ where
+ ftarget = ForeignTarget (CmmLit (CmmLabel lbl)) conv
+ conv = ForeignConvention CCallConv [AddrHint] [] CmmMayReturn
+ lbl = mkForeignLabel (fsLit "__tsan_write8") Nothing ForeignLabelInExternalPackage IsFunction
+
+tsanLoad :: CmmExpr -> CmmNode O O
+tsanLoad dest =
+ CmmUnsafeForeignCall ftarget [] [dest]
+ where
+ ftarget = ForeignTarget (CmmLit (CmmLabel lbl)) conv
+ conv = ForeignConvention CCallConv [AddrHint] [] CmmMayReturn
+ lbl = mkForeignLabel (fsLit "__tsan_read8") Nothing ForeignLabelInExternalPackage IsFunction
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -1537,8 +1537,8 @@ genCCall target dest_regs arg_regs bid = do
-- -- Atomic read-modify-write.
MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
- MO_AtomicRead w -> mkCCall (atomicReadLabel w)
- MO_AtomicWrite w -> mkCCall (atomicWriteLabel w)
+ MO_AtomicRead w _ -> mkCCall (atomicReadLabel w)
+ MO_AtomicWrite w _ -> mkCCall (atomicWriteLabel w)
MO_Cmpxchg w -> mkCCall (cmpxchgLabel w)
-- -- Should be an AtomicRMW variant eventually.
-- -- Sequential consistent.
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -1173,7 +1173,7 @@ genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
(n_reg, n_code) <- getSomeReg n
return (op dst dst (RIReg n_reg), n_code)
-genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
+genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr]
= do let fmt = intFormat width
reg_dst = getLocalRegReg dst
form = if widthInBits width == 64 then DS else D
@@ -1200,7 +1200,7 @@ genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
-- This is also what gcc does.
-genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do
+genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do
code <- assignMem_IntCode (intFormat width) addr val
return $ unitOL HWSYNC `appOL` code
@@ -2067,8 +2067,8 @@ genCCall' config gcp target dest_regs args
MO_AtomicRMW {} -> unsupported
MO_Cmpxchg w -> (cmpxchgLabel w, False)
MO_Xchg w -> (xchgLabel w, False)
- MO_AtomicRead _ -> unsupported
- MO_AtomicWrite _ -> unsupported
+ MO_AtomicRead _ _ -> unsupported
+ MO_AtomicWrite _ _ -> unsupported
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -2203,8 +2203,8 @@ genSimplePrim bid (MO_Pdep width) [dst] [src,mask] = genPdep bid widt
genSimplePrim bid (MO_Pext width) [dst] [src,mask] = genPext bid width dst src mask
genSimplePrim bid (MO_Clz width) [dst] [src] = genClz bid width dst src
genSimplePrim bid (MO_UF_Conv width) [dst] [src] = genWordToFloat bid width dst src
-genSimplePrim _ (MO_AtomicRead w) [dst] [addr] = genAtomicRead w dst addr
-genSimplePrim _ (MO_AtomicWrite w) [] [addr,val] = genAtomicWrite w addr val
+genSimplePrim _ (MO_AtomicRead w _) [dst] [addr] = genAtomicRead w dst addr
+genSimplePrim _ (MO_AtomicWrite w _) [] [addr,val] = genAtomicWrite w addr val
genSimplePrim bid (MO_Cmpxchg width) [dst] [addr,old,new] = genCmpXchg bid width dst addr old new
genSimplePrim _ (MO_Xchg width) [dst] [addr, value] = genXchg width dst addr value
genSimplePrim _ (MO_AddWordC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y
=====================================
compiler/GHC/CmmToC.hs
=====================================
@@ -950,8 +950,9 @@ pprCallishMachOp_for_C mop
MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop)
MO_Cmpxchg w -> ftext (cmpxchgLabel w)
MO_Xchg w -> ftext (xchgLabel w)
- MO_AtomicRead w -> ftext (atomicReadLabel w)
- MO_AtomicWrite w -> ftext (atomicWriteLabel w)
+ -- TODO: handle orderings
+ MO_AtomicRead w _ -> ftext (atomicReadLabel w)
+ MO_AtomicWrite w _ -> ftext (atomicWriteLabel w)
MO_UF_Conv w -> ftext (word2FloatLabel w)
MO_S_Mul2 {} -> unsupported
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -45,7 +45,7 @@ import qualified Data.Semigroup as Semigroup
import Data.List ( nub )
import Data.Maybe ( catMaybes )
-type Atomic = Bool
+type Atomic = Maybe MemoryOrdering
type LlvmStatements = OrdList LlvmStatement
data Signage = Signed | Unsigned deriving (Eq, Show)
@@ -265,9 +265,9 @@ genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $
retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
statement $ Store retVar dstVar Nothing
-genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do
+genCall (PrimTarget (MO_AtomicRead _ mem_ord)) [dst] [addr] = runStmtsDecls $ do
dstV <- getCmmRegW (CmmLocal dst)
- v1 <- genLoadW True addr (localRegType dst) NaturallyAligned
+ v1 <- genLoadW (Just mem_ord) addr (localRegType dst) NaturallyAligned
statement $ Store v1 dstV Nothing
genCall (PrimTarget (MO_Cmpxchg _width))
@@ -294,13 +294,14 @@ genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do
resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)
statement $ Store resVar dstV Nothing
-genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
+genCall (PrimTarget (MO_AtomicWrite _width mem_ord)) [] [addr, val] = runStmtsDecls $ do
addrVar <- exprToVarW addr
valVar <- exprToVarW val
let ptrTy = pLift $ getVarType valVar
ptrExpr = Cast LM_Inttoptr addrVar ptrTy
ptrVar <- doExprW ptrTy ptrExpr
- statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst
+ let ordering = convertMemoryOrdering mem_ord
+ statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar ordering
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
@@ -1012,11 +1013,11 @@ cmmPrimOpFunctions mop = do
MO_Touch -> unsupported
MO_UF_Conv _ -> unsupported
- MO_AtomicRead _ -> unsupported
- MO_AtomicRMW _ _ -> unsupported
- MO_AtomicWrite _ -> unsupported
- MO_Cmpxchg _ -> unsupported
- MO_Xchg _ -> unsupported
+ MO_AtomicRead _ _ -> unsupported
+ MO_AtomicRMW _ _ -> unsupported
+ MO_AtomicWrite _ _ -> unsupported
+ MO_Cmpxchg _ -> unsupported
+ MO_Xchg _ -> unsupported
MO_I64_ToI -> dontReach64
MO_I64_FromI -> dontReach64
@@ -1368,7 +1369,7 @@ exprToVarOpt opt e = case e of
-> genLit opt lit
CmmLoad e' ty align
- -> genLoad False e' ty align
+ -> genLoad Nothing e' ty align
-- Cmmreg in expression is the value, so must load. If you want actual
-- reg pointer, call getCmmReg directly.
@@ -1893,7 +1894,8 @@ case we will need a more granular way of specifying alignment.
mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression
mkLoad atomic vptr alignment
- | atomic = ALoad SyncSeqCst False vptr
+ | Just mem_ord <- atomic
+ = ALoad (convertMemoryOrdering mem_ord) False vptr
| otherwise = Load vptr align
where
ty = pLower (getVarType vptr)
@@ -2030,6 +2032,11 @@ genLit _ CmmHighStackMark
-- * Misc
--
+convertMemoryOrdering :: MemoryOrdering -> LlvmSyncOrdering
+convertMemoryOrdering MemOrderAcquire = SyncAcquire
+convertMemoryOrdering MemOrderRelease = SyncRelease
+convertMemoryOrdering MemOrderSeqCst = SyncSeqCst
+
-- | Find CmmRegs that get assigned and allocate them on the stack
--
-- Any register that gets written needs to be allocated on the
=====================================
compiler/GHC/Driver/Config/Cmm.hs
=====================================
@@ -18,6 +18,7 @@ initCmmConfig dflags = CmmConfig
, cmmDoLinting = gopt Opt_DoCmmLinting dflags
, cmmOptElimCommonBlks = gopt Opt_CmmElimCommonBlocks dflags
, cmmOptSink = gopt Opt_CmmSink dflags
+ , cmmOptThreadSanitizer = gopt Opt_CmmThreadSanitizer dflags
, cmmGenStackUnwindInstr = debugLevel dflags > 0
, cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
, cmmDoCmmSwitchPlans = not . backendHasNativeSwitch . backend $ dflags
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -66,6 +66,7 @@ data DumpFlag
| Opt_D_dump_cmm_split
| Opt_D_dump_cmm_info
| Opt_D_dump_cmm_cps
+ | Opt_D_dump_cmm_thread_sanitizer
-- end cmm subflags
| Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout.
| Opt_D_dump_asm
@@ -352,6 +353,7 @@ data GeneralFlag
| Opt_Ticky_Dyn_Thunk
| Opt_Ticky_Tag
| Opt_Ticky_AP -- ^ Use regular thunks even when we could use std ap thunks in order to get entry counts
+ | Opt_CmmThreadSanitizer
| Opt_RPath
| Opt_RelativeDynlibPaths
| Opt_CompactUnwind -- ^ @-fcompact-unwind@
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2436,6 +2436,8 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_cmm_cps)
, make_ord_flag defGhcFlag "ddump-cmm-opt"
(setDumpFlag Opt_D_dump_opt_cmm)
+ , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer"
+ (setDumpFlag Opt_D_dump_cmm_thread_sanitizer)
, make_ord_flag defGhcFlag "ddump-cfg-weights"
(setDumpFlag Opt_D_dump_cfg_weights)
, make_ord_flag defGhcFlag "ddump-core-stats"
@@ -3509,8 +3511,8 @@ fFlagsDeps = [
unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on)
(addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.")
return dflags)),
- flagSpec "show-error-context" Opt_ShowErrorContext
-
+ flagSpec "show-error-context" Opt_ShowErrorContext,
+ flagSpec "cmm-thread-sanitizer" Opt_CmmThreadSanitizer
]
++ fHoleFlags
=====================================
compiler/GHC/StgToCmm/ExtCode.hs
=====================================
@@ -231,8 +231,12 @@ emitLabel = code . F.emitLabel
emitAssign :: CmmReg -> CmmExpr -> CmmParse ()
emitAssign l r = code (F.emitAssign l r)
-emitStore :: CmmExpr -> CmmExpr -> CmmParse ()
-emitStore l r = code (F.emitStore l r)
+emitStore :: Maybe MemoryOrdering -> CmmExpr -> CmmExpr -> CmmParse ()
+emitStore (Just mem_ord) l r = do
+ platform <- getPlatform
+ let w = typeWidth $ cmmExprType platform r
+ emit $ mkUnsafeCall (PrimTarget $ MO_AtomicWrite w mem_ord) [] [l,r]
+emitStore Nothing l r = code (F.emitStore l r)
getCode :: CmmParse a -> CmmParse CmmAGraph
getCode (EC ec) = EC $ \c e s -> do
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -3011,7 +3011,7 @@ doAtomicReadAddr
doAtomicReadAddr res addr ty =
emitPrimCall
[ res ]
- (MO_AtomicRead (typeWidth ty))
+ (MO_AtomicRead (typeWidth ty) MemOrderSeqCst)
[ addr ]
-- | Emit an atomic write to a byte array that acts as a memory barrier.
@@ -3039,7 +3039,7 @@ doAtomicWriteAddr
doAtomicWriteAddr addr ty val =
emitPrimCall
[ {- no results -} ]
- (MO_AtomicWrite (typeWidth ty))
+ (MO_AtomicWrite (typeWidth ty) MemOrderSeqCst)
[ addr, val ]
doCasByteArray
=====================================
compiler/ghc.cabal.in
=====================================
@@ -213,6 +213,7 @@ Library
GHC.Cmm.Sink
GHC.Cmm.Switch
GHC.Cmm.Switch.Implement
+ GHC.Cmm.ThreadSanitizer
GHC.CmmToAsm
GHC.Cmm.LRegSet
GHC.CmmToAsm.AArch64
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/517b68227c01b97d01a1d796a583d587e85fd4f2...3fd980dd8a676d2e6dae77de5ed90d401650fac5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/517b68227c01b97d01a1d796a583d587e85fd4f2...3fd980dd8a676d2e6dae77de5ed90d401650fac5
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221105/fcdf6d31/attachment-0001.html>
More information about the ghc-commits
mailing list