fix(journal): Fix CAS for 64-bits

src/journal/src/Journal/Internal/Atomics.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE CApiFFI #-}
 
 module Journal.Internal.Atomics where
 
+import Data.Coerce (coerce)
 import Foreign
 import Foreign.C.Types
 
@@ -64,8 +66,11 @@ fetchAddInt64Ptr = c_atomic_fetch_add_int_8
 foreign import ccall unsafe "c_atomic_compare_exchange_strong"
   c_atomic_compare_exchange_strong_4 :: Ptr Int32 -> Int32 -> Int32 -> IO CBool
 
-foreign import ccall unsafe "c_atomic_compare_exchange_strong"
-  c_atomic_compare_exchange_strong_8 :: Ptr Int64 -> Int64 -> Int64 -> IO CBool
+newtype {-# CTYPE "atomic_llong" #-} AtomicLong = AtomicLong Int64
+
+foreign import capi "stdatomic.h atomic_compare_exchange_strong"
+  c_atomic_compare_exchange_strong_8 :: Ptr AtomicLong -> Ptr Int64 -> Int64 -> IO CBool
+
 
 casInt32Ptr :: Ptr Int32 -> Int32 -> Int32 -> IO Bool
 casInt32Ptr ptr expected desired = do
@@ -77,8 +82,9 @@ casInt32Ptr ptr expected desired = do
       error "casInt32Addr: impossible, c_atomic_compare_exchange_strong should return a _Bool"
 
 casInt64Ptr :: Ptr Int64 -> Int64 -> Int64 -> IO Bool
-casInt64Ptr ptr expected desired = do
-  result <- c_atomic_compare_exchange_strong_8 ptr expected desired
+casInt64Ptr ptr expected desired = alloca $ \ expected_ptr -> do
+  poke expected_ptr expected
+  result <- c_atomic_compare_exchange_strong_8 (coerce ptr) expected_ptr desired
   case result of
     0 -> return False
     1 -> return True

src/journal/test/Journal/Internal/AtomicsTest.hs

@@ -2,11 +2,14 @@ module Journal.Internal.AtomicsTest where
 
 import Control.Concurrent
 import Control.Concurrent.Async
+import Control.Monad(unless)
 import Data.IORef
 import Data.List (sort)
 import Data.Word
 import Foreign
 import Test.Tasty.HUnit (Assertion, assertBool, assertEqual)
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
 
 import Journal.Internal.Atomics
 import Journal.Types.AtomicCounter
@@ -81,3 +84,43 @@ unit_atomicCASConcurrent = do
           if b
           then atomicModifyIORef' hist (\hist -> ((current : hist), ()))
           else go ticket
+
+prop_cas32Prop :: Int32 -> Int32 -> Property
+prop_cas32Prop old new = monadicIO $ do
+  p <- run malloc
+  run $ poke p old
+  v <- run $ peek p
+  assertEq v old
+  success <- run $ casInt32Ptr p old new
+  assertBool success "cas did not succeed"
+  v' <- run $ peek p
+  assertEq v' new
+  where
+    assertBool condition msg = do
+      unless condition $
+        monitor (counterexample $ "Failed: " <> msg)
+      assert condition
+    assertEq x y = do
+      unless (x == y) $
+        monitor (counterexample $ "Failed: " <> show x <> " is not equal to " <> show y)
+      assert (x == y)
+
+prop_cas64Prop :: Int64 -> Int64 -> Property
+prop_cas64Prop old new = monadicIO $ do
+  p <- run malloc
+  run $ poke p old
+  v <- run $ peek p
+  assertEq v old
+  success <- run $ casInt64Ptr p old new
+  assertBool success "cas did not succeed"
+  v' <- run $ peek p
+  assertEq v' new
+  where
+    assertBool condition msg = do
+      unless condition $
+        monitor (counterexample $ "Failed: " <> msg)
+      assert condition
+    assertEq x y = do
+      unless (x == y) $
+        monitor (counterexample $ "Failed: " <> show x <> " is not equal to " <> show y)
+      assert (x == y)