cmm: Introduce MemoryOrderings

8 files changed, 36 insertions, 24 deletions

diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs
index 7bb84972a6..d134fdc346 100644
--- a/compiler/GHC/Cmm/MachOp.hs
+++ b/compiler/GHC/Cmm/MachOp.hs
@@ -24,6 +24,7 @@ module GHC.Cmm.MachOp
     , machOpMemcpyishAlign
 
     -- Atomic read-modify-write
+    , MemoryOrdering(..)
     , AtomicMachOp(..)
    )
 where
@@ -662,10 +663,12 @@ data CallishMachOp
   | MO_BSwap Width
   | MO_BRev Width
 
-  -- Atomic read-modify-write.
+  -- | Atomic read-modify-write. Arguments are @[dest, n]@.
   | MO_AtomicRMW Width AtomicMachOp
-  | MO_AtomicRead Width
-  | MO_AtomicWrite Width
+  -- | Atomic read. Arguments are @[addr]@.
+  | MO_AtomicRead Width MemoryOrdering
+  -- | Atomic write. Arguments are @[addr, value]@.
+  | MO_AtomicWrite Width MemoryOrdering
   -- | Atomic compare-and-swap. Arguments are @[dest, expected, new]@.
   -- Sequentially consistent.
   -- Possible future refactoring: should this be an'MO_AtomicRMW' variant?
@@ -680,6 +683,14 @@ data CallishMachOp
   | MO_ResumeThread
   deriving (Eq, Show)
 
+-- | C11 memory ordering semantics.
+data MemoryOrdering
+  = MemOrderRelaxed  -- ^ relaxed ordering
+  | MemOrderAcquire  -- ^ acquire ordering
+  | MemOrderRelease  -- ^ release ordering
+  | MemOrderSeqCst   -- ^ sequentially consistent
+  deriving (Eq, Ord, Show)
+
 -- | The operation to perform atomically.
 data AtomicMachOp =
       AMO_Add
diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
index 42c2d82247..4569caecca 100644
--- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
@@ -1533,8 +1533,8 @@ genCCall target dest_regs arg_regs bid = do
 
         -- -- Atomic read-modify-write.
         MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
-        MO_AtomicRead w     -> mkCCall (atomicReadLabel w)
-        MO_AtomicWrite w    -> mkCCall (atomicWriteLabel w)
+        MO_AtomicRead w _   -> mkCCall (atomicReadLabel w)
+        MO_AtomicWrite w _  -> mkCCall (atomicWriteLabel w)
         MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)
         -- -- Should be an AtomicRMW variant eventually.
         -- -- Sequential consistent.
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index 3b448041e3..1d6169a45d 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -1173,7 +1173,7 @@ genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
                           (n_reg, n_code) <- getSomeReg n
                           return  (op dst dst (RIReg n_reg), n_code)
 
-genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
+genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr]
  = do let fmt      = intFormat width
           reg_dst  = getLocalRegReg dst
           form     = if widthInBits width == 64 then DS else D
@@ -1200,7 +1200,7 @@ genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
 -- This is also what gcc does.
 
 
-genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do
+genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do
     code <- assignMem_IntCode (intFormat width) addr val
     return $ unitOL HWSYNC `appOL` code
 
@@ -2067,8 +2067,8 @@ genCCall' config gcp target dest_regs args
                     MO_AtomicRMW {} -> unsupported
                     MO_Cmpxchg w -> (cmpxchgLabel w, False)
                     MO_Xchg w    -> (xchgLabel w, False)
-                    MO_AtomicRead _  -> unsupported
-                    MO_AtomicWrite _ -> unsupported
+                    MO_AtomicRead _ _  -> unsupported
+                    MO_AtomicWrite _ _ -> unsupported
 
                     MO_S_Mul2    {}  -> unsupported
                     MO_S_QuotRem {}  -> unsupported
diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
index 676fe1f8fe..43c9c2fd31 100644
--- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
+++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
@@ -1304,7 +1304,7 @@ lower_CallishMachOp lbl (MO_AtomicRMW w0 op) rs xs =
     CmmMayReturn
     rs
     xs
-lower_CallishMachOp lbl (MO_AtomicRead w0) [reg] [ptr] = do
+lower_CallishMachOp lbl (MO_AtomicRead w0 _) [reg] [ptr] = do
   SomeWasmExpr ty (WasmExpr ret_instr) <-
     lower_CmmLoad
       lbl
@@ -1313,7 +1313,7 @@ lower_CallishMachOp lbl (MO_AtomicRead w0) [reg] [ptr] = do
       NaturallyAligned
   ri <- onCmmLocalReg_Typed ty reg
   pure $ WasmStatements $ ret_instr `WasmConcat` WasmLocalSet ty ri
-lower_CallishMachOp lbl (MO_AtomicWrite _) [] [ptr, val] =
+lower_CallishMachOp lbl (MO_AtomicWrite _ _) [] [ptr, val] =
   lower_CmmStore lbl ptr val NaturallyAligned
 lower_CallishMachOp lbl (MO_Cmpxchg w0) rs xs = lower_MO_Cmpxchg lbl w0 rs xs
 lower_CallishMachOp lbl (MO_Xchg w0) rs xs =
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index 6fe264572a..d9ad3aa781 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -2203,8 +2203,8 @@ genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid widt
 genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask
 genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src
 genSimplePrim bid (MO_UF_Conv width)   [dst]   [src]          = genWordToFloat bid width dst src
-genSimplePrim _   (MO_AtomicRead w)    [dst]   [addr]         = genAtomicRead w dst addr
-genSimplePrim _   (MO_AtomicWrite w)   []      [addr,val]     = genAtomicWrite w addr val
+genSimplePrim _   (MO_AtomicRead w _)  [dst]   [addr]         = genAtomicRead w dst addr
+genSimplePrim _   (MO_AtomicWrite w _) []      [addr,val]     = genAtomicWrite w addr val
 genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new
 genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value
 genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index b52cc10150..03058eee9c 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -944,8 +944,9 @@ pprCallishMachOp_for_C mop
         MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop)
         MO_Cmpxchg w        -> ftext (cmpxchgLabel w)
         MO_Xchg w           -> ftext (xchgLabel w)
-        MO_AtomicRead w     -> ftext (atomicReadLabel w)
-        MO_AtomicWrite w    -> ftext (atomicWriteLabel w)
+        -- TODO: handle orderings
+        MO_AtomicRead w _   -> ftext (atomicReadLabel w)
+        MO_AtomicWrite w _  -> ftext (atomicWriteLabel w)
         MO_UF_Conv w        -> ftext (word2FloatLabel w)
 
         MO_S_Mul2     {} -> unsupported
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 7b14290432..6bfda5f909 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -265,7 +265,7 @@ genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $
     retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
     statement $ Store retVar dstVar Nothing
 
-genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do
+genCall (PrimTarget (MO_AtomicRead _ _)) [dst] [addr] = runStmtsDecls $ do
     dstV <- getCmmRegW (CmmLocal dst)
     v1 <- genLoadW True addr (localRegType dst) NaturallyAligned
     statement $ Store v1 dstV Nothing
@@ -294,7 +294,7 @@ genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do
     resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)
     statement $ Store resVar dstV Nothing
 
-genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
+genCall (PrimTarget (MO_AtomicWrite _width _)) [] [addr, val] = runStmtsDecls $ do
     addrVar <- exprToVarW addr
     valVar <- exprToVarW val
     let ptrTy = pLift $ getVarType valVar
@@ -1012,11 +1012,11 @@ cmmPrimOpFunctions mop = do
     MO_Touch         -> unsupported
     MO_UF_Conv _     -> unsupported
 
-    MO_AtomicRead _  -> unsupported
-    MO_AtomicRMW _ _ -> unsupported
-    MO_AtomicWrite _ -> unsupported
-    MO_Cmpxchg _     -> unsupported
-    MO_Xchg _        -> unsupported
+    MO_AtomicRead _ _  -> unsupported
+    MO_AtomicRMW _ _   -> unsupported
+    MO_AtomicWrite _ _ -> unsupported
+    MO_Cmpxchg _       -> unsupported
+    MO_Xchg _          -> unsupported
 
     MO_I64_ToI       -> dontReach64
     MO_I64_FromI     -> dontReach64
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 7366c529c8..93fdd3f5e2 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -3011,7 +3011,7 @@ doAtomicReadAddr
 doAtomicReadAddr res addr ty =
     emitPrimCall
         [ res ]
-        (MO_AtomicRead (typeWidth ty))
+        (MO_AtomicRead (typeWidth ty) MemOrderSeqCst)
         [ addr ]
 
 -- | Emit an atomic write to a byte array that acts as a memory barrier.
@@ -3039,7 +3039,7 @@ doAtomicWriteAddr
 doAtomicWriteAddr addr ty val =
     emitPrimCall
         [ {- no results -} ]
-        (MO_AtomicWrite (typeWidth ty))
+        (MO_AtomicWrite (typeWidth ty) MemOrderSeqCst)
         [ addr, val ]
 
 doCasByteArray