{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
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 { Env -> Platform
platform :: Platform
, Env -> [Unique]
uniques :: [Unique]
}
annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph
annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph
annotateTSAN Platform
platform CmmGraph
graph = do
Env
env <- Platform -> [Unique] -> Env
Env Platform
platform ([Unique] -> Env) -> UniqSM [Unique] -> UniqSM Env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
CmmGraph -> UniqSM CmmGraph
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmGraph -> UniqSM CmmGraph) -> CmmGraph -> UniqSM CmmGraph
forall a b. (a -> b) -> a -> b
$ (Graph CmmNode C C -> Graph CmmNode C C) -> CmmGraph -> CmmGraph
forall (n :: Extensibility -> Extensibility -> *)
(n' :: Extensibility -> Extensibility -> *).
(Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph ((forall (e1 :: Extensibility) (x1 :: Extensibility).
Block CmmNode e1 x1 -> Block CmmNode e1 x1)
-> Graph CmmNode C C -> Graph CmmNode C C
forall (block :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n :: Extensibility -> Extensibility -> *)
(block' :: (Extensibility -> Extensibility -> *)
-> Extensibility -> Extensibility -> *)
(n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
(x :: Extensibility).
(forall (e1 :: Extensibility) (x1 :: Extensibility).
block n e1 x1 -> block' n' e1 x1)
-> Graph' block n e x -> Graph' block' n' e x
mapGraphBlocks (Env -> Block CmmNode e1 x1 -> Block CmmNode e1 x1
forall (e :: Extensibility) (x :: Extensibility).
Env -> Block CmmNode e x -> Block CmmNode e x
annotateBlock Env
env)) CmmGraph
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
CmmStore CmmExpr
lhs CmmExpr
rhs AlignmentSpec
align ->
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
-> AlignmentSpec -> CmmType -> CmmExpr -> Block CmmNode 'Open 'Open
tsanStore Env
env AlignmentSpec
align 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)
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 []
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
_) = []
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
_) = []
annotatePrim :: Env
-> CallishMachOp
-> [CmmFormal]
-> [CmmActual]
-> Maybe (Block CmmNode O O)
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
-> [CmmFormal]
-> [CmmActual]
-> 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`
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`
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`
Block CmmNode 'Open 'Open
restore
where
(Block CmmNode 'Open 'Open
save, Block CmmNode 'Open 'Open
restore) = Platform -> (Block CmmNode 'Open 'Open, Block CmmNode 'Open 'Open)
saveRestoreCallerRegs (Env -> Platform
platform Env
env)
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 (Env -> [Unique]
uniques Env
env) [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)
saveRestoreCallerRegs :: Platform
-> (Block CmmNode O O, Block CmmNode O O)
saveRestoreCallerRegs :: Platform -> (Block CmmNode 'Open 'Open, Block CmmNode 'Open 'Open)
saveRestoreCallerRegs Platform
platform =
(Block CmmNode 'Open 'Open
save, Block CmmNode 'Open 'Open
restore)
where
regs :: [GlobalReg]
regs = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform) (Platform -> [GlobalReg]
activeStgRegs Platform
platform)
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 ((GlobalReg -> CmmNode 'Open 'Open)
-> [GlobalReg] -> [CmmNode 'Open 'Open]
forall a b. (a -> b) -> [a] -> [b]
map GlobalReg -> CmmNode 'Open 'Open
saveReg [GlobalReg]
regs)
saveReg :: GlobalReg -> CmmNode 'Open 'Open
saveReg GlobalReg
reg =
CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode 'Open 'Open
CmmStore (Platform -> GlobalReg -> CmmExpr
get_GlobalReg_addr Platform
platform GlobalReg
reg)
(CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
reg))
AlignmentSpec
NaturallyAligned
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 ((GlobalReg -> CmmNode 'Open 'Open)
-> [GlobalReg] -> [CmmNode 'Open 'Open]
forall a b. (a -> b) -> [a] -> [b]
map GlobalReg -> CmmNode 'Open 'Open
restoreReg [GlobalReg]
regs)
restoreReg :: GlobalReg -> CmmNode 'Open 'Open
restoreReg GlobalReg
reg =
CmmReg -> CmmExpr -> CmmNode 'Open 'Open
CmmAssign (GlobalReg -> CmmReg
CmmGlobal GlobalReg
reg)
(CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> GlobalReg -> CmmExpr
get_GlobalReg_addr Platform
platform GlobalReg
reg)
(Platform -> GlobalReg -> CmmType
globalRegType Platform
platform GlobalReg
reg)
AlignmentSpec
NaturallyAligned)
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
-> [ForeignHint]
-> [ForeignHint]
-> 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
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
fn Maybe Int
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction
tsanStore :: Env
-> AlignmentSpec -> CmmType -> CmmExpr
-> Block CmmNode O O
tsanStore :: Env
-> AlignmentSpec -> CmmType -> CmmExpr -> Block CmmNode 'Open 'Open
tsanStore Env
env AlignmentSpec
align CmmType
ty CmmExpr
addr =
Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [] [CmmExpr
addr]
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_write" 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_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 =
Env
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Block CmmNode 'Open 'Open
mkUnsafeCall Env
env ForeignTarget
ftarget [] [CmmExpr
addr]
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"
tsanAtomicCas :: Env
-> MemoryOrdering
-> MemoryOrdering
-> Width
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> LocalReg
-> 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'