module Data.Concurrent.SkipListMap (
SLMap(), newSLMap, find, PutResult(..), putIfAbsent, putIfAbsentToss, foldlWithKey, counts,
debugShow,
SLMapSlice(Slice), toSlice, splitSlice, sliceSize
)
where
import System.Random
import Control.Applicative ((<$>))
import Control.Monad
import Control.Monad.IO.Class
import Control.Exception (assert)
import Control.LVish.MonadToss
import Control.LVish (Par)
import Control.LVish.Unsafe ()
import Data.Maybe (fromMaybe)
import Data.IORef
import Data.Atomics
import qualified Data.Concurrent.LinkedMap as LM
import Prelude hiding (map)
import qualified Prelude as P
data SLMap_ k v t where
Bottom :: LM.LMap k v -> SLMap_ k v (LM.LMap k v)
Index :: LM.LMap k (t, v) -> SLMap_ k v t -> SLMap_ k v (LM.LMap k (t, v))
data SLMap k v = forall t. SLMap (SLMap_ k v t) (LM.LMap k v)
data SLMapSlice k v = Slice (SLMap k v)
!(Maybe k)
!(Maybe k)
instance Eq (SLMap k v) where
SLMap _ lm1 == SLMap _ lm2 = lm1 == lm2
newSLMap :: Int -> IO (SLMap k v)
newSLMap 0 = do
lm <- LM.newLMap
return $ SLMap (Bottom lm) lm
newSLMap n = do
SLMap slm lmBottom <- newSLMap (n1)
lm <- LM.newLMap
return $ SLMap (Index lm slm) lmBottom
find :: Ord k => SLMap k v -> k -> IO (Maybe v)
find (SLMap slm _) k = find_ slm Nothing k
find_ :: Ord k => SLMap_ k v t -> Maybe t -> k -> IO (Maybe v)
find_ (Bottom m) shortcut k = do
searchResult <- LM.find (fromMaybe m shortcut) k
case searchResult of
LM.Found v -> return $ Just v
LM.NotFound tok -> return Nothing
find_ (Index m slm) shortcut k = do
searchResult <- LM.find (fromMaybe m shortcut) k
case searchResult of
LM.Found (_, v) ->
return $ Just v
LM.NotFound tok -> case LM.value tok of
Just (m', _) -> find_ slm (Just m') k
Nothing -> find_ slm Nothing k
data PutResult v = Added v | Found v
putIfAbsent :: (Ord k, MonadIO m, MonadToss m) =>
SLMap k v
-> k
-> m v
-> m (PutResult v)
putIfAbsent (SLMap slm _) k vc =
putIfAbsent_ slm Nothing k vc toss $ \_ _ -> return ()
putIfAbsentToss :: (Ord k, MonadIO m) => SLMap k v
-> k
-> m v
-> m Bool
-> m (PutResult v)
putIfAbsentToss (SLMap slm _) k vc coin =
putIfAbsent_ slm Nothing k vc coin $ \_ _ -> return ()
putIfAbsent_ :: (Ord k, MonadIO m) =>
SLMap_ k v t
-> Maybe t
-> k
-> m v
-> m Bool
-> (t -> v -> m ())
-> m (PutResult v)
putIfAbsent_ (Bottom m) shortcut k vc coin install = retryLoop vc where
retryLoop vc = do
searchResult <- liftIO $ LM.find (fromMaybe m shortcut) k
case searchResult of
LM.Found v -> return $ Found v
LM.NotFound tok -> do
v <- vc
maybeMap <- liftIO $ LM.tryInsert tok v
case maybeMap of
Just m' -> do
install m' v
return $ Added v
Nothing -> retryLoop $ return v
putIfAbsent_ (Index m slm) shortcut k vc coin install = do
searchResult <- liftIO $ LM.find (fromMaybe m shortcut) k
case searchResult of
LM.Found (_, v) -> return $ Found v
LM.NotFound tok ->
let install' mBelow v = do
shouldAdd <- coin
when shouldAdd $ do
maybeHere <- liftIO $ LM.tryInsert tok (mBelow, v)
case maybeHere of
Just mHere -> install mHere v
Nothing -> return ()
in case LM.value tok of
Just (m', _) -> putIfAbsent_ slm (Just m') k vc coin install'
Nothing -> putIfAbsent_ slm Nothing k vc coin install'
foldlWithKey :: Monad m => (forall x . IO x -> m x) ->
(a -> k -> v -> m a) -> a -> SLMap k v -> m a
foldlWithKey liftIO f !a (SLMap _ !lm) = LM.foldlWithKey liftIO f a lm
map :: MonadIO m => (a -> a) -> SLMap k a -> m (SLMap k a)
map fn (SLMap (Bottom lm) lm2) = do
lm' <- LM.map fn lm
return$! SLMap (Bottom lm') lm'
map fn (SLMap (Index lm slm) lmbot) = do
SLMap slm2 bot2 <- map fn (SLMap slm lmbot)
lm2 <- LM.map (\(t,a) -> (t,fn a)) lm
error "FINISHME -- SkipListMap.map"
counts :: SLMap k v -> IO [Int]
counts (SLMap slm _) = counts_ slm
counts_ :: SLMap_ k v t -> IO [Int]
counts_ (Bottom m) = do
c <- LM.foldlWithKey id (\n _ _ -> return (n+1)) 0 m
return [c]
counts_ (Index m slm) = do
c <- LM.foldlWithKey id (\n _ _ -> return (n+1)) 0 m
cs <- counts_ slm
return $ c:cs
toSlice :: SLMap k v -> SLMapSlice k v
toSlice mp = Slice mp Nothing Nothing
instance Show (LM.LMap k v) where
show _ = "<LinkedMap>"
instance Show (LM.LMList k v) where
show _ = "<LinkedMapList>"
splitSlice :: forall k v . (Show k, Ord k) =>
SLMapSlice k v -> IO (Maybe (SLMapSlice k v, SLMapSlice k v))
splitSlice sl0@(Slice (SLMap index lmbot) mstart mend) = do
res <- loop index
case res of
Just (x,y) -> do sz1 <- fmap (P.map fst) $ sliceToList sl0
sz2 <- fmap (P.map fst) $ sliceToList x
sz3 <- fmap (P.map fst) $ sliceToList y
putStrLn $ "Splitslice! size " ++(show sz1) ++" out szs "++(show (sz2,sz3))
++ " mstart/end "++show (mstart,mend)
Nothing -> return ()
return res
where
loop :: SLMap_ k v t -> IO (Maybe (SLMapSlice k v, SLMapSlice k v))
loop (Bottom lm) = do
putStrLn "AT BOT"
lm' <- readIORef lm
lm'' <- case mstart of
Nothing -> return lm'
Just strtK -> LM.dropUntil strtK lm'
res <- LM.halve mend lm''
putStrLn $ "halve RES -> "++show res
case res of
Nothing -> return Nothing
Just x -> dosplit (SLMap (Bottom lm) lm)
(\ tlboxed -> SLMap (Bottom tlboxed) tlboxed) x
loop orig@(Index m slm) = do
indm <- readIORef m
indm' <- case mstart of
Nothing -> return indm
Just strtK -> LM.dropUntil strtK indm
res <- LM.halve mend indm'
case res of
Nothing -> loop slm
Just x -> dosplit (SLMap orig lmbot)
(\ tlboxed -> SLMap (Index tlboxed slm) lmbot) x
dosplit :: SLMap k v -> (LM.LMap k tmp -> SLMap k v) ->
(Int, Int, LM.LMList k tmp) ->
IO (Maybe (SLMapSlice k v, SLMapSlice k v))
dosplit lmap mkRight (lenL, lenR, tlseg) =
assert (lenL > 0) $ assert (lenR > 0) $ do
putStrLn $ "Halved lengths "++show (lenL,lenR)
tlboxed <- newIORef tlseg
tmp <- fmap length $ LM.toList tlboxed
let (LM.Node tlhead _ _) = tlseg
rmap = mkRight tlboxed
rslice = Slice rmap (Just tlhead) mend
lslice = Slice lmap Nothing (Just tlhead)
return $! Just $! (lslice, rslice)
sliceSize :: Ord k => SLMapSlice k v -> IO Int
sliceSize slc = do
ls <- sliceToList slc
return $! length ls
sliceToList :: Ord k => SLMapSlice k v -> IO [(k,v)]
sliceToList (Slice (SLMap _ lmbot) mstart mend) = do
ls <- LM.toList lmbot
return $! [ pr | pr@(k,v) <- ls, strtCheck k, endCheck k ]
where
strtCheck = case mstart of
Just strt -> \ k -> k >= strt
Nothing -> \ _ -> True
endCheck = case mend of
Just end -> \ k -> k < end
Nothing -> \ _ -> True
debugShow :: forall k v . (Ord k, Show k, Show v) => SLMapSlice k v -> IO String
debugShow (Slice (SLMap index lmbot) mstart mend) =
do lns <- loop index
let len = length lns
return $ unlines [ "["++show i++"] "++l | l <- lns | i <- reverse [0..len1] ]
where
startCheck = case mstart of
Just start -> \ k -> k >= start
Nothing -> \ _ -> True
endCheck = case mend of
Just end -> \ k -> k < end
Nothing -> \ _ -> True
loop :: SLMap_ k v t -> IO [String]
loop (Bottom lm) = do
ls <- LM.toList lm
return [ unwords $ [ if endCheck k && startCheck k
then show i++":"++show k++","++show v
else "_"
| i <- [0::Int ..]
| (k,v) <- ls
] ]
loop (Index indm slm) = do
ls <- LM.toList indm
strs <- forM [ (i,tup) | i <- [0..] | tup@(k,_) <- ls ] $
\ (ix, (key, (shortcut::t, val))) -> do
if endCheck key && startCheck key
then return $ show ix++":"++show key++","++show val
else return "_"
rest <- loop slm
return $ unwords strs : rest