diff options
| -rw-r--r-- | compiler/GHC/Cmm/Config.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Pipeline.hs | 8 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/ThreadSanitizer.hs | 285 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/Cmm.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 6 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | docs/users_guide/debugging.rst | 16 | ||||
| -rw-r--r-- | rts/TSANUtils.c | 37 | ||||
| -rw-r--r-- | rts/include/rts/TSANUtils.h | 7 | ||||
| -rw-r--r-- | rts/rts.cabal.in | 1 |
11 files changed, 363 insertions, 2 deletions
diff --git a/compiler/GHC/Cmm/Config.hs b/compiler/GHC/Cmm/Config.hs index 415becd109..4c8f8f2280 100644 --- a/compiler/GHC/Cmm/Config.hs +++ b/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 diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index c0a37cd3bc..9a5a5aa338 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/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 @@ -98,6 +99,13 @@ cpsTop logger platform cfg proc = else pure g dump Opt_D_dump_cmm_switch "Post switch plan" g + ----------- ThreadSanitizer instrumentation ----------------------------- + g <- {-# SCC "annotateTSAN" #-} + if cmmOptThreadSanitizer cfg + then runUniqSM $ annotateTSAN platform g + else return g + dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g + ----------- Proc points ------------------------------------------------- let call_pps :: ProcPointSet -- LabelMap diff --git a/compiler/GHC/Cmm/ThreadSanitizer.hs b/compiler/GHC/Cmm/ThreadSanitizer.hs new file mode 100644 index 0000000000..0200654ae2 --- /dev/null +++ b/compiler/GHC/Cmm/ThreadSanitizer.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +-- | Annotate a CmmGraph with ThreadSanitizer instrumentation calls. +module GHC.Cmm.ThreadSanitizer (annotateTSAN) where + +import GHC.Prelude + +import GHC.StgToCmm.Utils (get_GlobalReg_addr) +import GHC.Platform +import GHC.Platform.Regs (activeStgRegs, callerSaves) +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 +import GHC.Types.Unique +import GHC.Types.Unique.Supply + +import Data.Maybe (fromMaybe) + +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 +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 :: Env -> Block CmmNode e x -> Block CmmNode e x +annotateBlock env = mapBlockList (annotateNode env) + +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 env node + CmmStore lhs rhs align -> + 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 env op formals args) + arg_nodes = blockConcat $ map (annotateExpr env) args + in arg_nodes `blockAppend` 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 :: Env -> CmmNode O O -> Block CmmNode O O +annotateNodeOO env node = + annotateLoads env (collectLoadsNode node) `blockSnoc` node + +annotateNodeOC :: Env -> CmmNode O C -> Block CmmNode O C +annotateNodeOC env node = + annotateLoads env (collectLoadsNode node) `blockJoinTail` node + +annotateExpr :: Env -> CmmExpr -> Block CmmNode O O +annotateExpr env expr = + annotateLoads env (collectExprLoads expr) + +data Load = Load CmmType AlignmentSpec CmmExpr + +annotateLoads :: Env -> [Load] -> Block CmmNode O O +annotateLoads env loads = + blockConcat + [ tsanLoad env align ty addr + | Load ty align addr <- loads + ] + +collectLoadsNode :: CmmNode e x -> [Load] +collectLoadsNode node = + foldExp (\exp rest -> collectExprLoads exp ++ rest) node [] + +-- | Collect all of the memory locations loaded from by a 'CmmExpr'. +collectExprLoads :: CmmExpr -> [Load] +collectExprLoads (CmmLit _) = [] +collectExprLoads (CmmLoad e ty align) = [Load ty align e] +collectExprLoads (CmmReg _) = [] +collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args +collectExprLoads (CmmStackSlot _ _) = [] +collectExprLoads (CmmRegOff _ _) = [] + +-- | Generate TSAN instrumentation for a 'CallishMachOp' occurrence. +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 :: Env + -> ForeignTarget -- ^ function + -> [CmmFormal] -- ^ results + -> [CmmActual] -- ^ arguments + -> Block CmmNode O O +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. + (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) +saveRestoreCallerRegs platform = + (save, restore) + where + regs = filter (callerSaves platform) (activeStgRegs platform) + + save = blockFromList (map saveReg regs) + saveReg reg = + CmmStore (get_GlobalReg_addr platform reg) + (CmmReg (CmmGlobal reg)) + NaturallyAligned + + restore = blockFromList (map restoreReg regs) + restoreReg reg = + CmmAssign (CmmGlobal reg) + (CmmLoad (get_GlobalReg_addr platform reg) + (globalRegType platform reg) + NaturallyAligned) + +-- | Mirrors __tsan_memory_order +-- <https://github.com/llvm-mirror/compiler-rt/blob/master/include/sanitizer/tsan_interface_atomic.h#L32> +memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr +memoryOrderToTsanMemoryOrder env mord = + mkIntExpr (platform env) n + where + n = case mord of + MemOrderRelaxed -> 0 + MemOrderAcquire -> 2 + MemOrderRelease -> 3 + MemOrderSeqCst -> 5 + +tsanTarget :: FastString -- ^ function name + -> [ForeignHint] -- ^ formals + -> [ForeignHint] -- ^ arguments + -> ForeignTarget +tsanTarget fn formals args = + ForeignTarget (CmmLit (CmmLabel lbl)) conv + where + conv = ForeignConvention CCallConv args formals CmmMayReturn + lbl = mkForeignLabel fn Nothing ForeignLabelInExternalPackage IsFunction + +tsanStore :: Env + -> AlignmentSpec -> CmmType -> CmmExpr + -> Block CmmNode O O +tsanStore env align ty addr = + mkUnsafeCall env ftarget [] [addr] + where + ftarget = tsanTarget fn [] [AddrHint] + w = widthInBytes (typeWidth ty) + fn = case align of + Unaligned + | w > 1 -> fsLit $ "__tsan_unaligned_write" ++ show w + _ -> fsLit $ "__tsan_write" ++ show w + +tsanLoad :: Env + -> AlignmentSpec -> CmmType -> CmmExpr + -> Block CmmNode O O +tsanLoad env align ty addr = + mkUnsafeCall env ftarget [] [addr] + where + ftarget = tsanTarget fn [] [AddrHint] + w = widthInBytes (typeWidth ty) + fn = case align of + Unaligned + | w > 1 -> fsLit $ "__tsan_unaligned_read" ++ show w + _ -> fsLit $ "__tsan_read" ++ show w + +tsanAtomicStore :: Env + -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr + -> Block CmmNode O O +tsanAtomicStore env mord w val addr = + mkUnsafeCall env ftarget [] [addr, val, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [] [AddrHint, NoHint, NoHint] + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_store" + +tsanAtomicLoad :: Env + -> MemoryOrdering -> Width -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicLoad env mord w addr dest = + mkUnsafeCall env ftarget [dest] [addr, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint] + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_load" + +tsanAtomicExchange :: Env + -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicExchange env mord w val addr dest = + mkUnsafeCall env ftarget [dest] [addr, val, mord'] + where + 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 :: Env + -> MemoryOrdering -- ^ success ordering + -> MemoryOrdering -- ^ failure ordering + -> Width + -> CmmExpr -- ^ address + -> CmmExpr -- ^ expected value + -> CmmExpr -- ^ new value + -> LocalReg -- ^ result destination + -> Block CmmNode O O +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' = 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 :: Env + -> MemoryOrdering -> AtomicMachOp -> Width -> CmmExpr -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicRMW env mord op w addr val dest = + mkUnsafeCall env ftarget [dest] [addr, val, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint] + op' = case op of + AMO_Add -> "fetch_add" + AMO_Sub -> "fetch_sub" + AMO_And -> "fetch_and" + AMO_Nand -> "fetch_nand" + AMO_Or -> "fetch_or" + AMO_Xor -> "fetch_xor" + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_" ++ op' + diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs index 26ee35cba1..e130385cb0 100644 --- a/compiler/GHC/Driver/Config/Cmm.hs +++ b/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)) diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 1d8bd226b3..f45397d887 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/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 @@ -354,6 +355,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@ diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index a0c371f76c..831267e2bf 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2434,6 +2434,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" @@ -3511,8 +3513,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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 3ad8271127..4b66f8dc33 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -214,6 +214,7 @@ Library GHC.Cmm.Sink GHC.Cmm.Switch GHC.Cmm.Switch.Implement + GHC.Cmm.ThreadSanitizer GHC.CmmToAsm GHC.Cmm.LRegSet GHC.CmmToAsm.AArch64 diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst index 1448662698..e9d61e3834 100644 --- a/docs/users_guide/debugging.rst +++ b/docs/users_guide/debugging.rst @@ -551,6 +551,13 @@ These flags dump various phases of GHC's C-\\- pipeline. Dump the results of the C-\\- control flow optimisation pass. +.. ghc-flag:: -ddump-cmm-thread-sanitizer + :shortdesc: Dump the results of the C-\\- ThreadSanitizer elaboration pass. + :type: dynamic + + Dump the results of the C-\\- pass responsible for adding instrumentation + added by :ghc-flag:`-fcmm-thread-sanitizer`. + .. ghc-flag:: -ddump-cmm-cbe :shortdesc: Dump the results of common block elimination :type: dynamic @@ -1075,6 +1082,15 @@ Checking for consistency Note that this is only intended to be used as a debugging measure, not as the primary means of catching out-of-bounds accesses. +.. ghc-flag:: -fcmm-thread-sanitizer + :shortdesc: Enable ThreadSanitizer instrumentation of memory accesses. + :type: dynamic + + This enables generation of `ThreadSanitizer + <https://github.com/google/sanitizers/wiki/ThreadSanitizerCppManual>` + instrumentation of memory accesses. Requires use of ``-fsanitize=thread`` + or similar when compiling and linking. + .. _checking-determinism: Checking for determinism diff --git a/rts/TSANUtils.c b/rts/TSANUtils.c new file mode 100644 index 0000000000..790381acdb --- /dev/null +++ b/rts/TSANUtils.c @@ -0,0 +1,37 @@ +#include <Rts.h> + +#if defined(TSAN_ENABLED) + +uint64_t ghc_tsan_atomic64_compare_exchange(uint64_t *ptr, uint64_t expected, uint64_t new_value, int success_memorder, int failure_memorder) +{ + __tsan_atomic64_compare_exchange_strong( + ptr, &expected, new_value, + success_memorder, failure_memorder); + return expected; +} + +uint32_t ghc_tsan_atomic32_compare_exchange(uint32_t *ptr, uint32_t expected, uint32_t new_value, int success_memorder, int failure_memorder) +{ + __tsan_atomic32_compare_exchange_strong( + ptr, &expected, new_value, + success_memorder, failure_memorder); + return expected; +} + +uint16_t ghc_tsan_atomic16_compare_exchange(uint16_t *ptr, uint16_t expected, uint16_t new_value, int success_memorder, int failure_memorder) +{ + __tsan_atomic16_compare_exchange_strong( + ptr, &expected, new_value, + success_memorder, failure_memorder); + return expected; +} + +uint8_t ghc_tsan_atomic8_compare_exchange(uint8_t *ptr, uint8_t expected, uint8_t new_value, int success_memorder, int failure_memorder) +{ + __tsan_atomic8_compare_exchange_strong( + ptr, &expected, new_value, + success_memorder, failure_memorder); + return expected; +} + +#endif diff --git a/rts/include/rts/TSANUtils.h b/rts/include/rts/TSANUtils.h index ddcf108041..da2240085e 100644 --- a/rts/include/rts/TSANUtils.h +++ b/rts/include/rts/TSANUtils.h @@ -65,3 +65,10 @@ void AnnotateBenignRaceSized(const char *file, #define TSAN_ANNOTATE_BENIGN_RACE(addr,desc) \ TSAN_ANNOTATE_BENIGN_RACE_SIZED((void*)(addr), sizeof(*addr), desc) + + +uint64_t ghc_tsan_atomic64_compare_exchange(uint64_t *ptr, uint64_t expected, uint64_t new_value, int success_memorder, int failure_memorder); +uint32_t ghc_tsan_atomic32_compare_exchange(uint32_t *ptr, uint32_t expected, uint32_t new_value, int success_memorder, int failure_memorder); +uint16_t ghc_tsan_atomic16_compare_exchange(uint16_t *ptr, uint16_t expected, uint16_t new_value, int success_memorder, int failure_memorder); +uint8_t ghc_tsan_atomic8_compare_exchange(uint8_t *ptr, uint8_t expected, uint8_t new_value, int success_memorder, int failure_memorder); + diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in index e4a78a64cf..d10ee390e4 100644 --- a/rts/rts.cabal.in +++ b/rts/rts.cabal.in @@ -588,6 +588,7 @@ library Trace.c TraverseHeap.c TraverseHeapTest.c + TSANUtils.c WSDeque.c Weak.c eventlog/EventLog.c |