chaselev-deque 0.1.3 → 0.4
raw patch · 4 files changed
+635/−46 lines, 4 filesdep ~abstract-dequedep ~atomic-primops
Dependency ranges changed: abstract-deque, atomic-primops
Files
- Data/Concurrent/Deque/ChaseLev.hs +32/−19
- Data/Concurrent/Deque/ChaseLevUnboxed.hs +334/−0
- Test.hs +252/−21
- chaselev-deque.cabal +17/−6
Data/Concurrent/Deque/ChaseLev.hs view
@@ -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)
+ Data/Concurrent/Deque/ChaseLevUnboxed.hs view
@@ -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 "<uninit>"+ | 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)
Test.hs view
@@ -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)++-}
chaselev-deque.cabal view
@@ -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