[Git][ghc/ghc][wip/tsan/fixes] Instrumentation: Refactor
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Tue Nov 22 20:59:23 UTC 2022
Ben Gamari pushed to branch wip/tsan/fixes at Glasgow Haskell Compiler / GHC
Commits:
b1c163f7 by Ben Gamari at 2022-11-22T15:59:12-05:00
Instrumentation: Refactor
- - - - -
2 changed files:
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/ThreadSanitizer.hs
Changes:
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -100,10 +100,10 @@ cpsTop logger platform cfg proc =
dump Opt_D_dump_cmm_switch "Post switch plan" g
----------- ThreadSanitizer instrumentation -----------------------------
- g <- {-# SCC "annotateTSAN" #-} return $
+ g <- {-# SCC "annotateTSAN" #-}
if cmmOptThreadSanitizer cfg
- then annotateTSAN platform g
- else g
+ then runUniqSM $ annotateTSAN platform g
+ else return g
dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g
----------- Proc points -------------------------------------------------
=====================================
compiler/GHC/Cmm/ThreadSanitizer.hs
=====================================
@@ -18,12 +18,19 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Data.FastString
import GHC.Types.Basic
import GHC.Types.ForeignCall
+import GHC.Types.Unique
+import GHC.Types.Unique.Supply
import Data.Maybe (fromMaybe)
-annotateTSAN :: Platform -> CmmGraph -> CmmGraph
-annotateTSAN platform graph =
- modifyGraph (mapGraphBlocks (annotateBlock platform)) graph
+data Env = Env { platform :: Platform
+ , uniques :: [Unique]
+ }
+
+annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph
+annotateTSAN platform graph = do
+ env <- Env platform <$> getUniquesM
+ return $ modifyGraph (mapGraphBlocks (annotateBlock env)) graph
mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
@@ -36,52 +43,52 @@ 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 :: Platform -> Block CmmNode e x -> Block CmmNode e x
-annotateBlock platform = mapBlockList (annotateNode platform)
+annotateBlock :: Env -> Block CmmNode e x -> Block CmmNode e x
+annotateBlock env = mapBlockList (annotateNode env)
-annotateNode :: Platform -> CmmNode e x -> Block CmmNode e x
-annotateNode platform node =
+annotateNode :: Env -> CmmNode e x -> Block CmmNode e x
+annotateNode env node =
case node of
CmmEntry{} -> BlockCO node BNil
CmmComment{} -> BMiddle node
CmmTick{} -> BMiddle node
CmmUnwind{} -> BMiddle node
- CmmAssign{} -> annotateNodeOO platform node
+ CmmAssign{} -> annotateNodeOO env node
CmmStore lhs rhs align ->
- let ty = cmmExprType platform rhs
- rhs_nodes = annotateLoads platform (collectExprLoads rhs)
- lhs_nodes = annotateLoads platform (collectExprLoads lhs)
- st = tsanStore platform align ty lhs
+ let ty = cmmExprType (platform env) rhs
+ rhs_nodes = annotateLoads env (collectExprLoads rhs)
+ lhs_nodes = annotateLoads env (collectExprLoads lhs)
+ st = tsanStore env align ty lhs
in rhs_nodes `blockAppend` lhs_nodes `blockAppend` st `blockSnoc` node
CmmUnsafeForeignCall (PrimTarget op) formals args ->
- let node' = fromMaybe (BMiddle node) (annotatePrim platform op formals args)
- arg_nodes = blockConcat $ map (annotateExpr platform) args
+ let node' = fromMaybe (BMiddle node) (annotatePrim env op formals args)
+ arg_nodes = blockConcat $ map (annotateExpr env) args
in arg_nodes `blockAppend` node'
- CmmUnsafeForeignCall{} -> annotateNodeOO platform node
- CmmBranch{} -> annotateNodeOC platform node
- CmmCondBranch{} -> annotateNodeOC platform node
- CmmSwitch{} -> annotateNodeOC platform node
- CmmCall{} -> annotateNodeOC platform node
- CmmForeignCall{} -> annotateNodeOC platform node
+ CmmUnsafeForeignCall{} -> annotateNodeOO env node
+ CmmBranch{} -> annotateNodeOC env node
+ CmmCondBranch{} -> annotateNodeOC env node
+ CmmSwitch{} -> annotateNodeOC env node
+ CmmCall{} -> annotateNodeOC env node
+ CmmForeignCall{} -> annotateNodeOC env node
-annotateNodeOO :: Platform -> CmmNode O O -> Block CmmNode O O
-annotateNodeOO platform node =
- annotateLoads platform (collectLoadsNode node) `blockSnoc` node
+annotateNodeOO :: Env -> CmmNode O O -> Block CmmNode O O
+annotateNodeOO env node =
+ annotateLoads env (collectLoadsNode node) `blockSnoc` node
-annotateNodeOC :: Platform -> CmmNode O C -> Block CmmNode O C
-annotateNodeOC platform node =
- annotateLoads platform (collectLoadsNode node) `blockJoinTail` node
+annotateNodeOC :: Env -> CmmNode O C -> Block CmmNode O C
+annotateNodeOC env node =
+ annotateLoads env (collectLoadsNode node) `blockJoinTail` node
-annotateExpr :: Platform -> CmmExpr -> Block CmmNode O O
-annotateExpr platform expr =
- annotateLoads platform (collectExprLoads expr)
+annotateExpr :: Env -> CmmExpr -> Block CmmNode O O
+annotateExpr env expr =
+ annotateLoads env (collectExprLoads expr)
data Load = Load CmmType AlignmentSpec CmmExpr
-annotateLoads :: Platform -> [Load] -> Block CmmNode O O
-annotateLoads platform loads =
+annotateLoads :: Env -> [Load] -> Block CmmNode O O
+annotateLoads env loads =
blockConcat
- [ tsanLoad platform align ty addr
+ [ tsanLoad env align ty addr
| Load ty align addr <- loads
]
@@ -99,25 +106,47 @@ collectExprLoads (CmmStackSlot _ _) = []
collectExprLoads (CmmRegOff _ _) = []
-- | Generate TSAN instrumentation for a 'CallishMachOp' occurrence.
-annotatePrim :: Platform -> CallishMachOp -> [CmmFormal] -> [CmmActual] -> Maybe (Block CmmNode O O)
-annotatePrim plat (MO_AtomicRMW w aop) [dest] [addr, val] = Just $ tsanAtomicRMW plat MemOrderSeqCst aop w addr val dest
-annotatePrim plat (MO_AtomicRead w mord) [dest] [addr] = Just $ tsanAtomicLoad plat mord w addr dest
-annotatePrim plat (MO_AtomicWrite w mord) [] [addr, val] = Just $ tsanAtomicStore plat mord w val addr
-annotatePrim plat (MO_Xchg w) [dest] [addr, val] = Just $ tsanAtomicExchange plat MemOrderSeqCst w val addr dest
-annotatePrim plat (MO_Cmpxchg w) [dest] [addr, expected, new]
- = Just $ tsanAtomicCas plat MemOrderSeqCst MemOrderSeqCst w addr expected new dest
+annotatePrim :: Env
+ -> CallishMachOp -- ^ the applied operation
+ -> [CmmFormal] -- ^ results
+ -> [CmmActual] -- ^ arguments
+ -> Maybe (Block CmmNode O O)
+ -- ^ 'Just' a block of instrumentation, if applicable
+annotatePrim env (MO_AtomicRMW w aop) [dest] [addr, val] = Just $ tsanAtomicRMW env MemOrderSeqCst aop w addr val dest
+annotatePrim env (MO_AtomicRead w mord) [dest] [addr] = Just $ tsanAtomicLoad env mord w addr dest
+annotatePrim env (MO_AtomicWrite w mord) [] [addr, val] = Just $ tsanAtomicStore env mord w val addr
+annotatePrim env (MO_Xchg w) [dest] [addr, val] = Just $ tsanAtomicExchange env MemOrderSeqCst w val addr dest
+annotatePrim env (MO_Cmpxchg w) [dest] [addr, expected, new]
+ = Just $ tsanAtomicCas env MemOrderSeqCst MemOrderSeqCst w addr expected new dest
annotatePrim _ _ _ _ = Nothing
-mkUnsafeCall :: Platform
+mkUnsafeCall :: Env
-> ForeignTarget -- ^ function
-> [CmmFormal] -- ^ results
- -> [CmmActual] -- arguments
+ -> [CmmActual] -- ^ arguments
-> Block CmmNode O O
-mkUnsafeCall platform ftgt formals args =
+mkUnsafeCall env ftgt formals args =
+ save `blockAppend` -- save global registers
+ bind_args `blockSnoc` -- bind arguments to local registers
+ call `blockAppend` -- perform call
+ restore -- restore global registers
+ where
-- We are rather conservative here and just save/restore all GlobalRegs.
- let (save, restore) = saveRestoreCallerRegs platform
- call = CmmUnsafeForeignCall ftgt formals args
- in save `blockSnoc` call `blockAppend` restore
+ (save, restore) = saveRestoreCallerRegs (platform env)
+
+ -- We also must be careful not to mention caller-saved registers in
+ -- arguments as Cmm-Lint checks this. To accomplish this we instead bind
+ -- the arguments to local registers.
+ arg_regs :: [CmmReg]
+ arg_regs = zipWith arg_reg (uniques env) args
+ where
+ arg_reg :: Unique -> CmmExpr -> CmmReg
+ arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr)
+
+ bind_args :: Block CmmNode O O
+ bind_args = blockConcat $ zipWith (\r e -> BMiddle $ CmmAssign r e) arg_regs args
+
+ call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs)
saveRestoreCallerRegs :: Platform
-> (Block CmmNode O O, Block CmmNode O O)
@@ -141,9 +170,11 @@ saveRestoreCallerRegs platform =
-- | Mirrors __tsan_memory_order
-- <https://github.com/llvm-mirror/compiler-rt/blob/master/include/sanitizer/tsan_interface_atomic.h#L32>
-memoryOrderToTsanMemoryOrder :: MemoryOrdering -> Int
-memoryOrderToTsanMemoryOrder mord =
- case mord of
+memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr
+memoryOrderToTsanMemoryOrder env mord =
+ mkIntExpr (platform env) n
+ where
+ n = case mord of
MemOrderRelaxed -> 0
MemOrderAcquire -> 2
MemOrderRelease -> 3
@@ -159,11 +190,11 @@ tsanTarget fn formals args =
conv = ForeignConvention CCallConv args formals CmmMayReturn
lbl = mkForeignLabel fn Nothing ForeignLabelInExternalPackage IsFunction
-tsanStore :: Platform
+tsanStore :: Env
-> AlignmentSpec -> CmmType -> CmmExpr
-> Block CmmNode O O
-tsanStore platform align ty addr =
- mkUnsafeCall platform ftarget [] [addr]
+tsanStore env align ty addr =
+ mkUnsafeCall env ftarget [] [addr]
where
ftarget = tsanTarget fn [] [AddrHint]
w = widthInBytes (typeWidth ty)
@@ -172,11 +203,11 @@ tsanStore platform align ty addr =
| w > 1 -> fsLit $ "__tsan_unaligned_write" ++ show w
_ -> fsLit $ "__tsan_write" ++ show w
-tsanLoad :: Platform
+tsanLoad :: Env
-> AlignmentSpec -> CmmType -> CmmExpr
-> Block CmmNode O O
-tsanLoad platform align ty addr =
- mkUnsafeCall platform ftarget [] [addr]
+tsanLoad env align ty addr =
+ mkUnsafeCall env ftarget [] [addr]
where
ftarget = tsanTarget fn [] [AddrHint]
w = widthInBytes (typeWidth ty)
@@ -185,40 +216,40 @@ tsanLoad platform align ty addr =
| w > 1 -> fsLit $ "__tsan_unaligned_read" ++ show w
_ -> fsLit $ "__tsan_read" ++ show w
-tsanAtomicStore :: Platform
+tsanAtomicStore :: Env
-> MemoryOrdering -> Width -> CmmExpr -> CmmExpr
-> Block CmmNode O O
-tsanAtomicStore platform mord w val addr =
- mkUnsafeCall platform ftarget [] [addr, val, mord']
+tsanAtomicStore env mord w val addr =
+ mkUnsafeCall env ftarget [] [addr, val, mord']
where
- mord' = mkIntExpr platform $ memoryOrderToTsanMemoryOrder mord
+ mord' = memoryOrderToTsanMemoryOrder env mord
ftarget = tsanTarget fn [] [AddrHint, NoHint, NoHint]
fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_store"
-tsanAtomicLoad :: Platform
+tsanAtomicLoad :: Env
-> MemoryOrdering -> Width -> CmmExpr -> LocalReg
-> Block CmmNode O O
-tsanAtomicLoad platform mord w addr dest =
- mkUnsafeCall platform ftarget [dest] [addr, mord']
+tsanAtomicLoad env mord w addr dest =
+ mkUnsafeCall env ftarget [dest] [addr, mord']
where
- mord' = mkIntExpr platform $ memoryOrderToTsanMemoryOrder mord
+ mord' = memoryOrderToTsanMemoryOrder env mord
ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint]
fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_load"
-tsanAtomicExchange :: Platform
+tsanAtomicExchange :: Env
-> MemoryOrdering -> Width -> CmmExpr -> CmmExpr -> LocalReg
-> Block CmmNode O O
-tsanAtomicExchange platform mord w val addr dest =
- mkUnsafeCall platform ftarget [dest] [addr, val, mord']
+tsanAtomicExchange env mord w val addr dest =
+ mkUnsafeCall env ftarget [dest] [addr, val, mord']
where
- mord' = mkIntExpr platform $ memoryOrderToTsanMemoryOrder mord
+ mord' = memoryOrderToTsanMemoryOrder env mord
ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint]
fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_exchange"
-- N.B. C11 CAS returns a boolean (to avoid the ABA problem) whereas Cmm's CAS
-- returns the expected value. We use define a shim in the RTS to provide
-- Cmm's semantics using the TSAN C11 primitive.
-tsanAtomicCas :: Platform
+tsanAtomicCas :: Env
-> MemoryOrdering -- ^ success ordering
-> MemoryOrdering -- ^ failure ordering
-> Width
@@ -227,21 +258,21 @@ tsanAtomicCas :: Platform
-> CmmExpr -- ^ new value
-> LocalReg -- ^ result destination
-> Block CmmNode O O
-tsanAtomicCas platform mord_success mord_failure w addr expected new dest =
- mkUnsafeCall platform ftarget [dest] [addr, expected, new, mord_success', mord_failure']
+tsanAtomicCas env mord_success mord_failure w addr expected new dest =
+ mkUnsafeCall env ftarget [dest] [addr, expected, new, mord_success', mord_failure']
where
- mord_success' = mkIntExpr platform $ memoryOrderToTsanMemoryOrder mord_success
- mord_failure' = mkIntExpr platform $ memoryOrderToTsanMemoryOrder mord_failure
+ mord_success' = memoryOrderToTsanMemoryOrder env mord_success
+ mord_failure' = memoryOrderToTsanMemoryOrder env mord_failure
ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint, NoHint, NoHint]
fn = fsLit $ "ghc_tsan_atomic" ++ show (widthInBits w) ++ "_compare_exchange"
-tsanAtomicRMW :: Platform
+tsanAtomicRMW :: Env
-> MemoryOrdering -> AtomicMachOp -> Width -> CmmExpr -> CmmExpr -> LocalReg
-> Block CmmNode O O
-tsanAtomicRMW platform mord op w addr val dest =
- mkUnsafeCall platform ftarget [dest] [addr, val, mord']
+tsanAtomicRMW env mord op w addr val dest =
+ mkUnsafeCall env ftarget [dest] [addr, val, mord']
where
- mord' = mkIntExpr platform $ memoryOrderToTsanMemoryOrder mord
+ mord' = memoryOrderToTsanMemoryOrder env mord
ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint]
op' = case op of
AMO_Add -> "fetch_add"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b1c163f7c5efffccafda6c48f96a4549f660ee06
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b1c163f7c5efffccafda6c48f96a4549f660ee06
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/20221122/e33513a9/attachment-0001.html>
More information about the ghc-commits
mailing list