[Git][ghc/ghc][wip/andreask/xchg_primop] Add testcase.

[Andreas Klebinger]

Andreas Klebinger pushed to branch wip/andreask/xchg_primop at Glasgow Haskell Compiler / GHC


Commits:
57952bd7 by Andreas Klebinger at 2020-05-19T18:15:42+02:00
Add testcase.

- - - - -


2 changed files:

- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/codeGen/should_run/cg_xchg001.hs


Changes:

=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -205,3 +205,4 @@ test('T15892',
 test('T16617', normal, compile_and_run, [''])
 test('T16449_2', exit_code(0), compile_and_run, [''])
 test('T16846', [only_ways(['optasm']), exit_code(1)], compile_and_run, [''])
+test('cg_xchg001', normal, compile_and_run, [''])
\ No newline at end of file


=====================================
testsuite/tests/codeGen/should_run/cg_xchg001.hs
=====================================
@@ -0,0 +1,50 @@
+{-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-}
+
+-- Tests for the atomic exchange primop.
+
+-- We initialize a value with 1, and then perform exchanges on it
+-- with two different values. At the end all the values should still
+-- be present.
+
+module Main ( main ) where
+
+import Data.Bits
+import GHC.Int
+import GHC.Prim
+import GHC.Word
+import Control.Monad
+import Control.Concurrent
+import Foreign.Marshal.Alloc
+import Foreign.Storable
+import Data.List
+
+import GHC.Exts
+import GHC.Types
+
+#include "MachDeps.h"
+
+main = do
+   alloca $ \ptr_i -> do
+      poke ptr_i (1 :: Int)
+      w1 <- newEmptyMVar :: IO (MVar Int)
+      forkIO $ do
+         v <- swapN 50000 2 ptr_i
+         putMVar w1 v
+
+      v2 <- swapN 50000 3 ptr_i
+      v1 <- takeMVar w1
+      v0 <- peek ptr_i
+      print $ sort [v0,v1,v2]
+
+swapN :: Int -> Int -> Ptr Int -> IO Int
+swapN 0 val ptr = return val
+swapN n val ptr = do
+   val' <- swap ptr val
+   swapN (n-1) val' ptr
+
+
+swap :: Ptr Int -> Int -> IO Int
+swap (Ptr ptr) (I# val) = do
+   IO $ \s -> case (interlockedExchangeInt# ptr val s) of
+            (# s2, old_val #) -> (# s2, I# old_val #)
+



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57952bd7bb4aa3d715e2725decab8bbf77a1ff55

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57952bd7bb4aa3d715e2725decab8bbf77a1ff55
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/20200519/b0dffee5/attachment-0001.html>