cmm: implement parsing of MO_AtomicRMW from hand-written CMM files

Fixes #23206

5 files changed, 153 insertions, 0 deletions

diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 6ba2d9df71..29870dc647 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -1137,6 +1137,12 @@ callishMachOps platform = listToUFM $
     , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst)
     , allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease)
     , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst)
+    , allWidths "fetch_add" (\w -> MO_AtomicRMW w AMO_Add)
+    , allWidths "fetch_sub" (\w -> MO_AtomicRMW w AMO_Sub)
+    , allWidths "fetch_and" (\w -> MO_AtomicRMW w AMO_And)
+    , allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand)
+    , allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or)
+    , allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor)
     ]
   where
     allWidths
diff --git a/testsuite/tests/cmm/should_run/AtomicFetch.hs b/testsuite/tests/cmm/should_run/AtomicFetch.hs
new file mode 100644
index 0000000000..f5a49d67b0
--- /dev/null
+++ b/testsuite/tests/cmm/should_run/AtomicFetch.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+-- This is not a test of atomic semantics,
+-- just checking that GHC can parse %fetch_fooXX
+
+import GHC.Exts
+import GHC.Int
+import GHC.ST
+
+foreign import prim "cmm_foo8" cmm_foo8
+  :: MutableByteArray# s -> State# s -> (# State# s, Int8# #)
+
+foreign import prim "cmm_foo16" cmm_foo16
+  :: MutableByteArray# s -> State# s -> (# State# s, Int16# #)
+
+foreign import prim "cmm_foo32" cmm_foo32
+  :: MutableByteArray# s -> State# s -> (# State# s, Int32# #)
+
+foreign import prim "cmm_foo64" cmm_foo64
+  :: MutableByteArray# s -> State# s -> (# State# s, Int64# #)
+
+go8 :: Int8
+go8 = runST $ ST $ \s0 ->
+  case newByteArray# 8# s0 of
+    (# s1, mba #) -> case cmm_foo8 mba s1 of
+        (# s2, n' #) -> (# s2, I8# n' #)
+
+go16 :: Int16
+go16 = runST $ ST $ \s0 ->
+  case newByteArray# 8# s0 of
+    (# s1, mba #) -> case cmm_foo16 mba s1 of
+        (# s2, n' #) -> (# s2, I16# n' #)
+
+go32 :: Int32
+go32 = runST $ ST $ \s0 ->
+  case newByteArray# 8# s0 of
+    (# s1, mba #) -> case cmm_foo32 mba s1 of
+        (# s2, n' #) -> (# s2, I32# n' #)
+
+go64 :: Int64
+go64 = runST $ ST $ \s0 ->
+  case newByteArray# 8# s0 of
+    (# s1, mba #) -> case cmm_foo64 mba s1 of
+        (# s2, n' #) -> (# s2, I64# n' #)
+
+main = do
+  print go8
+  print go16
+  print go32
+  print go64
diff --git a/testsuite/tests/cmm/should_run/AtomicFetch.stdout b/testsuite/tests/cmm/should_run/AtomicFetch.stdout
new file mode 100644
index 0000000000..f08efc6e71
--- /dev/null
+++ b/testsuite/tests/cmm/should_run/AtomicFetch.stdout
@@ -0,0 +1,4 @@
+-4
+-4
+-4
+-4
diff --git a/testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm b/testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm
new file mode 100644
index 0000000000..f545b632e0
--- /dev/null
+++ b/testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm
@@ -0,0 +1,80 @@
+#include "Cmm.h"
+
+// This is not a test of atomic semantics,
+// just checking that GHC can parse %fetch_fooXX
+
+cmm_foo64 (P_ p)
+{
+  // p points to a ByteArray header, q points to its first element
+  P_ q;
+  q = p + SIZEOF_StgHeader + WDS(1);
+
+  bits64 x;
+
+  prim %store_seqcst64(q, 42);
+  (x) = prim %fetch_add64(q, 5);
+  (x) = prim %fetch_sub64(q, 10);
+  (x) = prim %fetch_and64(q, 120);
+  (x) = prim %fetch_or64(q, 2);
+  (x) = prim %fetch_xor64(q, 33);
+  (x) = prim %fetch_nand64(q, 127);
+  (x) = prim %load_seqcst64(q);
+  return (x);
+}
+
+cmm_foo32 (P_ p)
+{
+  // p points to a ByteArray header, q points to its first element
+  P_ q;
+  q = p + SIZEOF_StgHeader + WDS(1);
+
+  bits32 x;
+
+  prim %store_seqcst32(q, 42);
+  (x) = prim %fetch_add32(q, 5);
+  (x) = prim %fetch_sub32(q, 10);
+  (x) = prim %fetch_and32(q, 120);
+  (x) = prim %fetch_or32(q, 2);
+  (x) = prim %fetch_xor32(q, 33);
+  (x) = prim %fetch_nand32(q, 127);
+  (x) = prim %load_seqcst32(q);
+  return (x);
+}
+
+cmm_foo16 (P_ p)
+{
+  // p points to a ByteArray header, q points to its first element
+  P_ q;
+  q = p + SIZEOF_StgHeader + WDS(1);
+
+  bits16 x;
+
+  prim %store_seqcst16(q, 42);
+  (x) = prim %fetch_add16(q, 5);
+  (x) = prim %fetch_sub16(q, 10);
+  (x) = prim %fetch_and16(q, 120);
+  (x) = prim %fetch_or16(q, 2);
+  (x) = prim %fetch_xor16(q, 33);
+  (x) = prim %fetch_nand16(q, 127);
+  (x) = prim %load_seqcst16(q);
+  return (x);
+}
+
+cmm_foo8 (P_ p)
+{
+  // p points to a ByteArray header, q points to its first element
+  P_ q;
+  q = p + SIZEOF_StgHeader + WDS(1);
+
+  bits8 x;
+
+  prim %store_seqcst8(q, 42);
+  (x) = prim %fetch_add8(q, 5);
+  (x) = prim %fetch_sub8(q, 10);
+  (x) = prim %fetch_and8(q, 120);
+  (x) = prim %fetch_or8(q, 2);
+  (x) = prim %fetch_xor8(q, 33);
+  (x) = prim %fetch_nand8(q, 127);
+  (x) = prim %load_seqcst8(q);
+  return (x);
+}
diff --git a/testsuite/tests/cmm/should_run/all.T b/testsuite/tests/cmm/should_run/all.T
index d6c90d4ac2..5222a55c80 100644
--- a/testsuite/tests/cmm/should_run/all.T
+++ b/testsuite/tests/cmm/should_run/all.T
@@ -34,3 +34,12 @@ test('T22871',
      ],
      multi_compile_and_run,
      ['T22871', [('T22871_cmm.cmm', '')], ''])
+
+test('AtomicFetch',
+     [    extra_run_opts('"' + config.libdir + '"')
+     ,    omit_ways(['ghci'])
+     ,    req_cmm
+     ,    when(arch('i386'), skip) # https://gitlab.haskell.org/ghc/ghc/-/issues/23217
+     ],
+     multi_compile_and_run,
+     ['AtomicFetch', [('AtomicFetch_cmm.cmm', '')], ''])