chaselev-deque 0.5.0.2 → 0.5.0.3
raw patch · 3 files changed
+412/−7 lines, 3 filesdep +abstract-deque-testsdep ~abstract-dequePVP ok
version bump matches the API change (PVP)
Dependencies added: abstract-deque-tests
Dependency ranges changed: abstract-deque
API changes (from Hackage documentation)
Files
- RegressionTests/Issue5.hs +59/−0
- RegressionTests/Issue5B.hs +342/−0
- chaselev-deque.cabal +11/−7
+ RegressionTests/Issue5.hs view
@@ -0,0 +1,59 @@+module RegressionTests.Issue5 (standalone_pushPop) where++import Control.Concurrent+import Data.IORef+import Data.Concurrent.Deque.Class +import qualified Data.Concurrent.Deque.ChaseLev as CL++--------------------------------------------------------------------------------++standalone_pushPop :: IO ()+standalone_pushPop =+ triv =<< (newQ :: IO (DebugDeque CL.ChaseLevDeque a)) + where + -- This is what's failing with the debug wrapper, WHY?+ triv :: PopL d => d [Char] -> IO ()+ triv q = do+ pushL q "hi" + x <- tryPopL q+ case x of+ Just "hi" -> putStrLn "Got expected value. Test passed.\n"+ Just x' -> error$ "A single push/pop got the WRONG value back: "++show x'+ Nothing -> error "Even a single push/pop in isolation did not work!"+++-- | Warning, this enforces the excessively STRONG invariant that if any end of the+-- deque is non-threadsafe then it may ever only be touched by one thread during its+-- entire lifetime.+--+-- This extreme form of monagamy is easier to verify, because we don't have enough+-- information to know if two operations on different threads are racing with one+-- another or are properly synchronized.+--+-- The wrapper data structure has two IORefs to track the last thread that touched+-- the left and right end of the deque, respectively.+data DebugDeque d elt = DebugDeque (IORef (Maybe ThreadId), IORef (Maybe ThreadId)) (d elt) +++instance DequeClass d => DequeClass (DebugDeque d) where + pushL (DebugDeque (ref,_) q) elt = do+ pushL q elt++ tryPopR (DebugDeque (_,ref) q) = do+ tryPopR q ++ newQ = do l <- newIORef Nothing+ r <- newIORef Nothing+ fmap (DebugDeque (l,r)) newQ++ -- FIXME: What are the threadsafe rules for nullQ?+ nullQ (DebugDeque _ q) = nullQ q+ + leftThreadSafe (DebugDeque _ q) = leftThreadSafe q+ rightThreadSafe (DebugDeque _ q) = rightThreadSafe q+++instance PopL d => PopL (DebugDeque d) where + tryPopL (DebugDeque (ref,_) q) = do+ tryPopL q +
+ RegressionTests/Issue5B.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE FlexibleInstances, NamedFieldPuns, CPP #-}++module RegressionTests.Issue5B (standalone_pushPop) where++import Control.Concurrent+import Data.IORef+import qualified Data.Concurrent.Deque.Class as PC++-- We DO observe the error with SEPLIB on, and NOT with it off.+-- That means for the time being I cannot reproduce this bug in a standalone file...+#define SEPLIB+#ifdef SEPLIB+import Data.Concurrent.Deque.ChaseLev (ChaseLevDeque, dbgInspectCLD)+#endif++import Data.Atomics++-- import Data.CAS (casIORef)+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector as V+-- import Text.Printf (printf)+import Control.Exception(catch, SomeException, throw, evaluate)+import Control.Monad (when, unless, forM_)+-- import Control.Monad.ST++import Data.Atomics (readArrayElem, readForCAS, casIORef, Ticket, peekTicket)+import System.Mem.StableName (makeStableName, hashStableName)+import GHC.IO (unsafePerformIO)+import Text.Printf (printf)++--------------------------------------------------------------------------------++standalone_pushPop :: IO ()+standalone_pushPop =+ triv =<< (PC.newQ :: IO (DebugDeque ChaseLevDeque a)) + where + -- This is what's failing with the debug wrapper, WHY?+ -- triv :: PC.PopL d => d [Char] -> IO ()+ triv :: DebugDeque ChaseLevDeque [Char] -> IO ()+ triv q = do+ -- r <- newIORef+ -- writeIORef r "hi"+ -- (bl,tick) <- readForCAS r + -- casIORef r tick "there"+ -- case bl of+ -- True -> putStrLn "CAS succeeded. Test passed.\n"+ let val = "hi"+ PC.pushL q val+ printf "Done pushing single value... queue %x, val %x\n" (unsafeName q) (unsafeName val)+ x <- PC.tryPopL q+ y <- PC.tryPopL q+ z <- PC.tryPopL q++ s <- dbgInspectCLD (unwrapDebug q)+ printf "Queue after 3 pops:\n%s\n" s + case x of+ Just "hi" -> putStrLn "Got expected value. Test passed.\n"+ Just x' -> error$ "A single push/pop got the WRONG value back: "++show x'+ Nothing -> error$"Even a single push/pop in isolation did not work!: "++show (x,y,z)++data DebugDeque d elt =+ DebugDeque {+ tidMarks :: (IORef (Maybe ThreadId), IORef (Maybe ThreadId)),+ unwrapDebug :: (d elt)+ }++instance PC.DequeClass d => PC.DequeClass (DebugDeque d) where + pushL (DebugDeque (ref,_) q) elt = do+ PC.pushL q elt++ tryPopR (DebugDeque (_,ref) q) = do+ PC.tryPopR q ++ newQ = do l <- newIORef Nothing+ r <- newIORef Nothing+ fmap (DebugDeque (l,r)) PC.newQ++ -- FIXME: What are the threadsafe rules for nullQ?+ nullQ (DebugDeque _ q) = PC.nullQ q+ + leftThreadSafe (DebugDeque _ q) = PC.leftThreadSafe q+ rightThreadSafe (DebugDeque _ q) = PC.rightThreadSafe q+++instance PC.PopL d => PC.PopL (DebugDeque d) where + tryPopL (DebugDeque (ref,_) q) = do+ PC.tryPopL q ++--------------------------------------------------------------------------------++{-# NOINLINE unsafeName #-}+unsafeName :: a -> Int+unsafeName x = unsafePerformIO $ do + sn <- makeStableName x+ return (hashStableName sn)++#ifndef SEPLIB+--------------------------------------------------------------------------------+-- 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 #-} !(IORef Int)+ , bottom :: {-# UNPACK #-} !(IORef Int)+ -- This is a circular array:+ , activeArr :: {-# UNPACK #-} !(IORef (MV.IOVector a))+ }++--------------------------------------------------------------------------------+-- Debugging mode.+#define DEBUG+-- define FAKECAS++{-# INLINE rd #-}+{-# INLINE wr #-}+{-# INLINE nu #-}+{-# INLINE cpy #-}+{-# INLINE slc #-}+#ifndef DEBUG+dbg = False+nu = MV.unsafeNew+rd = MV.unsafeRead+wr = MV.unsafeWrite+slc = MV.unsafeSlice+cpy = MV.unsafeCopy+#else+dbg = True+nu = MV.new +rd = MV.read+slc = MV.slice+cpy = MV.copy+wr = MV.write+-- 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 +#endif+++#ifdef DEBUG+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 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:+ forM_ [strt..end - 1] $ \ind -> do + x <- getCirc oldarr ind + evaluate x+ putCirc newarr ind x+ return newarr+{-# INLINE growCirc #-}++getCirc arr ind = rd arr (ind `mod` MV.length arr)+putCirc arr ind x = wr arr (ind `mod` MV.length arr) x+{-# INLINE getCirc #-}+{-# INLINE putCirc #-}++copyOffset :: 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++-- logInitialSize+newQ :: IO (ChaseLevDeque elt)+newQ = do+ -- We start as size 32 and double from there:+ v <- MV.new 32 + r1 <- newIORef 0+ r2 <- newIORef 0+ r3 <- newIORef v+ return$ CLD r1 r2 r3++nullQ :: ChaseLevDeque elt -> IO Bool+nullQ CLD{top,bottom} = do+ b <- readIORef bottom+ t <- readIORef top +-- return (b == t)+ let size = b - t + return (size <= 0)++-- | For a work-stealing queue `pushL` is the ``local'' push. Thus+-- only a single thread should perform this operation.+pushL :: ChaseLevDeque a -> a -> IO ()+pushL CLD{top,bottom,activeArr} obj = tryit "pushL" $ do+ b <- readIORef bottom+ t <- readIORef 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+ writeIORef bottom (b+1)+ return ()++-- | This is the steal operation. Multiple threads may concurrently+-- attempt steals from the same thread.+tryPopR :: ChaseLevDeque elt -> IO (Maybe elt)+tryPopR CLD{top,bottom,activeArr} = tryit "tryPopR" $ do+-- t <- readIORef top+ tt <- readForCAS top+ b <- readIORef bottom+ arr <- readIORef activeArr+ -- when (dbg && b < t) $ error$ "tryPopR: INVARIANT BREAKAGE - bottom < top: "++ show (b,t)++ let t = peekTicket tt+ size = b - t+ if size <= 0 then + return Nothing+ else do + obj <- getCirc arr t+ (b,_) <- doCAS top tt (t+1)+ if b then + return (Just obj)+ else + return Nothing -- Someone beat us, abort++tryPopL :: ChaseLevDeque elt -> IO (Maybe elt)+tryPopL CLD{top,bottom,activeArr} = tryit "tryPopL" $ do+ b <- readIORef bottom+ arr <- readIORef activeArr+ b <- return (b - 1) -- shadowing+ writeIORef bottom b+ tt <- readForCAS top +-- when (dbg && b < t) $ error$ "tryPopL: INVARIANT BREAKAGE - bottom < top: "++ show (b,t)++ let t = peekTicket tt+ size = b - t + if size < 0 then do+ writeIORef bottom t + return Nothing+ else do+ obj <- getCirc arr b+ if size > 0 then + return (Just obj)+ else do+ (b,_) <- doCAS top tt (t+1)+ writeIORef bottom (t+1)+ if b then return$ Just obj+ else return$ Nothing ++------------------------------------------------------------++{-# INLINE doCAS #-}+#ifdef FAKECAS+doCAS = fakeCAS+#else +doCAS = casIORef+#endif++{-# INLINE fakeCAS #-}+-- 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,a)+-- casIORef r !old !new = +fakeCAS r oldT new = do+ let old = peekTicket oldT+ 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))++#endif
chaselev-deque.cabal view
@@ -1,5 +1,5 @@ Name: chaselev-deque-Version: 0.5.0.2+Version: 0.5.0.3 License: BSD3 License-file: LICENSE Author: Ryan R. Newton, Edward Kmett @@ -15,8 +15,10 @@ -- 0.3 -- bump to go along with atomic-primops 0.3 -- 0.4 -- bump to go along with atomic-primops 0.4 -- 0.5.0.2 -- bump to go along with MAJOR bugfix in atomic-primops 0.5.0.2+-- 0.5.0.3 -- minor bump to change abstract-deque dep. Homepage: https://github.com/rrnewton/haskell-lockfree/wiki+Bug-Reports: https://github.com/rrnewton/haskell-lockfree/issues Synopsis: Chase & Lev work-stealing lock-free double-ended queues (deques). @@ -28,6 +30,8 @@ . "http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.170.1097&rep=rep1&type=pdf" +Extra-Source-Files: Test.hs RegressionTests/Issue5.hs RegressionTests/Issue5B.hs+ Flag debug Description: Enable the extra internal checks. Default: False@@ -41,9 +45,8 @@ other-modules: Data.Concurrent.Deque.ChaseLevUnboxed build-depends: base >= 4.4.0.0 && < 5, array, transformers, bits-atomic,- abstract-deque >= 0.2.2 && < 0.3, vector, ghc-prim,+ abstract-deque >= 0.3 && < 0.4, vector, ghc-prim, atomic-primops >= 0.5.0.2--- IORefCAS >= 0.2 build-depends: ghc-prim ghc-options: -O2 if flag(debug)@@ -51,17 +54,18 @@ Source-Repository head Type: git- Location: git://github.com/rrnewton/haskell-lockfree-queue.git+ Location: git://github.com/rrnewton/haskell-lockfree.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 && < 0.3, + build-depends: base >= 4.4.0.0 && < 5, + abstract-deque >= 0.3 && < 0.4, abstract-deque-tests >= 0.3, HUnit, test-framework, test-framework-hunit, atomic-primops >= 0.5.0.2, vector, ghc-prim, array--- IORefCAS >= 0.2 build-depends: containers- ghc-options: -O2 -threaded -rtsopts + ghc-options: -O2 -threaded + ghc-options: -rtsopts -with-rtsopts=-N4 -- ghc-options: -O2 -threaded -rtsopts -- -- Debugging generated code: