atomic-counter 0.1.1 → 0.1.2

raw patch · 8 files changed

+114/−19 lines, 8 filesdep ~tasty-benchPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: tasty-bench

API changes (from Hackage documentation)

Files

• Changelog.md +5/−0
• Counter.cmm +7/−0
• atomic-counter.cabal +17/−7
• bench/BenchMain.hs +2/−6
• src/Control/Concurrent/Counter/Lifted/IO.hs +11/−0
• src/Control/Concurrent/Counter/Lifted/ST.hs +12/−0
• src/Control/Concurrent/Counter/Unlifted.hs +19/−1
• test/TestMain.hs +41/−5

@@ -1,3 +1,8 @@+# 0.1.2++- Add compare and swap operation+- Add flag to force non-CMM implementation (`no-cmm`), not that users should use it normally+ # 0.1.1  - On non-javascript platforms the counter is implemented directly in

@@ -94,3 +94,10 @@ #endif   return (y); }++stg_casCounterzh (P_ c, W_ x, W_ y)+{+  W_ z;+  (z) = prim %cmpxchg64(c + SIZEOF_StgHeader, x, y);+  return (z);+}

@@ -5,16 +5,18 @@ name:   atomic-counter version:-  0.1.1+  0.1.2 synopsis:   Mutable counters that can be modified with atomic operatinos  description:   This package defines Counter type that can be safely modified-  concurrently from multiple threads. The supports only few operations,-  namely read, write, add, subtract and a few bitwise ones like or, and, xor.+  concurrently from multiple threads. The type supports only few+  operations, namely read, write, cas (compare and swap), add,+  subtract and a few bitwise ones like or, and xor. -  Most common use case is having a shared counter that multiple threads increment.+  Most common use case is having a shared counter that multiple+  threads increment. Another potential use case is lightweight locks.  copyright:   (c) Sergey Vinokurov 2022@@ -47,12 +49,20 @@  flag dev   description:-    Enable development flags+    Enable development flags like -Werror and linting   default:     False   manual:     True +flag no-cmm+  description:+    Don't use cmm implementation+  default:+    False+  manual:+    True+ common ghc-options   default-language:     Haskell2010@@ -88,7 +98,7 @@     src   build-depends:     , base >= 4.14 && < 5-  if impl(ghc >= 9.4) && !arch(javascript)+  if impl(ghc >= 9.4) && !arch(javascript) && !flag(no-cmm)     cmm-sources:       Counter.cmm     cpp-options:@@ -144,7 +154,7 @@     , primitive     , stm     , tasty >= 1.4.2-    , tasty-bench >= 0.3.2+    , tasty-bench >= 0.3.4     , tasty-quickcheck     , test-utils   ghc-options:

@@ -24,11 +24,10 @@ import GHC.Exts import GHC.IO import Test.QuickCheck-import Test.Tasty+import Test.Tasty hiding (defaultMain) import Test.Tasty.Bench import Test.Tasty.Patterns.Printer import Test.Tasty.QuickCheck qualified as QC-import Test.Tasty.Runners qualified as Tasty  import Control.Concurrent.Counter.Lifted.IO qualified as C @@ -140,10 +139,7 @@         , n <- [Iterations 10, Iterations 100, Iterations 1000, Iterations 10000]         ] -  defaultMainWithIngredients benchIngredients $-    localOption (Tasty.NumThreads 1) $-      testGroup "All" $-      tests ++ benchmarks+  defaultMain $ tests ++ benchmarks  counterBenchName :: String counterBenchName = "Counter"

@@ -21,6 +21,7 @@   -- * Read/write   , get   , set+  , cas    -- * Arithmetic operations   , add@@ -68,6 +69,16 @@ set :: Counter -> Int -> IO () set = coerce Lifted.set +{-# INLINE cas #-}+-- | Atomic compare and swap, i.e. write the new value if the current+-- value matches the provided old value. Returns the value of the+-- element before the operation+cas+  :: Counter+  -> Int -- ^ Expected old value+  -> Int -- ^ New value+  -> IO Int+cas = coerce Lifted.cas  {-# INLINE add #-} -- | Atomically add an amount to the counter and return its old value.

@@ -23,6 +23,7 @@   -- * Read/write   , get   , set+  , cas    -- * Arithmetic operations   , add@@ -77,6 +78,17 @@ set (Counter c) (I# x) = ST $ \s1 -> case Unlifted.set c x s1 of   (# s2 #) -> (# s2, () #) +{-# INLINE cas #-}+-- | Atomic compare and swap, i.e. write the new value if the current+-- value matches the provided old value. Returns the value of the+-- element before the operation+cas+  :: Counter s+  -> Int -- ^ Expected old value+  -> Int -- ^ New value+  -> ST s Int+cas (Counter c) (I# x) (I# y) = ST $ \s1 -> case Unlifted.cas c x y s1 of+  (# s2, z #) -> (# s2, I# z #)  {-# INLINE add #-} -- | Atomically add an amount to the counter and return its old value.

@@ -33,6 +33,7 @@   -- * Read/write   , get   , set+  , cas    -- * Arithmetic operations   , add@@ -46,6 +47,7 @@    -- * Compare   , sameCounter+   ) where  import Prelude hiding (and, or)@@ -100,6 +102,12 @@ foreign import prim "stg_atomicNandCounterzh"   nand :: Counter s -> Int# -> State# s -> (# State# s, Int# #) +-- | Atomic compare and swap, i.e. write the new value if the current+-- value matches the provided old value. Returns the value of the+-- element before the operation+foreign import prim "stg_casCounterzh"+  cas :: Counter s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+ -- | Compare the underlying pointers of two counters. sameCounter :: Counter s -> Counter s -> Bool sameCounter (Counter x) (Counter y) =@@ -130,6 +138,17 @@ set (Counter arr) n = \s1 -> case atomicWriteIntArray# arr 0# n s1 of   s2 -> (# s2 #) +{-# INLINE cas #-}+-- | Atomic compare and swap, i.e. write the new value if the current+-- value matches the provided old value. Returns the value of the+-- element before the operation+cas+  :: Counter s+  -> Int# -- ^ Expected old value+  -> Int# -- ^ New value+  -> State# s+  -> (# State# s, Int# #)+cas (Counter arr) = casIntArray# arr 0#  {-# INLINE add #-} -- | Atomically add an amount to the counter and return its old value.@@ -161,7 +180,6 @@ -- | Atomically combine old value with a new one via bitwise nand. Returns old counter value. nand :: Counter s -> Int# -> State# s -> (# State# s, Int# #) nand (Counter arr) = fetchNandIntArray# arr 0#-  -- | Compare the underlying pointers of two counters. sameCounter :: Counter s -> Counter s -> Bool

@@ -6,25 +6,49 @@ -- Maintainer  :  serg.foo@gmail.com ---------------------------------------------------------------------------- +{-# LANGUAGE BangPatterns        #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns      #-}  module TestMain (main) where +import Control.Concurrent+import Control.Exception+import Data.IORef import Data.Semigroup import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck qualified as QC-import Test.Tasty.Runners qualified as Tasty  import Control.Concurrent.Counter.Lifted.IO qualified as C  import TestUtils +newtype Lock = Lock { _unLock :: C.Counter }++newLock :: IO Lock+newLock = Lock <$> C.new 0++acquire :: Lock -> IO ()+acquire (Lock c) = go+  where+    go = do+      !x <- C.cas c 0 1+      if x == 1+      then do+        -- Could try 'threadDelay 1' instead.+        yield+        go+      else pure ()++release :: Lock -> IO ()+release (Lock c) =+  C.set c 0+ main :: IO ()-main = defaultMain $-  localOption (Tasty.NumThreads 1) $-  testGroup "All"+main = do+  setNumCapabilities 1+  defaultMain $ testGroup "All"     [ adjustOption (\(QC.QuickCheckTests x) -> QC.QuickCheckTests (max x 500)) $       QC.testProperty "Correctness" $         \(Threads ts) -> ioProperty $ do@@ -35,7 +59,19 @@     , adjustOption (\(QC.QuickCheckTests x) -> QC.QuickCheckTests (max x 10000)) $       QC.testProperty "Correctness, no delays" $         \(Threads ts) -> ioProperty $ do-          res <- spawnAndCall ts (C.new 0) (\ref t -> runThread t (\_ -> pure ()) (C.add ref)) >>= C.get+          res <- spawnAndCall ts (C.new 0) (\ref t -> runThread t (\_delay -> pure ()) (C.add ref)) >>= C.get+          let Sum expected =+                foldMap (\Thread{tIncrement, tIterations} -> Sum $ tIncrement * unIterations tIterations) ts+          pure $ res === expected++    , adjustOption (\(QC.QuickCheckTests x) -> QC.QuickCheckTests (max x 100000)) $+      QC.testProperty "Hand-made lock" $+        \(Threads ts) -> ioProperty $ do+          (ref, _lock) <- spawnAndCall ts ((,) <$> newIORef 0 <*> newLock) $ \(ref, lock) t ->+            runThread t (\_delay -> pure ()) $ \incr ->+              bracket_ (acquire lock) (release lock) $+                modifyIORef' ref (+ incr)+          res <- readIORef ref           let Sum expected =                 foldMap (\Thread{tIncrement, tIterations} -> Sum $ tIncrement * unIterations tIterations) ts           pure $ res === expected