atomic-primops 0.3 → 0.4

raw patch · 16 files changed

+690/−18 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Atomics.hs +22/−2
• Data/Atomics/Counter.hs +5/−3
• Data/Atomics/Counter/Foreign.hs +16/−1
• Data/Atomics/Counter/IORef.hs +7/−0
• Data/Atomics/Counter/Reference.hs +10/−2
• Data/Atomics/Counter/Unboxed.hs +96/−0
• Data/Atomics/Internal.hs +10/−2
• atomic-primops.cabal +15/−6
• cbits/RtsDup.c +101/−0
• cbits/primops.cmm +31/−1
• testing/CommonTesting.hs +124/−0
• testing/CounterTests.hs +184/−0
• testing/Makefile +47/−0
• testing/Test.hs +4/−0
• testing/hello.hs +13/−0
• testing/test-atomic-primops.cabal +5/−1

@@ -17,6 +17,9 @@    -- * Atomic operations on mutable arrays    casArrayElem, casArrayElem2, readArrayElem,  +   -- * Atomic operations on byte arrays+   casByteArrayInt, fetchAddByteArrayInt,+       -- * Atomic operations on IORefs    readForCAS, casIORef, casIORef2,     @@ -29,6 +32,7 @@  import Control.Monad.ST (stToIO) import Data.Primitive.Array (MutableArray(MutableArray))+import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray)) import Data.Atomics.Internal import Data.Int -- TEMPORARY @@ -83,7 +87,6 @@  case casArray# arr# i# old new s1# of     (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #) - readArrayElem :: forall a . MutableArray RealWorld a -> Int -> IO (Ticket a) -- readArrayElem = unsafeCoerce# readArray# readArrayElem (MutableArray arr#) (I# i#) = IO $ \ st -> unsafeCoerce# (fn st)@@ -91,7 +94,25 @@     fn :: State# RealWorld -> (# State# RealWorld, a #)     fn = readArray# arr# i# +casByteArrayInt ::  MutableByteArray RealWorld -> Int -> Int -> Int -> IO Int+casByteArrayInt (MutableByteArray mba#) (I# ix#) (I# old#) (I# new#) =+  IO$ \s1# ->+  -- It would be nice to avoid allocating a tuple result here.+  -- Further, it will probably not be possible or the compiler to unbox the integer+  -- result either with the current arrangement: +  -- case casByteArrayInt# mba# ix# old# new# s1# of+  --   (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, I# res) #)++  let (# s2#, res #) = casByteArrayInt# mba# ix# old# new# s1# in+  (# s2#, (I# res) #)+  -- I don't know if a let will mak any difference here... hopefully not.++fetchAddByteArrayInt ::  MutableByteArray RealWorld -> Int -> Int -> IO Int+fetchAddByteArrayInt (MutableByteArray mba#) (I# offset#) (I# incr#) = IO $ \ s1# -> +  let (# s2#, res #) = fetchAddByteArrayInt# mba# offset# incr# s1# in+  (# s2#, (I# res) #)+ --------------------------------------------------------------------------------  readForCAS :: IORef a -> IO ( Ticket a )@@ -149,7 +170,6 @@       (# st, (flag ==# 0#, tick') #) --      (# st, if flag ==# 0# then Succeed tick' else Fail tick' #) --      if flag ==# 0#    then       else (# st, Fail (W# tick')  #)-  -------------------------------------------------------------------------------- -- Memory barriers

@@ -3,8 +3,10 @@ module Data.Atomics.Counter        ( --         module Data.Atomics.Counter.IORef-         module Data.Atomics.Counter.Foreign+--         module Data.Atomics.Counter.Foreign+         module Data.Atomics.Counter.Unboxed        ) where ---import Data.Atomics.Counter.IORef-import Data.Atomics.Counter.Foreign+-- import Data.Atomics.Counter.IORef+-- import Data.Atomics.Counter.Foreign+import Data.Atomics.Counter.Unboxed

@@ -5,8 +5,11 @@ -- It has the disadvantage of extra overhead due to FFI calls.  module Data.Atomics.Counter.Foreign+       (AtomicCounter, CTicket,+        newCounter, readCounterForCAS, readCounter, peekCTicket,+        writeCounter, casCounter, incrCounter, incrCounter_)    where-+import Control.Monad (void) import Data.Bits.Atomic import Foreign.ForeignPtr import Foreign.Storable@@ -16,6 +19,7 @@  type CTicket = Int +{-# INLINE newCounter #-} -- | Create a new counter initialized to the given value. newCounter :: Int -> IO AtomicCounter newCounter n = do x <- mallocForeignPtr@@ -23,6 +27,7 @@                   -- Do we need a write barrier here?                   return x +{-# INLINE incrCounter #-} -- | Increment the counter by a given amount. --   Returns the original value before the increment. --                 @@ -32,23 +37,33 @@ incrCounter :: Int -> AtomicCounter -> IO Int incrCounter bump r = withForeignPtr r$ \r' -> fetchAndAdd r' bump +{-# INLINE incrCounter_ #-}+-- | An alternate version for when you don't care about the old value.+incrCounter_ :: Int -> AtomicCounter -> IO ()+incrCounter_ bump r = withForeignPtr r$ \r' -> void (fetchAndAdd r' bump)++{-# 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 r = withForeignPtr r peek  +{-# INLINE writeCounter #-} -- | Make a non-atomic write to the counter.  No memory-barrier. writeCounter :: AtomicCounter -> Int -> IO () writeCounter r !new = withForeignPtr r $ \r' -> poke r' new +{-# INLINE casCounter #-} -- | Compare and swap for the counter ADT. casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket) casCounter r !tick !new = withForeignPtr r $ \r' -> do

@@ -5,8 +5,12 @@ -- 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 @@ -34,6 +38,9 @@       (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 #-}

@@ -3,9 +3,13 @@ -- | 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+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)@@ -33,7 +37,11 @@       (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.

@@ -0,0 +1,96 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, CPP #-}++module Data.Atomics.Counter.Unboxed+       (AtomicCounter, CTicket,+        newCounter, readCounterForCAS, readCounter, peekCTicket,+        writeCounter, casCounter, incrCounter, incrCounter_)+       where++import GHC.Base+import GHC.Ptr+import Data.Atomics (casByteArrayInt)+import Data.Atomics.Internal (casByteArrayInt#, fetchAddByteArrayInt#)++#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++data AtomicCounter = AtomicCounter (MutableByteArray# RealWorld)+type CTicket = Int++-- | Create a new counter initialized to the given value.+{-# INLINE newCounter #-}+newCounter :: Int -> IO AtomicCounter+newCounter n = do+  c <- newRawCounter+  writeCounter c n+  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.+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.+casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket)+-- casCounter (AtomicCounter barr) !old !new =+casCounter (AtomicCounter mba#) (I# old#) (I# new#) = IO$ \s1# ->+  let (# s2#, res# #) = casByteArrayInt# mba# 0# old# new# s1# in+  (# s2#, (res# ==# old#, I# res#) #)++{-# INLINE sameCTicket #-}+sameCTicket :: CTicket -> CTicket -> Bool+sameCTicket = (==)++{-# INLINE incrCounter #-}+-- | Increment the counter by a given amount.+--   Returns the original value before the increment.+--                 +--   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 #) = fetchAddByteArrayInt# 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 #) = fetchAddByteArrayInt# mba# 0# incr# s1# in+  (# s2#, () #)

@@ -4,7 +4,7 @@ -- | This module provides only the raw primops (and necessary types) for atomic -- operations.   module Data.Atomics.Internal -   (casArray#, +   (casArray#, casByteArrayInt#, fetchAddByteArrayInt#,      readForCAS#, casMutVarTicketed#,      Ticket,     stg_storeLoadBarrier#, stg_loadLoadBarrier#, stg_writeBarrier# )@@ -12,7 +12,9 @@  import GHC.Base (Int(I#)) import GHC.Word (Word(W#))-import GHC.Prim (RealWorld, Int#, Word#, State#, MutableArray#, unsafeCoerce#, MutVar#, reallyUnsafePtrEquality#) +import GHC.Prim (RealWorld, Int#, Word#, State#, MutableArray#, MutVar#,+                 MutableByteArray#, +                 unsafeCoerce#, reallyUnsafePtrEquality#)  #if MIN_VERSION_base(4,5,0) -- Any is only in GHC 7.6!!!  We want 7.4 support. import GHC.Prim (readMutVar#, casMutVar#, Any)@@ -128,3 +130,9 @@ --   :: MutVar# RealWorld () ->  --      State# RealWorld -> (# State# RealWorld, Any () #) +foreign import prim "stg_casByteArrayIntzh" casByteArrayInt#+  :: MutableByteArray# s -> Int# -> Int# -> Int# ->+     State# s -> (# State# s, Int# #) ++foreign import prim "stg_fetchAddByteArrayIntzh" fetchAddByteArrayInt#+  :: MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) 

@@ -1,11 +1,10 @@ Name:                atomic-primops-Version:             0.3+Version:             0.4 License:             BSD3 License-file:        LICENSE Author:              Ryan Newton Maintainer:          rrnewton@gmail.com Category:            Data-Stability:           Provisional -- Portability:         non-portabile (x86_64) Build-type:          Custom -- TODO: This requirement needs to be bumped to 1.17 when the latest cabal is@@ -20,6 +19,7 @@ -- 0.2.2 -- Add more counters -- 0.2.2.1 -- Minor, add warning. -- 0.3 -- Major internal change.  Duplicate GHC RTS barriers and support non -threaded.+-- 0.4 -- Duplicate 'cas' as well as barriers.  Add fetchAdd on ByteArray, Counter.Unboxed.  Synopsis: A safe approach to CAS and other atomic ops in Haskell. @@ -38,10 +38,19 @@  .  * Major internal change.  Duplicate the barrier code from the GHC RTS and thus     enable support for executables that are NOT built with '-threaded'.+ .+ Changes in 0.4:+ . + * Further internal changes, duplicate 'cas' routine well as barriers.  + .+ * Add `fetchAddByteArrayInt`+ .+ * Add an `Unboxed` counter variant that uses movable "ByteArray"s on the GHC heap.   Extra-Source-Files:  DEVLOG.md,-                     testing/Test.hs, testing/test-atomic-primops.cabal+                     testing/Test.hs, testing/test-atomic-primops.cabal,+                     testing/Makefile, testing/CommonTesting.hs, testing/CounterTests.hs, testing/hello.hs --                    Makefile, Test.hs, README.md  Flag debug@@ -55,6 +64,7 @@                      Data.Atomics.Counter.IORef                      Data.Atomics.Counter.Reference                      Data.Atomics.Counter.Foreign+                     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@@ -68,6 +78,8 @@    Include-Dirs:     cbits   C-Sources:        cbits/primops.cmm+  -- Duplicate RTS functionality: +  C-Sources:        cbits/RtsDup.c   CC-Options:       -Wall    ghc-prof-options: -DGHC_PROFILING_ON   -- if( cabal-version < 1.17 ) {@@ -76,9 +88,6 @@    if flag(debug)     cpp-options: -DDEBUG_ATOMICS--  -- Duplicate RTS functionality: -  C-Sources:    cbits/RtsDup.c   -- -- [2013.04.08] This isn't working presently:

@@ -90,3 +90,104 @@ // multiple loads of the memory location, as it might otherwise do in // a busy wait loop for example. // #define VOLATILE_LOAD(p) (*((StgVolatilePtr)(p)))++++/* + * CMPXCHG - the single-word atomic compare-and-exchange instruction.  Used + * in the STM implementation.+ */+EXTERN_INLINE StgWord+DUP_cas(StgVolatilePtr p, StgWord o, StgWord n)+{+#if i386_HOST_ARCH || x86_64_HOST_ARCH+    __asm__ __volatile__ (+ 	  "lock\ncmpxchg %3,%1"+          :"=a"(o), "=m" (*(volatile unsigned int *)p) +          :"0" (o), "r" (n));+    return o;+#elif powerpc_HOST_ARCH+    StgWord result;+    __asm__ __volatile__ (+        "1:     lwarx     %0, 0, %3\n"+        "       cmpw      %0, %1\n"+        "       bne       2f\n"+        "       stwcx.    %2, 0, %3\n"+        "       bne-      1b\n"+        "2:"+        :"=&r" (result)+        :"r" (o), "r" (n), "r" (p)+        :"cc", "memory"+    );+    return result;+#elif sparc_HOST_ARCH+    __asm__ __volatile__ (+	"cas [%1], %2, %0"+	: "+r" (n)+	: "r" (p), "r" (o)+	: "memory"+    );+    return n;+#elif arm_HOST_ARCH && defined(arm_HOST_ARCH_PRE_ARMv6)+    StgWord r;+    arm_atomic_spin_lock();+    r  = *p; +    if (r == o) { *p = n; } +    arm_atomic_spin_unlock();+    return r;+#elif arm_HOST_ARCH && !defined(arm_HOST_ARCH_PRE_ARMv6)+    StgWord result,tmp;++    __asm__ __volatile__(+        "1:     ldrex   %1, [%2]\n"+        "       mov     %0, #0\n"+        "       teq     %1, %3\n"+        "       it      eq\n"+        "       strexeq %0, %4, [%2]\n"+        "       teq     %0, #1\n"+        "       it      eq\n"+        "       beq     1b\n"+#if !defined(arm_HOST_ARCH_PRE_ARMv7)+        "       dmb\n"+#endif+                : "=&r"(tmp), "=&r"(result)+                : "r"(p), "r"(o), "r"(n)+                : "cc","memory");++    return result;+#elif !defined(WITHSMP)+    StgWord result;+    result = *p;+    if (result == o) {+        *p = n;+    }+    return result;+#else+#error cas() unimplemented on this architecture+#endif+}++++// Copied from atomic_inc in the GHC RTS, except tweaked to allow+// arbitrary increments (other than 1).+EXTERN_INLINE StgWord+atomic_inc_with(StgWord incr, StgVolatilePtr p)+{+#if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)+    StgWord r;+    r = incr;+    __asm__ __volatile__ (+        "lock\nxadd %0,%1":+            "+r" (r), "+m" (*p):+    );+    return r + incr;+#else+    StgWord old, new;+    do {+        old = *p;+        new = old + incr;+    } while (DUP_cas(p, old, new) != old);+    return new;+#endif+}

@@ -2,7 +2,7 @@ #include "Cmm.h"  #warning "Duplicating functionality from the GHC RTS..."-#define WHICH_CAS       cas+#define WHICH_CAS       DUP_cas #define WHICH_SLBARRIER DUP_store_load_barrier #define WHICH_LLBARRIER DUP_load_load_barrier #define WHICH_WBARRIER  DUP_write_barrier@@ -46,6 +46,36 @@ 	I8[arr + SIZEOF_StgMutArrPtrs + WDS(len) + (ind >> MUT_ARR_PTRS_CARD_BITS )] = 1;         RET_NP(0,h);     }+}+++stg_casByteArrayIntzh+/* MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) */+{+    W_ arr, p, ind, old, new, h, len;+    arr = R1; +    ind = R2;+    old = R3;+    new = R4;++    p = arr + SIZEOF_StgArrWords + WDS(ind);+    (h) = foreign "C" WHICH_CAS(p, old, new) [];++    RET_N(h);+}++stg_fetchAddByteArrayIntzh+/* MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) */+{+    W_ arr, p, ind, incr, h, len;+    arr  = R1; +    ind  = R2;+    incr = R3;++    p = arr + SIZEOF_StgArrWords + WDS(ind);+    (h) = foreign "C" atomic_inc_with(incr, p) [];++    RET_N(h); }  

@@ -0,0 +1,124 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, NamedFieldPuns, CPP #-}++module CommonTesting  where++import Control.Monad+import Control.Concurrent.MVar+import GHC.Conc+import Data.Time.Clock+import Text.Printf+import GHC.IO (unsafePerformIO)+import System.Mem.StableName (makeStableName, hashStableName)+import System.Environment (getEnvironment)+import System.IO        (stdout, stderr, hPutStrLn, hFlush)+import Debug.Trace      (trace)++-- import Test.Framework.TH (defaultMainGenerator)+++----------------------------------------------------------------------------------------------------+-- Helpers+----------------------------------------------------------------------------------------------------++checkGCStats :: IO ()+checkGCStats = return ()+    -- do b <- getGCStatsEnabled+    --    unless b $ error "Cannot run tests without +RTS -T !!"++dotdot :: Int -> String -> String+dotdot len chars = +  if length chars > len+  then take len chars ++ "..."+  else chars++printBits :: [Bool] -> IO ()+printBits = print . map pb+ where pb True  = '1' +       pb False = '0'++forkJoin :: Int -> (Int -> IO b) -> IO [b]+forkJoin numthreads action = +  do+     answers <- sequence (replicate numthreads newEmptyMVar) -- padding?+     dbgPrint 1 $ printf "Forking %d threads.\n" numthreads+    +     forM_ (zip [0..] answers) $ \ (ix,mv) -> + 	forkIO (action ix >>= putMVar mv)++     -- Reading answers:+     ls <- mapM readMVar answers+     dbgPrint 1 $ printf "All %d thread(s) completed\n" numthreads+     return ls++-- TODO: Here's an idea.  Describe a structure of forking and joining threads for+-- tests, then we can stress test it by running different interleavings explicitly.+data Forkable a = Fork Int (IO a)+                | Parallel (Forkable a) (Forkable a) -- Parallel composition+                | Sequence (Forkable a) (Forkable a) -- Sequential compositon, with barrier+--                | Barrier Forkable+++timeit :: IO a -> IO a +timeit ioact = do +   start <- getCurrentTime+   res <- ioact+   end   <- getCurrentTime+   putStrLn$ "  Time elapsed: " ++ show (diffUTCTime end start)+   return res++{-# NOINLINE unsafeName #-}+unsafeName :: a -> Int+unsafeName x = unsafePerformIO $ do +   sn <- makeStableName x+   return (hashStableName sn)++++----------------------------------------------------------------------------------------------------+-- DEBUGGING+----------------------------------------------------------------------------------------------------++-- | Debugging flag shared by all accelerate-backend-kit modules.+--   This is activated by setting the environment variable DEBUG=1..5+dbg :: Int+dbg = case lookup "DEBUG" unsafeEnv of+       Nothing  -> defaultDbg+       Just ""  -> defaultDbg+       Just "0" -> defaultDbg+       Just s   ->+         warnUsing (" DEBUG="++s)$+         case reads s of+           ((n,_):_) -> n+           [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s++-- | How many elements or iterations should the test use?+numElems :: Int+numElems = case lookup "NUMELEMS" unsafeEnv of +             Nothing  -> 1000 * 1000 +             Just str -> warnUsing ("NUMELEMS = "++str) $ +                         read str++warnUsing :: String -> a -> a+warnUsing str a = trace ("  [Warning]: Using environment variable "++str) a++defaultDbg :: Int+defaultDbg = 0++unsafeEnv :: [(String,String)]+unsafeEnv = unsafePerformIO getEnvironment++-- | Print if the debug level is at or above a threshold.+dbgPrint :: Int -> String -> IO ()+dbgPrint lvl str = if dbg < lvl then return () else do+    hPutStrLn stderr str+    hFlush stderr++-- My own forM for numeric ranges (not requiring deforestation optimizations).+-- Inclusive start, exclusive end.+{-# INLINE for_ #-}+for_ :: Monad m => Int -> Int -> (Int -> m ()) -> m ()+for_ start end _fn | start > end = error "for_: start is greater than end"+for_ start end fn = loop start+  where+   loop !i | i == end  = return ()+	   | otherwise = do fn i; loop (i+1)

@@ -0,0 +1,184 @@+{-# LANGUAGE BangPatterns #-}++-- | Test the counter implementation alternatives.++module CounterTests where++import Control.Monad+import GHC.Conc+import System.CPUTime+import Test.Framework.Providers.HUnit (testCase)+import Text.Printf+import Data.IORef  ++import Data.Atomics+import qualified Data.Atomics.Counter.Reference as C1 +import qualified Data.Atomics.Counter.IORef     as C2+import qualified Data.Atomics.Counter.Foreign   as C3+import qualified Data.Atomics.Counter.Unboxed   as C4++import CommonTesting (numElems, forkJoin, timeit)++--------------------------------------------------------------------------------++-- {-# INLINE nTimes #-}+-- | To make sure we get a simple loop...+nTimes :: Int -> IO () -> IO ()+-- nTimes :: Int -> IO a -> IO ()+-- Note: starting out I would get 163Mb allocation for 10M sequential incrs (on unboxed).+-- The problem was that the "Int" result from each incr was being allocated.+-- Weird thing is that inlining nTimes reduces the allocation to 323Mb.+-- But forcing it to take an (IO ()) gets rid of the allocation.+-- Egad, wait, no, I have to NOT inline nTimes to get rid of the allocation!?!?+-- Otherwise I'm still stuck with at least 163Mb of allocation.+-- In fact... the allocation is still there even if we use incrCounter_ !!+-- If we leave nTimes uninlined, we can get down to 3Mb allocation with either incrCounter or incrCounter_.+-------------------------+-- UPDATE:+-- As per http://www.haskell.org/pipermail/glasgow-haskell-users/2011-June/020472.html+--+--  INLINE should not affect recursive functions.  But here it seems to have a+--  deleterious effect!+nTimes 0 !c = return ()+nTimes !n !c = c >> nTimes (n-1) c++-- {-# INLINE vd #-}+-- vd = void+-- vd x = x++cputime :: IO t -> IO t+cputime a = do+    start <- getCPUTime+    v <- a+    end   <- getCPUTime+    let diff = (fromIntegral (end - start)) / (10^12)+    printf "SELFTIMED: %0.3f sec\n" (diff :: Double)+    return v++normal tries = do+  r <- newIORef True+  nTimes tries $ do+    x <- readIORef r+    writeIORef r $! not x++-- This is not allocating per-iteration currently, which is rather amazing given what+-- casIORef returns.+casBased tries = do    +  r <- newIORef True+  nTimes tries $ do+    t <- readForCAS r+    casIORef r t (not $ peekTicket t)+    return ()+  readIORef r++normalIncr tries = do+  r <- newIORef 0+  nTimes tries $ do+    x <- readIORef r+    writeIORef r $! 1 + x+  readIORef r++casBasedIncr tries = do    +  r <- newIORef 0+  nTimes tries $ do+    t <- readForCAS r+    casIORef r t $! (1 + peekTicket t)+    return ()+  readIORef r++incrloop1 tries = do r <- C1.newCounter 0; nTimes tries $ void$ C1.incrCounter 1 r+incrloop2 tries = do r <- C2.newCounter 0; nTimes tries $ void$ C2.incrCounter 1 r+incrloop3 tries = do r <- C3.newCounter 0; nTimes tries $ void$ C3.incrCounter 1 r+incrloop4 tries = do r <- C4.newCounter 0; nTimes tries $ C4.incrCounter_ 1 r++-- | 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.+incrloop4B tries = do+  putStrLn " [incrloop4B] A test where we use the result of each incr."+  r <- C4.newCounter 1+  loop r tries 1+ where+   loop :: C4.AtomicCounter -> Int -> Int -> IO ()+   loop r 0 _ = do v <- C4.readCounter r+                   putStrLn$"Final value: "++show v+                   return ()+   loop r tries last = do+     n <- C4.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 <- C4.newCounter 1+  loop r tries 1+ where+   loop :: C4.AtomicCounter -> Int -> Int -> IO ()+   loop r 0 _ = do v <- C4.readCounter r+                   putStrLn$"Final value: "++show v+                   return ()+   loop r tries last = do+     putStrLn$ " [incrloop4B] Looping with tries left "++show tries +     n <- C4.incrCounter last r+     -- This is HANGING afer passing 2,147,483,648.+     -- Is there some defect wrt overflow?+     putStrLn$ " [incrloop4B] Done incr, received "++show n+     loop r (tries-1) n++++{-# INLINE parIncrloop #-} +parIncrloop new incr iters = do+  numcap <- getNumCapabilities+  let each = iters `quot` numcap+  putStrLn$ "Concurrently incrementing counter from all "++show numcap++" threads, incrs per thread: "++show each+  r <- new 0+  forkJoin numcap $ \ _ ->    +    nTimes each $ void $ incr 1 r+  return r++parIncrloop1 = parIncrloop C1.newCounter C1.incrCounter+parIncrloop2 = parIncrloop C2.newCounter C2.incrCounter+parIncrloop3 = parIncrloop C3.newCounter C3.incrCounter+parIncrloop4 = parIncrloop C4.newCounter C4.incrCounter++--------------------------------------------------------------------------------++default_seq_tries  = 10 * numElems+-- Things are MUCH slower with contention:+default_conc_tries = numElems++counterTests = + [+   ----------------------------------------+   testCase "RAW_single_thread_repeat_flip" $ do +     putStrLn "Timing readIORef/writeIORef on one thread"+     timeit (normal default_seq_tries)   + , testCase "CAS_single_thread_repeat_flip" $ do +     putStrLn "Timing CAS boolean flips on one thread without retries"+     fin <- timeit (casBased default_seq_tries)+     putStrLn$"Final value: "++show fin+   ----------------------------------------+ , testCase "RAW_single_thread_repeat_incr" $ do +     putStrLn "Timing readIORef/writeIORef on one thread"+     fin <- timeit (normalIncr default_seq_tries)+     putStrLn$"Final value: "++show fin      + , testCase "CAS_single_thread_repeat_incr" $ do +     putStrLn "Timing CAS increments on one thread without retries"+     fin <- timeit (casBasedIncr default_seq_tries)+     putStrLn$"Final value: "++show fin +   ----------------------------------------+ , testCase "CounterReference_single_thread_repeat_incr" $ timeit (incrloop1 default_seq_tries)+ , testCase "CounterIORef_single_thread_repeat_incr"     $ timeit (incrloop2 default_seq_tries)   + , testCase "CounterForeign_single_thread_repeat_incr"   $ timeit (incrloop3 default_seq_tries)+ , testCase "CounterUnboxed_single_thread_repeat_incr"   $ timeit (incrloop4 default_seq_tries)+ , testCase "CounterUnboxed_incr_with_result_feedback"   $ timeit (incrloop4B default_seq_tries)+   ----------------------------------------++   -- Parallel versions:+ , testCase "CounterReference_concurrent_repeat_incr" $ void$ timeit (parIncrloop1 default_conc_tries)+ , testCase "CounterIORef_concurrent_repeat_incr"     $ void$ timeit (parIncrloop2 default_conc_tries)+ , testCase "CounterForeign_concurrent_repeat_incr"   $ void$ timeit (parIncrloop3 default_conc_tries)+ , testCase "CounterUnboxed_concurrent_repeat_incr"   $ void$ timeit (parIncrloop4 default_conc_tries)+ ]

@@ -0,0 +1,47 @@++GHC=ghc++all: simple full++simple: hello+hello:+	$(GHC) -fforce-recomp hello.hs -o hello_regular.exe +	$(GHC) -fforce-recomp hello.hs -o hello_threaded.exe -threaded+	$(GHC) -fforce-recomp hello.hs -o hello_prof.exe -prof+	$(GHC) -fforce-recomp hello.hs -o hello_prof_threaded.exe -prof -threaded+	./hello_regular.exe +	./hello_threaded.exe+	./hello_prof.exe+	./hello_prof_threaded.exe++NOPROF= --disable-library-profiling --disable-executable-profiling+PROF= --enable-library-profiling --enable-executable-profiling++CBL= rm -rf dist; echo "\n\n"; cabal install --enable-tests++#================================================================================+# The --builddir approach is broken with cabal 1.16.  It works fine in+# the current cabal HEAD [2013.07.18].+# ================================================================================++# Try all combinations of profiling, optimization, and threading:+full:+	$(CBL) $(NOPROF) -fopt  -fthreaded  # --builddir=dist_reg_opt_thrd+	$(CBL) $(PROF)   -fopt  -fthreaded  # --builddir=dist_prof_opt_thrd++	$(CBL) $(NOPROF) -f-opt -fthreaded  # --builddir=dist_reg__thrd+	$(CBL) $(PROF)   -f-opt -fthreaded  # --builddir=dist_prof__thrd++	$(CBL) $(NOPROF) -fopt  -f-threaded # --builddir=dist_reg_opt_+	$(CBL) $(PROF)   -fopt  -f-threaded # --builddir=dist_prof_opt_++	$(CBL) $(NOPROF) -f-opt  -f-threaded # --builddir=dist_reg__+	$(CBL) $(PROF)   -f-opt  -f-threaded # --builddir=dist_prof__++# These shoud be redundant with the above, but we run them anyway:+	for f in `ls dist_*/build/hello-world-atomic-primops/hello-world-atomic-primops`; do ./$f; done++	tail dist_*/test/test-atomic-primops-*-test-atomic-primops.log++clean:+	rm -rf ./dist/ ./dist_*/

@@ -131,6 +131,10 @@  assertBool "2nd should fail: " (not res2)  +-- case_casbytearray1 :: IO ()+-- case_casbytearray1 = do +--  putStrLn "Perform a CAS within a MutableByteArray#"+ -- | This test uses a number of producer and consumer threads which push and pop -- elements from random positions in an array. test_random_array_comm :: Int -> Int -> Int -> IO ()

@@ -0,0 +1,13 @@++-- A simple test that verifies the compile & link went ok for atomic-primops.++import Data.IORef+import Data.Atomics++main = do +  putStrLn "hello"+  x <- newIORef (3::Int)+  t <- readForCAS x+  casIORef x t 4+  print =<< readIORef x +

@@ -24,9 +24,13 @@     if flag(threaded)        ghc-options: -threaded         -    build-depends: base, ghc-prim, primitive, containers, random, atomic-primops,+    build-depends: base, ghc-prim, primitive, containers, random, atomic-primops >= 0.4,                    -- For Testing:                    time, HUnit, test-framework, test-framework-hunit++    -- Debugging generated code:+--    ghc-options: -keep-tmp-files -dsuppress-module-prefixes -ddump-to-file -ddump-core-stats -ddump-simpl-stats -dcore-lint -dcmm-lint+--    ghc-options: -ddump-ds -ddump-simpl -ddump-stg -ddump-asm -ddump-bcos -ddump-cmm -ddump-opt-cmm -ddump-inlinings  Executable hello-world-atomic-primops   main-is: hello.hs