diff --git a/RegressionTests/Issue5.hs b/RegressionTests/Issue5.hs new file mode 100644 --- /dev/null +++ b/RegressionTests/Issue5.hs @@ -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 + diff --git a/RegressionTests/Issue5B.hs b/RegressionTests/Issue5B.hs new file mode 100644 --- /dev/null +++ b/RegressionTests/Issue5B.hs @@ -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 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.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: