chaselev-deque-0.5.0.3: RegressionTests/Issue5B.hs

{-# 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