[Git][ghc/ghc][wip/tsan/cmm-codegen] 7 commits: rts: Introduce more principled fence operations

Ben Gamari (@bgamari) gitlab at gitlab.haskell.org
Mon Jul 24 18:17:59 UTC 2023



Ben Gamari pushed to branch wip/tsan/cmm-codegen at Glasgow Haskell Compiler / GHC


Commits:
afdc15ea by Ben Gamari at 2023-07-24T14:13:28-04:00
rts: Introduce more principled fence operations

- - - - -
6bdb0bce by Ben Gamari at 2023-07-24T14:14:02-04:00
rts: Introduce SET_INFO_RELAXED

- - - - -
af672b66 by Ben Gamari at 2023-07-24T14:14:11-04:00
rts: Fix unsupported fence warnings with TSAN

- - - - -
9451cd1e by Ben Gamari at 2023-07-24T14:17:51-04:00
codeGen/tsan: Rework handling of spilling

- - - - -
65feb180 by Ben Gamari at 2023-07-24T14:17:51-04:00
hadrian: More debug information

- - - - -
4993f3b4 by Ben Gamari at 2023-07-24T14:17:51-04:00
Improve TSAN documentation

- - - - -
e4820538 by Ben Gamari at 2023-07-24T14:17:51-04:00
hadrian: More selective TSAN instrumentation

- - - - -


7 changed files:

- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/ThreadSanitizer.hs
- hadrian/src/Flavour.hs
- rts/include/Cmm.h
- rts/include/rts/TSANUtils.h
- rts/include/rts/storage/ClosureMacros.h
- rts/include/stg/SMP.h


Changes:

=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -205,7 +205,7 @@ memory ordering guarantees. These are supported in Cmm syntax as follows:
     %relaxed W_[ptr] = ...;   // an atomic store with relaxed ordering semantics
     %release W_[ptr] = ...;   // an atomic store with release ordering semantics
 
-    x = W_(ptr);              // a non-atomic load
+    x = W_[ptr];              // a non-atomic load
     x = %relaxed W_[ptr];     // an atomic load with relaxed ordering
     x = %acquire W_[ptr];     // an atomic load with acquire ordering
     // or equivalently...


=====================================
compiler/GHC/Cmm/ThreadSanitizer.hs
=====================================
@@ -6,7 +6,6 @@ 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
@@ -24,12 +23,12 @@ import GHC.Types.Unique.Supply
 import Data.Maybe (fromMaybe)
 
 data Env = Env { platform :: Platform
-               , uniques :: [Unique]
+               , uniques :: UniqSupply
                }
 
 annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph
 annotateTSAN platform graph = do
-    env <- Env platform <$> getUniquesM
+    env <- Env platform <$> getUniqueSupplyM
     return $ modifyGraph (mapGraphBlocks (annotateBlock env)) graph
 
 mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')
@@ -133,14 +132,15 @@ mkUnsafeCall env ftgt formals args =
     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)
+    (save, restore) = saveRestoreCallerRegs gregs_us (platform env)
+
+    (arg_us, gregs_us) = splitUniqSupply (uniques 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
+    arg_regs = zipWith arg_reg (uniqsFromSupply arg_us) args
       where
         arg_reg :: Unique -> CmmExpr -> CmmReg
         arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr)
@@ -150,31 +150,34 @@ mkUnsafeCall env ftgt formals args =
 
     call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs)
 
-saveRestoreCallerRegs :: Platform
+-- | We save the contents of global registers in locals and allow the
+-- register allocator to spill them to the stack around the call.
+-- We cannot use the register table for this since we would interface
+-- with {SAVE,RESTORE}_THREAD_STATE.
+saveRestoreCallerRegs :: UniqSupply -> Platform
                       -> (Block CmmNode O O, Block CmmNode O O)
-saveRestoreCallerRegs platform =
+saveRestoreCallerRegs us platform =
     (save, restore)
   where
-    regs = filter (callerSaves platform) (activeStgRegs platform)
-
-    save = blockFromList (map saveReg regs)
-
-    saveReg :: GlobalReg -> CmmNode O O
-    saveReg reg =
-      CmmStore (get_GlobalReg_addr platform reg)
-               (CmmReg (CmmGlobal (GlobalRegUse reg ty)))
-               NaturallyAligned
-      where ty = globalRegSpillType platform reg
-
-    restore = blockFromList (map restoreReg regs)
-
-    restoreReg :: GlobalReg -> CmmNode O O
-    restoreReg reg =
-      CmmAssign (CmmGlobal (GlobalRegUse reg ty))
-                (CmmLoad (get_GlobalReg_addr platform reg)
-                         ty
-                         NaturallyAligned)
-      where ty = globalRegSpillType platform reg
+    regs_to_save :: [GlobalReg]
+    regs_to_save = filter (callerSaves platform) (activeStgRegs platform)
+
+    nodes :: [(CmmNode O O, CmmNode O O)]
+    nodes =
+        zipWith mk_reg regs_to_save (uniqsFromSupply us)
+      where
+        mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O)
+        mk_reg reg u =
+            let ty = globalRegSpillType platform reg
+                greg = CmmGlobal (GlobalRegUse reg ty)
+                lreg = CmmLocal (LocalReg u ty)
+                save = CmmAssign lreg (CmmReg greg)
+                restore = CmmAssign greg (CmmReg lreg)
+            in (save, restore)
+
+    (save_nodes, restore_nodes) = unzip nodes
+    save = blockFromList save_nodes
+    restore = blockFromList restore_nodes
 
 -- | Mirrors __tsan_memory_order
 -- <https://github.com/llvm-mirror/compiler-rt/blob/master/include/sanitizer/tsan_interface_atomic.h#L32>


=====================================
hadrian/src/Flavour.hs
=====================================
@@ -47,7 +47,8 @@ flavourTransformers = M.fromList
     , "ticky_ghc"        =: enableTickyGhc
     , "split_sections"   =: splitSections
     , "no_split_sections" =: noSplitSections
-    , "thread_sanitizer" =: enableThreadSanitizer
+    , "thread_sanitizer" =: enableThreadSanitizer False
+    , "thread_sanitizer_cmm" =: enableThreadSanitizer True
     , "llvm"             =: viaLlvmBackend
     , "profiled_ghc"     =: enableProfiledGhc
     , "no_dynamic_ghc"   =: disableDynamicGhcPrograms
@@ -152,7 +153,8 @@ werror =
 -- | Build C and Haskell objects with debugging information.
 enableDebugInfo :: Flavour -> Flavour
 enableDebugInfo = addArgs $ notStage0 ? mconcat
-    [ builder (Ghc CompileHs) ? arg "-g3"
+    [ builder (Ghc CompileHs) ? pure ["-g3"]
+    , builder (Ghc CompileCWithGhc) ? pure ["-optc-g3"]
     , builder (Cc CompileC) ? arg "-g3"
     , builder (Cabal Setup) ? arg "--disable-library-stripping"
     , builder (Cabal Setup) ? arg "--disable-executable-stripping"
@@ -218,14 +220,18 @@ noSplitSections f = f { ghcSplitSections = False }
 
 -- | Build GHC and libraries with ThreadSanitizer support. You likely want to
 -- configure with @--disable-large-address-space@ when using this.
-enableThreadSanitizer :: Flavour -> Flavour
-enableThreadSanitizer = addArgs $ notStage0 ? mconcat
-    [ builder (Ghc CompileHs) ? (arg "-optc-fsanitize=thread" <> arg "-fcmm-thread-sanitizer")
-    , builder (Ghc CompileCWithGhc) ? arg "-optc-fsanitize=thread"
+enableThreadSanitizer :: Bool -> Flavour -> Flavour
+enableThreadSanitizer instrumentCmm = addArgs $ notStage0 ? mconcat
+    [ instrumentCmm ? builder (Ghc CompileCWithGhc) ? arg "-optc-fsanitize=thread"
+
     , builder (Ghc LinkHs) ? (arg "-optc-fsanitize=thread" <> arg "-optl-fsanitize=thread")
     , builder Cc ? arg "-fsanitize=thread"
     , builder (Cabal Flags) ? arg "thread-sanitizer"
     , builder Testsuite ? arg "--config=have_thread_sanitizer=True"
+    , builder (Ghc CompileHs) ? mconcat
+        [ package pkg ? (arg "-optc-fsanitize=thread" <> arg "-fcmm-thread-sanitizer")
+        | pkg <- [base, ghcPrim, array, rts]
+        ]
     ]
 
 -- | Use the LLVM backend in stages 1 and later.


=====================================
rts/include/Cmm.h
=====================================
@@ -596,6 +596,7 @@
 /* Getting/setting the info pointer of a closure */
 #define SET_INFO(p,info) StgHeader_info(p) = info
 #define SET_INFO_RELEASE(p,info) %release StgHeader_info(p) = info
+#define SET_INFO_RELAXED(p,info) %relaxed StgHeader_info(p) = info
 #define GET_INFO(p) StgHeader_info(p)
 #define GET_INFO_ACQUIRE(p) %acquire GET_INFO(p)
 
@@ -687,10 +688,18 @@
 #define RELEASE_FENCE prim %fence_release();
 #define ACQUIRE_FENCE prim %fence_acquire();
 
+// TODO
+#if 1
+#define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire64(x); }
+#else
+#define ACQUIRE_FENCE_ON(x) ACQUIRE_FENCE
+#endif
+
 #else
 
 #define RELEASE_FENCE /* nothing */
 #define ACQUIRE_FENCE /* nothing */
+#define ACQUIRE_FENCE_ON(x) /* nothing */
 #endif /* THREADED_RTS */
 
 /* -----------------------------------------------------------------------------


=====================================
rts/include/rts/TSANUtils.h
=====================================
@@ -28,6 +28,40 @@
  * In general it's best to add suppressions only as a last resort, when the
  * more precise annotation functions prove to be insufficient.
  *
+ * GHC can be configured with two extents of TSAN instrumentation:
+ *
+ *  - instrumenting the C RTS (by passing `-optc-fsanitize=thread`
+ *    when compiling the RTS)
+ *
+ *  - instrumenting both the C RTS and Cmm memory accesses (by passing
+ *    `-optc-fsanitize=thread -fcmm-thread-sanitizer` to all GHC invocations).
+ *
+ * These two modes can be realized in Hadrian using the `+thread_sanitizer`
+ * and `+thread_sanitizer_cmm` flavour transformers.
+ *
+ * Tips and tricks:
+ *
+ *  - One should generally run TSAN instrumented programs with the environment
+ *    variable
+ *
+ *      TSAN_OPTIONS=suppressions=$ghc_root/rts/.tsan-suppressions
+ *
+ *    to maximize signal-to-noise.
+ *
+ *  - One can set a breakpoint on `__tsan_on_report` in a debugger to pause when
+ *    a TSAN report is found.
+ *
+ *  - TSAN-instrumented will by default exit with code 66 when a violation has
+ *    been found. However, this can be disabled by setting
+ *    `TSAN_OPTIONS=exitcode=0`
+ *
+ *  - If TSAN is able to report useful stack traces it may help to set
+ *    `TSAN_OPTIONS=history_size=3` or greater (up to 7). This increases the
+ *    size of TSAN's per-thread memory access history buffer.
+ *
+ * - TSAN report messages can be redirected to a file using
+ *   `TSAN_OPTIONS=log_path=...`
+ *
  * Users guide: https://github.com/google/sanitizers/wiki/ThreadSanitizerCppManual
  */
 


=====================================
rts/include/rts/storage/ClosureMacros.h
=====================================
@@ -47,6 +47,11 @@
 
 EXTERN_INLINE void SET_INFO(StgClosure *c, const StgInfoTable *info);
 EXTERN_INLINE void SET_INFO(StgClosure *c, const StgInfoTable *info) {
+    c->header.info = info;
+}
+
+EXTERN_INLINE void SET_INFO_RELAXED(StgClosure *c, const StgInfoTable *info);
+EXTERN_INLINE void SET_INFO_RELAXED(StgClosure *c, const StgInfoTable *info) {
     RELAXED_STORE(&c->header.info, info);
 }
 
@@ -70,6 +75,7 @@ EXTERN_INLINE StgThunkInfoTable *itbl_to_thunk_itbl     (const StgInfoTable *i);
 EXTERN_INLINE StgConInfoTable   *itbl_to_con_itbl       (const StgInfoTable *i);
 
 #if defined(TABLES_NEXT_TO_CODE)
+NO_WARN(-Warray-bounds,
 EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info - 1;}
 EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info - 1;}
 EXTERN_INLINE StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info - 1;}
@@ -79,6 +85,7 @@ EXTERN_INLINE StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (
 EXTERN_INLINE StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)(i + 1) - 1;}
 EXTERN_INLINE StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)(i + 1) - 1;}
 EXTERN_INLINE StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)(i + 1) - 1;}
+)
 #else
 EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info;}
 EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info;}


=====================================
rts/include/stg/SMP.h
=====================================
@@ -490,10 +490,25 @@ busy_wait_nop(void)
 // These are typically necessary only in very specific cases (e.g. WSDeque)
 // where the ordered operations aren't expressive enough to capture the desired
 // ordering.
+//
+// Additionally, it is preferable to use the *_FENCE_ON() forms, which turn into
+// memory accesses when compiling for ThreadSanitizer (as ThreadSanitizer is
+// otherwise unable to reason about fences). See Note [ThreadSanitizer] in
+// TSANUtils.h.
+
 #define ACQUIRE_FENCE() __atomic_thread_fence(__ATOMIC_ACQUIRE)
 #define RELEASE_FENCE() __atomic_thread_fence(__ATOMIC_RELEASE)
 #define SEQ_CST_FENCE() __atomic_thread_fence(__ATOMIC_SEQ_CST)
 
+#if defined(TSAN_ENABLED)
+#define ACQUIRE_FENCE() NO_WARN(-Wtsan, __atomic_thread_fence(__ATOMIC_ACQUIRE);)
+#define RELEASE_FENCE() NO_WARN(-Wtsan, __atomic_thread_fence(__ATOMIC_RELEASE);)
+#define SEQ_CST_FENCE() NO_WARN(-Wtsan, __atomic_thread_fence(__ATOMIC_SEQ_CST);)
+#define ACQUIRE_FENCE_ON(x) (void)ACQUIRE_LOAD(x)
+#else
+#define ACQUIRE_FENCE_ON(x) __atomic_thread_fence(__ATOMIC_ACQUIRE)
+#endif
+
 /* ---------------------------------------------------------------------- */
 #else /* !THREADED_RTS */
 
@@ -521,6 +536,8 @@ busy_wait_nop(void)
 #define ACQUIRE_FENCE()
 #define RELEASE_FENCE()
 #define SEQ_CST_FENCE()
+#define ACQUIRE_FENCE_ON(x)
+#define RELEASE_FENCE_ON(x)
 
 #if !IN_STG_CODE || IN_STGCRUN
 INLINE_HEADER StgWord



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e4045a960c7e224e3a084edc67755c3fdc2ffa70...e4820538810f0b348ee0155f90811ada0956058b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e4045a960c7e224e3a084edc67755c3fdc2ffa70...e4820538810f0b348ee0155f90811ada0956058b
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/20230724/41f3711a/attachment-0001.html>


More information about the ghc-commits mailing list