diff --git a/Control/Concurrent/TBox.hs b/Control/Concurrent/TBox.hs --- a/Control/Concurrent/TBox.hs +++ b/Control/Concurrent/TBox.hs @@ -17,11 +17,12 @@ -- * Operations on a TBox read, write, - delete, + clear, isEmpty, + isEmptyNotDirty, ) where -import Control.Concurrent.TBox.Class -import Control.Concurrent.TBox.Operations +import Control.Concurrent.TBox.Internal.Class +import Control.Concurrent.TBox.Internal.Operations import Prelude hiding (read,readIO) diff --git a/Control/Concurrent/TBox/Class.hs b/Control/Concurrent/TBox/Class.hs deleted file mode 100644 --- a/Control/Concurrent/TBox/Class.hs +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Concurrent.TBox.Class --- Copyright : Peter Robinson 2009 --- License : LGPL --- --- Maintainer : Peter Robinson --- Stability : experimental --- Portability : non-portable (requires STM) --- --- The type class 'TBox'. --- --- ------------------------------------------------------------------------------ -module Control.Concurrent.TBox.Class -where -import Control.Concurrent.AdvSTM -import Prelude hiding(readIO) - --------------------------------------------------------------------------------- --- | An instance of 'TBox' is a (Adv)STM variable that might contain a value of --- some type 'a'. In contrast to a plain 'TVar', a --- 'TBox' has IO hooks that are executed transparently on updates and reads. --- The functions of the type class shouldn't be exposed directly but should be used via --- the interface defined in the module 'TBox.Operations'. --- --- See the module 'TFile' for a concrete instantiation. -class TBox t a where - writeSTM :: t a -> a -> AdvSTM () - writeIO :: t a -> a -> IO () - - readSTM :: t a -> AdvSTM (Maybe a) - -- | Note: Might be executed multiple times for the - -- same 'TBox' in a single transaction. See 'unsafeRetryWith'. - readIO :: t a -> IO (Maybe a) - - deleteSTM :: t a -> AdvSTM () - deleteIO :: t a -> IO () - - -- | If 'isDirty' yields 'True', the 'readIO' hook will be run on the next - -- read. - isDirty :: t a -> AdvSTM Bool - setDirty :: t a -> Bool -> AdvSTM () - --- modifySTM :: t a -> (a -> a) -> AdvSTM () --- modifySTM t f = readSTM t >>= writeSTM t . f --- modifyIO :: t a -> (a -> a) -> AdvSTM () --- modifyIO t f = readIO t >>= - - diff --git a/Control/Concurrent/TBox/Internal/Class.hs b/Control/Concurrent/TBox/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/TBox/Internal/Class.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.TBox.Internal.Class +-- Copyright : Peter Robinson 2009 +-- License : LGPL +-- +-- Maintainer : Peter Robinson +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- The type class 'TBox'. +-- +-- +----------------------------------------------------------------------------- +module Control.Concurrent.TBox.Internal.Class +where +import Control.Concurrent.AdvSTM +import Prelude hiding(readIO) + +-------------------------------------------------------------------------------- +-- | An instance of 'TBox' is a (Adv)STM variable that might contain a value of +-- some type 'a'. In contrast to a plain 'TVar (Maybe a)', a +-- 'TBox' has IO hooks that are executed transparently on writes and reads, +-- which makes it particularly suitable for implementing a persistent and thread-safe storage. +-- The type variable 'k' can be used to provide additional storage information, e.g., +-- a filepath. +-- +-- /Important:/ Note that the read/write functions of this type class, i.e., +-- 'readIO', 'readSTM', 'writeIO', 'writeSTM', 'clearIO', 'clearSTM' should +-- /only/ be used to derive new +-- instances and do not serve to modify the state of a 'TBox'. +-- The interface defined in module 'TBox.Operations' provides +-- operations on 'TBox's that guarantee consistency. +-- +-- See the module 'Control.Concurrent.TFile' for a sample instance. +class TBox t k a where + -- | Takes a key and an initial value + new :: k -> a -> AdvSTM (t k a) + -- | Takes a key and an initial value. Has a default implementation. + newIO :: k -> a -> IO (t k a) + newIO k a = atomically (new k a) + + -- | Takes a key and returns an empty 't' + newEmpty :: k -> AdvSTM (t k a) + -- | Takes a key and returns an empty 't'. Has a default implementation. + newEmptyIO :: k -> IO (t k a) + newEmptyIO = atomically . newEmpty + +-- -- | Return the key +-- getKey :: t k a -> AdvSTM k + + -- | Used in 'TBox.write'. + writeSTM :: t k a -> a -> AdvSTM () + -- | Used in 'TBox.write' during the commit phase. + -- Is guaranteed to be executed exactly once /iff/ the transaction commits. + writeIO :: t k a -> a -> IO () + + -- | Used in 'TBox.read' + readSTM :: t k a -> AdvSTM (Maybe a) + -- | Used in 'TBox.read' when retrying the transaction, which happens when the + -- 'TBox' has been marked \"dirty\". + -- Note: Might be executed multiple times for the + -- same 'TBox' in a single transaction. See 'unsafeRetryWith'. + readIO :: t k a -> IO (Maybe a) + + -- | Used in 'TBox.clear' + clearSTM :: t k a -> AdvSTM () + -- | Used in 'TBox.clear' during the commit phase. + -- Is guaranteed to be executed exactly once /iff/ the transaction commits. + clearIO :: t k a -> IO () + + -- | If 'isDirty' yields 'True', the 'readIO' hook will be + -- run on the next read. + isDirty :: t k a -> AdvSTM Bool + -- | Change the \"dirty\" status of the 'TBox'. + setDirty :: t k a -> Bool -> AdvSTM () + +{- +-- TODO: what about modify? + modifySTM :: t k a -> (a -> a) -> AdvSTM () + modifyIO :: t k a -> (a -> a) -> IO (Maybe a) + modifySTM t f = readSTM t >>= writeSTM t . f + modifyIO t f = readIO t >>= writeIO t +-} + diff --git a/Control/Concurrent/TBox/Internal/Operations.hs b/Control/Concurrent/TBox/Internal/Operations.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/TBox/Internal/Operations.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.TBox.Internal.Operations +-- Copyright : Peter Robinson 2009 +-- License : LGPL +-- +-- Maintainer : Peter Robinson +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- Operations on instances of 'TBox'. +-- +----------------------------------------------------------------------------- +module Control.Concurrent.TBox.Internal.Operations +where +import Control.Concurrent.TBox.Internal.Class +import Control.Monad +import Control.Concurrent.AdvSTM +import Data.Maybe +import Control.Monad.Loops + +import Prelude hiding(lookup,catch,null,read,readIO,writeFile) + + +-------------------------------------------------------------------------------- + +-- | Deletes the content. +clear :: (TBox t k a) => t k a -> AdvSTM () +clear tbox = do + clearSTM tbox + setDirty tbox False + onCommit $ clearIO tbox + +-- | Writes the new content. +write :: (TBox t k a) => t k a -> a -> AdvSTM () +write tbox a = do + writeSTM tbox a + setDirty tbox False + onCommit $ writeIO tbox a + +-- | If the TBox is dirty, this retries the transaction and +-- rereads the content using 'readIO' in a separate thread. +-- Otherwise it simply returns the result of 'readSTM'. +-- +-- Note: Depending on the instance implementation, careless +-- use of 'setDirty' and 'read' in the same transaction might lead +-- to nonterminating retry loops. +read :: TBox t k a => t k a -> AdvSTM (Maybe a) +read tbox = do + dirty <- isDirty tbox + if dirty + then unsafeRetryWith $ do + !mvalIO <- readIO tbox +-- print "retrying" + atomically $ do + stillDirty <- isDirty tbox + when stillDirty $ do + setDirty tbox False + case mvalIO of + Nothing -> clearSTM tbox + Just v -> writeSTM tbox v + else + readSTM tbox + +-- | Returns 'True' iff the 'TBox' is empty. +isEmpty :: TBox t k a => t k a -> AdvSTM Bool +isEmpty = liftM isJust . readSTM + +-- | Returns 'True' iff the 'TBox' is empty and not dirty. +isEmptyNotDirty :: TBox t k a => t k a -> AdvSTM Bool +isEmptyNotDirty t = andM [isEmpty t,isDirty t] diff --git a/Control/Concurrent/TBox/Operations.hs b/Control/Concurrent/TBox/Operations.hs deleted file mode 100644 --- a/Control/Concurrent/TBox/Operations.hs +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Control.Concurrent.TBox.Operations --- Copyright : Peter Robinson 2009 --- License : LGPL --- --- Maintainer : Peter Robinson --- Stability : experimental --- Portability : non-portable (requires STM) --- --- Operations on instances of 'TBox'. --- ------------------------------------------------------------------------------ -module Control.Concurrent.TBox.Operations -where -import Control.Concurrent.TBox.Class -import Control.Monad -import Control.Concurrent.AdvSTM -import Data.Maybe - -import Prelude hiding(lookup,catch,null,read,readIO,writeFile) - - --------------------------------------------------------------------------------- - --- | Deletes the content. -delete :: (TBox t a) => t a -> AdvSTM () -delete tbox = do - deleteSTM tbox - setDirty tbox False - onCommit $ deleteIO tbox - --- | Writes the new content. -write :: (TBox t a) => t a -> a -> AdvSTM () -write tbox a = do - writeSTM tbox a - setDirty tbox False - onCommit $ writeIO tbox a - --- | If the TBox is dirty, this retries the transaction and --- rereads the content using 'readIO' in a separate thread. --- Otherwise it simply returns the result of 'readSTM'. --- --- Note: Depending on the implementation, careless --- use of 'setDirty' and 'read' in the same transaction might lead --- to nonterminating retry loops. -read :: TBox t a => t a -> AdvSTM (Maybe a) -read tbox = do - dirty <- isDirty tbox - if dirty - then unsafeRetryWith $ do - mvalIO <- readIO tbox - atomically $ do - stillDirty <- isDirty tbox - when stillDirty $ do - setDirty tbox False - case mvalIO of - Nothing -> deleteSTM tbox - Just v -> writeSTM tbox v - else - readSTM tbox - --- | Returns 'True' iff the 'TBox' is empty. -isEmpty :: TBox t a => t a -> AdvSTM Bool -isEmpty = liftM isJust . readSTM - diff --git a/Control/Concurrent/TBox/TSkipList.hs b/Control/Concurrent/TBox/TSkipList.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/TBox/TSkipList.hs @@ -0,0 +1,312 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.TBox.TSkipList +-- Copyright : Peter Robinson 2010 +-- License : LGPL +-- +-- Maintainer : Peter Robinson +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- Provides an implementation of a skip list in the 'AdvSTM' monad. +-- A skip list is a probabilistic data structure with map-like operations. +-- In contrast to a balanced tree, a skip list does not need any rebalancing, +-- which makes it suitable for concurrent programming. +-- See: /William Pugh. Skip Lists: A Probabilistic Alternative to Balanced Trees./ +-- +-- The elements of the skip list are stored in a 'TBox'. +-- When an element of the skip list is modified, the operation is relegated +-- to the corresponding 'TBox'. +-- +-- For a concrete instance see module 'Control.Concurrent.TFile.TSkipList' +----------------------------------------------------------------------------- + +module Control.Concurrent.TBox.TSkipList(-- * Data type + TSkipList,newIO, + -- * Operations + insert,lookup,update,delete,geq,leq,min,filter, + -- * Low-level Operations + insertNode,lookupNode,readAndValidate,newNode, + contentTBox,key, + -- * Utilities + chooseLevel, + toString, + ) + +where +import Control.Concurrent.TBox(TBox) +import qualified Control.Concurrent.TBox as TBox + +import Control.Exception +import Control.Concurrent.AdvSTM.TVar +import Control.Concurrent.AdvSTM.TArray +import Control.Concurrent.AdvSTM +import Control.Applicative +import Control.Monad +import Control.Monad.IfElse(unlessM) + +import System.Random +import Data.Maybe +--import Data.List(unlines) +import Data.Map(Map) +import qualified Data.Map as M +import Data.Array.MArray +import Prelude hiding(lookup,filter,catch,min) + +type ForwardPtrs t k a = TArray Int (Node t k a) + + +data TSkipList t k a = TSkipList + { maxLevel :: Int + , probability :: Float + , curLevel :: TVar Int + , listHead :: ForwardPtrs t k a + } + +data Node t k a + = Nil + | Node { key :: k + , contentTBox :: t k a + , forwardPtrs :: ForwardPtrs t k a + } + +newNode :: TBox t k a => k -> t k a -> Int -> AdvSTM (Node t k a) +newNode k t maxLvl = Node k t `liftM` newForwardPtrs maxLvl + +isNil :: Node t k a -> Bool +isNil Nil = True +isNil _ = False + +-- | An empty skiplist. +newIO :: TBox t k a + => Float -- ^ Probability for choosing a new level + -> Int -- ^ Maximum number of levels + -> IO (TSkipList t k a) +newIO p maxLvl = + atomically $ new p maxLvl + + +-- | An empty skiplist. +new :: TBox t k a + => Float -- ^ Probability for choosing a new level + -> Int -- ^ Maximum number of levels + -> AdvSTM (TSkipList t k a) +new p maxLvl = + TSkipList maxLvl p `liftM` {- newTVar stdG + `ap` -} newTVar 1 + `ap` newForwardPtrs maxLvl + + +newForwardPtrs :: Int -> AdvSTM (ForwardPtrs t k a) +newForwardPtrs maxLvl = newListArray (1,maxLvl) $ replicate maxLvl Nil + + +-- | Returns a randomly chosen level. Is used for inserting new elements. +-- Note that this function uses 'unsafeIOToAdvSTM' to access the random +-- number generator. +chooseLevel :: TSkipList t k a -> AdvSTM Int +chooseLevel tskip = do + stdG <- unsafeIOToAdvSTM newStdGen + let rs :: StdGen -> [(Float)] + rs g = x : rs g' where (x,g') = randomR (0,1) g + let samples = take (maxLevel tskip - 1) (rs stdG) + return $ 1 + length (takeWhile ((probability tskip) <) $ samples) + + +-- | Returns all elements that are smaller than the key. +leq :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM (Map k a) +leq k tskip = + leqAcc (listHead tskip) 1 M.empty + where + leqAcc fwdPtrs lvl curAcc = do + let moveDown acc _ level = + leqAcc fwdPtrs (level-1) acc + let moveRight acc succNode level = do + newAcc <- addElem acc succNode + leqAcc (forwardPtrs succNode) level newAcc + let onFound acc succNode _ = + addElem acc succNode + traverse k fwdPtrs lvl (moveDown curAcc) (moveRight curAcc) (onFound curAcc) (moveDown curAcc) curAcc + + addElem acc succNode = + maybe acc (\a -> M.insert (key succNode) a acc) <$> readAndValidate tskip succNode + + +-- | Returns all elements that are greater than the key. +-- TODO: currently in O(n), can be made more efficient (like 'leq') +geq :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM (Map k a) +geq k = filter (\k' _ -> (k'>=k)) + +-- | Returns the element with the least key, if it exists. /O(1)/. +min :: (Ord k, TBox t k a) => TSkipList t k a -> AdvSTM (Maybe a) +min tskip = do + node <- readArray (listHead tskip) 1 + if isNil node + then return Nothing + else readAndValidate tskip node + +-- | Reads the 'TBox' of the node. If the 'TBox' is empty, the node +-- is removed from the skip list. +-- This is necessary when 'TBox's are shared between different data +-- structures. +readAndValidate :: (Ord k, TBox t k a) + => TSkipList t k a -> Node t k a -> AdvSTM (Maybe a) +readAndValidate tskip succNode = do + ma <- TBox.read (contentTBox succNode) + case ma of + Just a -> return $ Just a + Nothing -> do + delete (key succNode) tskip + return Nothing + +{- + maxAcc (listHead tskip) 1 M.empty + where + maxAcc fwdPtrs level acc = do + succNode <- readArray fwdPtrs level + if isNil succNode + then return Nothing + else do + if isNil succsuccNode + then return (key succNode) + else maxAcc (forwardPtrs succNode) level newAcc + newAcc <- addElem acc succNode + filterAcc (forwardPtrs succNode) level newAcc +-} + + +lookupNode :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM (Maybe (Node t k a)) +lookupNode k tskip = + lookupAcc (listHead tskip) =<< readTVar (curLevel tskip) + where + lookupAcc fwdPtrs lvl = do + let moveDown _ level = lookupAcc fwdPtrs (level-1) + let moveRight succNode = lookupAcc (forwardPtrs succNode) + let onFound succNode _ = return (Just succNode) + traverse k fwdPtrs lvl moveDown moveRight onFound moveDown Nothing + + +lookup :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM (Maybe a) +lookup k tskip = + maybe (return Nothing) + (readAndValidate tskip) =<< lookupNode k tskip + + +-- | Updates an element. Throws 'AssertionFailed' if the element is not in the +-- list. +update :: ({- Show k,-}Ord k, TBox t k a) => k -> a -> TSkipList t k a -> AdvSTM () +update k a tskip = + maybe (throw $ AssertionFailed "TSkipList.update: element not found!") + (flip TBox.write a . contentTBox) =<< lookupNode k tskip + + +delete :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM () +delete k tskip = + deleteAcc (listHead tskip) =<< readTVar (curLevel tskip) + where + deleteAcc fwdPtrs lvl = do + let moveDown _ level = deleteAcc fwdPtrs (level-1) + let moveRight succNode = deleteAcc (forwardPtrs succNode) + let onFound succNode level = do + let tbox = contentTBox succNode + unlessM (TBox.isEmptyNotDirty tbox) $ + TBox.clear (contentTBox succNode) + succsuccNode <- readArray (forwardPtrs succNode) level + writeArray fwdPtrs level succsuccNode + moveDown succNode level + traverse k fwdPtrs lvl moveDown moveRight onFound moveDown () + + +insert :: ({- Show k,-}Ord k, TBox t k a) => k -> a -> TSkipList t k a -> AdvSTM () +insert k a tskip = do + -- Make new TBox: + tbox <- TBox.new k a + newPtrs <- newForwardPtrs (maxLevel tskip) + let node = Node k tbox newPtrs + insertNode k node tskip + + +insertNode :: ({- Show k,-}Ord k, TBox t k a) => k -> Node t k a -> TSkipList t k a -> AdvSTM () +insertNode k node tskip = do + newLevel <- chooseLevel tskip + -- Adapt current maximum level: + curLvl <- readTVar (curLevel tskip) + when (curLvl < newLevel) $ + writeTVar (curLevel tskip) newLevel + insertAcc (listHead tskip) newLevel + where + insertAcc fwdPtrs lvl = do + let moveDown succNode level = do + writeArray (forwardPtrs node) level succNode + writeArray fwdPtrs level node + insertAcc fwdPtrs (level-1) + let moveRight succNode = + insertAcc (forwardPtrs succNode) + let onFound _ level = do + writeArray fwdPtrs level node + insertAcc fwdPtrs (level-1) + traverse k fwdPtrs lvl moveDown moveRight onFound moveDown () + + +traverse :: ({- Show k,-}Ord k, TBox t k a) + => k -> ForwardPtrs t k a -> Int + -> (Node t k a -> Int -> AdvSTM b) + -> (Node t k a -> Int -> AdvSTM b) + -> (Node t k a -> Int -> AdvSTM b) + -> (Node t k a -> Int -> AdvSTM b) + -> b + -> AdvSTM b +traverse k fwdPtrs level onLT onGT onFound onNil def + | level < 1 = return def + | otherwise = do + succNode <- readArray fwdPtrs level + if isNil succNode + then onNil succNode level + else case k `compare` key succNode of + GT -> onGT succNode level + LT -> onLT succNode level + EQ -> onFound succNode level + + +-- | Returns all elements that satisfy the predicate. O(n). +filter :: ({- Show k,-}Ord k, TBox t k a) + => (k -> a -> Bool) -> TSkipList t k a -> AdvSTM (Map k a) +filter p tskip = + filterAcc (listHead tskip) 1 M.empty + where + filterAcc fwdPtrs level acc = do + succNode <- readArray fwdPtrs level + if isNil succNode + then return acc + else do + newAcc <- addElem acc succNode + filterAcc (forwardPtrs succNode) level newAcc + + addElem acc succNode = + maybe acc (\a -> if p (key succNode) a + then M.insert (key succNode) a acc + else acc) + <$> readAndValidate tskip succNode + + +-- | Debug helper. Returns the skip list as a string. +-- All elements smaller than the given key are written to the string. +toString :: (Ord k, Show k, TBox t k a) => k -> TSkipList t k a -> AdvSTM String +toString k tskip = do + curLvl <- readTVar (curLevel tskip) + ls <- forM (reverse [1..curLvl]) $ printAcc (listHead tskip) [] + return $ unlines ls + where + printAcc fwdPtrs acc curLvl = do + let moveDown succNode level = + if (isNil succNode) + then return acc + else printAcc (forwardPtrs succNode) acc level + let moveRight succNode level = do + let n = (' ':show (key succNode)) + printAcc (forwardPtrs succNode) (acc++n) level + let onFound succNode level = do + let n = (' ':show (key succNode)) + printAcc (forwardPtrs succNode) (acc++n) level + traverse k fwdPtrs curLvl moveDown moveRight onFound moveDown "" + diff --git a/Control/Concurrent/TFile.hs b/Control/Concurrent/TFile.hs --- a/Control/Concurrent/TFile.hs +++ b/Control/Concurrent/TFile.hs @@ -9,28 +9,37 @@ -- Portability : non-portable (requires STM) -- -- --- A transactional variable that writes its content to a file on each update. +-- A transactional variable that writes its content to a file when updated. +-- Due to the atomicity guarantees of the 'AdvSTM' monad, an update to a +-- 'TFile' is only committed when the file operation succeeds. -- -- This module should be imported qualified. -- ----------------------------------------------------------------------------- -module Control.Concurrent.TFile( -- * Data type +module Control.Concurrent.TFile( + -- * Data type TFile, - -- * Construction - newEmptyIO, - newIO, +-- -- * Construction +-- newIO, +-- new, new, + newIO, + newFromFileIO, + newEmpty, + newEmptyIO, + newEmptyFromFileIO, -- * Operations read, write, - delete, - isEmpty + clear, + isEmpty, + -- * Utilities + basedir, ) where -import Control.Concurrent.TBox.Class -import Control.Concurrent.TBox.Operations +import Control.Concurrent.TBox import Data.Binary import Data.Typeable @@ -38,24 +47,30 @@ import Control.Concurrent.AdvSTM import Control.Concurrent.AdvSTM.TVar import Control.Monad +import Control.Monad.IfElse(unlessM) import Control.Exception +import System.FilePath((),takeFileName) import System.Directory import System.IO.Error hiding(catch) import System.IO.Cautious(writeFileL) import Prelude hiding(lookup,catch,null,read,readIO,writeFile) +import qualified Prelude as P +import qualified Safe.Failure as Safe -------------------------------------------------------------------------------- -- | A transactional variable that writes its content to a file on each update. +-- The file is created in directory \".\/_TFile\/\". -- --- * The updated memory content of the TFile is not visible to other threads --- until the file has been written successfully. +-- * The 'onCommit' hook of the 'AdvSTM' monad guarantee that the updated memory content +-- of the TFile is only visible to other threads /iff/ the file has been written +-- successfully. -- -- * If the 'TFile' is \"dirty\", the content is (re)read from the file on the next -- 'read'. -- -data TFile a = TF +data TFile k a = TF { filepath :: FilePath , tfileTVar :: TVar (Maybe a) , dirtyTVar :: TVar Bool @@ -63,42 +78,80 @@ } deriving(Typeable) --- | Constructs an initially empty 'TFile' that is marked dirty. --- That means, on the next 'read', the contents of the provided file (if it --- exists) will be loaded into the 'TFile'. -newEmptyIO :: Binary a => FilePath -> IO (TFile a) -newEmptyIO fp = - TF fp `liftM` newTVarIO Nothing - `ap` (newTVarIO =<< doesFileExist fp) - `ap` newTMVarIO () -newIO :: Binary a => FilePath -> a -> IO (TFile a) -newIO fp = atomically . new fp +-- | Currently set to \".\/_TFile\" +-- TODO: provide interface for updating base directory within a transaction(?) +basedir :: FilePath +basedir = "_TFile" -new :: Binary a => FilePath -> a -> AdvSTM (TFile a) -new fp a = do - tbox <- TF fp `liftM` newTVar (Just a) - `ap` newTVar False - `ap` newTMVar () - write tbox a - return tbox -instance Binary a => TBox TFile a where - writeSTM tbox = writeTVar (tfileTVar tbox) . Just +-- | Tries to construct a 'TFile' from a given filepath. +-- Reads the content of the file into memory. +newFromFileIO :: (Read k,TBox TFile k a) => FilePath -> IO (TFile k a,k) +newFromFileIO fp = do + (t,k) <- newEmptyFromFileIO fp + _ <- atomically $ read t + return (t,k) - writeIO (TF fp _ _ lock) = withTMVar lock . const . writeFileL fp . encode +-- | Tries to construct a 'TFile' from a given filepath. +-- Note that the content of the file is read into memory only on demand, i.e., +-- when executing 'TBox.read'. +-- Throws 'AssertionFailed' if the filename could not be parsed. +newEmptyFromFileIO :: (Read k,TBox TFile k a) => FilePath -> IO (TFile k a,k) +newEmptyFromFileIO fp = do + k <- Safe.read (takeFileName fp) `catch` (\(_::Safe.SafeException) -> + throw $ AssertionFailed ("Could not parse filename: " ++ fp)) + t <- newEmptyIO k + return (t,k) + +{- maybe (throw $ AssertionFailed ("Could not parse filename: " ++ fp)) + (\k -> do + t <- newEmptyIO k + return (t,k)) + $ Safe.read (takeFileName fp) +-} +instance (Binary a,Show k) => TBox TFile k a where + newEmpty k = + let fp = basedir show k + in TF fp `liftM` newTVar Nothing + `ap` newTVar True + `ap` newTMVar () + + newEmptyIO k = do + unlessM (doesDirectoryExist basedir) $ + createDirectory basedir + let fp = basedir show k + TF fp `liftM` newTVarIO Nothing + `ap` (newTVarIO =<< doesFileExist fp) + `ap` newTMVarIO () + + new k a = do + let fp = basedir show k + tbox <- TF fp `liftM` newTVar (Just a) + `ap` newTVar False + `ap` newTMVar () + write tbox a + return tbox + + writeSTM tfile = writeTVar (tfileTVar tfile) . Just + + writeIO (TF fp _ _ lock) a = do + unlessM (doesDirectoryExist basedir) $ + createDirectory basedir + withTMVar lock $ const $ writeFileL fp $ encode a + readSTM = readTVar . tfileTVar - readIO (TF fp _ _ lock) = (do - a <- withTMVar lock $ const $ decodeFile fp - return $ Just a) + readIO tmap = do + a <- withTMVar (fileLock tmap) $ const $ decodeFile (filepath tmap) + return (Just a) `catch` \(e::IOException) -> if isDoesNotExistError e then return Nothing else throw e - deleteSTM tbox = writeTVar (tfileTVar tbox) Nothing + clearSTM tbox = writeTVar (tfileTVar tbox) Nothing - deleteIO (TF fp _ _ lock) = withTMVar lock $ const $ removeFile fp + clearIO (TF fp _ _ lock) = withTMVar lock $ const $ removeFile fp `catch` \(e::IOException) -> unless (isDoesNotExistError e) $ throw e isDirty = readTVar . dirtyTVar @@ -112,5 +165,4 @@ return res -------------------------------------------------------------------------------- - diff --git a/Control/Concurrent/TFile/TSkipList.hs b/Control/Concurrent/TFile/TSkipList.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/TFile/TSkipList.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.TFile.TSkipList +-- Copyright : Peter Robinson 2010 +-- License : LGPL +-- +-- Maintainer : Peter Robinson +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- Instantiates the STM skiplist implementation of +-- Control.Concurrent.TBox.TSkipList with the 'TFile' backend. +-- +-- This module should be imported qualified. +-- +-- Example: +-- +-- > t <- newIO 0.5 5 :: IO (TSkipList Int String) +-- > atomically $ sequence_ [ insert i (show i) t | i <- [1..10] ] +-- > +-- > putStr =<< atomically (toString 100 t) +-- > 9 +-- > 9 +-- > 3 7 9 +-- > 1 3 7 9 +-- > 1 2 3 4 5 6 7 8 9 10 +-- > +-- > atomically $ delete 7 t +-- > putStr =<< atomically (toString 100 t) +-- > 9 +-- > 9 +-- > 3 9 +-- > 1 3 9 +-- > 1 2 3 4 5 6 8 9 10 +-- > +-- > atomically $ sequence [ lookup i t | i <- [5..10] ] +-- > [Just "5",Just "6",Nothing,Just "8",Just "9",Just "10"] +-- > +-- > atomically $ update 8 "X" t +-- > atomically $ sequence [ lookup i t | i <- [5..10] ] +-- > [Just "5",Just "6",Nothing,Just "X",Just "9",Just "10"] +----------------------------------------------------------------------------- + +module Control.Concurrent.TFile.TSkipList(-- * Data type + TSkipList,newEmptyIO,newIO, + -- * Operations + insert,lookup,update,leq,geq,min,filter,delete, + -- * Utilities + chooseLevel, toString + ) +where +import Prelude hiding(lookup,filter,catch,min) +import qualified Prelude as P +import Control.Concurrent.TBox.TSkipList hiding (TSkipList,newIO) -- (insert,lookup,update,leq,geq,filter,delete,newEmptyIO,chooseLevel) +import qualified Control.Concurrent.TBox.TSkipList as TBox.TSkipList +import Control.Concurrent.TBox(TBox) +import qualified Control.Concurrent.TBox as TBox +import Control.Concurrent.AdvSTM +import Control.Exception +import System.Directory +import System.IO.Error hiding (catch) +import Data.Binary +import Control.Monad +import Control.Applicative +--import Data.List(lem) + +import Control.Concurrent.TFile(TFile) +import qualified Control.Concurrent.TFile as TFile + + +type TSkipList k a = TBox.TSkipList.TSkipList TFile k a + + +-- | Returns a new (reconstructed!) 'TSkipList'. Automatically inserts all 'TFile' entries found +-- in \"basedir\". +-- Note that the 'TFile's are initially empty, i.e., the file content will only be +-- read into memory on demand. +newEmptyIO :: (Binary a,Show k,Ord k,Read k,TBox TFile k a) => Float -> Int -> IO (TSkipList k a) +newEmptyIO p maxLvl = do + fs <- getFilesInDirectory TFile.basedir `catch` \(e::IOException) -> + if isDoesNotExistError e then return [] + else throw e + tskip <- TBox.TSkipList.newIO p maxLvl + forM_ fs (\(f::String) -> do + (t,k) <- TFile.newEmptyFromFileIO f + atomically $ do node <- newNode k t maxLvl + TBox.TSkipList.insertNode k node tskip) + return tskip + + +-- | Returns a new (reconstructed!) 'TSkipList'. Automatically inserts all 'TFile' entries found +-- in \"basedir\". +-- In contrast to 'newEmptyIO', the 'TFile's initially contain the file content. +-- Use this if you want to have all data in memory from the start. +newIO :: (Binary a,Show k,Ord k,Read k,TBox TFile k a) => Float -> Int -> IO (TSkipList k a) +newIO p maxLvl = do + fs <- getFilesInDirectory TFile.basedir `catch` \(e::IOException) -> + if isDoesNotExistError e then return [] + else throw e + tskip <- TBox.TSkipList.newIO p maxLvl + forM_ fs (\(f::String) -> do + (t,k) <- TFile.newEmptyFromFileIO f -- TODO: why *empty*? + atomically $ do + _ <- TBox.read t + node <- newNode k t maxLvl + TBox.TSkipList.insertNode k node tskip) + return tskip + + +getFilesInDirectory :: FilePath -> IO [FilePath] +getFilesInDirectory fp = + P.filter (flip notElem [".",".."]) <$> getDirectoryContents fp + diff --git a/tbox.cabal b/tbox.cabal --- a/tbox.cabal +++ b/tbox.cabal @@ -1,18 +1,36 @@ Name: tbox -Synopsis: Transactional variables with IO hooks +Synopsis: Transactional variables and data structures with IO hooks Description: - (to be expanded...) + This package provides STM data structures with IO hooks. + The basic building blocks are instances of class 'TBox'. Such an + instance is an STM variable that might contain a value of + some type 'a'. In contrast to a plain 'TVar (Maybe a)', a + 'TBox' has IO hooks that are executed transparently on writes and reads. + The IO hooks of the 'AdvSTM' monad extend the atomicity of STM transactions + to the on-commit IO actions, which makes it particularly suitable for + implementing a persistent and thread-safe storage. . - This package provides transactional variables with IO hooks. - See module 'Control.Concurrent.TFile' for a concrete instance. + See module Control.Concurrent.TFile for a (simple) instance of a 'TBox' + that serializes its content to a file via 'Data.Binary'. . - Feedback appreciated! + New in this release is the implementation of a skip list in module + Control.Concurrent.TBox.TSkipList. A skip list is a probabilistic data + structure that provides expected run time of /O(log n)/ for + dictionary operations (insert, lookup, filter, delete, update) similar to + a balanced tree. + The main advantage of a skip list is that it does not need rebalancing, + which could cause lots of contention among transactions. + The 'TFile' skip list instance tries to reconstruct its content from the + 'TFile'-directory. See module Control.Concurrent.TFile.TSkipList for a + usage example. + . + Feedback is highly appreciated! -Author: Peter Robinson 2009 +Author: Peter Robinson 2009, 2010 Maintainer: Peter Robinson License: LGPL License-file: LICENSE -Version: 0.0.0 +Version: 0.1.0 Category: Data, Concurrency Stability: experimental Homepage: http://darcs.monoid.at/tbox @@ -23,28 +41,43 @@ ghc-options: -Wall -fno-ignore-asserts -fwarn-incomplete-patterns exposed-modules: Control.Concurrent.TBox - Control.Concurrent.TBox.Class - Control.Concurrent.TBox.Operations + Control.Concurrent.TBox.Internal.Class + Control.Concurrent.TBox.Internal.Operations +-- Control.Concurrent.TBox.TList +-- Control.Concurrent.TBox.THashtable + Control.Concurrent.TBox.TSkipList Control.Concurrent.TFile +-- Control.Concurrent.TFile.TList +-- Control.Concurrent.TFile.THashtable + Control.Concurrent.TFile.TSkipList -- other-modules: test.hs build-depends: base >= 4 && < 5, - stm-io-hooks >= 0.5.0 && < 0.6, + stm-io-hooks >= 0.6.0 && < 0.7, mtl >= 1.1.0.2 && < 1.2, binary >= 0.5 && < 0.6, filepath >= 1.1 && < 1.2, directory >= 1.0.0.3 && < 1.1, - cautious-file >= 0.1.5 && < 0.2 --- containers >= 0.2.0.1 && < 0.3 + cautious-file >= 0.1.5 && < 0.2, + array >= 0.2 && < 0.4, + containers >= 0.2.0.1 && < 0.4, + random >= 1.0.0.1 && < 1.1, + monad-loops >= 0.3.0.2 && < 0.4.0.0, + IfElse >= 0.85 && < 1, + safe-failure >= 0.4.0 && < 0.5 extensions: MultiParamTypeClasses, -- RankNTypes, -- FunctionalDependencies, --- FlexibleContexts, + FlexibleContexts, FlexibleInstances, -- UndecidableInstances, DeriveDataTypeable, + ExistentialQuantification, + TypeSynonymInstances, + BangPatterns, ScopedTypeVariables -- TypeSynonymInstances +