From 509d1f11bf4e7eb4b916ae1c33abc48047b3be0e Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Thu, 9 Mar 2023 09:44:39 -0500
Subject: codeGen/tsan: Disable instrumentation of unaligned stores

There is some disagreement regarding the prototype of
`__tsan_unaligned_write` (specifically whether it takes just the written
address, or the address and the value as an argument). Moreover, I have
observed crashes which appear to be due to it. Disable instrumentation
of unaligned stores as a temporary mitigation.

Fixes #23096.
---
 compiler/GHC/Cmm/ThreadSanitizer.hs | 15 +++++++--------
 1 file changed, 7 insertions(+), 8 deletions(-)

(limited to 'compiler')

diff --git a/compiler/GHC/Cmm/ThreadSanitizer.hs b/compiler/GHC/Cmm/ThreadSanitizer.hs
index ab4e16edb7..f202c1dc43 100644
--- a/compiler/GHC/Cmm/ThreadSanitizer.hs
+++ b/compiler/GHC/Cmm/ThreadSanitizer.hs
@@ -54,11 +54,13 @@ annotateNode env node =
       CmmTick{}               -> BMiddle node
       CmmUnwind{}             -> BMiddle node
       CmmAssign{}             -> annotateNodeOO env node
-      CmmStore lhs rhs align  ->
+      -- TODO: Track unaligned stores
+      CmmStore _ _ Unaligned  -> annotateNodeOO env node
+      CmmStore lhs rhs NaturallyAligned  ->
           let ty = cmmExprType (platform env) rhs
               rhs_nodes = annotateLoads env (collectExprLoads rhs)
               lhs_nodes = annotateLoads env (collectExprLoads lhs)
-              st        = tsanStore env align ty lhs
+              st        = tsanStore env 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)
@@ -197,17 +199,14 @@ tsanTarget fn formals args =
     lbl = mkForeignLabel fn Nothing ForeignLabelInExternalPackage IsFunction
 
 tsanStore :: Env
-          -> AlignmentSpec -> CmmType -> CmmExpr
+          -> CmmType -> CmmExpr
           -> Block CmmNode O O
-tsanStore env align ty addr =
+tsanStore env 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
+    fn = fsLit $ "__tsan_write" ++ show w
 
 tsanLoad :: Env
          -> AlignmentSpec -> CmmType -> CmmExpr
-- 
cgit v1.2.1