diff --git a/Control/Concurrent/AdvSTM.hs b/Control/Concurrent/AdvSTM.hs --- a/Control/Concurrent/AdvSTM.hs +++ b/Control/Concurrent/AdvSTM.hs @@ -23,6 +23,8 @@ , catchSTM , liftAdv , newTVar + , readTVarAsync + , writeTVarAsync , readTVar , writeTVar ) @@ -62,9 +64,9 @@ instance MonadAdvSTM AdvSTM where onCommit ioaction = do - commitVar <- AdvSTM $ asks commitTVar - commitFun <- liftAdv $ STVar.readTVar commitVar - liftAdv $ STVar.writeTVar commitVar $ commitFun . (ioaction >>) + commitVar <- AdvSTM $ asks commitTVar + commitActions <- liftAdv $ STVar.readTVar commitVar + liftAdv $ STVar.writeTVar commitVar $ ioaction : commitActions -- unsafeOnRetry ioaction = do -- retryVar <- AdvSTM $ asks retryMVar @@ -128,6 +130,8 @@ liftAdv $ putTMVar (onCommitLock tvar) () + writeTVarAsync tvar = liftAdv . STVar.writeTVar (valueTVar tvar) + -------------------------------------------------------------------------------- -- | Reads a value from a TVar. Blocks until the IO onCommit action(s) of @@ -148,7 +152,9 @@ return result + readTVarAsync = liftAdv . STVar.readTVar . valueTVar + -- | Forks a separate thread to run the IO action and then retries the transaction. unsafeRetryWith io = do -- unsafeOnRetry io >> retry doneMVar <- AdvSTM $ asks retryDoneMVar @@ -172,10 +178,10 @@ debug "***************************************************************" 0 debugging debug (show (tid,"Starting transaction...")) 1000000 debugging -- Building the Reader monad environment - commitVar <- STVar.newTVarIO id -- IO actions to be run if the transaction commits + commitVar <- STVar.newTVarIO [] -- IO actions to be run if the transaction commits retryDoneMVar <- newMVar $ Just () commitListeners <- STVar.newTVarIO [] - let env = Env { commitTVar = commitVar :: STVar.TVar (IO () -> IO ()) + let env = Env { commitTVar = commitVar :: STVar.TVar [IO ()] -- -> IO ()) , retryDoneMVar = retryDoneMVar :: MVar (Maybe ()) -- (IO () -> IO ()) , transThreadId = tid :: ThreadId , listeners = commitListeners :: STVar.TVar [(TMVar (),TVarValue)] @@ -214,8 +220,8 @@ stopRetryWith -- Now try to run the onCommit IO actions: - commitFun <- S.atomically $ STVar.readTVar commitVar - commitFun (return ()) `catch` (\(e::SomeException) -> rollbackOnCommit >> throw e) + commitAcs <- S.atomically $ STVar.readTVar commitVar + sequence_ [ ac | ac <- commitAcs ] `catch` (\(e::SomeException) -> rollbackOnCommit >> throw e) -- Everything's ok, so notify and unblock the TVars: debug (show (tid,"*********************")) 1000000 debugging diff --git a/Control/Concurrent/AdvSTM/TVar.hs b/Control/Concurrent/AdvSTM/TVar.hs --- a/Control/Concurrent/AdvSTM/TVar.hs +++ b/Control/Concurrent/AdvSTM/TVar.hs @@ -18,9 +18,12 @@ , newTVarIO , readTVar , writeTVar + , readTVarAsync + , writeTVarAsync ) where -import Control.Monad.AdvSTM.Class(readTVar,writeTVar,newTVar,TVar(TVar)) +import Control.Monad.AdvSTM.Class + (readTVar,writeTVar,newTVar,TVar(TVar),valueTVar,readTVarAsync,writeTVarAsync) import qualified Control.Concurrent.STM.TVar as OldTVar import qualified Control.Concurrent.STM.TMVar as OldTMVar import Control.Monad(liftM,ap) diff --git a/Control/Monad/AdvSTM/Class.hs b/Control/Monad/AdvSTM/Class.hs --- a/Control/Monad/AdvSTM/Class.hs +++ b/Control/Monad/AdvSTM/Class.hs @@ -43,9 +43,9 @@ -- | Takes an IO action that will be executed /iff/ the transaction commits. -- - -- * When a TVar was modified in a transaction and this transaction commits, + -- * When a TVar was modified in a transaction and the transaction tries to commit, -- this update remains invisible to other threads until the corresponding - -- onCommit action was run. + -- onCommit action is dispatched. -- -- * If the onCommit action throws an exception, the original value of -- the TVars will be restored. @@ -63,6 +63,8 @@ -- > x <- readTVar tvar -- > onCommit (writeFile "myfile" x) -- + -- Note: If you /really/ need to access the 'TVar' within an onCommit action + -- (e.g. to recover from an IO exception), you can use 'writeTVarAsync'. -- onCommit :: IO () -> m () @@ -103,6 +105,16 @@ -- complete. See 'onCommit' for details. writeTVar :: TVar a -> a -> m () + -- | Reads a value directly from the TVar. Does not block when the + -- onCommit actions aren't done yet. NOTE: Only use this function when + -- you know what you're doing. + readTVarAsync :: TVar a -> m a + + -- | Writes a value directly to the TVar. Does not block when + -- onCommit actions aren't done yet. This function comes in handy for + -- error recovery of exceptions that occur in onCommit. + writeTVarAsync :: TVar a -> a -> m () + -- | See 'OldTVar.newTVar' newTVar :: a -> m (TVar a) @@ -151,6 +163,10 @@ writeTVar tvar = lift . writeTVar tvar + readTVarAsync = lift . readTVarAsync + + writeTVarAsync tvar = lift . writeTVarAsync tvar + newTVar = lift . newTVar -------------------------------------------------------------------------------- @@ -197,6 +213,10 @@ writeTVar tvar = lift . writeTVar tvar + readTVarAsync = lift . readTVarAsync + + writeTVarAsync tvar = lift . writeTVarAsync tvar + newTVar = lift . newTVar -------------------------------------------------------------------------------- @@ -222,9 +242,14 @@ liftAdv = lift . liftAdv - readTVar = lift . readTVar + writeTVarAsync tvar = lift . writeTVarAsync tvar + + readTVarAsync = lift . readTVarAsync + writeTVar tvar = lift . writeTVar tvar + + readTVar = lift . readTVar newTVar = lift . newTVar diff --git a/Control/Monad/AdvSTM/Def.hs b/Control/Monad/AdvSTM/Def.hs --- a/Control/Monad/AdvSTM/Def.hs +++ b/Control/Monad/AdvSTM/Def.hs @@ -32,9 +32,9 @@ -- | The environment used for the Reader Monad -data Env = Env { commitTVar :: TVar (IO () -> IO ()) -- the commit action(s) +data Env = Env { commitTVar :: TVar [IO ()] -- the commit action(s) , retryDoneMVar :: MVar (Maybe ()) -- (IO () -> IO ()) -- the retry action(s) - , transThreadId :: ThreadId -- the current ThreadId + , transThreadId :: ThreadId -- the current ThreadId , listeners :: TVar [(TMVar (),TVarValue)] -- ,TVar (Maybe ThreadId),TChan (Maybe ThreadId))] -- Contains communication facilities for modified TVars: -- [(tVar-Lock,Old-tVar-Value,Maybe (current ThreadId) diff --git a/stm-io-hooks.cabal b/stm-io-hooks.cabal --- a/stm-io-hooks.cabal +++ b/stm-io-hooks.cabal @@ -14,7 +14,7 @@ the modified TVars are restored. . Note: The package can be used as a drop-in replacement for - 'Control.Concurrent.STM'. Part of this library uses code from + 'Control.Concurrent.STM'. This library was inspired by the AdvSTM monad on the Haskell Wiki (see ). . Feedback is welcome! @@ -26,7 +26,7 @@ License: BSD3 License-file: LICENSE Homepage: http://darcs.monoid.at/stm-io-hooks -Version: 0.5.4 +Version: 0.6.0 Build-type: Simple Cabal-Version: >= 1.2.3 @@ -44,9 +44,9 @@ build-depends: base >= 4 && < 5 ,stm >= 2.1.1.2 && < 2.2 - ,array >= 0.2.0.0 && < 0.3 - ,containers >= 0.2.0.0 && < 0.3 - ,mtl >= 1.1.0.2 && < 1.2 + ,array >= 0.2.0.0 && < 0.4 + ,containers >= 0.2.0.0 && < 0.4 + ,mtl >= 1.1.0.2 && < 1.3 extensions: MultiParamTypeClasses FunctionalDependencies