btree-concurrent (empty) → 0.1.0
raw patch · 15 files changed
+1816/−0 lines, 15 filesdep +QuickCheckdep +arraydep +basebuild-type:Customsetup-changed
Dependencies added: QuickCheck, array, base, base16-bytestring, base64-bytestring, bytestring, cereal, containers, cprng-aes, directory, entropy, filepath, hashable, mtl, old-time, random, snappy, stm, time, unix
Files
- Data/BTree/BTree.hs +670/−0
- Data/BTree/Cache/Class.hs +20/−0
- Data/BTree/Cache/STM.hs +348/−0
- Data/BTree/Class.hs +63/−0
- Data/BTree/HashTable/STM.hs +113/−0
- Data/BTree/KVBackend/Class.hs +13/−0
- Data/BTree/KVBackend/Files.hs +77/−0
- Data/BTree/KVBackend/Util.hs +37/−0
- Data/BTree/Types.hs +68/−0
- IOTreeTestQC.hs +202/−0
- README.md +7/−0
- Setup.hs +10/−0
- TODO.org +25/−0
- Test/Util.hs +60/−0
- btree-concurrent.cabal +103/−0
+ Data/BTree/BTree.hs view
@@ -0,0 +1,670 @@+{-# LANGUAGE FlexibleContexts+ , FlexibleInstances+ , ScopedTypeVariables+ , BangPatterns+ , UndecidableInstances+ , ConstraintKinds+ , Rank2Types+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.BTree.BTree+-- Concurrent BTree with relaxed balance.+--+-- This module is inspired by the paper+-- /B-Trees with Relaxed Balance/,+-- Kim S. Larsen and Rolf Fagerberg, 1993+-- Department of Mathematics and Computer Science, Odense University, Denmark.+--+-- This implementation is not full, and has some serious limitations:+--+-- 1. The rebalance logic to handle underful leafs has not been implemented.+--+-- 1. 'toList', 'foldli', 'foldri', 'search', 'findMin' and 'findMax' may fail+-- if run in parallel with 'rebalanceProcess'. The current implementations of+-- these operations are therefore considered unsafe.+--+-- 1. 'findMin' and 'findMax' may fail in the case where the outer leaf is empty.+--+-- It is important to note, that these limitations are limitations of the+-- current implementation and not of the original design. They are solely due to+-- lack of time.+--+-- To clarify: @Safe operations@ are those that support rebalancing during the+-- operations, while @unsafe operations@ may fail if run during rebalancing.+-----------------------------------------------------------------------------+++module Data.BTree.BTree+ ( -- * Setup and execution:+ makeParam+ , execTree+ -- * Class and type aliases+ , Key+ , Value+ , Interval(..)+ , TreeBackend+ , TreeResult+ -- * Safe operations:+ , insert+ , delete+ , lookup+ , modify+ , save+ -- * Rebalancing:+ , rebalanceProcess+ -- * Unsafe operations:+ , toList+ , foldli+ , foldri+ , search+ , search_+ , findMin+ , findMax+ , height+ ) where++import Data.BTree.Types+import Data.Maybe++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad.Reader+import Control.Monad.Trans+import System.Random (randomIO)+++import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.ByteString as B+import Data.Serialize (Serialize)++import qualified Data.BTree.Cache.Class as C+import qualified Data.BTree.Cache.STM as Cstm+import qualified Data.BTree.KVBackend.Class as KV+-- import GHC.Conc++import Debug.Trace++import Prelude hiding (lookup, catch)+++-- | Type aliases to ease reading.+type CacheSTM m k v = Cstm.CacheSTM m (Ref (Node k v)) (Node k v)+type CacheSTMP m k v = Cstm.Param m (Ref (Node k v)) (Node k v)+++-- | Some type-fu. Context (Key k) gives the context (Ord k, Serialize k, ...)+class (Ord k, Serialize k, Interval k) => Key k+-- | Dummy instance.+instance (Ord k, Serialize k, Interval k) => Key k+++-- | Some type-fu. Context (Value v) gives the context (Eq v, Serialize v, ...)+class (Eq v, Serialize v) => Value v+-- | Dummy instance.+instance (Eq v, Serialize v) => Value v+++-- | Needed to generate the split-keys used in branch nodes.+class Interval k where+ -- | Given two keys, a < c, compute a new key b, such that a <= b < c.+ -- Default is to choose a, however a smarter instance exist for ByteString.+ between :: k -> k -> k+ between = const+++-- | Instance for Bytestring that yields short keys.+instance Interval B.ByteString where+ between a b = if n < B.length b then B.take n b+ else a -- can't use full b, since not (b < b)+ where+ n = 1 + (length $ takeWhile (uncurry equals) $ B.zip a b)+++-- | Type aliases to shorten cache type.+type TreeBackend mc k v = KV.KVBackend mc (Ref (Node k v)) B.ByteString -- (Node k v)++-- | Type aliases to shorten result types.+type TreeResult m mc k v a = BTreeM m (Cstm.Param mc (Ref (Node k v)) (Node k v)) k v a++++-- | helpers+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM m t f | true <- m = t+ | otherwise = f++equals a b = a `compare` b == EQ+++-- | Make a new tree parameter from order, root node and cache parameter. When+-- no root node is given, 'Ref' 0 will be used and a new tree initialised+-- here. This may overwrite an existing tree. Is used together with 'execTree'.+makeParam :: (MonadIO mIO, C.Cache m p (Ref a) (Node k v))+ => Int -- ^ Order of tree.+ -> Maybe (Ref (Node k1 v1)) -- ^ Optional root node.+ -> p -- ^ Cache parameter.+ -> mIO (Param p k1 v1) -- ^ The result in monadIO+makeParam ord mroot cacheP = do+ -- Init tree when root is Nothing+ un <- liftIO $ newTVarIO []+ tv <- liftIO $ newTVarIO $ fromMaybe 0 mroot+ when (isNothing mroot) $+ liftIO $ C.eval cacheP $ C.store Nothing (Ref 0) emptyTree+ -- New channel for rebalance msgs+ rebCh <- liftIO $ newTChanIO+ return $ Param ord tv cacheP rebCh un+ where+ emptyTree = Leaf M.empty++++-- | 'execTree' takes a tree parameter and a group of operations in a BTreeM+-- monad and exectures the operations.+execTree :: Param st k v -- ^ Tree parameter (see 'makeParam')+ -> BTreeM m st k v a -- ^ Tree instance+ -> m a -- ^ The result inside the chosen monad+execTree p m =+ runReaderT (runBTreeM m) p++++-- | Get next unique node reference id+newRef p = do+ ls <- Cstm.liftSTM $ readTVar $ unused p+ case ls of+ (r:rs) -> do Cstm.liftSTM $ writeTVar (unused p) rs+ return r+ _ -> Cstm.fail newNode+ where+ newNode = do+ refids <- map Ref `fmap` replicateM 8 randomIO+ -- Collisions are rare, but not impossible+ forM_ refids $ \ref -> C.eval (state p) $ do+ n <- C.fetch ref+ case n of+ Nothing -> do Cstm.liftSTM $ do ls <- readTVar $ unused p+ writeTVar (unused p) $ ref : ls+ Just _ -> return ()+++-- | Queue marked node for rebalancing+addMarked p k = do+ Cstm.liftSTM $ writeTChan (marked p) k++-- | Get root reference id+root' p = do+ liftIO $ atomically $ readTVar $ root p++-- | Fetch node from reference id; error when not found+fetch' ref = do+ n <- C.fetch ref+ return $ fromMaybe (error $ "invalid tree: " ++ show ref) n++-- | Store node in new ref+storeNew p parent ns = do+ refs <- replicateM (length ns) $ newRef p+ mapM_ (\(r, n) -> C.store (Just parent) r n) $ zip refs ns+ return refs++-- | Split a node in two, resulting in a new parent node+split p parent r (Leaf ks) = do+ [refL, refR] <- storeNew p r [leafL, leafR]+ when (keyL > keyB || keyR <= keyB) $ error "Between has failed!"+ let branch = Branch [keyB] [refL, refR]+ C.store (Just parent) r $! branch+ return branch+ where+ (keyL, keyR) = ((fst $ last keysL), (fst $ head keysR))+ keyB = keyL `between` keyR+ keys = M.toList ks+ (keysL, keysR) = L.splitAt (order p) keys+ leafL = Leaf $! M.fromAscList keysL+ leafR = Leaf $! M.fromAscList keysR++split p parent r (Branch keys rs) =+ do [refL, refR] <- storeNew p r [ Branch keysL rsL+ , Branch keysR rsR ]+ let branch = Branch [b] [refL, refR]+ mapM_ (Cstm.updateTag $ Just r) rs+ C.store (Just parent) r $! branch+ return branch+ where+ i = order p+ (keysL, (b : keysR)) = L.splitAt i keys+ (rsL, rsR) = L.splitAt (i+1) rs++++-- | /O(log n)/. Insert key-value pair into current tree. After this operation+-- 'lookup' @k@ will yield @Just v@. If the key already exists it is overridden.+-- If you want the overridden value, or want different behaviour when the key+-- exists see 'modify'.+--+-- 'insert' may leave the tree /unbalanced/, skewed or with underfull nodes.+-- The tree can be re-balanced by starting a 'rebalanceProcess'.+--+-- > execTree p $ insert 42 "foobar"+insert :: ( MonadIO m, TreeBackend mc k v+ , Key k, Value v)+ => k -- ^ key+ -> v -- ^ value to associate with the key+ -> TreeResult m mc k v ()+insert k v = do _ <- modify const k v+ return ()+++-- | /O(log n)/. Delete a key from the tree. The deleted value is returned as+-- @Just v@ if present, otherwise @Nothing@ is returned.+--+-- > execTree p $ delete 42+delete :: ( MonadIO m, TreeBackend mc k v+ , Key k, Value v)+ => k -- ^ key+ -> TreeResult m mc k v (Maybe v) -- ^ The previous value if present+delete k = modifyLeaf (findChild k) $ \p parent r ks -> do+ let (vOld, ks') = M.updateLookupWithKey (\_ _ -> Nothing) k ks+ C.store (Just parent) r $! Leaf ks'+ return vOld++++-- | /O(log n)/. Lookup key in current tree.+--+-- > execTree p $ do insert 42 "foo" -- ()+-- > a <- lookup 42 -- Just "foo"+-- > insert 42 "bar" -- ()+-- > b <- lookup 42 -- Just "bar"+-- > delete 42 -- Just "bar"+-- > c <- lookup 42 -- Nothing+-- > return (a, b, c) -- (Just "foo", Just "bar", Nothing)+lookup :: ( MonadIO m, TreeBackend mc k v+ , Key k, Value v)+ => k -- ^ key+ -> TreeResult m mc k v (Maybe v) -- ^ The value if present+lookup k = modifyLeaf (findChild k) $ \_ _ _ -> return . M.lookup k++++-- | /O(log n)/. Replace the value of @k@ with @f v v'@, where @v'@ is the+-- current value. The old value @v'@ is returned after the replacement. If no+-- current value exist, @v@ is inserted.+--+-- The semantics is the same as @'Data.Map.insertLookupWithKey' . const@.+--+-- > execTree p $ do delete 42+-- > modify subtract 42 1 -- inserts (42, 1)+-- > modify subtract 42 1 -- updates to (42, 0)+-- > modify subtract 42 1 -- updates to (42, -1)+modify :: ( MonadIO m, TreeBackend mc k v+ , Key k, Value v)+ => (v -> v -> v) -- ^ @f@ computes the new value from old and default.+ -> k -- ^ key+ -> v -- ^ Default value is used when no other is present+ -> TreeResult m mc k v (Maybe v) -- ^ The previous value if present+modify f k v = do+ -- c <- asks state+ -- liftIO $ Cstm.flush c+ modifyLeaf (findChild k) $ \p parent r ks -> do+ let (vOld, ks') = M.insertLookupWithKey (const f) k v ks+ lf' = Leaf ks'+ if M.size ks' <= 2 * order p+ then C.store (Just parent) r $! lf'+ else do Branch [bk] _ <- split p parent r lf'+ addMarked p bk+ return vOld+{-# INLINE modify #-}+++-- modifyFromChannel ch = do+-- -- get first set of f k v+-- task@(_, _, k, _) <- liftIO $ atomically $ readTChan ch+-- -- lookup parent and child, execute task+-- (r, ks) <- modifyLeaf (findChild k) $ \p r ks -> do insert' p task r ks+-- return (r, ks)+-- -- try to execute next task, too+-- task'@(_, _, k, _) <- liftIO $ atomically $ readTChan ch+-- next ch task' r+-- where+-- next ch task r = do+-- suc <- go task r+-- case suc of+-- True -> do+-- task <- liftIO $ atomically $ readTChan ch+-- next ch task r+-- False -> do+-- liftIO $ atomically $ writeTChan ch task+-- modifyFromChannel ch++-- go task@(_, _, k, _) r = do+-- p <- ask+-- liftIO $ C.eval (state p) $ do+-- n <- C.fetch r+-- case n of+-- (Just (Leaf ks))+-- -- Inside correct leaf+-- | M.size ks > 0 && (fst $ M.findMin ks) <= k && k <= (fst $ M.findMax ks) ->+-- do insert' p task r ks+-- return True++-- | otherwise -> return False+-- _ -> return False++-- insert' p (tm, f, k, v) r ks = do+-- let (vOld, ks') = M.insertLookupWithKey (const f) k v ks+-- lf' = Leaf ks'+-- if M.size ks' <= 2 * order p+-- then do C.store r r lf'+-- else do b@(Branch [bk] _) <- split p lf'+-- C.store r r b+-- addMarked p bk+-- Cstm.liftSTM $ putTMVar tm vOld+++findChild k (Branch ks rs) =+ let idx = L.length $ L.takeWhile (<k) ks in rs !! idx+++-- | Calculate the height of the tree, i.e. the longest node path from root to leaf.+height :: (MonadIO m, C.Cache m1 p (Ref (Node k v)) (Node k v)) => BTreeM m p k v Int+height = do p <- ask+ r <- root' p+ liftIO $ go p r+ where+ go p r = do+ n <- C.eval (state p) $ C.fetch r+ case n of+ Nothing -> error $ "height: invalid tree: " ++ show r+ Just (Leaf ks) -> return 1+ Just (Branch _ rs) -> do h <- foldM (\h r -> do h' <- go p r+ return $ max h h') 0 rs+ return $ 1 + h+++-- | Modify a leaf in current tree and return result of modification+modifyLeaf :: (Ord k, MonadIO m, C.Cache mc p (Ref (Node k v)) (Node k v)) =>+ (Node k v -> Ref (Node k v)) ->+ (Param p k v -> Ref (Node k v) -> Ref (Node k v) -> M.Map k v -> mc a) ->+ BTreeM m p k v a+modifyLeaf pick f = retry 100 $ do p <- ask+ r <- root' p+ liftIO $ try $ go p r r+ where+ retry 0 m = do x <- m+ either throw return x+ retry n m = do x <- m+ case x of+ Left (_::ErrorCall) -> retry (n-1) m+ Right a -> return a++ go p parent r = do+ res <- C.eval (state p) transaction+ either (go p r) return res+ where+ transaction =+ do n <- C.fetch r+ case n of+ Just (Leaf ks) ->+ do v <- f p parent r ks+ return $! Right $! v+ Just n -> return $! Left $! pick n+ Nothing ->+ error $ "modifyLeaf: invalid tree: " ++ show r+{-# INLINE modifyLeaf #-}+++-- | A process for background rebalancing. Start inside its own thread, since+-- this will run forever. Stop by killing the thread.+--+-- > pid <- forkIO $ rebalanceProcess p+-- > -- Perform safe tree operations+-- > killThread pid+rebalanceProcess :: (MonadIO m, TreeBackend m2 k v, Key k, Value v)+ => Param (CacheSTMP m2 k v) k v -- ^ Tree parameter.+ -> m (MVar ThreadId) -- ^ ThreadId+rebalanceProcess p = liftIO $ do+ mv <- newEmptyMVar+ pid <- forkIO $ forever $ execTree p $ do+ p <- ask+ r <- root' p+ k <- liftIO $ atomically $ readTChan $ marked p+ x <- liftIO $ takeMVar mv+ rebalanceKey p r r k+ liftIO $ putMVar mv x+ putMVar mv pid+ return mv+++-- | Rebalance until no more rebalancing can take place+rebalanceAll :: (MonadIO m, Key k, Value v,+ C.Cache (CacheSTM m2 k v) (CacheSTMP m2 k v) (Ref (Node k v)) (Node k v),+ TreeBackend m2 k v) =>+ BTreeM m (CacheSTMP m2 k v) k v ()+rebalanceAll = ifM rebalance rebalanceAll $ return ()+++-- | Perform rebalancing.+-- Moves the tree one step closer to rebalancing+rebalance :: (Key k, Value v, MonadIO m,+ C.Cache (CacheSTM m2 k v) (CacheSTMP m2 k v) (Ref (Node k v)) (Node k v),+ TreeBackend m2 k v) =>+ BTreeM m (CacheSTMP m2 k v) k v Bool+rebalance = do p <- ask+ r <- root' p+ let ch = marked p+ mk <- liftIO $ atomically $+ ifM (isEmptyTChan ch)+ (return Nothing)+ (Just `fmap` readTChan ch)+ case mk of+ Just k -> do rebalanceKey p r r k+ return True+ Nothing -> return False+++rebalance' :: (Key k, Value v, MonadIO m,+ C.Cache (CacheSTM m2 k v) (CacheSTMP m2 k v) (Ref (Node k v)) (Node k v),+ TreeBackend m2 k v) =>+ BTreeM m (CacheSTMP m2 k v) k v ()+rebalance' = do p <- ask+ r <- root' p+ let ch = marked p+ k <- liftIO $ atomically $ readTChan ch+ rebalanceKey p r r k++rebalanceKey p parent r k = do+ ord <- asks order+ mr <- liftIO $ C.eval (state p) $ trans ord+ case mr of+ Nothing -> return ()+ Just r' -> rebalanceKey p r r' k+ where+ trans ord = do+ mn <- C.fetch r+ case mn of+ Nothing -> error $ "rebalanceKey: invalid tree: " ++ show r+ Just (Leaf _) -> return Nothing+ Just (n@(Branch ks rs)) -> do+ let cr = findChild k n+ mcn <- C.fetch cr+ case mcn of+ Nothing -> error $ "rebalanceKey: invalid tree: cr = " ++ show cr+ Just (Leaf _) -> return Nothing -- TODO: Handle empty leaf+ Just (cn@(Branch [k'] [r0, r1])) -> do+ let ks' = L.insert k' ks+ Just idx = L.elemIndex k' ks'+ (a, _ : b) = L.splitAt idx rs+ rs' = a ++ (r0 : r1 : b)+ branch = Branch ks' rs'+ if length rs' <= 2 * ord+ then do C.store (Just parent) r branch+ C.remove Nothing cr+ -- TODO: why can't we remove cr?+ else do branch'@(Branch _ frs) <- split p parent r branch+ C.store (Just parent) r branch'+ C.remove Nothing cr+ addMarked p k'+ if k `equals` k' then return Nothing+ else return $ Just r+ Just (Branch cks crs) -> return $ Just cr++++deleteByFst k = L.deleteBy cmpfst (k, undefined)+ where+ cmpfst (a, _) (b, _) = a `equals` b+++size :: (Ord k, MonadIO m, C.Cache mc p (Ref (Node k v)) (Node k v)) =>+ BTreeM m p k v Int+size = do p <- ask+ r <- root' p+ go p r+ where+ go p r = do+ n <- liftIO $ C.eval (state p) $ fetch' r+ case n of+ Leaf ks -> return $ M.size ks+ Branch ks rs -> do+ tot <- foldM (\n r ->+ do m <- go p r+ return $ n + m+ ) 0 rs+ return tot+++-- | Convert the tree into a list of key-value pairs. This function may crash+-- if used together with 'rebalanceProcess'.+toList :: ( MonadIO m, TreeBackend mc k v, Key k, Value v)+ => TreeResult m mc k v [(k, v)] -- ^ The list of (key, value) pairs.+toList = do p <- ask+ r <- root' p+ Cstm.withGeneration (state p) $ \n -> go n p r+ where+ go gen p r = do+ n <- liftIO $ C.eval (state p) $ Cstm.fetchGen gen r+ case n of+ Nothing -> error $ "toList: invalid tree: " ++ show r+ Just (Leaf ks) -> return $ M.toList ks+ Just (Branch ks rs) -> do+ ls <- mapM (go gen p) rs+ return $ concat ls+++-- | Save the tree by flushing the underlying cache to the permanent store and+-- return a ref to the root node.+save :: ( MonadIO m, TreeBackend mc k v, Key k, Value v)+ => TreeResult m mc k v (Ref (Node k v)) -- ^ 'Ref' to the root node.+save = do+ p <- ask+ liftIO $ C.sync $ state p+ root' p+++-- | Lookup minimum key+findMin :: (Ord k, MonadIO m, C.Cache mc p (Ref (Node k v)) (Node k v)) =>+ BTreeM m p k v (k, v)+findMin = modifyLeaf (\(Branch _ rs) -> head rs) $ \_ _ _ -> return . M.findMin+++-- | Lookup maximum key+findMax :: (Ord k, MonadIO m, C.Cache mc p (Ref (Node k v)) (Node k v)) =>+ BTreeM m p k v (k, v)+findMax = modifyLeaf (\(Branch _ rs) -> last rs) $ \_ _ _ -> return . M.findMax++++-- | Fold with key in left to right order.+foldli :: (MonadIO m, TreeBackend mc k v, Key k, Value v) =>+ (a -> k -> v -> a) -> a -> TreeResult m mc k v a+foldli f a = do p <- ask+ r <- root' p+ go p a r+ where+ go p a r = do+ n <- liftIO $ C.eval (state p) $ fetch' r+ case n of+ Leaf ks -> return $ M.foldlWithKey f a ks+ Branch ks rs -> foldM (go p) a rs+++-- | Fold with key in right to left order.+foldri :: (MonadIO m, TreeBackend mc k v, Key k, Value v) =>+ (k -> v -> a -> a) -> a -> TreeResult m mc k v a+foldri f a = do p <- ask+ r <- root' p+ go p a r+ where+ go p a r = do+ n <- liftIO $ C.eval (state p) $ fetch' r+ case n of+ Leaf ks -> return $ M.foldrWithKey f a ks+ Branch ks rs -> foldM (go p) a $ reverse rs+++++-- | A generalised way of querying the tree. Given two keys @a <= b@ the+-- function needs to answer @True@ or @False@ as to whether the interval @[a,+-- b]@ contains interesting keys. No all keys in the interval need be+-- interesting. This function will then return all interesting keys in an+-- efficient way.+search :: (MonadIO m, TreeBackend mc k v, Key k, Value v)+ => ((k, k) -> Bool) -- ^ @f@ defines interesting intervals+ -> TreeResult m mc k v [(k, v)] -- ^ A list of chosen (key, value) pairs+search f = do p <- ask+ r <- root' p+ lb <- fst `fmap'` findMin -- lower bound+ ub <- fst `fmap'` findMax -- upper bound+ go p r lb ub+ where+ fmap' f m = m >>= return . f++ go p r lb ub = do+ n <- liftIO $ C.eval (state p) $ fetch' r+ case n of+ Leaf ks -> return $ filter (\(k, _) -> f (k, k)) $ M.toList ks+ Branch ks rs -> do+ let ints = findInts 0 (lb:ks ++ [ub])+ ls <- mapM (\(n, lb, ub) -> go p (rs!!n) lb ub) ints+ return $ concat ls+ where+ findInts (!n) (lb:ub:xs) =+ if f (lb, ub) then (n, lb, ub) : rest else rest+ where+ rest = findInts (n+1) (ub:xs)+ findInts _ _ = []+++search_ :: (MonadIO m, TreeBackend mc k v, Key k, Value v)+ => ((k, k) -> Bool) -- ^ @f@ defines interesting intervals+ -> TreeResult m mc k v () -- ^ A list of chosen (key, value) pairs+search_ f = do p <- ask+ r <- root' p+ lb <- fst `fmap'` findMin -- lower bound+ ub <- fst `fmap'` findMax -- upper bound+ tv <- liftIO $ newEmptyMVar+ liftIO $ go p r lb ub tv+ liftIO $ takeMVar tv+ where+ fmap' f m = m >>= return . f++ go p r lb ub tv = do+ n <- C.eval (state p) $ fetch' r+ case n of+ Leaf ks -> putMVar tv ()+ Branch ks rs -> do+ let ints = findInts 0 (lb:ks ++ [ub])+ tv' <- newEmptyMVar+ mapM_ (\(n, lb, ub) -> forkIO $ go p (rs!!n) lb ub tv') ints+ replicateM_ (length ints) $ takeMVar tv'+ putMVar tv ()+ where+ findInts (!n) (lb:ub:xs) =+ if f (lb, ub) then (n, lb, ub) : rest else rest+ where+ rest = findInts (n+1) (ub:xs)+ findInts _ _ = []
+ Data/BTree/Cache/Class.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE MultiParamTypeClasses+ , FunctionalDependencies+ , ExistentialQuantification+ #-}++module Data.BTree.Cache.Class where++import Control.Concurrent.STM+++data R b = forall a. Inter (IO a) (a -> STM ())+ | Final b+++class Monad m => Cache m p k v | m -> p, p -> k, p -> v, p -> m where+ store :: Maybe k -> k -> v -> m ()+ fetch :: k -> m (Maybe v)+ remove :: Maybe k -> k -> m ()+ sync :: p -> IO ()+ eval :: p -> m a -> IO a
+ Data/BTree/Cache/STM.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE GeneralizedNewtypeDeriving+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , UndecidableInstances+ , RankNTypes+ , ScopedTypeVariables+ #-}++module Data.BTree.Cache.STM where++import Data.Hashable (Hashable)+import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Graph as G++import qualified Data.BTree.Cache.Class as C+import qualified Data.BTree.HashTable.STM as H+import qualified Data.Serialize as S++import qualified Data.BTree.KVBackend.Class as KV++import Control.Concurrent.STM+import Control.Concurrent++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Reader++import qualified Data.ByteString as B++import Data.Either+import Data.Maybe+import Data.Time.Clock+import Debug.Trace+import System.IO++import Control.Monad.Error+++data State k v = Read !(Maybe v)+ | Write !(Maybe k) !(Maybe v)+ deriving Eq++instance Show (State k v) where+ show (Read a) = "Read: " ++ mtoS a+ show (Write k a) = "Write: " ++ mtoS a++mtoS a = if isJust a then "Just" else "Nothing"++type AccessTime = UTCTime+++data Exist = Exist | NoExist+ deriving (Eq)++data Ref k v = Ref {+ refST :: TVar (Either (State k v)+ (State k v, Int, State k v)), -- Current state+ refExt :: TVar Exist -- Exists in external storage?+ }+++data Param m k v = Param {+ cacheSize :: Int+ , table :: H.HashTableSTM k (Ref k (Either B.ByteString v))+ , toIO :: forall a. m a -> IO a+ , flushQ :: TVar [(k, Ref k v)]+ , timestamp :: UTCTime+ , genId :: TVar Int -- Generation ID+ , genActive :: TVar Int -- Active users of maintained generation+ }++trace = id++newtype CacheSTM m k v a = CacheSTM { runCacheSTM :: ReaderT (Param m k v) (ErrorT (IO ()) STM) a }+ deriving (Monad, MonadReader (Param m k v), MonadError (IO ()), Functor)++instance Error (IO ())+++stm m = lift $ lift m+++evalCacheSTM :: Param m k v -> CacheSTM m k v a -> IO a+evalCacheSTM p m = do+ mer <- atomically $ runErrorT $ runReaderT (runCacheSTM m) p+ case mer of+ Left io -> io >> evalCacheSTM p m -- perform IO and retry+ Right a -> return a -- return final result+++sizedParam :: Int -> (forall a. m a -> IO a) -> IO (Param m k v)+sizedParam s f = do+ ts <- getCurrentTime+ ht <- H.newSized s+ mv <- atomically $ newTVar []+ gn <- atomically $ newTVar 0+ ga <- atomically $ newTVar 0+ return $ Param s ht f mv ts gn ga+++getRef k = do+ p <- ask+ ht <- asks table+ ev <- asks toIO+ mr <- stm $ H.lookup ht k+ case mr of+ Nothing -> fetchRef p ev ht+ Just r -> return r+ where+ fetchRef p ev ht = throwError $ (ev $ KV.fetch k) >>= createRef p ht+ createRef p ht bytes = do+ atomically $ do+ l <- H.lookup ht k+ case l of+ Just _ -> return ()+ Nothing -> do+ tvst <- newTVar $ Left $ Read $ Left `fmap` bytes+ tvex <- newTVar Exist+ let ref = Ref tvst tvex+ H.insert ht k ref+++newRef t k v = do+ ht <- asks table+ r@(Ref tv _) <- getRef k+ -- maybeQueue False tv (k, r)+ update tv $! Write t v+ where+ update tv x = do+ gt <- asks genId+ ga <- asks genActive+ stm $ do+ gid <- readTVar gt -- Generation ID+ act <- readTVar ga -- Active users+ s <- readTVar tv -- State of ref+ case s of+ Left o | act == 0 -> writeTVar tv $! Left $! x+ | otherwise -> writeTVar tv $! Right $! (x, gid, o)+ Right (x', n, o)+ | act == 0 -> writeTVar tv $! Left $! x+ | gid /= n -> writeTVar tv $! Right $! (x, gid, x')+ | otherwise -> writeTVar tv $! Right $! (x, gid, o )+++maybeQueue force t x =+ if force then update+ else do+ s <- stm $ readTVar t+ case s of+ Left (Write _ _) -> return () -- Already in queue+ Right (Write _ _, _, _) -> return ()+ _ -> update+ where+ update = do+ qt <- asks flushQ+ stm $ do q <- readTVar qt+ writeTVar qt $! x : q+++store t k v = CacheSTM $ newRef t k $! Just $! Right v+++-- fetch :: (Eq k, NFData k, Hashable k, KV.KVBackend IO k v) => k -> CacheSTM m k v (Maybe v)+fetch k = CacheSTM $ do+ r@(Ref tv _) <- getRef k+ s <- stm $ readTVar tv+ case s of+ Left x -> return $! value x+ Right (x, _, _) -> return $! value x++fetchGen n k = CacheSTM $ do+ r@(Ref tv _) <- getRef k+ s <- stm $ readTVar tv+ return $ value $ getGen n s+++remove t k = CacheSTM $ newRef t k Nothing+++updateTag t k = CacheSTM $ do+ ht <- asks table+ x <- stm $ H.lookup ht k+ case x of+ Nothing -> return ()+ Just (Ref tv _) -> do+ s <- stm $ readTVar tv+ case s of+ Left (Write _ v) -> stm $ writeTVar tv $! Left $! Write t v+ Right (Write _ v, n, o) -> stm $ writeTVar tv $! Right $! (Write t v, n, o)+ _ -> return ()+++keys = CacheSTM $ do+ ht <- asks table+ stm $ H.keys ht+++debug a = liftIO $ do print a+ hFlush stdout++getGen n (Left s) = s+getGen n (Right (news, m, olds))+ | n == m = olds+ | otherwise = news++flipWrite x (Left (Write _ x')) | x == x' = Left $! (Read x)+flipWrite x (Right (Write _ x', n, o)) | x == x' = Right $! (Read x', n, o)+flipWrite x (Right (c, n, Write _ x')) | x == x' = Right $! (c, n, Read x')+flipWrite _ s = s+++equals a b = value a == value b+++value v = case v of+ Read x -> either decode id `fmap` x+ Write _ x -> either decode id `fmap` x+ where+ decode = either error id . S.decode+++withGeneration p f = do+ -- start generation+ n <- liftIO $ atomically $ do+ a <- readTVar $ genActive p+ n <- readTVar $ genId p+ writeTVar (genActive p) $! a + 1+ if a > 0 then return n+ else do writeTVar (genId p) $! n + 1+ return $! n + 1+ -- compute+ x <- f n++ -- end generation+ liftIO $ atomically $ do+ a <- readTVar $ genActive p+ writeTVar (genActive p) $! a - 1++ -- yield result+ return x+++flush p = do+ nowSize <- atomically $ H.size ht+ gen <- atomically $ readTVar $ genId p+ when (nowSize > maxSize) $ do+ flush =<< (atomically $ H.toList ht)+ where+ ht = table p+ maxSize = cacheSize p++ flush ks = do+ mapM_ (evalCacheSTM p . flushKey ht) ks+++flushKey ht (k, r@(Ref tvst tvex)) = CacheSTM $ do+ tvga <- asks genActive+ tvgi <- asks genId+ stm $ do+ act <- readTVar tvga+ gen <- readTVar tvgi+ s <- readTVar tvst+ case s of+ Left (Read _) ->+ H.delete ht k >> return Nothing++ Right (Read s, n, _) | act == 0 || n /= gen ->+ H.delete ht k >> return Nothing++ Right (Write t s, n, _) | act == 0 || n /= gen ->+ (writeTVar tvst $! Left $! Write t s) >> return Nothing++ Left (Write t (Just (Right v))) ->+ (writeTVar tvst $! Left $! Write t $! Just $! Left $! S.encode v)+ >> return Nothing++ Right (Write t (Just (Right v)), n, o) ->+ (writeTVar tvst $! Right $! (Write t $! Just $! Left $! S.encode v, n, o))+ >> return Nothing++ _ -> return $ Just s+++sync p = do+ withGeneration p $ \gen -> do+ -- sync+ -- TODO: use flush queue+ ks <- atomically $ H.toList $ table p++ ls <- forM ks $ \(k, r@(Ref tv _)) -> do+ s <- atomically $ readTVar tv+ case getGen gen s of+ Write (Just t) _ -> return $! Just $! Left (t, k, r)+ Write Nothing _ -> return $! Just $! Right (k, r)+ _ -> return $! Nothing++ let (lefts, rights) = partitionEithers $ catMaybes ls++ mapM_ (evalCacheSTM p . go gen) $ sortByTag lefts+ mapM_ (evalCacheSTM p . go gen) $ rights+ where+ sortByTag :: Ord k => [(k, k, Ref k v)] -> [(k, Ref k v)]+ sortByTag ls =+ let m = M.fromList $ zip (map (\(_, k, _) -> k) ls) [0..]+ (g, f, _) = G.graphFromEdges+ [((k, r), i, maybe [] return $ M.lookup t m)+ | ((t, k, r), i) <- zip ls [0..]]+ in map (\(p, _, _) -> p) $ map f $ G.topSort g++ go gen (k, (r@(Ref tv tvex))) = CacheSTM $ do+ s <- stm $ readTVar tv+ ex <- stm $ readTVar tvex+ case getGen gen s of+ -- TODO: handle exist+ Write _ Nothing | ex == Exist -> throwError write+ | otherwise -> stm $ update Nothing++ Write _ (Just v) -> throwError write+ _ -> return ()++ where+ write = do+ s <- atomically $ readTVar tv+ case getGen gen s of+ Write _ Nothing -> (toIO p $ KV.remove k ) >> (atomically $ update Nothing)+ Write _ (Just v) -> (toIO p $ KV.store k $ either id S.encode $ v)+ >> (atomically $ update (Just v))+ _ -> return ()++ update v = do+ s <- readTVar tv+ writeTVar tv $! flipWrite v s+++liftSTM = CacheSTM . stm+fail = CacheSTM . throwError+++instance ( Show k, S.Serialize k, S.Serialize v, Ord k, Eq k, Eq v+ , Hashable k, KV.KVBackend m k B.ByteString) =>+ C.Cache (CacheSTM m k v) (Param m k v) k v where+ store = store+ fetch = fetch+ remove = remove+ sync = sync+ eval = evalCacheSTM
+ Data/BTree/Class.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE MultiParamTypeClasses+ , GeneralizedNewtypeDeriving+ , FunctionalDependencies+ , FlexibleInstances+ , FlexibleContexts+ , UndecidableInstances+ #-}++module Data.BTree.Class where++import Prelude hiding (lookup)+import Data.Maybe+import Data.Serialize()++import Control.Monad.Trans+import Control.Monad++import Data.BTree.Types+import qualified Data.BTree.BTree as T()+import qualified Data.BTree.Cache.Class as C()+import qualified Data.BTree.Cache.STM as Cstm+import qualified Data.BTree.KVBackend.Class as KV()++class (Functor m, MonadIO m) => Tree m k v | m -> v, m -> k where+ -- lookup k <- case lookup k of+ -- Nothing -> v+ -- Just v' -> f v v'+ -- modify f k v = Just v' if T(k) = v'+ -- = Nothing otherwise+ modify :: (v -> v -> v) -> k -> v -> m (Maybe v)++ modify_ :: (v -> v -> v) -> k -> v -> m ()+ modify_ f k = void . modify f k++ modifyMany :: [(v -> v -> v, k, v)] -> m ()+ modifyMany fks = mapM_ (\(f, k, v) -> modify_ f k v) fks++ delete :: k -> m (Maybe v)+ delete_ :: k -> m ()+ delete_ = void . delete++ lookup :: k -> m (Maybe v)++ member :: k -> m Bool+ member k = isJust `fmap` lookup k++ search :: ((k, k) -> Bool) -> m [(k, v)]++ foldli :: (a -> k -> v -> a) -> a -> m a++ toList :: m [(k,v)]+ toList = reverse `fmap` (foldli (\l k v -> (k,v):l) [])+++type N k v = Node k v+type R k v = Ref (N k v)++-- Cache Parameter+type Cp m k v = Cstm.Param m (R k v) (N k v)+++type S m k v = Cstm.Param m (R k v) (N k v)+
+ Data/BTree/HashTable/STM.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE TupleSections+ , BangPatterns+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.BTree.HashTable.STM+-- A hashtable in STM.+--+-----------------------------------------------------------------------------+++module Data.BTree.HashTable.STM+ ( HashTableSTM+ , newSized+ , insert+ , lookup+ , delete+ , size+ , keys+ , toList+ ) where++import Prelude hiding (lookup)++import Control.Concurrent.STM+import Control.Monad++import Data.Array+import Data.Hashable (Hashable(..))+import Data.Maybe++import qualified Data.List as L+import qualified Data.Map as M+++type Bucket k v = M.Map k v+++data HashTableSTM k v = HashTableSTM { buckets :: !Int -- number of buckets+ , count :: TVar Int -- current element count+ , getArray :: Array Int (TVar (Bucket k v)) }+++bucket (HashTableSTM n _ arr) k = arr ! (hash k `mod` n)+{-# INLINE bucket #-}++-- | Create a new HashTable with fixed size+newSized :: Int -> IO (HashTableSTM k v)+newSized n =+ do co <- newTVarIO 0+ vs <- mapM (\i -> (i,) `fmap` newTVarIO M.empty) [0..n-1]+ return $! HashTableSTM n co $! array (0, n-1) vs+++modifyCount h f = do+ n <- readTVar $ count h+ writeTVar (count h) $! f n+{-# INLINE modifyCount #-}+++-- | /O(log n)/. Insert a key/value pair into HashTable.+insert :: (Hashable k, Ord k) => HashTableSTM k v -> k -> v -> STM ()+insert h !k !v = do+ m <- readTVar b+ let m' = M.insert k v m+ writeTVar b $! m'+ modifyCount h (+1)+ where+ b = bucket h k+++-- | /O(log n)/. Lookup a key in HashTable.+lookup :: (Hashable k, Ord k) => HashTableSTM k v -> k -> STM (Maybe v)+lookup h !k =+ do lst <- readTVar $ bucket h k+ return $! M.lookup k lst+++-- | /O(log n)/. Delete a key from HashTable.+delete :: (Hashable k, Ord k) => HashTableSTM k v -> k -> STM ()+delete h !k =+ do m <- readTVar b+ let (a, m') = M.updateLookupWithKey (\_ _ -> Nothing) k m+ when (isJust a) $+ modifyCount h (subtract 1)+ M.lookup k m' `seq` writeTVar b m'+ where+ b = bucket h k+++-- | /O(1)/. Grab the size of the hash table.+size :: HashTableSTM k v -> STM Int+size h = readTVar c+ where+ c = count h+++-- | /O(n)/. Get a list of key/value pairs.+toList :: HashTableSTM k v -> STM [(k, v)]+toList h =+ do bs <- buckets h+ return $ concat $ map M.toList bs+ where+ buckets (HashTableSTM n _ arr) =+ mapM readTVar $ elems arr+++-- | /O(n)/. Get a list of keys.+keys :: HashTableSTM k v -> STM [k]+keys h =+ do l <- toList h+ return $ map fst l
+ Data/BTree/KVBackend/Class.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE MultiParamTypeClasses+ , FunctionalDependencies+ #-}++module Data.BTree.KVBackend.Class+ ( KVBackend(..) )+ where+++class Monad m => KVBackend m k v | m -> k, m -> v where+ store :: k -> v -> m ()+ fetch :: k -> m (Maybe v)+ remove :: k -> m ()
+ Data/BTree/KVBackend/Files.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleInstances+ , MultiParamTypeClasses+ , GeneralizedNewtypeDeriving+ , UndecidableInstances+ , ScopedTypeVariables+ #-}++module Data.BTree.KVBackend.Files where++import Debug.Trace++import Prelude hiding (catch)++import Control.Exception+import Control.Concurrent+import Control.Monad.Reader++import System.Random+import System.FilePath+import System.Directory (removeFile, renameFile)++import Data.Serialize (Serialize, encode, decode)++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as BL+import Data.Word++import Data.BTree.KVBackend.Util (atomicFileWrite, safeReadFile, safeWriteFile)+import qualified Data.BTree.KVBackend.Class as KV++import Codec.Compression.Snappy++type Param = FilePath++newtype FilesKV a = FilesKV { runFilesKV :: ReaderT Param IO a }+ deriving (Monad, MonadIO, MonadReader Param)++evalFilesKV :: FilePath -> FilesKV a -> IO a+evalFilesKV p m =+ runReaderT (runFilesKV m) p++traceThis a = traceShow a a++filePath :: Serialize k => k -> FilesKV FilePath+filePath path =+ do dir <- ask+ return $ dir </> (B.unpack $ B.map fix $ B64.encode $ encode path)+ where+ fix '/' = '-'+ fix c = c+++store k v = do path <- filePath k+ e <- liftIO $! try $! safeWriteFile path bin+ case e of+ Left (e :: IOError) -> do -- File is probably locked+ liftIO $ threadDelay 1+ store k v+ Right _ -> return ()+ where+ bin = compress $ encode v++fetch k = do path <- filePath k+ liftIO $ do bin <- safeReadFile path+ return $! either (const Nothing) Just $ decode $ decompress bin+ `catch` \(_ :: IOError) -> return Nothing++remove k = do path <- filePath k+ liftIO $ removeFile path+ `catch` \(_ :: IOError) -> return ()+++instance (Show k, Serialize k, Serialize v) => KV.KVBackend FilesKV k v where+ store k v = store k v+ fetch k = fetch k+ remove k = remove k
+ Data/BTree/KVBackend/Util.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.BTree.KVBackend.Util+ ( atomicFileWrite+ , safeWriteFile+ , safeReadFile+ ) where++import Prelude hiding (catch)++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Base64 as B64++import Data.Serialize (Serialize, encode, decode)++import System.FilePath ((<.>), (</>))+import System.Directory (renameFile, removeFile)++import Control.Exception++import Data.BTree.UUID+++atomicFileWrite path bytes = do+ tmp <- (path <.>) `fmap` show `fmap` uuid+ write tmp+ where+ writeThenMove tmp = do+ B.writeFile tmp bytes+ renameFile tmp path++ write tmp = do+ writeThenMove tmp `finally` (removeFile tmp `catch` \(_::IOError) -> return ())++safeWriteFile path bytes = atomicFileWrite path bytes+safeReadFile path = B.readFile path
+ Data/BTree/Types.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE GeneralizedNewtypeDeriving+ , TypeSynonymInstances+ , FlexibleInstances+ #-}++module Data.BTree.Types where++import Data.Hashable (Hashable)++import Data.BTree.Cache.Class++import Data.Word++import Data.Serialize+import Data.Map as M+import Data.Hashable++import Control.Concurrent.STM+import Control.Monad.Reader++import System.Random+++newtype Ref a = Ref Word64+ deriving (Show, Ord, Eq, Hashable, Num)+++instance Serialize (Ref a) where+ put (Ref a) = put a+ get = Ref `fmap` get+++data Node k v = Leaf (M.Map k v)+ | Branch [k] [Ref (Node k v)]+ deriving Eq+++instance (Ord k, Serialize k, Serialize v) => Serialize (Node k v) where+ put (Leaf ks) =+ do put (0 :: Word8)+ put ks++ put (Branch ks rs) =+ do put (1 :: Word8)+ put ks+ put rs++ get = do tag <- get :: Get Word8+ case tag of+ 0 -> Leaf `fmap` get+ 1 -> do ks <- get+ rs <- get+ return $ Branch ks rs+++data Param st k v = Param {+ order :: Int+ , root :: TVar (Ref (Node k v))+ , state :: st+ , marked :: TChan k+ , unused :: TVar [Ref (Node k v)]+ }+++newtype BTreeM m st k v a = BTreeM { runBTreeM :: ReaderT (Param st k v) m a }+ deriving (Monad, MonadIO, MonadReader (Param st k v), Functor)++
+ IOTreeTestQC.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE ScopedTypeVariables+ , TypeSynonymInstances+ #-}++import Prelude hiding (lookup)++import Control.Concurrent+import Control.Monad+import Control.Monad.Trans++import Data.Word++import qualified Data.ByteString.Char8 as B++import qualified Data.BTree.Types as Ty+import qualified Data.BTree.BTree as T+import qualified Data.BTree.Cache.Class as C+import qualified Data.BTree.Cache.STM as Cstm+import qualified Data.BTree.KVBackend.Files as Files++import qualified Data.Map as M+import Data.Maybe++import Test.QuickCheck+import Test.QuickCheck.Monadic as QCM++import System.Posix.Directory (createDirectory)+import Test.Util+++type Index = Word64+type Key = Word32+type Value = Word16+++data TreeOps = Insert Key Value+ | InsertMany [(Key, Value)]++ | UpdateIndex Index Value++ | ModifyKey ModFun Key Value+ | ModifyIndex ModFun Index Value++ | ModifyMany [(ModFun, Key, Value)]++ | UpdateNoop Index++ | DeleteKey Key+ | DeleteIndex Index+ | DeleteMany [Index]++ | DeleteMin+ | DeleteMax+ deriving (Show)+++data ModFun = ModFun (Value -> Value -> Value)+++instance T.Interval Key where+ between a b = a + ((b - a) `div` 2)+++instance Show ModFun where+ show _ = "ModFun"++instance Arbitrary ModFun where+ arbitrary = ModFun `fmap` (oneof $ map return [+ (+)+ , (*)+ , (-)+ , const+ , flip const+ ])+++smallArbitrary :: Arbitrary a => Gen a+smallArbitrary = sized $ \s -> resize (floor $ sqrt $ fromIntegral s) arbitrary++instance Arbitrary TreeOps where+ arbitrary = oneof [+ liftM2 Insert arbitrary arbitrary+ , liftM InsertMany smallArbitrary++ , liftM3 ModifyKey arbitrary arbitrary arbitrary+ , liftM3 ModifyIndex arbitrary arbitrary arbitrary+ -- , liftM ModifyMany arbitrary++ , liftM2 UpdateIndex arbitrary arbitrary+ , liftM UpdateNoop arbitrary++ , liftM DeleteIndex arbitrary+ , liftM DeleteKey arbitrary++ -- , return DeleteMin+ -- , return DeleteMax+ ]+++-- behaves_like_map_prop :: String -> Property+behaves_like_map_prop dir root =+ QCM.monadicIO $+ do ops <- pick arbitrary+ eq <- QCM.run $ interp ops+ assert eq++ where+ interp ops =+ do c <- Cstm.sizedParam 8 $ Files.evalFilesKV dir+ r <- readMVar root+ p <- T.makeParam 8 (Just r) c++ l0 <- T.execTree p $ T.toList++ reb <- T.rebalanceProcess p+ sid <- safeForkIO $ \mv -> forever $ do+ threadDelay $ 10^5+ withMVar mv $ const $+ modifyMVar root $ \_ -> do+ r <- T.execTree p $ T.save+ return (r, ())+ fid <- safeForkIO $ \mv -> forever $ do+ threadDelay $ 10^5+ withMVar mv $ const $+ Cstm.flush c+++ m <- T.execTree p $ foldM go (M.fromList l0) ops++ mapM_ safeKill [reb, sid, fid]+ l1 <- T.execTree p $ T.toList++ return $ M.toList m == l1++ go m op =+ case op of+ Insert k v -> do T.modify const k v+ return $ M.insert k v m++ InsertMany ks -> do+ mapM_ (uncurry $ T.modify const) ks+ return $ foldl (flip $ uncurry $ M.insert) m ks+++ ModifyKey (ModFun f) k v -> do+ T.modify f k v+ return $ M.insertWith f k v m++ ModifyIndex (ModFun f) idx v -> withKey idx $ \k -> do+ T.modify f k v+ return $ M.insertWith f k v m++ ModifyMany fkvs -> do+ mapM_ (\(ModFun f, k, v) -> T.modify f k v) fkvs+ return $ foldl (\m (ModFun f, k, v) -> M.insertWith f k v m) m fkvs++ UpdateIndex idx v -> withKey idx $ \k -> do+ T.modify const k v+ return $ M.insert k v m++ UpdateNoop idx -> withKey idx $ \k -> do+ T.modify (flip const) k $ fromIntegral k+ return m++ DeleteIndex idx -> withKey idx $ \k -> do+ T.delete k+ return $ M.delete k m++ DeleteKey k -> do+ T.delete k+ return $ M.delete k m++ -- Delete-min and delete-max are not yet safe+ -- DeleteMin+ -- | M.null m -> return m+ -- | otherwise -> do+ -- (k, _) <- T.findMin+ -- T.delete k+ -- return $ M.deleteMin m++ _ -> return m++ where+ withKey idx f+ | M.null m = return m+ | otherwise = do+ f $ fst $ M.elemAt (fromIntegral idx `mod` M.size m) m++++main = do+ let args = stdArgs {maxSuccess = 30, maxSize = 5000}+ createDirectory dir 493+ -- Create an empty tree+ c <- Cstm.sizedParam 8 $ Files.evalFilesKV dir+ p <- T.makeParam 8 Nothing c+ r <- T.execTree p T.save+ root <- newMVar r+ quickCheckWithResult args $ behaves_like_map_prop dir root+ where+ dir = "btree-conc-test-tmp"+
+ README.md view
@@ -0,0 +1,7 @@+btree-concurrent+================++A backend agnostic, concurrent BTree written in Haskell.++Although the code does work, it is neither production-ready nor complete. See+the TODO.org file for more details on missing parts.
+ Setup.hs view
@@ -0,0 +1,10 @@+#!/usr/bin/env runhaskell++import Control.Monad+import Distribution.Simple+import System.Process++main = defaultMainWithHooks simpleUserHooks { postInst = myPostInst }+++myPostInst args flags desc info = return ()
+ TODO.org view
@@ -0,0 +1,25 @@+* Smaller things:+** Fix the code to give fewer warnings when compiled with -Wall++ There are tons of small things in the code that spit out warnings in GHC or+ hlint. Fixing this would likely improve code quality a bit.++** Update this TODO+ There is probably more things to do that aren't named in here.+++* Larger things:+** Should we only allow bytestring as key to avoid serialize/deserialze?++ This could give lower memory usage, since nodes could remains as packed+ bytestrings at all times. Some c-functions could be introduced to manipulate+ these in a safe yet efficient way (copy on change).++** Complete the implementations of findMin and findMax.++ Currently, min and max values can only be located if they reside in an+ outermost leaf. Due to the nature of eventual-balance and lazy rebalancing+ this is not always the case. The outermost leaf could be empty.+++
+ Test/Util.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Util+ ( byteStringToFileName+ , fileNameToByteString+ , clearDirectory+ , safeForkIO+ , safeKill+ , decode'+ )+ where++import Prelude hiding (catch)++import qualified Data.ByteString.Char8 as B+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Base64 as B64+import System.Directory+import Control.Monad++import Data.Serialize (encode, decode)++import System.FilePath ((<.>))+import System.Directory (renameFile)++import Control.Concurrent+import Control.Exception+++byteStringToFileName k = map fixChars $ B.unpack $ B64.encode k+ where+ fixChars '/' = '-'+ fixChars c = c++fileNameToByteString f = unRight $ B64.decode $ B.pack $ map unfixChars f+ where+ unRight (Right x) = x+ unfixChars '-' = '/'+ unfixChars c = c++clearDirectory path = do+ metaExists <- doesDirectoryExist path+ when metaExists $+ removeDirectoryRecursive path+ createDirectoryIfMissing True path+++safeForkIO f = do+ mv <- newEmptyMVar+ pid <- forkIO $ f mv+ putMVar mv pid+ return mv+++safeKill m = do+ withMVar m killThread+++decode' errmsg a =+ either (\msg -> error $ errmsg ++ ": " ++ msg) id $ decode a
+ btree-concurrent.cabal view
@@ -0,0 +1,103 @@+name: btree-concurrent+version: 0.1.0+homepage: https://github.com/brinchj/btree-concurrent+synopsis: A backend agnostic, concurrent BTree+description: A backend agnostic, concurrent BTree+category: Data Structures+license: LGPL+author: Morten Brøns, Johan Brinch+maintainer: brinchj@gmail.com+data-files: README.md TODO.org+cabal-version: >= 1.8+build-type: Custom+stability: Experimental++++Test-Suite quickcheck-highlevel+ type: exitcode-stdio-1.0+ main-is: IOTreeTestQC.hs++ other-modules:+ Test.Util++ build-depends:+ base == 4.*, unix == 2.5.*, QuickCheck == 2.4.*+ ,+ -- Everything the library depends on :-|+ base == 4.*+ ,+ -- control+ mtl == 2.*, stm == 2.2.*+ ,+ -- util+ old-time == 1.*, random == 1.*, time == 1.*+ ,+ -- data structures+ array == 0.4.*, containers == 0.4.*, hashable == 1.*+ ,+ -- packing+ snappy == 0.2.*+ ,+ -- bytestring+ bytestring == 0.9.*, base16-bytestring == 0.1.*, base64-bytestring == 0.1.*,+ cereal == 0.3.*+ ,+ -- files+ directory == 1.*, filepath == 1.*+ ,+ -- crypto+ cprng-aes == 0.2.*, entropy >= 0.2++ ghc-options:+ -threaded+ -Wall+++library+ exposed-modules:+ Data.BTree.BTree+ Data.BTree.Class+ Data.BTree.Types++ Data.BTree.Cache.Class+ Data.BTree.Cache.STM+ Data.BTree.HashTable.STM++ Data.BTree.KVBackend.Class+ Data.BTree.KVBackend.Files+ Data.BTree.KVBackend.Util+++ build-depends:+ base == 4.*+ ,+ -- control+ mtl == 2.*, stm == 2.2.*+ ,+ -- util+ old-time == 1.*, random == 1.*, time == 1.*+ ,+ -- data structures+ array == 0.4.*, containers == 0.4.*, hashable == 1.*+ ,+ -- packing+ snappy == 0.2.*+ ,+ -- bytestring+ bytestring == 0.9.*, base16-bytestring == 0.1.*, base64-bytestring == 0.1.*,+ cereal == 0.3.*+ ,+ -- files+ directory == 1.*, filepath == 1.*+ ,+ -- crypto+ cprng-aes == 0.2.*, entropy >= 0.2+++ ghc-options:+ -funbox-strict-fields+ -Wall+ -fno-warn-hi-shadowing+ -fno-warn-name-shadowing+ -fno-warn-missing-signatures -O2