diff --git a/Data/Atomics.hs b/Data/Atomics.hs --- a/Data/Atomics.hs +++ b/Data/Atomics.hs @@ -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', () #) diff --git a/Data/Atomics/Counter.hs b/Data/Atomics/Counter.hs new file mode 100644 --- /dev/null +++ b/Data/Atomics/Counter.hs @@ -0,0 +1,8 @@ + + +module Data.Atomics.Counter + ( + module Data.Atomics.Counter.IORef + ) where + +import Data.Atomics.Counter.IORef diff --git a/Data/Atomics/Counter/Foreign.hs b/Data/Atomics/Counter/Foreign.hs new file mode 100644 --- /dev/null +++ b/Data/Atomics/Counter/Foreign.hs @@ -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) diff --git a/Data/Atomics/Counter/IORef.hs b/Data/Atomics/Counter/IORef.hs new file mode 100644 --- /dev/null +++ b/Data/Atomics/Counter/IORef.hs @@ -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 diff --git a/Data/Atomics/Counter/Reference.hs b/Data/Atomics/Counter/Reference.hs new file mode 100644 --- /dev/null +++ b/Data/Atomics/Counter/Reference.hs @@ -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 + +-} diff --git a/Data/Atomics/Internal.hs b/Data/Atomics/Internal.hs --- a/Data/Atomics/Internal.hs +++ b/Data/Atomics/Internal.hs @@ -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 () #) + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/atomic-primops.cabal b/atomic-primops.cabal --- a/atomic-primops.cabal +++ b/atomic-primops.cabal @@ -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 diff --git a/cbits/primops.cmm b/cbits/primops.cmm --- a/cbits/primops.cmm +++ b/cbits/primops.cmm @@ -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); +} diff --git a/testing/Test.hs b/testing/Test.hs --- a/testing/Test.hs +++ b/testing/Test.hs @@ -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) diff --git a/testing/runTest.hs b/testing/runTest.hs --- a/testing/runTest.hs +++ b/testing/runTest.hs @@ -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 ()