diff --git a/Data/Concurrent/Deque/ChaseLev.hs b/Data/Concurrent/Deque/ChaseLev.hs --- a/Data/Concurrent/Deque/ChaseLev.hs +++ b/Data/Concurrent/Deque/ChaseLev.hs @@ -13,6 +13,7 @@ -- The convention here is to directly provide the concrete -- operations as well as providing the class instances. ChaseLevDeque(), newQ, nullQ, pushL, tryPopL, tryPopR, + approxSize, dbgInspectCLD ) where @@ -29,10 +30,10 @@ import Text.Printf (printf) import Control.Exception (catch, SomeException, throw, evaluate,try) import Control.Monad (when, unless, forM_) ---import Data.Atomics (readArrayElem, readForCAS, casIORef, Ticket, peekTicket) --- import Data.Atomics.Counter.IORef + import Data.Atomics (storeLoadBarrier, writeBarrier, loadLoadBarrier) -import Data.Atomics.Counter.Reference +-- TODO: Use whichever counter is exported as the DEFAULT: +import Data.Atomics.Counter.Unboxed (AtomicCounter, newCounter, readCounter, writeCounter, casCounter, readCounterForCAS, peekCTicket) -- Debugging: @@ -148,7 +149,7 @@ -- TODO: make a "grow" that uses memcpy. growCirc :: Int -> Int -> MV.IOVector a -> IO (MV.IOVector a) -growCirc strt end oldarr = do +growCirc !strt !end !oldarr = do -- let len = MV.length oldarr -- strtmod = strt`mod` len -- endmod = end `mod` len @@ -183,20 +184,20 @@ x <- getCirc oldarr ind evaluate x putCirc newarr ind x - return newarr + return $! newarr {-# INLINE growCirc #-} getCirc :: MV.IOVector a -> Int -> IO a -getCirc arr ind = rd arr (ind `mod` MV.length arr) +getCirc !arr !ind = rd arr (ind `mod` MV.length arr) {-# INLINE getCirc #-} putCirc :: MV.IOVector a -> Int -> a -> IO () -putCirc arr ind x = wr arr (ind `mod` MV.length arr) x +putCirc !arr !ind x = wr arr (ind `mod` MV.length arr) x {-# INLINE putCirc #-} -- Use a potentially-optimized block-copy: copyOffset :: MV.IOVector t -> MV.IOVector t -> Int -> Int -> Int -> IO () -copyOffset from to iFrom iTo len = +copyOffset !from !to !iFrom !iTo !len = cpy (slc iTo len to) (slc iFrom len from) {-# INLINE copyOffset #-} @@ -210,19 +211,29 @@ newQ = do -- Arbitrary Knob: We start as size 32 and double from there: v <- MV.new 32 - r1 <- newCounter - r2 <- newCounter + r1 <- newCounter 0 + r2 <- newCounter 0 r3 <- newIORef v - return$ CLD r1 r2 r3 + return $! CLD r1 r2 r3 +{-# INLINE newQ #-} nullQ :: ChaseLevDeque elt -> IO Bool nullQ CLD{top,bottom} = do + -- This should get a LOWER bound on size at some point in logic time, right? b <- readCounter bottom t <- readCounter top --- return (b == t) let size = b - t - return (size <= 0) + return $! size <= 0 +{-# INLINE approxSize #-} +-- | Return a lower bound on the size at some point in the recent past. +approxSize :: ChaseLevDeque elt -> IO Int +approxSize CLD{top,bottom} = do + b <- readCounter bottom + t <- readCounter top + return $! b - t + +{-# INLINE pushL #-} -- | For a work-stealing queue `pushL` is the ``local'' push. Thus -- only a single thread should perform this operation. pushL :: ChaseLevDeque a -> a -> IO () @@ -255,6 +266,7 @@ writeCounter bottom (b+1) return () +-- {-# INLINE tryPopR #-} -- | This is the steal operation. Multiple threads may concurrently -- attempt steals from the same thread. tryPopR :: ChaseLevDeque elt -> IO (Maybe elt) @@ -275,10 +287,11 @@ obj <- getCirc arr t (b,_) <- casCounter top tt (t+1) if b then - return (Just obj) + return $! Just obj else return Nothing -- Someone beat us, abort +{-# INLINE tryPopL #-} tryPopL :: ChaseLevDeque elt -> IO (Maybe elt) tryPopL CLD{top,bottom,activeArr} = tryit "tryPopL" $ do b <- readCounter bottom @@ -301,12 +314,12 @@ else do obj <- getCirc arr b if size > 0 then do - return (Just obj) + return $! Just obj else do (b,ol) <- casCounter top tt (t+1) writeCounter bottom (t+1) - if b then return$ Just obj - else return$ Nothing + if b then return $! Just obj + else return $ Nothing ------------------------------------------------------------ @@ -314,8 +327,8 @@ -- 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 +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/Data/Concurrent/Deque/ChaseLevUnboxed.hs b/Data/Concurrent/Deque/ChaseLevUnboxed.hs new file mode 100644 --- /dev/null +++ b/Data/Concurrent/Deque/ChaseLevUnboxed.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE FlexibleInstances, NamedFieldPuns, CPP, ScopedTypeVariables, BangPatterns, MagicHash #-} + +-- | Chase-Lev work stealing Deques +-- +-- This implementation derives directly from the pseudocode in the 2005 SPAA paper: +-- +-- http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.170.1097&rep=rep1&type=pdf +-- +-- TODO: local topBound optimization. +-- TODO: Do the more optimized version of growCirc +module Data.Concurrent.Deque.ChaseLevUnboxed + ( + -- The convention here is to directly provide the concrete + -- operations as well as providing the class instances. + ChaseLevDeque(), newQ, nullQ, pushL, tryPopL, tryPopR, + approxSize, + dbgInspectCLD + ) + where + +import Data.IORef +import Data.List (isInfixOf, intersperse) +import qualified Data.Concurrent.Deque.Class as PC + +-- import Data.CAS (casIORef) +import qualified Data.Vector.Unboxed.Mutable as MV +import qualified Data.Vector.Unboxed as V +-- import Data.Vector.Unboxed.Mutable as V +-- import Data.Vector +import Text.Printf (printf) +import Control.Exception (catch, SomeException, throw, evaluate,try) +import Control.Monad (when, unless, forM_) + +import Data.Atomics (storeLoadBarrier, writeBarrier, loadLoadBarrier) +-- TODO: Use whichever counter is exported as the DEFAULT: +import Data.Atomics.Counter.Unboxed + (AtomicCounter, newCounter, readCounter, writeCounter, casCounter, readCounterForCAS, peekCTicket) + +-- Debugging: +import System.IO.Unsafe (unsafePerformIO) +import Text.Printf (printf) +import System.Mem.StableName (makeStableName, hashStableName) +import GHC.Exts (Int(I#)) +import GHC.Prim (reallyUnsafePtrEquality#, unsafeCoerce#) + +-------------------------------------------------------------------------------- +-- Instances + +{- +instance PC.DequeClass ChaseLevDeque where + newQ = newQ + nullQ = nullQ + pushL = pushL + tryPopR = tryPopR + -- | Popping the left end is the "local" side: + leftThreadSafe _ = False + rightThreadSafe _ = True + +instance PC.PopL ChaseLevDeque where + tryPopL = tryPopL +-} + +-------------------------------------------------------------------------------- +-- Type definition + +data ChaseLevDeque a = CLD { + top :: {-# UNPACK #-} !AtomicCounter + , bottom :: {-# UNPACK #-} !AtomicCounter + -- This is a circular array: + , activeArr :: {-# UNPACK #-} !(IORef (MV.IOVector a)) + } + +dbgInspectCLD :: (V.Unbox a, Show a) => ChaseLevDeque a -> IO String +dbgInspectCLD CLD{top,bottom,activeArr} = do + tp <- readCounter top + bt <- readCounter bottom + vc <- readIORef activeArr + elems <- fmap V.toList$ V.freeze vc + elems' <- mapM safePrint elems + let sz = MV.length vc + return$ " {DbgInspectCLD: top "++show tp++", bot "++show bt++", size "++show sz++"\n" ++ + -- show elems ++ "\n"++ + " [ "++(concat $ intersperse " " elems')++" ]\n"++ + " end_DbgInspectCLD}" + where + -- Print any thunk, even if it raises an exception. + safePrint :: Show a => a -> IO String + safePrint val = do + res <- try (evaluate val) + case res of + Left (e::SomeException) + | isInfixOf "uninitialised element" (show e) -> return "" + | otherwise -> return$ "<"++ show e ++">" + Right val' -> return (show val') + + + +-------------------------------------------------------------------------------- +-- Debugging mode. +-- define DEBUGCL +--define FAKECAS + +{-# INLINE rd #-} +{-# INLINE wr #-} +{-# INLINE nu #-} +{-# INLINE cpy #-} +{-# INLINE slc #-} +#ifndef DEBUGCL +dbg = False +nu a = MV.unsafeNew a +rd a b = MV.unsafeRead a b +wr a b c = MV.unsafeWrite a b c +slc a b c = MV.unsafeSlice a b c +cpy a b = MV.unsafeCopy a b +#else +#warning "Activating DEBUGCL!" +dbg = True +nu a = MV.new a +rd a b = MV.read a b +wr a b c = MV.write a b c +slc a b c = MV.slice a b c +cpy a b = MV.copy a b +-- Temp, debugging: Our own bounds checking, better error: +-- wr v i x = +-- if i >= MV.length v +-- then error (printf "ERROR: Out of bounds of top of vector index %d, vec length %d\n" i (MV.length v)) +-- else MV.write v i x + +-- [2013.06.25] Note Issue5 is not affected by this: +{-# NOINLINE pushL #-} +{-# NOINLINE tryPopL #-} +{-# NOINLINE tryPopR #-} +#endif + + +#ifdef DEBUGCL +-- This simply localizes exceptions better: +tryit msg action = Control.Exception.catch action + (\e -> do putStrLn$ "ERROR inside "++msg++" "++ show e + throw (e::SomeException)) +#else +{-# INLINE tryit #-} +tryit msg action = action +#endif + + +-------------------------------------------------------------------------------- +-- Circular array routines: + +-- TODO: make a "grow" that uses memcpy. +growCirc :: V.Unbox a => Int -> Int -> MV.IOVector a -> IO (MV.IOVector a) +growCirc !strt !end !oldarr = do + -- let len = MV.length oldarr + -- strtmod = strt`mod` len + -- endmod = end `mod` len + -- newarr <- nu (len + len) + -- if endmod < strtmod then do + -- let elems1 = len - strtmod + -- elems2 = endmod + -- BS.putStrLn$ BS.pack$ printf "Copying segmented ... %d and %d" elems1 elems2 + + -- -- Copy the upper then lower segments: + -- copyOffset oldarr newarr strtmod 0 elems1 + -- copyOffset oldarr newarr 0 elems1 elems2 + -- else do + -- BS.putStrLn$ BS.pack$ printf "Copying one seg into vec of size %d... size %d, strt %d, end %d, strtmod %d endmod %d" (MV.length newarr) (end - strt) strt end strtmod endmod + -- -- Copy a single segment: + -- copyOffset oldarr newarr strtmod 0 (end - strt) + -- return newarr + ---------------------------------------- + -- Easier version first: + ---------------------------------------- + let len = MV.length oldarr + elems = end - strt + -- putStrLn$ "Grow to size "++show (len+len)++", copying over "++show elems + newarr <- if dbg then + nu (len + len) + else -- Better errors: + V.thaw $ V.generate (len+len) (\i -> error (" uninitialized element at position " ++ show i + ++" had only initialized "++show elems++" elems: " + ++show(strt`mod`(len+len),end`mod`(len+len)))) + -- Strictly matches what's in the paper: + for_ strt end $ \ind -> do + x <- getCirc oldarr ind + evaluate x + putCirc newarr ind x + return $! newarr +{-# INLINE growCirc #-} + +getCirc :: V.Unbox a => MV.IOVector a -> Int -> IO a +getCirc !arr !ind = rd arr (ind `mod` MV.length arr) +{-# INLINE getCirc #-} + +putCirc :: V.Unbox a => MV.IOVector a -> Int -> a -> IO () +putCirc !arr !ind x = wr arr (ind `mod` MV.length arr) x +{-# INLINE putCirc #-} + +-- Use a potentially-optimized block-copy: +copyOffset :: V.Unbox t => MV.IOVector t -> MV.IOVector t -> Int -> Int -> Int -> IO () +copyOffset !from !to !iFrom !iTo !len = + cpy (slc iTo len to) + (slc iFrom len from) +{-# INLINE copyOffset #-} + + +-------------------------------------------------------------------------------- +-- Queue Operations +-------------------------------------------------------------------------------- + +newQ :: V.Unbox elt => IO (ChaseLevDeque elt) +newQ = do + -- Arbitrary Knob: We start as size 32 and double from there: + v <- MV.new 32 + r1 <- newCounter 0 + r2 <- newCounter 0 + r3 <- newIORef v + return $! CLD r1 r2 r3 + +{-# INLINE newQ #-} +nullQ :: ChaseLevDeque elt -> IO Bool +nullQ CLD{top,bottom} = do + -- This should get a LOWER bound on size at some point in logic time, right? + b <- readCounter bottom + t <- readCounter top + let size = b - t + return $! size <= 0 + +{-# INLINE approxSize #-} +-- | Return a lower bound on the size at some point in the recent past. +approxSize :: ChaseLevDeque elt -> IO Int +approxSize CLD{top,bottom} = do + b <- readCounter bottom + t <- readCounter top + return $! b - t + +{-# INLINE pushL #-} +-- | For a work-stealing queue `pushL` is the ``local'' push. Thus +-- only a single thread should perform this operation. +pushL :: V.Unbox a => ChaseLevDeque a -> a -> IO () +pushL CLD{top,bottom,activeArr} obj = tryit "pushL" $ do + b <- readCounter bottom + t <- readCounter top + arr <- readIORef activeArr + let len = MV.length arr + size = b - t + +-- when (dbg && size < 0) $ error$ "pushL: INVARIANT BREAKAGE - bottom, top: "++ show (b,t) + + arr' <- if (size >= len - 1) then do + arr' <- growCirc t b arr -- Double in size, don't change b/t. + -- Only a single thread will do this!: + writeIORef activeArr arr' + return arr' + else return arr + + putCirc arr' b obj + {- + KG: we need to put write barrier here since otherwise we might + end with elem not added to q->elements, but q->bottom already + modified (write reordering) and with stealWSDeque_ failing + later when invoked from another thread since it thinks elem is + there (in case there is just added element in the queue). This + issue concretely hit me on ARMv7 multi-core CPUs + -} + writeBarrier + writeCounter bottom (b+1) + return () + +-- {-# INLINE tryPopR #-} +-- | This is the steal operation. Multiple threads may concurrently +-- attempt steals from the same thread. +tryPopR :: V.Unbox elt => ChaseLevDeque elt -> IO (Maybe elt) +tryPopR CLD{top,bottom,activeArr} = tryit "tryPopR" $ do + -- NB. these loads must be ordered, otherwise there is a race + -- between steal and pop. + tt <- readCounterForCAS top + loadLoadBarrier + b <- readCounter bottom + arr <- readIORef activeArr + -- when (dbg && b < t) $ error$ "tryPopR: INVARIANT BREAKAGE - bottom < top: "++ show (b,t) + + let t = peekCTicket tt + size = b - t + if size <= 0 then + return Nothing + else do + obj <- getCirc arr t + (b,_) <- casCounter top tt (t+1) + if b then + return $! Just obj + else + return Nothing -- Someone beat us, abort + +{-# INLINE tryPopL #-} +tryPopL :: V.Unbox elt => ChaseLevDeque elt -> IO (Maybe elt) +tryPopL CLD{top,bottom,activeArr} = tryit "tryPopL" $ do + b <- readCounter bottom + arr <- readIORef activeArr + b <- evaluate (b-1) + writeCounter bottom b + + -- very important that the following read of q->top does not occur + -- before the earlier write to q->bottom. + storeLoadBarrier + + tt <- readCounterForCAS top +-- when (dbg && b < t) $ error$ "tryPopL: INVARIANT BREAKAGE - bottom < top: "++ show (b,t) + + let t = peekCTicket tt + size = b - t + if size < 0 then do + writeCounter bottom t + return Nothing + else do + obj <- getCirc arr b + if size > 0 then do + return $! Just obj + else do + (b,ol) <- casCounter top tt (t+1) + writeCounter bottom (t+1) + if b then return $! Just obj + else return $ Nothing + +------------------------------------------------------------ + +-- 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/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -7,38 +7,48 @@ import System.Environment (getEnvironment) import Test.HUnit as HU +import Data.Int +import Data.Array as A +import GHC.Conc (setNumCapabilities, yield) +import Control.Monad (void) import Data.Concurrent.Deque.Tests import Data.Concurrent.Deque.Class import Data.Concurrent.Deque.Debugger (DebugDeque) import qualified Data.Concurrent.Deque.ChaseLev as CL +import qualified Data.Concurrent.Deque.ChaseLevUnboxed as CU +import qualified Data.Atomics.Counter as C + import RegressionTests.Issue5 (standalone_pushPop) import qualified RegressionTests.Issue5B main :: IO () -main = stdTestHarness $ do - theEnv <- getEnvironment - let wrapper = case lookup "NOWRAPPER" theEnv of - Just _ -> False - Nothing -> True - let plain = case lookup "ONLYWRAPPER" theEnv of - Just _ -> False - Nothing -> True - let all_tests :: HU.Test - all_tests = TestList $ - [ TestLabel "simplest_pushPop" $ TestCase simplest_pushPop - , TestLabel "standalone_pushPop" $ TestCase standalone_pushPop - , TestLabel "standalone_pushPop2" $ TestCase RegressionTests.Issue5B.standalone_pushPop ] - -- This is very ugly and should be unnecessary: - ++ if plain then - [ TestLabel "ChaseLev" $ tests_wsqueue (newQ :: IO (CL.ChaseLevDeque a)) ] - else [] - ++ if wrapper then - [ TestLabel "ChaseLev(DbgWrapper)" $ tests_wsqueue (newQ :: IO (DebugDeque CL.ChaseLevDeque a)) ] - else [] +main =do +-- setNumCapabilities 4 + stdTestHarness $ do +-- setNumCapabilities 4 + theEnv <- getEnvironment + + let newReg = (newQ :: IO (CL.ChaseLevDeque a)) + newDeb = (newQ :: IO (DebugDeque CL.ChaseLevDeque a)) - return all_tests + all_tests :: HU.Test + all_tests = TestList $ + [ appendLabel "simplest_pushPop" $ TestCase simplest_pushPop + , appendLabel "standalone_pushPop" $ TestCase $ timeit standalone_pushPop + , appendLabel "standalone_pushPop2" $ TestCase $ timeit RegressionTests.Issue5B.standalone_pushPop +-- , appendLabel "ChaseLev_DbgWrapper" $ tests_wsqueue newDeb + , appendLabel "ChaseLev" $ tests_wsqueue newReg + -- Even with inlining this isn't working: + -- , TestLabel "parfib_generic" $ TestCase $ timeit$ + -- print =<< test_parfib_work_stealing fibSize newReg + , TestLabel "parfib_specialized_boxed" $ TestCase $ timeit$ + print =<< test_parfib_work_stealing_specialized fibSize + , TestLabel "parfib_specialized_unboxed" $ TestCase $ timeit$ + print =<< test_parfib_work_stealing_specialized_unboxed fibSize + ] + return all_tests -------------------------------------------------------------------------------- -- Individual unit and regression tests: @@ -60,3 +70,224 @@ Nothing -> error "Even a single push/pop in isolation did not work!" assertEqual "test_ws_triv1" y "hi" + +test_parfib_work_stealing_specialized :: Elt -> IO Elt +test_parfib_work_stealing_specialized origInput = do + putStrLn$ " [parfib] Computing fib("++show origInput++")" + numAgents <- getNumAgents + qs <- sequence (replicate numAgents CL.newQ) + let arr = A.listArray (0,numAgents - 1) qs + + let parfib !myId !myQ !mySum !num + | num <= 2 = + do x <- CL.tryPopL myQ + case x of + Nothing -> trySteal myId myQ (mySum+1) + Just n -> parfib myId myQ (mySum+1) n + | otherwise = do + CL.pushL myQ (num-1) + parfib myId myQ mySum (num-2) + + trySteal !myId !myQ !mySum = + let loop ind + -- After we finish one sweep... we're completely done. + | ind == myId = return mySum + | ind == size arr = loop 0 + | otherwise = do + x <- CL.tryPopR (arr ! ind) + case x of + Just n -> parfib myId myQ mySum n + Nothing -> do -- yield + -- threaDelay 1000 + loop (ind+1) + in loop (myId+1) + + size a = let (st,en) = A.bounds a in en - st + 1 + + partial_sums <- forkJoin numAgents $ \ myId -> + if myId == 0 + then parfib myId (arr ! myId) 0 origInput + else trySteal myId (arr ! myId) 0 + + return (sum partial_sums) + +-- DUPLICATED CODE: +test_parfib_work_stealing_specialized_unboxed :: Elt -> IO Elt +test_parfib_work_stealing_specialized_unboxed origInput = do + putStrLn$ " [parfib] Computing fib("++show origInput++")" + numAgents <- getNumAgents + qs <- sequence (replicate numAgents CU.newQ) + let arr = A.listArray (0,numAgents - 1) qs + + let parfib !myId !myQ !mySum !num + | num <= 2 = + do x <- CU.tryPopL myQ + case x of + Nothing -> trySteal myId myQ (mySum+1) + Just n -> parfib myId myQ (mySum+1) n + | otherwise = do + CU.pushL myQ (num-1) + parfib myId myQ mySum (num-2) + + trySteal !myId !myQ !mySum = + let loop ind + -- After we finish one sweep... we're completely done. + | ind == myId = return mySum + | ind == size arr = loop 0 + | otherwise = do + x <- CU.tryPopR (arr ! ind) + case x of + Just n -> parfib myId myQ mySum n + Nothing -> do -- yield + -- threaDelay 1000 + loop (ind+1) + in loop (myId+1) + + size a = let (st,en) = A.bounds a in en - st + 1 + + partial_sums <- forkJoin numAgents $ \ myId -> + if myId == 0 + then parfib myId (arr ! myId) 0 origInput + else trySteal myId (arr ! myId) 0 + + return (sum partial_sums) + + + +{- +NOTES ON PARFIB PERFORMANCE +=========================== + +Here are some old notes for a point of comparison: + +[2011.03] On 4-core nehalem, 3.33ghz: +------------------------------------- + + Non-monadic version, real/user time: + fib(40) 4 threads: 1.1s 4.4s + fib(42) 1 threads: 9.7s + fib(42) 4 threads: 2.86s 11.6s 17GB allocated -- 3.39X + + SPARKS: 433784785 (290 converted, 280395620 pruned) + + Monad-par version: + fib(38) non-threaded: 23.3s 23.1s + fib(38) 1 thread : 24.7s 24.5s + fib(38) 4 threads: 8.2s 31.3s + + fib(40) 4 threads: 20.6s 78.6s 240GB allocated + + +For comparison, Cilkarts Cilk++: + fib(42) 4 threads: 3.029s 23.610s + +Intel Cilk Plus: + fib(42) 4 threads: 4.212s 16.770s + + 1 thread: 17.53 -- e.g. 4.16X speedup + + +[2013.07.18] {Running with the ChaseLev-in-Haskell deques} +---------------------------------------------------------- + +Running initial timing tests with the new parfib test and a version of ChaseLev that +uses "Foreign" atomic counters. +On a 3.1 Ghz 4-core westmere desktop, running with +RTS -qa: + + fib(41) 1 thread : 10.9s (99.7% productivity, 7.9GB alloc, 5mb copied) + fib(41) 4 threads: 3.88s (72% productivity, 7.9 GB alloc, 5mb copied) + + fib(42) 1 threads: 17.6s (99.6% prod) + fib(42) 4 threads: 6.19s (70.5% productivity, 12.8G alloc) + + fib(43) 1 threads: 28.7s (99.6% prod) + fib(43) 4 threads: 10.2s (63% productivity, 20.8 GB alloc) + +Experimenting with a few optimizations... +Hmm, when I was running parfib_specialized on 4 threads I noticed it using 300% cpu if I used -qa. +Oops, since this isn't using forkOn it should NOT be using -qa. + +Aha! With the specialized version we can get it down to this: + + fib(42) 1 threads: 13.6 + fib(42) 4 threads: 5.46 (69% prod, 8.5G alloc) + +WEIRD! Switching back to Counter.Reference actually gets a SPEEDUP at this point, +bringing the above down to as low as 4.48s, in spite of a whopping 23GB allocation +and 50% productivity. While Counter.Foreign dominates in the highest contention +scenarious, the FFI tax must be hurting in this lower-contention example. +Perhaps if we exposed primops to perf atomic ops directly on byte arrays... + +Hmm... I think the variance is higher in this mode. Let's try Counter.IORef. +That one is actually SLOWER than atomicModifyIORef. How can that be? + +With a bit more optimization/INLINING I can get fib(42) down to 4.19s (Reference). +Still high variance and 19.2G allocation though... I get as low as 5.17s for Foreign +and 4.2G alloc. Actually, now IORef is doing almost as well as Reference, and it is +better under high contention. So making that the default for now. + +The Data.Seq based reference implementation in abstract-deque takes 6.6 seconds for +fib(42). + +[2013.07.19] {A few more updates} +------------------------------------ + +Ok, with the final "Data.Atomics.Counter.Unboxed" implementation, the fib(42) test +now takes as little as 3.12 seconds. That is competitive with Cilk and Haskell +sparks, however, its not a fair comparison, because we are literally pushing numbers +through the queue, not continuations/thunks. Although its not as far off as it might +be because currently our ChaseLev deque works with lifted/thunked values anyway, so +our "numbers" are not hugely dissimilar from continuations. + +(Ideally we could use closed type families to transparently optimize for the unboxed case.) + +If I COPY PASTE the ChaseLev implementation to produce an Unboxed version... it runs +a little quicker, 3.0 seconds. And, nicely, it eliminates almost all allocation, +from 4GB to a few MB. + +I still need to do the "local topBound" optimization. + +Testing on Hive +--------------- + +Unboxed version on a bigger, 32 core machine, lower clock speed (2.13ghz): + + fib(42) 1 threads: 21s + fib(42) 2 threads: 10.1s + fib(42) 4 threads: 5.2s (100%prod) + fib(42) 8 threads: 2.7s - 3.2s (100%prod) (whoa, some runs up to 7.87s! very random) + fib(42) 16 threads: 1.28s + fib(42) 24 threads: 1.85s + fib(42) 32 threads: 4.8s (high variance) + +As usual, without pinning, which cores get hit is kind of random (same socket, +different socket). I can confirm that just by watching htop. + +I wonder why scaling is falling off given that it's 100% productivity even at 32 +cores. The BOXED version actually isn't much worse though at 32 cores: + + (boxed) REALTIME 1.470864s 3.526944s 4.890355s + +The "Counter.Unboxed" implementation does help though... if we do +ChaselevUnboxed/Counter.Foreign, then we see vastly worse times: + + (hive/foreignCounter) fib(42) 32 threads: 14.4s + +And double the time on the 4-core as well: + + (travertine/foreignCounter) fib(42) 4 threads: 6.6s + +And needless to say the reference implementation (IORef Data.Seq) doesn't scale. +Let's call this the "legacy" implementation: + + (travertine/legacy) fib(42) 4 threads: 6.6s + + (hive) fib(42) 1 threads: 41.8s (95% prod) + (hive) fib(42) 2 threads: 25.2s (66% prod) + (hive) fib(42) 4 threads: 14.6s (27% prod, 135GB alloc) + (hive) fib(42) 8 threads: 17.1s (26% prod) + (hive) fib(42) 16 threads: 16.3s (13% prod) + (hive) fib(42) 24 threads: 21.2s (30% prod) + (hive) fib(42) 32 threads: 29.3s (33% prod) + +-} diff --git a/chaselev-deque.cabal b/chaselev-deque.cabal --- a/chaselev-deque.cabal +++ b/chaselev-deque.cabal @@ -1,5 +1,5 @@ Name: chaselev-deque -Version: 0.1.3 +Version: 0.4 License: BSD3 License-file: LICENSE Author: Ryan R. Newton, Edward Kmett @@ -10,13 +10,23 @@ -- Version history: -- 0.1.1 -- bump for fixing bugs! First release candidate. +-- 0.1.2 -- 0.1.3 -- small release to fix version deps before atomic-primops api change +-- 0.3 -- bump to go along with atomic-primops 0.3 +-- 0.4 -- bump to go along with atomic-primops 0.4 Homepage: https://github.com/rrnewton/haskell-lockfree-queue/wiki Synopsis: Chase & Lev work-stealing lock-free double-ended queues (deques). +Description: + A queue that is push/pop on one end and pop-only on the other. These are commonly + used for work-stealing. + This implementation derives directly from the pseudocode in the 2005 SPAA paper: + . + "http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.170.1097&rep=rep1&type=pdf" + Flag debug Description: Enable the extra internal checks. Default: False @@ -27,9 +37,11 @@ -- Data.Concurrent.Deque.ChaseLev2 -- Disabling this [2012.03.08]. It got terrible performance anyway: -- Data.Concurrent.Deque.ReactorDeque + other-modules: Data.Concurrent.Deque.ChaseLevUnboxed + build-depends: base >= 4.4.0.0 && < 5, array, transformers, bits-atomic, - abstract-deque >= 0.2.2, vector, ghc-prim, - atomic-primops >= 0.2 && < 0.3 + abstract-deque >= 0.2.2 && < 0.3, vector, ghc-prim, + atomic-primops >= 0.4 && < 0.5 -- IORefCAS >= 0.2 build-depends: ghc-prim ghc-options: -O2 @@ -40,13 +52,12 @@ Type: git Location: git://github.com/rrnewton/haskell-lockfree-queue.git - Test-Suite test-chaselev-deque type: exitcode-stdio-1.0 main-is: Test.hs - build-depends: base >= 4.4.0.0 && < 5, abstract-deque >= 0.2.2, + build-depends: base >= 4.4.0.0 && < 5, abstract-deque >= 0.2.2 && < 0.3, HUnit, test-framework, test-framework-hunit, - atomic-primops >= 0.2 && < 0.3, vector, ghc-prim + atomic-primops >= 0.4 && < 0.5, vector, ghc-prim, array -- IORefCAS >= 0.2 build-depends: containers ghc-options: -O2 -threaded -rtsopts