atomic-primops 0.6.1.1 → 0.7

raw patch · 16 files changed

+425/−504 lines, 16 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/Atomics.hs +7/−0
• Data/Atomics/Counter.hs +130/−8
• Data/Atomics/Counter/IORef.hs +0/−70
• Data/Atomics/Counter/Reference.hs +0/−88
• Data/Atomics/Counter/Unboxed.hs +0/−129
• atomic-primops.cabal +15/−8
• testing/CommonTesting.hs +2/−2
• testing/Counter.hs +148/−0
• testing/CounterCommon.hs +0/−138
• testing/CounterIORef.hs +0/−11
• testing/CounterReference.hs +0/−13
• testing/CounterUnboxed.hs +0/−11
• testing/Issue28.hs +21/−0
• testing/Raw781_test.hs +59/−0
• testing/TemplateHaskellSplices.hs +21/−0
• testing/Test.hs +22/−26

@@ -136,6 +136,7 @@   (# s2#, (I# res) #)   -- I don't know if a let will mak any difference here... hopefully not. +{-# DEPRECATED fetchAddByteArrayInt "Replaced by fetchAddIntArray which returns the OLD value" #-} -- | Atomically add to a word of memory within a `MutableByteArray`. --  --   This function returns the NEW value of the location after the increment.@@ -144,7 +145,13 @@ fetchAddByteArrayInt ::  MutableByteArray RealWorld -> Int -> Int -> IO Int fetchAddByteArrayInt (MutableByteArray mba#) (I# offset#) (I# incr#) = IO $ \ s1# ->    let (# s2#, res #) = fetchAddIntArray# mba# offset# incr# s1# in+-- fetchAddIntArray# changed behavior in 7.10 to return the OLD value, so we+-- need this to maintain forwards compatibility until removed:+#if MIN_VERSION_base(4,8,0)+  (# s2#, (I# (res +# incr#)) #)+#else   (# s2#, (I# res) #)+#endif  -------------------------------------------------------------------------------- 

@@ -1,11 +1,9 @@--+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, CPP #-} -- | Integer counters providing thread-safe, lock-free mutation functions. -----   While this package provides multiple implementations, this module will always---   expose the default (best) implementation.  Atomic counters are represented by a---   single memory location, such that built-in processor instructions are sufficient---   to perform fetch-and-add or compare-and-swap.+--   Atomic counters are represented by a single memory location, such that+--   built-in processor instructions are sufficient to perform fetch-and-add or+--   compare-and-swap. --  --   Remember, contention on such counters should still be minimized! @@ -32,5 +30,129 @@          writeCounter          )  where--- This module reexports the default implementation of atomic counters:-import Data.Atomics.Counter.Unboxed+++import GHC.Ptr+import Data.Atomics          (casByteArrayInt)+-- import Data.Atomics.Internal (casIntArray#, fetchAddIntArray#)+import Data.Atomics.Internal+#if MIN_VERSION_base(4,7,0)+import GHC.Base  hiding ((==#))+import GHC.Prim hiding ((==#))+import qualified GHC.PrimopWrappers as GPW+#else+import GHC.Base+import GHC.Prim+#endif+++-- GHC 7.8 changed some primops+#if MIN_VERSION_base(4,7,0)+(==#) :: Int# -> Int# -> Bool+(==#) x y = case x GPW.==# y of { 0# -> False; _ -> True }+#endif++++#ifndef __GLASGOW_HASKELL__+#error "Counter: this library is not portable to other Haskell's"+#endif++#include "MachDeps.h"+#ifndef SIZEOF_HSINT+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES+#endif++-- | The type of mutable atomic counters.+data AtomicCounter = AtomicCounter (MutableByteArray# RealWorld)++-- | You should not depend on this type.  It varies between different implementations+-- of atomic counters.+type CTicket = Int+-- TODO: Could newtype this.++-- | Create a new counter initialized to the given value.+{-# INLINE newCounter #-}+newCounter :: Int -> IO AtomicCounter+newCounter n = do+  c <- newRawCounter+  writeCounter c n -- Non-atomic is ok; it hasn't been released into the wild.+  return c++-- | Create a new, uninitialized counter.+{-# INLINE newRawCounter #-}+newRawCounter :: IO AtomicCounter  +newRawCounter = IO $ \s ->+  case newByteArray# size s of { (# s, arr #) ->+  (# s, AtomicCounter arr #) }+  where !(I# size) = SIZEOF_HSINT++{-# INLINE readCounter #-}+-- | Equivalent to `readCounterForCAS` followed by `peekCTicket`.        +readCounter :: AtomicCounter -> IO Int+readCounter (AtomicCounter arr) = IO $ \s ->+  case readIntArray# arr 0# s of { (# s, i #) ->+  (# s, I# i #) }++{-# INLINE writeCounter #-}+-- | Make a non-atomic write to the counter.  No memory-barrier.+writeCounter :: AtomicCounter -> Int -> IO ()+writeCounter (AtomicCounter arr) (I# i) = IO $ \s ->+  case writeIntArray# arr 0# i s of { s ->+  (# s, () #) }++{-# INLINE readCounterForCAS #-}+-- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque+-- ticket that can be used in CAS operations.  Except for the difference in return+-- type, the semantics of this are the same as `readCounter`.+readCounterForCAS :: AtomicCounter -> IO CTicket+readCounterForCAS = readCounter++{-# INLINE peekCTicket #-}+-- | Opaque tickets cannot be constructed, but they can be destructed into values.+peekCTicket :: CTicket -> Int+peekCTicket !x = x++{-# INLINE casCounter #-}+-- | Compare and swap for the counter ADT.  Similar behavior to+-- `Data.Atomics.casIORef`, in particular, in both success and failure cases it+-- returns a ticket that you should use for the next attempt.  (That is, in the+-- success case, it actually returns the new value that you provided as input, but in+-- ticket form.)+casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket)+-- casCounter (AtomicCounter barr) !old !new =+casCounter (AtomicCounter mba#) (I# old#) newBox@(I# new#) = IO$ \s1# ->+  let (# s2#, res# #) = casIntArray# mba# 0# old# new# s1# in+  case res# ==# old# of +    False -> (# s2#, (False, I# res# ) #) -- Failure+    True  -> (# s2#, (True , newBox ) #) -- Success++{-# INLINE sameCTicket #-}+sameCTicket :: CTicket -> CTicket -> Bool+sameCTicket = (==)++{-# INLINE incrCounter #-}+-- | Increment the counter by a given amount.  Returns the value AFTER the increment+--   (in contrast with the behavior of the underlying instruction on architectures+--   like x86.)+--                 +--   Note that UNLIKE with boxed implementations of counters, where increment is+--   based on CAS, this increment is /O(1)/.  Fetch-and-add does not require a retry+--   loop like CAS.+incrCounter :: Int -> AtomicCounter -> IO Int+incrCounter (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> +  let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in+-- fetchAddIntArray# changed behavior in 7.10 to return the OLD value, so we+-- need this to maintain forwards compatibility:+#if MIN_VERSION_base(4,8,0)+  (# s2#, (I# (res +# incr#)) #)+#else+  (# s2#, (I# res) #)+#endif++{-# INLINE incrCounter_ #-}+-- | An alternate version for when you don't care about the old value.+incrCounter_ :: Int -> AtomicCounter -> IO ()+incrCounter_ (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> +  let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in+  (# s2#, () #)

@@ -1,70 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- | This version uses a boxed IORef representation, but it can be somewhat cheaper--- than the Refence version because it uses raw CAS rather than full--- atomicModifyIORef.--module Data.Atomics.Counter.IORef-       (AtomicCounter, CTicket,-        newCounter, readCounterForCAS, readCounter, peekCTicket,-        writeCounter, casCounter, incrCounter, incrCounter_)-       where--import Control.Monad (void)-import Data.IORef-import Data.Atomics as A-------------------------------------------------------------------------------------- type AtomicCounter = IORef Int-newtype AtomicCounter = AtomicCounter (IORef Int)--type CTicket = Ticket Int--{-# INLINE newCounter #-}--- | Create a new counter initialized to the given value.-newCounter :: Int -> IO AtomicCounter-newCounter n = fmap AtomicCounter $ newIORef n--{-# INLINE incrCounter #-}--- | Try repeatedly until we successfully increment the counter by a given amount.--- Returns the original value of the counter (pre-increment).-incrCounter :: Int -> AtomicCounter -> IO Int--- <DUPLICATED CODE FROM Reference.hs>-incrCounter bump cntr =-    loop =<< readCounterForCAS cntr-  where-    loop tick = do-      (b,tick') <- casCounter cntr tick (peekCTicket tick + bump)-      if b then return (peekCTicket tick')-           else loop tick'-{-# INLINE incrCounter_ #-}-incrCounter_ :: Int -> AtomicCounter -> IO ()-incrCounter_ b c = void (incrCounter b c)--- </DUPLICATED CODE FROM Reference.hs>--{-# INLINE readCounterForCAS #-}--- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque--- ticket that can be used in CAS operations.-readCounterForCAS :: AtomicCounter -> IO CTicket-readCounterForCAS (AtomicCounter r) = readForCAS r--{-# INLINE peekCTicket #-}--- | Opaque tickets cannot be constructed, but they can be destructed into values.-peekCTicket :: CTicket -> Int-peekCTicket = peekTicket --{-# INLINE readCounter #-}--- | Equivalent to `readCounterForCAS` followed by `peekCTicket`.-readCounter :: AtomicCounter -> IO Int-readCounter (AtomicCounter r) = readIORef r--{-# INLINE writeCounter #-}--- | Make a non-atomic write to the counter.  No memory-barrier.-writeCounter :: AtomicCounter -> Int -> IO ()-writeCounter (AtomicCounter r) !new = writeIORef r new--{-# INLINE casCounter #-}--- | Compare and swap for the counter ADT.  Similar behavior to `casIORef`.-casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket)-casCounter (AtomicCounter r) tick !new = casIORef r tick new

@@ -1,88 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- | This reference version is implemented with atomicModifyIORef and can be a useful--- fallback if one of the other implementations needs to be debugged for a given--- architecture.-module Data.Atomics.Counter.Reference       -       (AtomicCounter, CTicket,-        newCounter, readCounterForCAS, readCounter, peekCTicket,-        writeCounter, casCounter, incrCounter, incrCounter_)-       where--import Control.Monad (void)-import Data.IORef--- import Data.Atomics-import System.IO.Unsafe (unsafePerformIO)-------------------------------------------------------------------------------------- type AtomicCounter = IORef Int-newtype AtomicCounter = AtomicCounter (IORef Int)--type CTicket = Int--{-# INLINE newCounter #-}--- | Create a new counter initialized to the given value.-newCounter :: Int -> IO AtomicCounter-newCounter !n = fmap AtomicCounter $ newIORef n--{-# INLINE incrCounter #-}--- | Try repeatedly until we successfully increment the counter by a given amount.--- Returns the original value of the counter (pre-increment).-incrCounter :: Int -> AtomicCounter -> IO Int-incrCounter !bump !cntr =-    loop =<< readCounterForCAS cntr-  where-    loop tick = do-      (b,tick') <- casCounter cntr tick (peekCTicket tick + bump)-      if b then return (peekCTicket tick')-           else loop tick'--{-# INLINE incrCounter_ #-}-incrCounter_ :: Int -> AtomicCounter -> IO ()-incrCounter_ b c = void (incrCounter b c)--{-# INLINE readCounterForCAS #-}--- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque--- ticket that can be used in CAS operations.-readCounterForCAS :: AtomicCounter -> IO CTicket-readCounterForCAS = readCounter--{-# INLINE peekCTicket #-}--- | Opaque tickets cannot be constructed, but they can be destructed into values.-peekCTicket :: CTicket -> Int-peekCTicket !x = x--{-# INLINE readCounter #-}--- | Equivalent to `readCounterForCAS` followed by `peekCTicket`.-readCounter :: AtomicCounter -> IO Int-readCounter (AtomicCounter r) = readIORef r--{-# INLINE writeCounter #-}--- | Make a non-atomic write to the counter.  No memory-barrier.-writeCounter :: AtomicCounter -> Int -> IO ()-writeCounter (AtomicCounter r) !new = writeIORef r new--{-# INLINE casCounter #-}--- | Compare and swap for the counter ADT.  Similar behavior to `casIORef`.-casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket)-casCounter (AtomicCounter r) oldT !new =-  let old = oldT in -  atomicModifyIORef' r $ \val -> -    if   (val == old)-    then (new, (True, new))-    else (val, (False,val))---{--{-# NOINLINE unsafeName #-}-unsafeName :: a -> Int-unsafeName x = unsafePerformIO $ do -   sn <- makeStableName x-   return (hashStableName sn)--{-# NOINLINE ptrEq #-}-ptrEq :: a -> a -> Bool-ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1---}

@@ -1,129 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, CPP #-}---- | This should be the most efficient implementation of atomic counters.---   You probably don't need the others!  (Except for testing/debugging.)--module Data.Atomics.Counter.Unboxed-       (AtomicCounter, CTicket,-        newCounter, readCounterForCAS, readCounter, peekCTicket,-        writeCounter, casCounter, incrCounter, incrCounter_)-       where--import GHC.Ptr-import Data.Atomics          (casByteArrayInt)--- import Data.Atomics.Internal (casIntArray#, fetchAddIntArray#)-import Data.Atomics.Internal-#if MIN_VERSION_base(4,7,0)-import GHC.Base  hiding ((==#))-import GHC.Prim hiding ((==#))-import qualified GHC.PrimopWrappers as GPW-#else-import GHC.Base-import GHC.Prim-#endif----- GHC 7.8 changed some primops-#if MIN_VERSION_base(4,7,0)-(==#) :: Int# -> Int# -> Bool-(==#) x y = case x GPW.==# y of { 0# -> False; _ -> True }-#endif----#ifndef __GLASGOW_HASKELL__-#error "Unboxed Counter: this library is not portable to other Haskell's"-#endif--#include "MachDeps.h"-#ifndef SIZEOF_HSINT-#define SIZEOF_HSINT  INT_SIZE_IN_BYTES-#endif---- | The type of mutable atomic counters.-data AtomicCounter = AtomicCounter (MutableByteArray# RealWorld)---- | You should not depend on this type.  It varies between different implementations--- of atomic counters.-type CTicket = Int--- TODO: Could newtype this.---- | Create a new counter initialized to the given value.-{-# INLINE newCounter #-}-newCounter :: Int -> IO AtomicCounter-newCounter n = do-  c <- newRawCounter-  writeCounter c n -- Non-atomic is ok; it hasn't been released into the wild.-  return c---- | Create a new, uninitialized counter.-{-# INLINE newRawCounter #-}-newRawCounter :: IO AtomicCounter  -newRawCounter = IO $ \s ->-  case newByteArray# size s of { (# s, arr #) ->-  (# s, AtomicCounter arr #) }-  where !(I# size) = SIZEOF_HSINT--{-# INLINE readCounter #-}--- | Equivalent to `readCounterForCAS` followed by `peekCTicket`.        -readCounter :: AtomicCounter -> IO Int-readCounter (AtomicCounter arr) = IO $ \s ->-  case readIntArray# arr 0# s of { (# s, i #) ->-  (# s, I# i #) }--{-# INLINE writeCounter #-}--- | Make a non-atomic write to the counter.  No memory-barrier.-writeCounter :: AtomicCounter -> Int -> IO ()-writeCounter (AtomicCounter arr) (I# i) = IO $ \s ->-  case writeIntArray# arr 0# i s of { s ->-  (# s, () #) }--{-# INLINE readCounterForCAS #-}--- | Just like the "Data.Atomics" CAS interface, this routine returns an opaque--- ticket that can be used in CAS operations.  Except for the difference in return--- type, the semantics of this are the same as `readCounter`.-readCounterForCAS :: AtomicCounter -> IO CTicket-readCounterForCAS = readCounter--{-# INLINE peekCTicket #-}--- | Opaque tickets cannot be constructed, but they can be destructed into values.-peekCTicket :: CTicket -> Int-peekCTicket !x = x--{-# INLINE casCounter #-}--- | Compare and swap for the counter ADT.  Similar behavior to--- `Data.Atomics.casIORef`, in particular, in both success and failure cases it--- returns a ticket that you should use for the next attempt.  (That is, in the--- success case, it actually returns the new value that you provided as input, but in--- ticket form.)-casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket)--- casCounter (AtomicCounter barr) !old !new =-casCounter (AtomicCounter mba#) (I# old#) newBox@(I# new#) = IO$ \s1# ->-  let (# s2#, res# #) = casIntArray# mba# 0# old# new# s1# in-  case res# ==# old# of -    False -> (# s2#, (False, I# res# ) #) -- Failure-    True  -> (# s2#, (True , newBox ) #) -- Success--{-# INLINE sameCTicket #-}-sameCTicket :: CTicket -> CTicket -> Bool-sameCTicket = (==)--{-# INLINE incrCounter #-}--- | Increment the counter by a given amount.  Returns the value AFTER the increment---   (in contrast with the behavior of the underlying instruction on architectures---   like x86.)---                 ---   Note that UNLIKE with boxed implementations of counters, where increment is---   based on CAS, this increment is /O(1)/.  Fetch-and-add does not require a retry---   loop like CAS.-incrCounter :: Int -> AtomicCounter -> IO Int-incrCounter (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> -  let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in-  (# s2#, (I# res) #)--{-# INLINE incrCounter_ #-}--- | An alternate version for when you don't care about the old value.-incrCounter_ :: Int -> AtomicCounter -> IO ()-incrCounter_ (I# incr#) (AtomicCounter mba#) = IO $ \ s1# -> -  let (# s2#, res #) = fetchAddIntArray# mba# 0# incr# s1# in-  (# s2#, () #)

@@ -1,5 +1,5 @@ Name:                atomic-primops-Version:             0.6.1.1+Version:             0.7 License:             BSD3 License-file:        LICENSE Author:              Ryan Newton@@ -34,6 +34,7 @@ -- 0.6.0.1 -- minor ghc 7.8 fix -- 0.6.0.5 -- fix for GHC 7.8 -- 0.6.1   -- several bug fixes, mainly re: platform portability+-- 0.7     -- support for GHC 7.10 and several new primops  Synopsis: A safe approach to CAS and other atomic ops in Haskell. @@ -72,14 +73,23 @@  Changes in 0.5.0.2:  .  * IMPORTANT BUGFIXES - don't use earlier versions.  They have been marked deprecated.--+ .+ Changes in 0.6.1+ .+ * This is a good version to use for GHC 7.8.3.  It includes portability and bug fixes +   and adds atomicModifyIORefCAS.+ .+ Changes in 0.7: + .+ * This release adds support for GHC 7.10 and its expanded library of (now inline) primops.   Extra-Source-Files:  DEVLOG.md,                      testing/Test.hs, testing/test-atomic-primops.cabal, testing/ghci-test.hs-                     testing/Makefile, testing/CommonTesting.hs, testing/CounterCommon.hs, testing/hello.hs-                     testing/CounterReference.hs testing/CounterUnboxed.hs testing/CounterIORef.hs+                     testing/Makefile, testing/CommonTesting.hs, testing/Counter.hs, testing/hello.hs+                     testing/Issue28.hs+                     testing/TemplateHaskellSplices.hs+                     testing/Raw781_test.hs  Flag debug     Description: Enable extra internal checks.@@ -90,9 +100,6 @@   exposed-modules:   Data.Atomics                      Data.Atomics.Internal                      Data.Atomics.Counter-                     Data.Atomics.Counter.IORef-                     Data.Atomics.Counter.Reference-                     Data.Atomics.Counter.Unboxed   ghc-options: -O2 -funbox-strict-fields    -- casMutVar# had a bug in GHC 7.2, thus we require GHC 7.4 or greater

@@ -46,7 +46,7 @@      dbgPrint 1 $ printf "Forking %d threads.\n" numthreads           forM_ (zip [0..] answers) $ \ (ix,mv) -> - 	forkIO (action ix >>= putMVar mv)+       forkIO (action ix >>= putMVar mv)       -- Reading answers:      ls <- mapM readMVar answers@@ -158,5 +158,5 @@ for_ start end fn = loop start   where    loop !i | i == end  = return ()-	   | otherwise = do fn i; loop (i+1)+           | otherwise = do fn i; loop (i+1) 

@@ -0,0 +1,148 @@+module Counter (tests) where++-- This was formerly CounterCommon and #include-ed to test the different+-- counter implementations which have been removed. +-- TODO clean up remnants of that approach.+import qualified Data.Atomics.Counter as C++import Control.Monad+import GHC.Conc+import System.CPUTime+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assertEqual, assertBool)+import Text.Printf+import Data.IORef  ++import CommonTesting (numElems, forkJoin, timeit, nTimes)++name = "Unboxed"++default_seq_tries  = 10 * numElems+-- Things are MUCH slower with contention:+default_conc_tries = numElems++--------------------------------------------------------------------------------+-- Test the basics++case_basic1 = do +  r <- C.newCounter 0+  ret <- C.incrCounter 10 r+  assertEqual "incrCounter returns the NEW value" 10 ret++case_basic2 = do +  r <- C.newCounter 0+  t <- C.readCounterForCAS r+  (True,newt) <- C.casCounter r t 10+  assertEqual "casCounter returns new val/ticket on success" 10 (C.peekCTicket newt)++case_basic3 = do +  r <- C.newCounter 0+  t <- C.readCounterForCAS r+  _ <- C.incrCounter 1 r+  (False,oldt) <- C.casCounter r t 10+  assertEqual "casCounter returns read val on failure" 1 (C.peekCTicket oldt)++case_basic4 = do +  let tries = numElems `quot` 100+  r <- C.newCounter 0+  nTimes tries $ do+    t <- C.readCounterForCAS r+    (True,_) <- C.casCounter r t (C.peekCTicket t + 1)+    return ()+  cnt <- C.readCounter r+  assertEqual "Every CAS should succeed on one thread" tries cnt ++--------------------------------------------------------------------------------+-- Repeated increments++incrloop tries = do r <- C.newCounter 0; nTimes tries $ void$ C.incrCounter 1 r+                    C.readCounter r+case_incrloop = do +   cnt <- incrloop default_seq_tries+   assertEqual "incrloop sum" default_seq_tries cnt++-- | Here we do a loop to test the unboxing of results from incrCounter:+--   As of now [2013.07.19], it is successfully unboxing the results +--   for Data.Atomics.Counter.Unboxed.+incrloop4B tries = do+  putStrLn " [incrloop4B] A test where we use the result of each incr."+  r <- C.newCounter 1+  loop r tries 1+ where+   loop :: C.AtomicCounter -> Int -> Int -> IO ()+   loop r 0 _ = do v <- C.readCounter r+                   putStrLn$"Final value: "++show v+                   return ()+   loop r tries last = do+     n <- C.incrCounter last r+     if n == 2+       then loop r (tries-1) 2+       else loop r (tries-1) 1++-- | Here we let the counter overflow, which seems to be causing problems.+overflowTest tries = do+  putStrLn " [incrloop4B] A test where we use the result of each incr."+  r <- C.newCounter 1+  loop r tries 1+ where+   loop :: C.AtomicCounter -> Int -> Int -> IO ()+   loop r 0 _ = do v <- C.readCounter r+                   putStrLn$"Final value: "++show v+                   return ()+   loop r tries last = do+     putStrLn$ " [incrloop4B] Looping with tries left "++show tries +     n <- C.incrCounter last r+     -- This is HANGING afer passing 2,147,483,648.  (using Unboxed)+     -- Is there some defect wrt overflow?+     putStrLn$ " [incrloop4B] Done incr, received "++show n+     loop r (tries-1) n++--------------------------------------------------------------------------------+-- Parallel repeated increments+++{-# INLINE parIncrloop #-} +parIncrloop new incr iters = do+  numcap <- getNumCapabilities+  let (each,left) = iters `quotRem` numcap+  putStrLn$ "Concurrently incrementing counter from all "++show numcap++" threads, incrs per thread: "++show each+  r <- new 0+  forkJoin numcap $ \ ix -> do+    let mine = if ix==0 then each+left else each+    nTimes mine $ void $ incr 1 r+  C.readCounter r++case_parincrloop = do +  cnt <- parIncrloop C.newCounter C.incrCounter default_conc_tries+  assertEqual "incrloop sum" default_conc_tries cnt++-- | Use CAS instead of the real incr so we can compare the overhead.+case_parincrloop_wCAS = do +  cnt <- parIncrloop C.newCounter fakeIncr default_conc_tries+  assertEqual "incrloop sum" default_conc_tries cnt+ where+  fakeIncr delt r = do tick <- C.readCounterForCAS r+                       loop r delt tick+  loop r delt tick = do x <- C.casCounter r tick (C.peekCTicket tick + delt)+                        case x of +                          (True, newtick) -> return (C.peekCTicket newtick)+                          (False,newtick) -> loop r delt newtick+                   ++--------------------------------------------------------------------------------++tests = + [+   testCase (name++"basic1_incrCounter") $ case_basic1+ , testCase (name++"basic2_casCounter") $ case_basic2+ , testCase (name++"basic3_casCounter") $ case_basic3+ , testCase (name++"basic4_casCounter") $ case_basic4+   ----------------------------------------+ , testCase (name++"_single_thread_repeat_incr") $ timeit case_incrloop+ , testCase (name++"_incr_with_result_feedback") $ timeit (incrloop4B default_seq_tries)+   ----------------------------------------++   -- Parallel versions:+ , testCase (name++"_concurrent_repeat_incr") $ void$ timeit case_parincrloop+ , testCase (name++"_concurrent_repeat_incrCAS") $ void$ timeit case_parincrloop_wCAS+ ]

@@ -1,138 +0,0 @@---- Common tests to the different counter implementations.--import Control.Monad-import GHC.Conc-import System.CPUTime-import Test.Framework.Providers.HUnit (testCase)-import Test.HUnit (Assertion, assertEqual, assertBool)-import Text.Printf-import Data.IORef  --import CommonTesting (numElems, forkJoin, timeit, nTimes)------------------------------------------------------------------------------------- Test the basics--case_basic1 = do -  r <- C.newCounter 0-  ret <- C.incrCounter 10 r-  assertEqual "incrCounter returns the NEW value" 10 ret--case_basic2 = do -  r <- C.newCounter 0-  t <- C.readCounterForCAS r-  (True,newt) <- C.casCounter r t 10-  assertEqual "casCounter returns new val/ticket on success" 10 (C.peekCTicket newt)--case_basic3 = do -  r <- C.newCounter 0-  t <- C.readCounterForCAS r-  _ <- C.incrCounter 1 r-  (False,oldt) <- C.casCounter r t 10-  assertEqual "casCounter returns read val on failure" 1 (C.peekCTicket oldt)--case_basic4 = do -  let tries = numElems `quot` 100-  r <- C.newCounter 0-  nTimes tries $ do-    t <- C.readCounterForCAS r-    (True,_) <- C.casCounter r t (C.peekCTicket t + 1)-    return ()-  cnt <- C.readCounter r-  assertEqual "Every CAS should succeed on one thread" tries cnt ------------------------------------------------------------------------------------- Repeated increments--incrloop tries = do r <- C.newCounter 0; nTimes tries $ void$ C.incrCounter 1 r-                    C.readCounter r-case_incrloop = do -   cnt <- incrloop default_seq_tries-   assertEqual "incrloop sum" default_seq_tries cnt---- | Here we do a loop to test the unboxing of results from incrCounter:---   As of now [2013.07.19], it is successfully unboxing the results ---   for Data.Atomics.Counter.Unboxed.-incrloop4B tries = do-  putStrLn " [incrloop4B] A test where we use the result of each incr."-  r <- C.newCounter 1-  loop r tries 1- where-   loop :: C.AtomicCounter -> Int -> Int -> IO ()-   loop r 0 _ = do v <- C.readCounter r-                   putStrLn$"Final value: "++show v-                   return ()-   loop r tries last = do-     n <- C.incrCounter last r-     if n == 2-       then loop r (tries-1) 2-       else loop r (tries-1) 1---- | Here we let the counter overflow, which seems to be causing problems.-overflowTest tries = do-  putStrLn " [incrloop4B] A test where we use the result of each incr."-  r <- C.newCounter 1-  loop r tries 1- where-   loop :: C.AtomicCounter -> Int -> Int -> IO ()-   loop r 0 _ = do v <- C.readCounter r-                   putStrLn$"Final value: "++show v-                   return ()-   loop r tries last = do-     putStrLn$ " [incrloop4B] Looping with tries left "++show tries -     n <- C.incrCounter last r-     -- This is HANGING afer passing 2,147,483,648.  (using Unboxed)-     -- Is there some defect wrt overflow?-     putStrLn$ " [incrloop4B] Done incr, received "++show n-     loop r (tries-1) n------------------------------------------------------------------------------------- Parallel repeated increments---{-# INLINE parIncrloop #-} -parIncrloop new incr iters = do-  numcap <- getNumCapabilities-  let (each,left) = iters `quotRem` numcap-  putStrLn$ "Concurrently incrementing counter from all "++show numcap++" threads, incrs per thread: "++show each-  r <- new 0-  forkJoin numcap $ \ ix -> do-    let mine = if ix==0 then each+left else each-    nTimes mine $ void $ incr 1 r-  C.readCounter r--case_parincrloop = do -  cnt <- parIncrloop C.newCounter C.incrCounter default_conc_tries-  assertEqual "incrloop sum" default_conc_tries cnt---- | Use CAS instead of the real incr so we can compare the overhead.-case_parincrloop_wCAS = do -  cnt <- parIncrloop C.newCounter fakeIncr default_conc_tries-  assertEqual "incrloop sum" default_conc_tries cnt- where-  fakeIncr delt r = do tick <- C.readCounterForCAS r-                       loop r delt tick-  loop r delt tick = do x <- C.casCounter r tick (C.peekCTicket tick + delt)-                        case x of -                          (True, newtick) -> return (C.peekCTicket newtick)-                          (False,newtick) -> loop r delt newtick-                   ------------------------------------------------------------------------------------tests = - [-   testCase (name++"basic1_incrCounter") $ case_basic1- , testCase (name++"basic2_casCounter") $ case_basic2- , testCase (name++"basic3_casCounter") $ case_basic3- , testCase (name++"basic4_casCounter") $ case_basic4-   ----------------------------------------- , testCase (name++"_single_thread_repeat_incr") $ timeit case_incrloop- , testCase (name++"_incr_with_result_feedback") $ timeit (incrloop4B default_seq_tries)-   ------------------------------------------   -- Parallel versions:- , testCase (name++"_concurrent_repeat_incr") $ void$ timeit case_parincrloop- , testCase (name++"_concurrent_repeat_incrCAS") $ void$ timeit case_parincrloop_wCAS- ]

@@ -1,11 +0,0 @@-{-# LANGUAGE CPP, BangPatterns #-}-module CounterIORef (tests) where-import qualified Data.Atomics.Counter.IORef as C--#include "CounterCommon.hs"--name = "IORef"--default_seq_tries  = 10 * numElems--- Things are MUCH slower with contention:-default_conc_tries = numElems

@@ -1,13 +0,0 @@-{-# LANGUAGE CPP, BangPatterns #-}-module CounterReference (tests) where-import qualified Data.Atomics.Counter.Reference as C--#include "CounterCommon.hs"--name = "Reference"---- This version is much slower than some of the others:-default_seq_tries  = 10 * base -default_conc_tries = base--base = numElems `quot` 15

@@ -1,11 +0,0 @@-{-# LANGUAGE CPP, BangPatterns #-}-module CounterUnboxed (tests) where-import qualified Data.Atomics.Counter.Unboxed as C--#include "CounterCommon.hs"--name = "Unboxed"--default_seq_tries  = 10 * numElems--- Things are MUCH slower with contention:-default_conc_tries = numElems

@@ -0,0 +1,21 @@++module Issue28 (main) where++import Control.Monad+import Data.IORef+import Data.Atomics+-- import Data.Atomics.Internal (ptrEq)++main = do+  putStrLn "Issue28: Conducting the simplest possible read-then-CAS test."+  r <- newIORef "hi"+  t0 <- readForCAS r+  (True,t1) <- casIORef r t0 "bye"+  -- putStrLn$ "First CAS succeeded? "++show b1+  -- putStrLn$ "Tickets pointer equal? " ++ show (t0 == t1)+  -- (b2,t2) <- casIORef r t1 "bye2"+  -- putStrLn$ "Second CAS succeeded? " ++ show b2+  -- unless (b1 == True) $ error "Test failed"  ++  putStrLn$  "Issue28: test passed "++show t1+  return ()

@@ -0,0 +1,59 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}+-- Test the primops in GHC 7.8.1 directly.++module Main where++import GHC.Prim+import GHC.IORef+import GHC.STRef+import GHC.ST+import GHC.IO++{-# NOINLINE str #-}+str :: String+str = "hello"++t :: MutVar# d a -> a -> a -> State# d -> (# State# d, Int#, a #)+t = casMutVar#++(===) :: Int# -> Int# -> Bool+(===) x y = case x ==# y of { 0# -> False; _ -> True }++----------------------------------------++-- | Performs a machine-level compare and swap operation on an+-- 'STRef'. Returns a tuple containing a 'Bool' which is 'True' when a+-- swap is performed, along with the 'current' value from the 'STRef'.+-- +-- Note \"compare\" here means pointer equality in the sense of+-- 'GHC.Prim.reallyUnsafePtrEquality#'.+casSTRef :: STRef s a -- ^ The 'STRef' containing a value 'current'+         -> a -- ^ The 'old' value to compare+         -> a -- ^ The 'new' value to replace 'current' if @old == current@+         -> ST s (Bool, a) +casSTRef (STRef var#) old new = ST $ \s1# ->+   -- The primop treats the boolean as a sort of error code.+   -- Zero means the CAS worked, one that it didn't.+   -- We flip that here:+    case casMutVar# var# old new s1# of+      (# s2#, x#, res #) -> (# s2#, (x# === 0#, res) #)++-- | Performs a machine-level compare and swap operation on an+-- 'IORef'. Returns a tuple containing a 'Bool' which is 'True' when a+-- swap is performed, along with the 'current' value from the 'IORef'.+-- +-- Note \"compare\" here means pointer equality in the sense of+-- 'GHC.Prim.reallyUnsafePtrEquality#'.+casIORef :: IORef a -- ^ The 'IORef' containing a value 'current'+         -> a -- ^ The 'old' value to compare+         -> a -- ^ The 'new' value to replace 'current' if @old == current@+         -> IO (Bool, a) +casIORef (IORef var) old new = stToIO (casSTRef var old new)++--------------------------------------------------------------------------------++main :: IO ()+main = do +  r <- newIORef str+  pr <- casIORef r str "new str"+  print pr

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell,+             RankNTypes       #-}++-- | TH splices used in atommic-primops tests.+--   Splices defined in own module for technical reasons.++module TemplateHaskellSplices where++import Language.Haskell.TH+import Control.Monad (replicateM)++tmap :: forall a. (Enum a, Eq a, Num a)+        => a -> Int -> Q Exp+tmap i n = do+    f <- newName "f"+    as <- replicateM n (newName "a")+    lamE [varP f, tupP (map varP as)] $+        tupE [  if i == i'+                    then [| $(varE f) $a |]+                    else a+               | (a,i') <- map varE as `zip` [1..] ]

@@ -33,9 +33,7 @@ import qualified Issue28  import CommonTesting -import qualified CounterReference -import qualified CounterUnboxed-import qualified CounterIORef+import qualified Counter  ------------------------------------------------------------------------ @@ -90,9 +88,7 @@          , size    <- [1, 10, 100]          , iters   <- [10000]] -         ++ CounterReference.tests-         ++ CounterUnboxed.tests-         ++ CounterIORef.tests+         ++ Counter.tests  setify :: [Int] -> [Int] setify = S.toList . S.fromList@@ -122,10 +118,10 @@  tick <- readArrayElem arr 4  putStrLn$ "(Peeking at array gave: "++show (peekTicket tick)++")" - (res1,tick2) <- casArrayElem arr 3 tick 44- (res2,_)     <- casArrayElem arr 3 tick 44--- res  <- stToIO$ casArrayST arr 3 mynum 44--- res2 <- stToIO$ casArrayST arr 3 mynum 44 + (res1,tick2) <- casArrayElem arr 4 tick 44+ (res2,_)     <- casArrayElem arr 4 tick 44+-- res  <- stToIO$ casArrayST arr 4 mynum 44+-- res2 <- stToIO$ casArrayST arr 4 mynum 44    putStrLn "Printing array:"  forM_ [0..4] $ \ i -> do@@ -320,7 +316,7 @@      bitls <- newIORef []      tick1 <- A.readForCAS r      let loop 0 = return ()-	 loop n = do+         loop n = do           res <- A.casIORef r tick1 100           atomicModifyIORef bitls (\x -> (res:x, ())) --          putStrLn$ "  CAS result: " ++ show res@@ -368,12 +364,12 @@   logs::[[Bool]] <- forkJoin threads $ \_ ->      do checkGCStats        let loop 0 _ _ !acc = return (reverse acc)-	   loop n !ticket !expected !acc = do+           loop n !ticket !expected !acc = do             -- This line will result in boxing/unboxing and using extra memory locations: --            let bumped = expected + 1              bumped <- evaluate$ expected + 1-	    (res,tick) <- casIORef ref ticket bumped-	    case res of+            (res,tick) <- casIORef ref ticket bumped+            case res of               True -> do                 when (iters < 30) $                   dbgPrint 1$ "  Succeed CAS, old tick "++show ticket++" new "++show tick++", wrote "++show bumped@@ -418,18 +414,18 @@  where     loop 0  = return ()    loop n  = do-	-- let bumped = expected+1 -- Must do this only once, should be NOINLINE+    -- let bumped = expected+1 -- Must do this only once, should be NOINLINE --        let bump !x !y = x+y #ifdef T1-	A.atomicModifyIORefCAS_ ref (+1)+    A.atomicModifyIORefCAS_ ref (+1) #endif #ifdef T2---	B.atomicModifyIORefCAS_ ref (+1)---	B.atomicModifyIORefCAS_ ref (bump 1)-	x <- atomicModifyIORef ref (\x -> (x+1,x))+--  B.atomicModifyIORefCAS_ ref (+1)+--  B.atomicModifyIORefCAS_ ref (bump 1)+    x <- atomicModifyIORef ref (\x -> (x+1,x))         evaluate x -- Avoid stack leak. #endif-	loop (n-1)+    loop (n-1)  ----------------------------------------------------------------------------------------------------        -- This version uses a non-scalar type for CAS.  It instead@@ -459,8 +455,8 @@     tl' <- readCASable tl     case tl' of        Null -> do (b,v) <- cas tl tl' new-		 if b then loop (n-1) v-		      else loop v+         if b then loop (n-1) v+              else loop v       cons -> loop cons tl'   loop n _ Null = error "too short" #endif@@ -496,11 +492,11 @@ --   a <- newStablePtr x  --   b <- newStablePtr x  --   printf "First call, word %d IntPtr %d\n" --- 	 (unsafeCoerce a :: Word)--- 	 ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr a) :: Int)+--   (unsafeCoerce a :: Word)+--   ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr a) :: Int) --   printf "Second call, word %d IntPtr %d\n" --- 	 (unsafeCoerce b :: Word)--- 	 ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr b) :: Int)+--   (unsafeCoerce b :: Word)+--   ((fromIntegral$ ptrToIntPtr $ castStablePtrToPtr b) :: Int)   -- main = test 3