[Git][ghc/ghc][master] cmm: implement parsing of MO_AtomicRMW from hand-written CMM files
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Apr 2 23:00:27 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
43ebd5dc by Bodigrim at 2023-04-02T19:00:09-04:00
cmm: implement parsing of MO_AtomicRMW from hand-written CMM files
Fixes #23206
- - - - -
5 changed files:
- compiler/GHC/Cmm/Parser.y
- + testsuite/tests/cmm/should_run/AtomicFetch.hs
- + testsuite/tests/cmm/should_run/AtomicFetch.stdout
- + testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm
- testsuite/tests/cmm/should_run/all.T
Changes:
=====================================
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
=====================================
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
=====================================
testsuite/tests/cmm/should_run/AtomicFetch.stdout
=====================================
@@ -0,0 +1,4 @@
+-4
+-4
+-4
+-4
=====================================
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);
+}
=====================================
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', '')], ''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/43ebd5dcdb7ff65b6afccbdee22d2c27f9df6b1c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/43ebd5dcdb7ff65b6afccbdee22d2c27f9df6b1c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230402/76023143/attachment-0001.html>
More information about the ghc-commits
mailing list