{-# 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.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 GHC.Cmm.Dataflow.Label

import Data.Maybe (fromMaybe)

data Env = Env { Env -> Platform
platform :: Platform
               , Env -> UniqSupply
uniques :: UniqSupply
               }

annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph
annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph
annotateTSAN Platform
platform CmmGraph
graph = do
    env <- Platform -> UniqSupply -> Env
Env Platform
platform (UniqSupply -> Env) -> UniqSM UniqSupply -> UniqSM Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
    return $ modifyGraph (mapGraphBlocks mapMap (annotateBlock env)) graph

mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')
             -> Block n e x -> Block n e x
mapBlockList :: forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f (BlockCO n C 'Open
n Block n 'Open 'Open
rest  ) = n e 'Open -> Block n e 'Open
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f n e 'Open
n C 'Open
n Block n e 'Open -> Block n 'Open x -> Block n e x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` (forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n 'Open x -> Block n 'Open x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList n e' x' -> Block n e' x'
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f Block n 'Open x
Block n 'Open 'Open
rest
mapBlockList forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f (BlockCC n C 'Open
n Block n 'Open 'Open
rest n 'Open C
m) = n e 'Open -> Block n e 'Open
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f n e 'Open
n C 'Open
n Block n e 'Open -> Block n 'Open 'Open -> Block n e 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` (forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n 'Open 'Open -> Block n 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList n e' x' -> Block n e' x'
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f Block n 'Open 'Open
rest Block n e 'Open -> Block n 'Open x -> Block n e x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` n 'Open x -> Block n 'Open x
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f n 'Open x
n 'Open C
m
mapBlockList forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f (BlockOC   Block n 'Open 'Open
rest n 'Open C
m) = (forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e 'Open -> Block n e 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList n e' x' -> Block n e' x'
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f Block n e 'Open
Block n 'Open 'Open
rest Block n e 'Open -> Block n 'Open x -> Block n e x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` n 'Open x -> Block n 'Open x
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f n 'Open x
n 'Open C
m
mapBlockList forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
_ Block n e x
BNil               = Block n e x
Block n 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Open 'Open
BNil
mapBlockList forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f (BMiddle n 'Open 'Open
blk)      = n e x -> Block n e x
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f n e x
n 'Open 'Open
blk
mapBlockList forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f (BCat Block n 'Open 'Open
a Block n 'Open 'Open
b)         = (forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e 'Open -> Block n e 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList n e' x' -> Block n e' x'
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f Block n e 'Open
Block n 'Open 'Open
a Block n e 'Open -> Block n 'Open x -> Block n e x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` (forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n 'Open x -> Block n 'Open x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList n e' x' -> Block n e' x'
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f Block n 'Open x
Block n 'Open 'Open
b
mapBlockList forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f (BSnoc Block n 'Open 'Open
a n 'Open 'Open
n)        = (forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e 'Open -> Block n e 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList n e' x' -> Block n e' x'
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f Block n e 'Open
Block n 'Open 'Open
a Block n e 'Open -> Block n 'Open x -> Block n e x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` n 'Open x -> Block n 'Open x
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f n 'Open x
n 'Open 'Open
n
mapBlockList forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f (BCons n 'Open 'Open
n Block n 'Open 'Open
a)        = n e 'Open -> Block n e 'Open
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f n e 'Open
n 'Open 'Open
n Block n e 'Open -> Block n 'Open x -> Block n e x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` (forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n 'Open x -> Block n 'Open x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList n e' x' -> Block n e' x'
forall (e' :: Extensibility) (x' :: Extensibility).
n e' x' -> Block n e' x'
f Block n 'Open x
Block n 'Open 'Open
a

annotateBlock :: Env -> Block CmmNode e x -> Block CmmNode e x
annotateBlock :: forall (e :: Extensibility) (x :: Extensibility).
Env -> Block CmmNode e x -> Block CmmNode e x
annotateBlock Env
env = (forall (e' :: Extensibility) (x' :: Extensibility).
 CmmNode e' x' -> Block CmmNode e' x')
-> Block CmmNode e x -> Block CmmNode e x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
(forall (e' :: Extensibility) (x' :: Extensibility).
 n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
mapBlockList (Env -> CmmNode e' x' -> Block CmmNode e' x'
forall (e :: Extensibility) (x :: Extensibility).
Env -> CmmNode e x -> Block CmmNode e x
annotateNode Env
env)

annotateNode :: Env -> CmmNode e x -> Block CmmNode e x
annotateNode :: forall (e :: Extensibility) (x :: Extensibility).
Env -> CmmNode e x -> Block CmmNode e x
annotateNode Env
env CmmNode e x
node =
    case CmmNode e x
node of
      CmmEntry{}              -> CmmNode C 'Open
-> Block CmmNode 'Open 'Open -> Block CmmNode C 'Open
forall (n :: Extensibility -> Extensibility -> *).
n C 'Open -> Block n 'Open 'Open -> Block n C 'Open
BlockCO CmmNode e x
CmmNode C 'Open
node Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Open 'Open
BNil
      CmmComment{}            -> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
n 'Open 'Open -> Block n 'Open 'Open
BMiddle CmmNode e x
CmmNode 'Open 'Open
node
      CmmTick{}               -> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
n 'Open 'Open -> Block n 'Open 'Open
BMiddle CmmNode e x
CmmNode 'Open 'Open
node
      CmmUnwind{}             -> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
n 'Open 'Open -> Block n 'Open 'Open
BMiddle CmmNode e x
CmmNode 'Open 'Open
node
      CmmAssign{}             -> Env -> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
annotateNodeOO Env
env CmmNode e x
CmmNode 'Open 'Open
node
      -- TODO: Track unaligned stores
      CmmStore CmmExpr
_ CmmExpr
_ AlignmentSpec
Unaligned  -> Env -> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
annotateNodeOO Env
env CmmNode e x
CmmNode 'Open 'Open
node
      CmmStore CmmExpr
lhs CmmExpr
rhs AlignmentSpec
NaturallyAligned  ->
          let ty :: CmmType
ty = Platform -> CmmExpr -> CmmType
cmmExprType (Env -> Platform
platform Env
env) CmmExpr
rhs
              rhs_nodes :: Block CmmNode 'Open 'Open
rhs_nodes = Env -> [Load] -> Block CmmNode 'Open 'Open
annotateLoads Env
env (CmmExpr -> [Load]
collectExprLoads CmmExpr
rhs)
              lhs_nodes :: Block CmmNode 'Open 'Open
lhs_nodes = Env -> [Load] -> Block CmmNode 'Open 'Open
annotateLoads Env
env (CmmExpr -> [Load]
collectExprLoads CmmExpr
lhs)
              st :: Block CmmNode 'Open 'Open
st        = Env -> CmmType -> CmmExpr -> Block CmmNode 'Open 'Open
tsanStore Env
env CmmType
ty CmmExpr
lhs
          in Block CmmNode e 'Open
Block CmmNode 'Open 'Open
rhs_nodes Block CmmNode e 'Open
-> Block CmmNode 'Open 'Open -> Block CmmNode e 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` Block CmmNode 'Open 'Open
lhs_nodes Block CmmNode e 'Open
-> Block CmmNode 'Open 'Open -> Block CmmNode e 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` Block CmmNode 'Open 'Open
st Block CmmNode e 'Open
-> CmmNode 'Open 'Open -> Block CmmNode e 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e 'Open -> n 'Open 'Open -> Block n e 'Open
`blockSnoc` CmmNode e x
CmmNode 'Open 'Open
node
      CmmUnsafeForeignCall (PrimTarget CallishMachOp
op) [CmmFormal]
formals [CmmExpr]
args ->
          let node' :: Block CmmNode 'Open 'Open
node' = Block CmmNode 'Open 'Open
-> Maybe (Block CmmNode 'Open 'Open) -> Block CmmNode 'Open 'Open
forall a. a -> Maybe a -> a
fromMaybe (CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
n 'Open 'Open -> Block n 'Open 'Open
BMiddle CmmNode e x
CmmNode 'Open 'Open
node) (Env
-> CallishMachOp
-> [CmmFormal]
-> [CmmExpr]
-> Maybe (Block CmmNode 'Open 'Open)
annotatePrim Env
env CallishMachOp
op [CmmFormal]
formals [CmmExpr]
args)
              arg_nodes :: Block CmmNode 'Open 'Open
arg_nodes = [Block CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
[Block n 'Open 'Open] -> Block n 'Open 'Open
blockConcat ([Block CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open)
-> [Block CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> Block CmmNode 'Open 'Open)
-> [CmmExpr] -> [Block CmmNode 'Open 'Open]
forall a b. (a -> b) -> [a] -> [b]
map (Env -> CmmExpr -> Block CmmNode 'Open 'Open
annotateExpr Env
env) [CmmExpr]
args
          in Block CmmNode e 'Open
Block CmmNode 'Open 'Open
arg_nodes Block CmmNode e 'Open -> Block CmmNode 'Open x -> Block CmmNode e x
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend` Block CmmNode 'Open x
Block CmmNode 'Open 'Open
node'
      CmmUnsafeForeignCall{}  -> Env -> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
annotateNodeOO Env
env CmmNode e x
CmmNode 'Open 'Open
node
      CmmBranch{}             -> Env -> CmmNode 'Open C -> Block CmmNode 'Open C
annotateNodeOC Env
env CmmNode e x
CmmNode 'Open C
node
      CmmCondBranch{}         -> Env -> CmmNode 'Open C -> Block CmmNode 'Open C
annotateNodeOC Env
env CmmNode e x
CmmNode 'Open C
node
      CmmSwitch{}             -> Env -> CmmNode 'Open C -> Block CmmNode 'Open C
annotateNodeOC Env
env CmmNode e x
CmmNode 'Open C
node
      CmmCall{}               -> Env -> CmmNode 'Open C -> Block CmmNode 'Open C
annotateNodeOC Env
env CmmNode e x
CmmNode 'Open C
node
      CmmForeignCall{}        -> Env -> CmmNode 'Open C -> Block CmmNode 'Open C
annotateNodeOC Env
env CmmNode e x
CmmNode 'Open C
node

annotateNodeOO :: Env -> CmmNode O O -> Block CmmNode O O
annotateNodeOO :: Env -> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
annotateNodeOO Env
env CmmNode 'Open 'Open
node =
    Env -> [Load] -> Block CmmNode 'Open 'Open
annotateLoads Env
env (CmmNode 'Open 'Open -> [Load]
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> [Load]
collectLoadsNode CmmNode 'Open 'Open
node) Block CmmNode 'Open 'Open
-> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e 'Open -> n 'Open 'Open -> Block n e 'Open
`blockSnoc` CmmNode 'Open 'Open
node

annotateNodeOC :: Env -> CmmNode O C -> Block CmmNode O C
annotateNodeOC :: Env -> CmmNode 'Open C -> Block CmmNode 'Open C
annotateNodeOC Env
env CmmNode 'Open C
node =
    Env -> [Load] -> Block CmmNode 'Open 'Open
annotateLoads Env
env (CmmNode 'Open C -> [Load]
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> [Load]
collectLoadsNode CmmNode 'Open C
node) Block CmmNode 'Open 'Open
-> CmmNode 'Open C -> Block CmmNode 'Open C
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e 'Open -> n 'Open C -> Block n e C
`blockJoinTail` CmmNode 'Open C
node

annotateExpr :: Env -> CmmExpr -> Block CmmNode O O
annotateExpr :: Env -> CmmExpr -> Block CmmNode 'Open 'Open
annotateExpr Env
env CmmExpr
expr =
    Env -> [Load] -> Block CmmNode 'Open 'Open
annotateLoads Env
env (CmmExpr -> [Load]
collectExprLoads CmmExpr
expr)

-- | A load mentioned in a 'CmmExpr'.
data Load = Load CmmType AlignmentSpec CmmExpr

annotateLoads :: Env -> [Load] -> Block CmmNode O O
annotateLoads :: Env -> [Load] -> Block CmmNode 'Open 'Open
annotateLoads Env
env [Load]
loads =
    [Block CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
[Block n 'Open 'Open] -> Block n 'Open 'Open
blockConcat
    [ Env
-> AlignmentSpec -> CmmType -> CmmExpr -> Block CmmNode 'Open 'Open
tsanLoad Env
env AlignmentSpec
align CmmType
ty CmmExpr
addr
    | Load CmmType
ty AlignmentSpec
align CmmExpr
addr <- [Load]
loads
    ]

collectLoadsNode :: CmmNode e x -> [Load]
collectLoadsNode :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> [Load]
collectLoadsNode CmmNode e x
node =
    (CmmExpr -> [Load] -> [Load]) -> CmmNode e x -> [Load] -> [Load]
forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExp (\CmmExpr
exp [Load]
rest -> CmmExpr -> [Load]
collectExprLoads CmmExpr
exp [Load] -> [Load] -> [Load]
forall a. [a] -> [a] -> [a]
++ [Load]
rest) CmmNode e x
node []

-- | Collect all of the memory locations loaded from by a 'CmmExpr'.
collectExprLoads :: CmmExpr -> [Load]
collectExprLoads :: CmmExpr -> [Load]
collectExprLoads (CmmLit CmmLit
_)           = []
collectExprLoads (CmmLoad CmmExpr
e CmmType
ty AlignmentSpec
align) = [CmmType -> AlignmentSpec -> CmmExpr -> Load
Load CmmType
ty AlignmentSpec
align CmmExpr
e]
collectExprLoads (CmmReg CmmReg
_)           = []
-- N.B. we don't bother telling TSAN about MO_RelaxedReads
-- since doing so would be inconvenient and they by
-- definition can neither race nor introduce ordering.
collectExprLoads (CmmMachOp MachOp
_op [CmmExpr]
args) = (CmmExpr -> [Load]) -> [CmmExpr] -> [Load]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CmmExpr -> [Load]
collectExprLoads [CmmExpr]
args
collectExprLoads (CmmStackSlot Area
_ Int
_)   = []
collectExprLoads (CmmRegOff CmmReg
_ Int
_)      = []

-- | 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
-> CallishMachOp
-> [CmmFormal]
-> [CmmExpr]
-> Maybe (Block CmmNode 'Open 'Open)
annotatePrim Env
env (MO_AtomicRMW Width
w AtomicMachOp
aop)    [CmmFormal
dest]   [CmmExpr
addr, CmmExpr
val]  = Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open))
-> Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a b. (a -> b) -> a -> b
$ Env
-> MemoryOrdering
-> AtomicMachOp
-> Width
-> CmmExpr
-> CmmExpr
-> CmmFormal
-> Block CmmNode 'Open 'Open
tsanAtomicRMW Env
env MemoryOrdering
MemOrderSeqCst AtomicMachOp
aop Width
w CmmExpr
addr CmmExpr
val CmmFormal
dest
annotatePrim Env
env (MO_AtomicRead Width
w MemoryOrdering
mord)  [CmmFormal
dest]   [CmmExpr
addr]       = Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open))
-> Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a b. (a -> b) -> a -> b
$ Env
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmFormal
-> Block CmmNode 'Open 'Open
tsanAtomicLoad Env
env MemoryOrdering
mord Width
w CmmExpr
addr CmmFormal
dest
annotatePrim Env
env (MO_AtomicWrite Width
w MemoryOrdering
mord) []       [CmmExpr
addr, CmmExpr
val]  = Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open))
-> Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a b. (a -> b) -> a -> b
$ Env
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmExpr
-> Block CmmNode 'Open 'Open
tsanAtomicStore Env
env MemoryOrdering
mord Width
w CmmExpr
val CmmExpr
addr
annotatePrim Env
env (MO_Xchg Width
w)             [CmmFormal
dest]   [CmmExpr
addr, CmmExpr
val]  = Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open))
-> Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a b. (a -> b) -> a -> b
$ Env
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmExpr
-> CmmFormal
-> Block CmmNode 'Open 'Open
tsanAtomicExchange Env
env MemoryOrdering
MemOrderSeqCst Width
w CmmExpr
val CmmExpr
addr CmmFormal
dest
annotatePrim Env
env (MO_Cmpxchg Width
w)          [CmmFormal
dest]   [CmmExpr
addr, CmmExpr
expected, CmmExpr
new]
                                                               = Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a. a -> Maybe a
Just (Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open))
-> Block CmmNode 'Open 'Open -> Maybe (Block CmmNode 'Open 'Open)
forall a b. (a -> b) -> a -> b
$ Env
-> MemoryOrdering
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> CmmFormal
-> Block CmmNode 'Open 'Open
tsanAtomicCas Env
env MemoryOrdering
MemOrderSeqCst MemoryOrdering
MemOrderSeqCst Width
w CmmExpr
addr CmmExpr
expected CmmExpr
new CmmFormal
dest
annotatePrim Env
_    CallishMachOp
_                       [CmmFormal]
_        [CmmExpr]
_           = Maybe (Block CmmNode 'Open 'Open)
forall a. Maybe a
Nothing

mkUnsafeCall :: Env
             -> ForeignTarget  -- ^ function
             -> [CmmFormal]    -- ^ results
             -> [CmmActual]    -- ^ arguments
             -> Block CmmNode O O
mkUnsafeCall :: Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftgt [CmmFormal]
formals [CmmExpr]
args =
    Block CmmNode 'Open 'Open
save Block CmmNode 'Open 'Open
-> Block CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend`     -- save global registers
    Block CmmNode 'Open 'Open
bind_args Block CmmNode 'Open 'Open
-> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
Block n e 'Open -> n 'Open 'Open -> Block n e 'Open
`blockSnoc`  -- bind arguments to local registers
    CmmNode 'Open 'Open
call Block CmmNode 'Open 'Open
-> Block CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *)
       (e :: Extensibility) (x :: Extensibility).
Block n e 'Open -> Block n 'Open x -> Block n e x
`blockAppend`     -- perform call
    Block CmmNode 'Open 'Open
restore                -- restore global registers
  where
    (Block CmmNode 'Open 'Open
save, Block CmmNode 'Open 'Open
restore) = UniqSupply
-> Platform
-> (Block CmmNode 'Open 'Open, Block CmmNode 'Open 'Open)
saveRestoreCallerRegs UniqSupply
gregs_us (Env -> Platform
platform Env
env)

    (UniqSupply
arg_us, UniqSupply
gregs_us) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply (Env -> UniqSupply
uniques Env
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 :: [CmmReg]
arg_regs = (Unique -> CmmExpr -> CmmReg) -> [Unique] -> [CmmExpr] -> [CmmReg]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Unique -> CmmExpr -> CmmReg
arg_reg (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
arg_us) [CmmExpr]
args
      where
        arg_reg :: Unique -> CmmExpr -> CmmReg
        arg_reg :: Unique -> CmmExpr -> CmmReg
arg_reg Unique
u CmmExpr
expr = CmmFormal -> CmmReg
CmmLocal (CmmFormal -> CmmReg) -> CmmFormal -> CmmReg
forall a b. (a -> b) -> a -> b
$ Unique -> CmmType -> CmmFormal
LocalReg Unique
u (Platform -> CmmExpr -> CmmType
cmmExprType (Env -> Platform
platform Env
env) CmmExpr
expr)

    bind_args :: Block CmmNode O O
    bind_args :: Block CmmNode 'Open 'Open
bind_args = [Block CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
[Block n 'Open 'Open] -> Block n 'Open 'Open
blockConcat ([Block CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open)
-> [Block CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall a b. (a -> b) -> a -> b
$ (CmmReg -> CmmExpr -> Block CmmNode 'Open 'Open)
-> [CmmReg] -> [CmmExpr] -> [Block CmmNode 'Open 'Open]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\CmmReg
r CmmExpr
e -> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
n 'Open 'Open -> Block n 'Open 'Open
BMiddle (CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open)
-> CmmNode 'Open 'Open -> Block CmmNode 'Open 'Open
forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
r CmmExpr
e) [CmmReg]
arg_regs [CmmExpr]
args

    call :: CmmNode 'Open 'Open
call = ForeignTarget -> [CmmFormal] -> [CmmExpr] -> CmmNode 'Open 'Open
CmmUnsafeForeignCall ForeignTarget
ftgt [CmmFormal]
formals ((CmmReg -> CmmExpr) -> [CmmReg] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map CmmReg -> CmmExpr
CmmReg [CmmReg]
arg_regs)

-- | 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 :: UniqSupply
-> Platform
-> (Block CmmNode 'Open 'Open, Block CmmNode 'Open 'Open)
saveRestoreCallerRegs UniqSupply
us Platform
platform =
    (Block CmmNode 'Open 'Open
save, Block CmmNode 'Open 'Open
restore)
  where
    regs_to_save :: [GlobalReg]
    regs_to_save :: [GlobalReg]
regs_to_save = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform) (Platform -> [GlobalReg]
activeStgRegs Platform
platform)

    nodes :: [(CmmNode O O, CmmNode O O)]
    nodes :: [(CmmNode 'Open 'Open, CmmNode 'Open 'Open)]
nodes =
        (GlobalReg -> Unique -> (CmmNode 'Open 'Open, CmmNode 'Open 'Open))
-> [GlobalReg]
-> [Unique]
-> [(CmmNode 'Open 'Open, CmmNode 'Open 'Open)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith GlobalReg -> Unique -> (CmmNode 'Open 'Open, CmmNode 'Open 'Open)
mk_reg [GlobalReg]
regs_to_save (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us)
      where
        mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O)
        mk_reg :: GlobalReg -> Unique -> (CmmNode 'Open 'Open, CmmNode 'Open 'Open)
mk_reg GlobalReg
reg Unique
u =
            let ty :: CmmType
ty = Platform -> GlobalReg -> CmmType
globalRegSpillType Platform
platform GlobalReg
reg
                greg :: CmmReg
greg = GlobalRegUse -> CmmReg
CmmGlobal (GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
reg CmmType
ty)
                lreg :: CmmReg
lreg = CmmFormal -> CmmReg
CmmLocal (Unique -> CmmType -> CmmFormal
LocalReg Unique
u CmmType
ty)
                save :: CmmNode 'Open 'Open
save = CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
lreg (CmmReg -> CmmExpr
CmmReg CmmReg
greg)
                restore :: CmmNode 'Open 'Open
restore = CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign CmmReg
greg (CmmReg -> CmmExpr
CmmReg CmmReg
lreg)
            in (CmmNode 'Open 'Open
save, CmmNode 'Open 'Open
restore)

    ([CmmNode 'Open 'Open]
save_nodes, [CmmNode 'Open 'Open]
restore_nodes) = [(CmmNode 'Open 'Open, CmmNode 'Open 'Open)]
-> ([CmmNode 'Open 'Open], [CmmNode 'Open 'Open])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmNode 'Open 'Open, CmmNode 'Open 'Open)]
nodes
    save :: Block CmmNode 'Open 'Open
save = [CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
[n 'Open 'Open] -> Block n 'Open 'Open
blockFromList [CmmNode 'Open 'Open]
save_nodes
    restore :: Block CmmNode 'Open 'Open
restore = [CmmNode 'Open 'Open] -> Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
[n 'Open 'Open] -> Block n 'Open 'Open
blockFromList [CmmNode 'Open 'Open]
restore_nodes

-- | Mirrors __tsan_memory_order
-- <https://github.com/llvm/llvm-project/blob/main/compiler-rt/include/sanitizer/tsan_interface_atomic.h#L34>
memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr
memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr
memoryOrderToTsanMemoryOrder Env
env MemoryOrdering
mord =
    Platform -> Int -> CmmExpr
mkIntExpr (Env -> Platform
platform Env
env) Int
n
  where
    n :: Int
n = case MemoryOrdering
mord of
      MemoryOrdering
MemOrderRelaxed -> Int
0
      MemoryOrdering
MemOrderAcquire -> Int
2
      MemoryOrdering
MemOrderRelease -> Int
3
      MemoryOrdering
MemOrderSeqCst  -> Int
5

tsanTarget :: FastString     -- ^ function name
           -> [ForeignHint]  -- ^ formals
           -> [ForeignHint]  -- ^ arguments
           -> ForeignTarget
tsanTarget :: FastString -> [ForeignHint] -> [ForeignHint] -> ForeignTarget
tsanTarget FastString
fn [ForeignHint]
formals [ForeignHint]
args =
    CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)) ForeignConvention
conv
  where
    conv :: ForeignConvention
conv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint]
args [ForeignHint]
formals CmmReturnInfo
CmmMayReturn
    lbl :: CLabel
lbl = FastString -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
fn ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction

tsanStore :: Env
          -> CmmType -> CmmExpr
          -> Block CmmNode O O
tsanStore :: Env -> CmmType -> CmmExpr -> Block CmmNode 'Open 'Open
tsanStore Env
env CmmType
ty CmmExpr
addr
  | CmmType -> Width
typeWidth CmmType
ty Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
W128 = Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [] [CmmExpr
addr]
  | Bool
otherwise           = Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Open 'Open
emptyBlock
  where
    ftarget :: ForeignTarget
ftarget = FastString -> [ForeignHint] -> [ForeignHint] -> ForeignTarget
tsanTarget FastString
fn [] [ForeignHint
AddrHint]
    w :: Int
w = Width -> Int
widthInBytes (CmmType -> Width
typeWidth CmmType
ty)
    fn :: FastString
fn = String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"__tsan_write" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
w

tsanLoad :: Env
         -> AlignmentSpec -> CmmType -> CmmExpr
         -> Block CmmNode O O
tsanLoad :: Env
-> AlignmentSpec -> CmmType -> CmmExpr -> Block CmmNode 'Open 'Open
tsanLoad Env
env AlignmentSpec
align CmmType
ty CmmExpr
addr
  | CmmType -> Width
typeWidth CmmType
ty Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
W128  = Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [] [CmmExpr
addr]
  | Bool
otherwise            = Block CmmNode 'Open 'Open
forall (n :: Extensibility -> Extensibility -> *).
Block n 'Open 'Open
emptyBlock
  where
    ftarget :: ForeignTarget
ftarget = FastString -> [ForeignHint] -> [ForeignHint] -> ForeignTarget
tsanTarget FastString
fn [] [ForeignHint
AddrHint]
    w :: Int
w = Width -> Int
widthInBytes (CmmType -> Width
typeWidth CmmType
ty)
    fn :: FastString
fn = case AlignmentSpec
align of
           AlignmentSpec
Unaligned
             | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1    -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"__tsan_unaligned_read" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
w
           AlignmentSpec
_            -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"__tsan_read" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
w

tsanAtomicStore :: Env
                -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr
                -> Block CmmNode O O
tsanAtomicStore :: Env
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmExpr
-> Block CmmNode 'Open 'Open
tsanAtomicStore Env
env MemoryOrdering
mord Width
w CmmExpr
val CmmExpr
addr =
    Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [] [CmmExpr
addr, CmmExpr
val, CmmExpr
mord']
  where
    mord' :: CmmExpr
mord' = Env -> MemoryOrdering -> CmmExpr
memoryOrderToTsanMemoryOrder Env
env MemoryOrdering
mord
    ftarget :: ForeignTarget
ftarget = FastString -> [ForeignHint] -> [ForeignHint] -> ForeignTarget
tsanTarget FastString
fn [] [ForeignHint
AddrHint, ForeignHint
NoHint, ForeignHint
NoHint]
    fn :: FastString
fn = String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"__tsan_atomic" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Width -> Int
widthInBits Width
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_store"

tsanAtomicLoad :: Env
               -> MemoryOrdering -> Width -> CmmExpr -> LocalReg
               -> Block CmmNode O O
tsanAtomicLoad :: Env
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmFormal
-> Block CmmNode 'Open 'Open
tsanAtomicLoad Env
env MemoryOrdering
mord Width
w CmmExpr
addr CmmFormal
dest =
    Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [CmmFormal
dest] [CmmExpr
addr, CmmExpr
mord']
  where
    mord' :: CmmExpr
mord' = Env -> MemoryOrdering -> CmmExpr
memoryOrderToTsanMemoryOrder Env
env MemoryOrdering
mord
    ftarget :: ForeignTarget
ftarget = FastString -> [ForeignHint] -> [ForeignHint] -> ForeignTarget
tsanTarget FastString
fn [ForeignHint
NoHint] [ForeignHint
AddrHint, ForeignHint
NoHint]
    fn :: FastString
fn = String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"__tsan_atomic" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Width -> Int
widthInBits Width
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_load"

tsanAtomicExchange :: Env
                   -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr -> LocalReg
                   -> Block CmmNode O O
tsanAtomicExchange :: Env
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmExpr
-> CmmFormal
-> Block CmmNode 'Open 'Open
tsanAtomicExchange Env
env MemoryOrdering
mord Width
w CmmExpr
val CmmExpr
addr CmmFormal
dest =
    Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [CmmFormal
dest] [CmmExpr
addr, CmmExpr
val, CmmExpr
mord']
  where
    mord' :: CmmExpr
mord' = Env -> MemoryOrdering -> CmmExpr
memoryOrderToTsanMemoryOrder Env
env MemoryOrdering
mord
    ftarget :: ForeignTarget
ftarget = FastString -> [ForeignHint] -> [ForeignHint] -> ForeignTarget
tsanTarget FastString
fn [ForeignHint
NoHint] [ForeignHint
AddrHint, ForeignHint
NoHint, ForeignHint
NoHint]
    fn :: FastString
fn = String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"__tsan_atomic" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Width -> Int
widthInBits Width
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_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
-> MemoryOrdering
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> CmmFormal
-> Block CmmNode 'Open 'Open
tsanAtomicCas Env
env MemoryOrdering
mord_success MemoryOrdering
mord_failure Width
w CmmExpr
addr CmmExpr
expected CmmExpr
new CmmFormal
dest =
    Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [CmmFormal
dest] [CmmExpr
addr, CmmExpr
expected, CmmExpr
new, CmmExpr
mord_success', CmmExpr
mord_failure']
  where
    mord_success' :: CmmExpr
mord_success' = Env -> MemoryOrdering -> CmmExpr
memoryOrderToTsanMemoryOrder Env
env MemoryOrdering
mord_success
    mord_failure' :: CmmExpr
mord_failure' = Env -> MemoryOrdering -> CmmExpr
memoryOrderToTsanMemoryOrder Env
env MemoryOrdering
mord_failure
    ftarget :: ForeignTarget
ftarget = FastString -> [ForeignHint] -> [ForeignHint] -> ForeignTarget
tsanTarget FastString
fn [ForeignHint
NoHint] [ForeignHint
AddrHint, ForeignHint
NoHint, ForeignHint
NoHint, ForeignHint
NoHint, ForeignHint
NoHint]
    fn :: FastString
fn = String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"ghc_tsan_atomic" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Width -> Int
widthInBits Width
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_compare_exchange"

tsanAtomicRMW :: Env
              -> MemoryOrdering -> AtomicMachOp -> Width -> CmmExpr -> CmmExpr -> LocalReg
              -> Block CmmNode O O
tsanAtomicRMW :: Env
-> MemoryOrdering
-> AtomicMachOp
-> Width
-> CmmExpr
-> CmmExpr
-> CmmFormal
-> Block CmmNode 'Open 'Open
tsanAtomicRMW Env
env MemoryOrdering
mord AtomicMachOp
op Width
w CmmExpr
addr CmmExpr
val CmmFormal
dest =
    Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [CmmFormal
dest] [CmmExpr
addr, CmmExpr
val, CmmExpr
mord']
  where
    mord' :: CmmExpr
mord' = Env -> MemoryOrdering -> CmmExpr
memoryOrderToTsanMemoryOrder Env
env MemoryOrdering
mord
    ftarget :: ForeignTarget
ftarget = FastString -> [ForeignHint] -> [ForeignHint] -> ForeignTarget
tsanTarget FastString
fn [ForeignHint
NoHint] [ForeignHint
AddrHint, ForeignHint
NoHint, ForeignHint
NoHint]
    op' :: String
op' = case AtomicMachOp
op of
           AtomicMachOp
AMO_Add  -> String
"fetch_add"
           AtomicMachOp
AMO_Sub  -> String
"fetch_sub"
           AtomicMachOp
AMO_And  -> String
"fetch_and"
           AtomicMachOp
AMO_Nand -> String
"fetch_nand"
           AtomicMachOp
AMO_Or   -> String
"fetch_or"
           AtomicMachOp
AMO_Xor  -> String
"fetch_xor"
    fn :: FastString
fn = String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ String
"__tsan_atomic" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Width -> Int
widthInBits Width
w) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op'