module Data.Concurrent.Deque.ChaseLev
(
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 qualified Data.Vector.Mutable as MV
import qualified Data.Vector as V
import Text.Printf (printf)
import Control.Exception (catch, SomeException, throw, evaluate,try)
import Control.Monad (when, unless, forM_)
import Data.Atomics (storeLoadBarrier, writeBarrier, loadLoadBarrier)
import Data.Atomics.Counter.Unboxed
(AtomicCounter, newCounter, readCounter, writeCounter, casCounter, readCounterForCAS, peekCTicket)
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#)
instance PC.DequeClass ChaseLevDeque where
newQ = newQ
nullQ = nullQ
pushL = pushL
tryPopR = tryPopR
leftThreadSafe _ = False
rightThreadSafe _ = True
instance PC.PopL ChaseLevDeque where
tryPopL = tryPopL
data ChaseLevDeque a = CLD {
top :: !AtomicCounter
, bottom :: !AtomicCounter
, activeArr :: !(IORef (MV.IOVector a))
}
dbgInspectCLD :: 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" ++
" [ "++(concat $ intersperse " " elems')++" ]\n"++
" end_DbgInspectCLD}"
where
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')
#ifndef DEBUGCL
dbg = False
nu = MV.unsafeNew
rd = MV.unsafeRead
wr = MV.unsafeWrite
slc = MV.unsafeSlice
cpy = MV.unsafeCopy
#else
#warning "Activating DEBUGCL!"
dbg = True
nu = MV.new
rd = MV.read
slc = MV.slice
cpy = MV.copy
wr = MV.write
#endif
#ifdef DEBUGCL
tryit msg action = Control.Exception.catch action
(\e -> do putStrLn$ "ERROR inside "++msg++" "++ show e
throw (e::SomeException))
#else
tryit msg action = action
#endif
growCirc :: Int -> Int -> MV.IOVector a -> IO (MV.IOVector a)
growCirc !strt !end !oldarr = do
let len = MV.length oldarr
elems = end strt
newarr <- if dbg then
nu (len + len)
else
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))))
for_ strt end $ \ind -> do
x <- getCirc oldarr ind
evaluate x
putCirc newarr ind x
return $! newarr
getCirc :: MV.IOVector a -> Int -> IO a
getCirc !arr !ind = rd arr (ind `mod` MV.length arr)
putCirc :: MV.IOVector a -> Int -> a -> IO ()
putCirc !arr !ind x = wr arr (ind `mod` MV.length arr) x
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)
newQ :: IO (ChaseLevDeque elt)
newQ = do
v <- MV.new 32
r1 <- newCounter 0
r2 <- newCounter 0
r3 <- newIORef v
return $! CLD r1 r2 r3
nullQ :: ChaseLevDeque elt -> IO Bool
nullQ CLD{top,bottom} = do
b <- readCounter bottom
t <- readCounter top
let size = b t
return $! size <= 0
approxSize :: ChaseLevDeque elt -> IO Int
approxSize CLD{top,bottom} = do
b <- readCounter bottom
t <- readCounter top
return $! b t
pushL :: 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
arr' <- if (size >= len 1) then do
arr' <- growCirc t b arr
writeIORef activeArr arr'
return arr'
else return arr
putCirc arr' b obj
writeBarrier
writeCounter bottom (b+1)
return ()
tryPopR :: ChaseLevDeque elt -> IO (Maybe elt)
tryPopR CLD{top,bottom,activeArr} = tryit "tryPopR" $ do
tt <- readCounterForCAS top
loadLoadBarrier
b <- readCounter bottom
arr <- readIORef activeArr
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
tryPopL :: ChaseLevDeque elt -> IO (Maybe elt)
tryPopL CLD{top,bottom,activeArr} = tryit "tryPopL" $ do
b <- readCounter bottom
arr <- readIORef activeArr
b <- evaluate (b1)
writeCounter bottom b
storeLoadBarrier
tt <- readCounterForCAS top
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
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)