atomic-primops 0.1.0.2 → 0.2.2

raw patch · 11 files changed

+350/−144 lines, 11 filesdep +bits-atomicbuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: bits-atomic

API changes (from Hackage documentation)

Files

• Data/Atomics.hs +54/−26
• Data/Atomics/Counter.hs +8/−0
• Data/Atomics/Counter/Foreign.hs +48/−0
• Data/Atomics/Counter/IORef.hs +40/−0
• Data/Atomics/Counter/Reference.hs +75/−0
• Data/Atomics/Internal.hs +46/−12
• Setup.hs +27/−2
• atomic-primops.cabal +18/−5
• cbits/primops.cmm +19/−0
• testing/Test.hs +12/−98
• testing/runTest.hs +3/−1

@@ -1,15 +1,5 @@ {-# LANGUAGE  MagicHash, UnboxedTuples, BangPatterns, ScopedTypeVariables, CPP #-} -#ifdef GHC_PROFILING_ON-#ifndef MIN_VERSION_Cabal-#error "MIN_VERSION_Cabal should be defined!"-#endif-#if MIN_VERSION_Cabal(1,17,0)-#else-#error "Before Cabal 1.17 there was a bug that prevents you from building this library with profiling.  See cabal issue 1284."-#endif-#endif- -- | Provides atomic memory operations on IORefs and Mutable Arrays. -- --   Pointer equality need not be maintained by a Haskell compiler.  For example, Int@@ -31,13 +21,15 @@    readForCAS, casIORef, casIORef2,         -- * Atomic operations on raw MutVars-   readMutVarForCAS, casMutVar, casMutVar2-      +   readMutVarForCAS, casMutVar, casMutVar2,++   -- * Memory barriers+   storeLoadBarrier, loadLoadBarrier, writeBarrier  ) where  import Control.Monad.ST (stToIO) import Data.Primitive.Array (MutableArray(MutableArray))-import Data.Atomics.Internal (casArray#, readForCAS#, casMutVarTicketed#, Ticket)+import Data.Atomics.Internal import Data.Int -- TEMPORARY  import Data.IORef@@ -50,9 +42,33 @@ import GHC.IO (IO(IO)) import GHC.Word (Word(W#)) ---------------------------------------------------------------------------------+#ifdef DEBUG_ATOMICS+#warning "Activating DEBUG_ATOMICS... NOINLINE's and more"+{-# NOINLINE seal #-} +{-# NOINLINE casIORef #-}+{-# NOINLINE casArrayElem2 #-}   +{-# NOINLINE readArrayElem #-}+{-# NOINLINE readForCAS #-}+{-# NOINLINE casArrayElem #-}+{-# NOINLINE casIORef2 #-}+{-# NOINLINE readMutVarForCAS #-}+{-# NOINLINE casMutVar #-}+{-# NOINLINE casMutVar2 #-}+#else+{-# INLINE casIORef #-}+{-# INLINE casArrayElem2 #-}   +{-# INLINE readArrayElem #-}+{-# INLINE readForCAS #-} {-# INLINE casArrayElem #-}+{-# INLINE casIORef2 #-}+{-# INLINE readMutVarForCAS #-}+{-# INLINE casMutVar #-}+{-# INLINE casMutVar2 #-}+#endif++--------------------------------------------------------------------------------+ -- | Compare-and-swap  casArrayElem :: MutableArray RealWorld a -> Int -> Ticket a -> a -> IO (Bool, Ticket a) -- casArrayElem (MutableArray arr#) (I# i#) old new = IO$ \s1# ->@@ -60,7 +76,6 @@ --    (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #) casArrayElem arr i old new = casArrayElem2 arr i old (seal new) -{-# INLINE casArrayElem2 #-}    -- | This variant takes two tickets: the 'new' value is a ticket rather than an -- arbitrary, lifted, Haskell value. casArrayElem2 :: MutableArray RealWorld a -> Int -> Ticket a -> Ticket a -> IO (Bool, Ticket a)@@ -69,7 +84,6 @@    (# s2#, x#, res #) -> (# s2#, (x# ==# 0#, res) #)  -{-# INLINE readArrayElem #-} readArrayElem :: forall a . MutableArray RealWorld a -> Int -> IO (Ticket a) -- readArrayElem = unsafeCoerce# readArray# readArrayElem (MutableArray arr#) (I# i#) = IO $ \ st -> unsafeCoerce# (fn st)@@ -80,11 +94,9 @@  -------------------------------------------------------------------------------- -{-# INLINE readForCAS #-} readForCAS :: IORef a -> IO ( Ticket a ) readForCAS (IORef (STRef mv)) = readMutVarForCAS mv -{-# INLINE casIORef #-} -- | 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'.@@ -97,8 +109,6 @@          -> IO (Bool, Ticket a) casIORef (IORef (STRef var)) old new = casMutVar var old new  --{-# INLINE casIORef2 #-} -- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an -- arbitrary, lifted, Haskell value. casIORef2 :: IORef a @@ -111,6 +121,9 @@ --------------------------------------------------------------------------------  -- | A ticket contains or can get the usable Haskell value.+{-# NOINLINE peekTicket #-}+-- At least this function MUST remain NOINLINE.  Issue5 is an example of a bug that+-- ensues otherwise. peekTicket :: Ticket a -> a  peekTicket = unsafeCoerce# @@ -119,19 +132,14 @@ seal :: a -> Ticket a  seal = unsafeCoerce# --{-# INLINE readMutVarForCAS #-} readMutVarForCAS :: MutVar# RealWorld a -> IO ( Ticket a ) readMutVarForCAS !mv = IO$ \ st -> readForCAS# mv st - -- | MutVar counterpart of `casIORef`. -- casMutVar :: MutVar# RealWorld a -> Ticket a -> a -> IO (Bool, Ticket a) casMutVar !mv !tick !new = casMutVar2 mv tick (seal new)-{-# INLINE casMutVar #-} - -- | This variant takes two tickets, i.e. the 'new' value is a ticket rather than an -- arbitrary, lifted, Haskell value. casMutVar2 :: MutVar# RealWorld a -> Ticket a -> Ticket a -> IO (Bool, Ticket a)@@ -141,7 +149,27 @@       (# st, (flag ==# 0#, tick') #) --      (# st, if flag ==# 0# then Succeed tick' else Fail tick' #) --      if flag ==# 0#    then       else (# st, Fail (W# tick')  #)-{-# INLINE casMutVar2 #-}  +--------------------------------------------------------------------------------+-- Memory barriers+-------------------------------------------------------------------------------- ++-- | Memory barrier implemented by the GHC rts (SMP.h).+storeLoadBarrier :: IO ()+storeLoadBarrier = IO$ \st ->+  case stg_storeLoadBarrier# st of+    (# st', _ #) -> (# st', () #)++-- | Memory barrier implemented by the GHC rts (SMP.h).+loadLoadBarrier :: IO ()+loadLoadBarrier = IO$ \st ->+  case stg_loadLoadBarrier# st of+    (# st', _ #) -> (# st', () #)++-- | Memory barrier implemented by the GHC rts (SMP.h).+writeBarrier :: IO ()+writeBarrier = IO$ \st ->+  case stg_writeBarrier# st of+    (# st', _ #) -> (# st', () #)

@@ -0,0 +1,8 @@+++module Data.Atomics.Counter+       (+         module Data.Atomics.Counter.IORef+       ) where++import Data.Atomics.Counter.IORef

@@ -0,0 +1,48 @@+{-# LANGUAGE BangPatterns #-}++-- | This implementation stores an unboxed counter and uses FFI+-- operations to modify its contents.++module Data.Atomics.Counter.Foreign+   where++import Data.Bits.Atomic+import Foreign.ForeignPtr+import Foreign.Storable++-- newtype AtomicCounter = AtomicCounter (ForeignPtr Int)+type AtomicCounter = ForeignPtr Int++type CTicket = Int++-- | Create a new counter initialized to zero.+newCounter :: IO AtomicCounter+newCounter = do x <- mallocForeignPtr+                writeCounter x 0+                return x++-- | Try repeatedly until we successfully increment the counter.+-- Returns the original value before the increment.+incrCounter :: AtomicCounter -> IO Int+incrCounter r = withForeignPtr r$ \r' -> fetchAndAdd r' 1 ++readCounterForCAS :: AtomicCounter -> IO CTicket+readCounterForCAS = readCounter++peekCTicket :: CTicket -> Int+peekCTicket x = x++readCounter :: AtomicCounter -> IO Int+readCounter r = withForeignPtr r peek ++-- | Make a non-atomic write to the counter.  No memory-barrier.+writeCounter :: AtomicCounter -> Int -> IO ()+writeCounter r !new = withForeignPtr r $ \r' -> poke r' new++casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket)+casCounter r !tick !new = withForeignPtr r $ \r' -> do+   b <- compareAndSwap r' tick new+   -- if b then return (True,new)+   --      else do x <- peek r'+   --              return (False,x)+   return (b==tick, b)

@@ -0,0 +1,40 @@+{-# LANGUAGE BangPatterns #-}++-- | This version uses a boxed IORef representation, but it can be+-- somewhat cheaper because it uses raw CAS rather than full atomicModifyIORef.++module Data.Atomics.Counter.IORef+       where++import Data.IORef+import Data.Atomics as A++--------------------------------------------------------------------------------++-- type AtomicCounter = IORef Int+newtype AtomicCounter = AtomicCounter (IORef Int)++type CTicket = Ticket Int++-- | Create a new counter initialized to zero.+newCounter :: IO AtomicCounter+newCounter = fmap AtomicCounter $ newIORef 0++-- | Try repeatedly until we successfully increment the counter.+-- incrCounter =++readCounterForCAS :: AtomicCounter -> IO CTicket+readCounterForCAS (AtomicCounter r) = readForCAS r++peekCTicket :: CTicket -> Int+peekCTicket = peekTicket ++readCounter :: AtomicCounter -> IO Int+readCounter (AtomicCounter r) = readIORef r++-- | Make a non-atomic write to the counter.  No memory-barrier.+writeCounter :: AtomicCounter -> Int -> IO ()+writeCounter (AtomicCounter r) !new = writeIORef r new++casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket)+casCounter (AtomicCounter r) tick !new = casIORef r tick new

@@ -0,0 +1,75 @@+{-# 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.+module Data.Atomics.Counter.Reference+       where++import Data.IORef+-- import Data.Atomics+import System.IO.Unsafe (unsafePerformIO)++--------------------------------------------------------------------------------++-- type AtomicCounter = IORef Int+newtype AtomicCounter = AtomicCounter (IORef Int)++type CTicket = Int++-- | Create a new counter initialized to zero.+newCounter :: IO AtomicCounter+newCounter = fmap AtomicCounter $ newIORef 0++-- | Try repeatedly until we successfully increment the counter.+-- incrCounter =++readCounterForCAS :: AtomicCounter -> IO CTicket+readCounterForCAS = readCounter++peekCTicket :: CTicket -> Int+peekCTicket x = x++readCounter :: AtomicCounter -> IO Int+readCounter (AtomicCounter r) = readIORef r++-- | Make a non-atomic write to the counter.  No memory-barrier.+writeCounter :: AtomicCounter -> Int -> IO ()+writeCounter (AtomicCounter r) !new = writeIORef r new++casCounter :: AtomicCounter -> CTicket -> Int -> IO (Bool, CTicket)+casCounter (AtomicCounter r) oldT !new =++   -- This approach for faking it requires proper equality, it doesn't use pointer+   -- equality at all.  That makes it not a true substitute but useful for some+   -- debugging.+   -- fakeCAS :: Eq a => IORef a -> Ticket a -> a -> IO (Bool,Ticket a)+  +  -- let old = peekTicket oldT+  let old = oldT in +  atomicModifyIORef r $ \val -> +{-+    trace ("    DBG: INSIDE ATOMIC MODIFY, ptr eqs found/expected: " ++ +	   show [ptrEq val old, ptrEq val old, ptrEq val old] ++ +	   " ptr eq self: " ++ +	   show [ptrEq val val, ptrEq old old] +++	   " names: " ++ show (unsafeName old, unsafeName old, unsafeName val, unsafeName val)+	  ) $+-}+    if   (val == old)+    then (new, (True, val))+    else (val, (False,val))+    -- then (new, (True, unsafeCoerce# val))+    -- else (val, (False,unsafeCoerce# 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++-}

@@ -6,30 +6,44 @@ module Data.Atomics.Internal     (casArray#,      readForCAS#, casMutVarTicketed#, -    Ticket )+    Ticket,+    stg_storeLoadBarrier#, stg_loadLoadBarrier#, stg_writeBarrier# )   where   import GHC.Base (Int(I#)) import GHC.Word (Word(W#)) import GHC.Prim (RealWorld, Int#, Word#, State#, MutableArray#, unsafeCoerce#, MutVar#, reallyUnsafePtrEquality#) -#if MIN_VERSION_base(4,6,0)+#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) #else-#error "Need to figure out how to emulate Any () in GHC 7.4."+#error "Need to figure out how to emulate Any () in GHC < 7.4 !" -- type Any a = Word# #endif     +#ifdef DEBUG_ATOMICS+{-# NOINLINE readForCAS# #-}+{-# NOINLINE casArray# #-}+{-# NOINLINE casMutVarTicketed# #-}+#define CASTFUN+#else+{-# INLINE casMutVarTicketed# #-}+{-# INLINE casArray# #-}+-- I *think* inlining may be ok here as long as casting happens on the arrow types:+#define CASTFUN+#endif+ ----------------------------------------------------------------------------------- Entrypoints for end-users+-- CAS and friendsa -------------------------------------------------------------------------------- -{-# INLINE casArray# #-} -- | Unsafe, machine-level atomic compare and swap on an element within an Array.   casArray# :: MutableArray# RealWorld a -> Int# -> Ticket a -> Ticket a            -> State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)+#ifdef CASTFUN+-- WARNING: cast of a function -- need to verify these are safe or eta expand. casArray# = unsafeCoerce# casArrayTypeErased#-+#endif  -- | When performing compare-and-swaps, the /ticket/ encapsulates proof -- that a thread observed a specific previous value of a mutable@@ -59,20 +73,39 @@  -------------------------------------------------------------------------------- --{-# INLINE readForCAS# #-} readForCAS# :: MutVar# RealWorld a ->                State# RealWorld -> (# State# RealWorld, Ticket a #)+-- WARNING: cast of a function -- need to verify these are safe or eta expand:+#ifdef CASTFUN readForCAS# = unsafeCoerce# readMutVar#--- readForCAS# = unsafeCoerce# readMutVar_TypeErased#+#else+readForCAS# mv rw =+  case readMutVar# mv rw of+    (# rw', a #) -> (# rw', unsafeCoerce# a #)+#endif -{-# INLINE casMutVarTicketed# #-}+ casMutVarTicketed# :: MutVar# RealWorld a -> Ticket a -> Ticket a ->                State# RealWorld -> (# State# RealWorld, Int#, Ticket a #)+-- WARNING: cast of a function -- need to verify these are safe or eta expand:+#ifdef CASTFUN casMutVarTicketed# = unsafeCoerce# casMutVar_TypeErased#--- casMutVarTicketed# = unsafeCoerce# casMutVar#+#endif  --------------------------------------------------------------------------------+-- Memory barriers+--------------------------------------------------------------------------------++foreign import prim "stg_store_load_barrier" stg_storeLoadBarrier#+  :: State# RealWorld -> (# State# RealWorld, Int# #)++foreign import prim "stg_load_load_barrier" stg_loadLoadBarrier#+  :: State# RealWorld -> (# State# RealWorld, Int# #)++foreign import prim "stg_write_barrier" stg_writeBarrier#+  :: State# RealWorld -> (# State# RealWorld, Int# #)++-------------------------------------------------------------------------------- -- Type-erased versions that call the raw foreign primops: -------------------------------------------------------------------------------- -- Due to limitations of the "foreign import prim" mechanism, we can't use the@@ -85,7 +118,7 @@ --   out_of_line = True --   has_side_effects = True --- | This alternate version of casMutVar returns a numeric "ticket" for+-- | This alternate version of casMutVar returns an opaque "ticket" for --   future CAS operations. foreign import prim "stg_casMutVar2zh" casMutVar_TypeErased#   :: MutVar# RealWorld () -> Any () -> Any () ->@@ -94,3 +127,4 @@ -- foreign import prim "stg_readMutVar2zh" readMutVar_TypeErased# --   :: MutVar# RealWorld () ->  --      State# RealWorld -> (# State# RealWorld, Any () #)+

@@ -1,2 +1,27 @@-import Distribution.Simple-main = defaultMain++import Control.Monad (when)+import Language.Haskell.TH+import Distribution.Simple                (defaultMainWithHooks, simpleUserHooks, UserHooks(postConf), Args)+import Distribution.Simple.Utils          (cabalVersion)+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup          (ConfigFlags)+import Distribution.Version               (Version(..))+import Distribution.PackageDescription    (PackageDescription)+import Debug.Trace++checkGoodVersion :: IO ()+checkGoodVersion =+  if   cabalVersion >= Version [1,17,0] []+  then putStrLn (" [Setup.hs] This version of Cabal is ok for profiling: "++show cabalVersion)+  else error (" [Setup.hs] This package should not be used in profiling mode with cabal version "+++                        show (versionBranch cabalVersion)++" < 1.17.0\n"+++                        " It will break, see cabal issue #1284")++main :: IO ()+main = do+  let myPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()+      myPostConf _args confFlags _descr lbi =+        when (withProfLib lbi)+          checkGoodVersion+      hooks = simpleUserHooks { postConf = myPostConf }+  defaultMainWithHooks hooks

@@ -1,5 +1,5 @@ Name:                atomic-primops-Version:             0.1.0.2+Version:             0.2.2 License:             BSD3 License-file:        LICENSE Author:              Ryan Newton@@ -7,7 +7,7 @@ Category:            Data Stability:           Provisional -- Portability:         non-portabile (x86_64)-Build-type:          Simple+Build-type:          Custom -- TODO: This requirement needs to be bumped to 1.17 when the latest cabal is -- released.  This package triggers issue #1284: Cabal-version:       >=1.8@@ -16,6 +16,8 @@ -- Version History: -- 0.1.0.0 -- initial release -- 0.1.0.2 -- disable profiling+-- 0.2 -- Critical bugfix and add Counter.+-- 0.2.2 -- Add more counters  Synopsis: A safe approach to CAS and other atomic ops in Haskell. @@ -34,14 +36,23 @@                      testing/runTest.hs, testing/Test.hs, testing/test-atomic-primops.cabal --                    Makefile, Test.hs, README.md +Flag debug+    Description: Enable extra internal checks.+    Default: False+ Library   exposed-modules:   Data.Atomics                      Data.Atomics.Internal+                     Data.Atomics.Counter+                     Data.Atomics.Counter.IORef+                     Data.Atomics.Counter.Reference+                     Data.Atomics.Counter.Foreign   ghc-options: -O2 -funbox-strict-fields    -- casMutVar# had a bug in GHC 7.2, thus we require GHC 7.4 or greater-  -- (base 4.5 or greater).-  build-depends:     base >= 4.5.0.0 && < 4.7, ghc-prim, primitive, Cabal+  -- (base 4.5 or greater). We also need the "Any" kind.+  build-depends:     base >= 4.5.0.0 && < 4.7, ghc-prim, primitive, Cabal,+                     bits-atomic    -- TODO: Try to push support back to 7.0:   -- Ah, but if we don't USE casMutVar# in this package we are ok:@@ -55,12 +66,14 @@   --   ghc-prof-options: ERROR_DO_NOT_BUILD_THIS_WITH_PROFILING_YET__SEE_CABAL_ISSUE_1284   -- } +  if flag(debug)+    cpp-options: -DDEBUG_ATOMICS+ -- -- [2013.04.08] This isn't working presently: -- -- I'm having problems with building it along with the library; see DEVLOG. -- -- Switching to a separate package in ./testing/  -- Test-Suite test-atomic-primops --     type:       exitcode-stdio-1.0-   Source-Repository head

@@ -89,3 +89,22 @@ } /* emitPrimOp [res] ReadMutVarOp [mutv] _ */ /*    = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) */+++// This is already existing functionality in the RTS (SMP.h).  It+// handles the complexity of architecture-portability.  We just need+// to expose it here.+stg_store_load_barrier {+    foreign "C" store_load_barrier();+    RET_N(0);+}++stg_load_load_barrier {+    foreign "C" load_load_barrier();+    RET_N(0);+}++stg_write_barrier {+    foreign "C" write_barrier();+    RET_N(0);+}

@@ -44,6 +44,9 @@  -- import Test.Framework.TH (defaultMainGenerator) +import CommonTesting +import CounterTests (counterTests)+ ------------------------------------------------------------------------  expect_false_positive_on_GC :: Bool@@ -64,6 +67,7 @@          , testCase "create_and_mutate"       case_create_and_mutate          , testCase "create_and_mutate_twice" case_create_and_mutate_twice          , testCase "n_threads_mutate"        case_n_threads_mutate+         , testCase "run_barriers"            case_run_barriers           , testCase "test_succeed_once Int"   (test_succeed_once (0::Int))          , testCase "test_succeed_once Int64" (test_succeed_once (0::Int64))@@ -88,6 +92,7 @@                       [1, numCapabilities `quot` 2, numCapabilities, 2*numCapabilities]          , size    <- [1, 10, 100]          , iters   <- [10000]]+         ++ counterTests           setify :: [Int] -> [Int] setify = S.toList . S.fromList@@ -259,6 +264,13 @@   ans <- readIORef counter   assertBool "Did the sum end up equal to 120?" (ans == 120) +-- | Just make sure these link and run properly:+case_run_barriers :: Assertion+case_run_barriers = do+  A.storeLoadBarrier+  A.loadLoadBarrier+  A.writeBarrier+ ----------------------------------------------------------------------------------------------------  ----------------------------------------------------------------------------------------------------@@ -364,63 +376,6 @@   ------------------------------------------------------------------------------------------------------- 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)------------------------------------------------------------------------------------------------------- {-  -- UNFINISHED@@ -519,44 +474,3 @@  -- main = test 3 -}----------------------------------------------------------------------------------------------------------- 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   ->-         trace (" ! Responding to env Var: DEBUG="++s)$-         case reads s of-           ((n,_):_) -> n-           [] -> error$"Attempt to parse DEBUG env var as Int failed: "++show s--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)

@@ -8,6 +8,8 @@ --  p <- getNumProcessors   putStrLn "[TestHarness] Calling compiled test-atomic-primops executable..."   ExitSuccess <- system "./dist/build/test-atomic-primops/test-atomic-primops +RTS -N1"-  ExitSuccess <- system$"./dist/build/test-atomic-primops/test-atomic-primops +RTS -N"+  -- TEMP: Fixing this at four processors because it takes a REALLY long time at larger numbers:+  ExitSuccess <- system$"./dist/build/test-atomic-primops/test-atomic-primops +RTS -N4"+  -- It does 248 test cases and takes 55s at -N16... --  ExitSuccess <- system$"./dist/build/test-atomic-primops/test-atomic-primops +RTS -N"++show p   return ()