diff --git a/Control/Concurrent/AdvSTM.hs b/Control/Concurrent/AdvSTM.hs --- a/Control/Concurrent/AdvSTM.hs +++ b/Control/Concurrent/AdvSTM.hs @@ -12,10 +12,6 @@ -- ----------------------------------------------------------------------------- --- TODO: remove type class or add readTVar/writeTVar to type class --- Try to change type of onCommit/retryWith to MonadIO! --- - module Control.Concurrent.AdvSTM( -- * Class MonadAdvSTM MonadAdvSTM( onCommit , onRetry @@ -37,19 +33,21 @@ , retryWith , atomically , unsafeIOToAdvSTM + , handleSTM , debugAdvSTM , debugMode ) where import Prelude hiding (catch) import Control.Monad.AdvSTM.Def(AdvSTM(..),Env(..),TVarValue(..)) -import Control.Monad.AdvSTM.Class( MonadAdvSTM(..), TVar( TVar ), onCommitLock, currentTid, valueTVar ) +import Control.Monad.AdvSTM.Class( + MonadAdvSTM(..), handleSTM, TVar( TVar ), onCommitLock, currentTid, valueTVar ) -- import Control.Monad.Reader(ReaderT(ReaderT),mapReaderT,runReaderT) -import Control.Exception(throw,catch,SomeException,fromException,try,block,Deadlock(..)) +import Control.Exception(Exception,throw,catch,SomeException,fromException,try,block,Deadlock(..)) import Control.Monad(mplus,when,liftM,ap,unless) -import Control.Monad.Reader(MonadReader(..),ReaderT,runReaderT,lift,asks) -import Control.Concurrent(threadDelay,forkIO,ThreadId,myThreadId) +import Control.Monad.Error(MonadError(..)) +import Control.Concurrent(threadDelay,forkIO,ThreadId,myThreadId,throwTo) import Control.Concurrent.Chan(Chan,newChan,readChan,writeChan) import Control.Concurrent.STM.TMVar(TMVar,putTMVar,takeTMVar,newTMVar,tryTakeTMVar) -- import Control.Concurrent.STM.TChan(TChan,writeTChan) @@ -59,6 +57,7 @@ import GHC.Conc(unsafeIOToSTM) import Data.IORef(newIORef,readIORef,writeIORef) import Data.Maybe(isJust,Maybe,fromJust) +import Control.Monad.Reader(MonadReader(..),ReaderT(ReaderT),runReaderT,lift,asks) -------------------------------------------------------------------------------- @@ -91,9 +90,9 @@ catchSTM action handler = do action' <- unlift action handler' <- unlift1 handler - let handler'' = \e -> case fromException e of - Nothing -> throw e - Just e' -> handler' e' + let handler'' e = case fromException e of + Nothing -> throw e + Just e' -> handler' e' liftAdv $ S.catchSTM action' handler'' liftAdv = AdvSTM . lift @@ -113,9 +112,9 @@ curTid <- AdvSTM $ asks transThreadId storedTid <- liftAdv $ STVar.readTVar (currentTid tvar) case commitLock of - Nothing -> do + Nothing -> if isJust storedTid && fromJust storedTid == curTid - then throw Deadlock -- No transaction during onCommit-phase! + then throw Deadlock -- Can't write the TVar in the onCommit phase else retry Just _ -> do unless (isJust storedTid && (fromJust storedTid == curTid)) $ do @@ -197,7 +196,7 @@ Nothing -> do chan <- newChan writeIORef retryChanVar (Just chan) - spawn'retry'thread (readChan chan) (putMVar retryEndVar ()) + spawn'retry'thread (readChan chan) (putMVar retryEndVar ()) tid return chan Just chan -> return chan writeChan chan $ Just (retryFun (return())) @@ -214,7 +213,7 @@ writeChan chan Nothing takeMVar retryEndVar - let wrappedAction = runReaderT action env `S.orElse` (check'retry) + let wrappedAction = runReaderT action env `S.orElse` check'retry -- Block interruptions from other threads for the rest of 'atomically' block $ do @@ -249,7 +248,7 @@ debug (show (tid,"Notifying TPVars that we're done:")) 0 debugging S.atomically $ do ls <- STVar.readTVar commitListeners - mapM_ (\(l,_) -> do + mapM_ (\(l,_) -> putTMVar l () ) ls wait'retry'finished @@ -259,8 +258,8 @@ where -- Helper thread for the retry IO-actions - spawn'retry'thread :: IO (Maybe (IO ())) -> IO () -> IO ThreadId - spawn'retry'thread nextJob atEndAction = forkIO $ loop + spawn'retry'thread :: IO (Maybe (IO ())) -> IO () -> ThreadId -> IO ThreadId + spawn'retry'thread nextJob atEndAction mainTId = forkIO loop where loop = do may'job <- nextJob case may'job of @@ -268,7 +267,7 @@ Just job -> do res <- try job case res of - Left (e::SomeException) -> throw e + Left (e::SomeException) -> throwTo mainTId e Right _ -> loop @@ -320,16 +319,17 @@ unlift1 :: (t -> AdvSTM a) -> AdvSTM (t -> S.STM a) unlift1 f = do u <- unlifter - return (\x -> u (f x)) + return (u . f) -- WARNING: Can lead to deadlocks! debugSTM :: String -> Int -> Bool -> S.STM () debugSTM msg delay debugging = - when (debugging) $ unsafeIOToSTM $ putStrLn msg >> threadDelay delay + when debugging $ unsafeIOToSTM $ putStrLn msg >> threadDelay delay -- WARNING: Can lead to deadlocks! debug :: String -> Int -> Bool -> IO () -debug msg delay debugging = when (debugging) $ putStrLn msg >> threadDelay delay - - +debug msg delay debugging = when debugging $ putStrLn msg >> threadDelay delay +instance (Exception e) => MonadError e AdvSTM where + throwError = throw + catchError = catchSTM 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.AdvSTM.Class --- Copyright : (c) HaskellWiki 2006-2007, Peter Robinson 2008 +-- Copyright : Peter Robinson 2008, HaskellWiki 2006-2007 -- License : BSD3 -- -- Maintainer : Peter Robinson @@ -13,18 +13,18 @@ -- MonadAdvSTM (see package description). ----------------------------------------------------------------------------- -module Control.Monad.AdvSTM.Class( MonadAdvSTM(..), TVar(TVar), valueTVar, onCommitLock, currentTid ) +module Control.Monad.AdvSTM.Class( MonadAdvSTM(..), handleSTM, TVar(TVar), valueTVar, onCommitLock, currentTid) where -import Control.Exception(Exception) +import Control.Exception(Exception,throw) import qualified Control.Concurrent.STM as S import qualified Control.Concurrent.STM.TVar as OldTVar import qualified Control.Concurrent.STM.TMVar as OldTMVar -import Control.Monad(Monad,liftM) +import Control.Monad(Monad,liftM,ap) import Control.Monad.Trans(lift) -import Control.Monad.Reader(ReaderT(ReaderT),mapReaderT,runReaderT) import Control.Monad.State(StateT(StateT),mapStateT,runStateT,evalStateT) import Control.Monad.Writer(WriterT(WriterT),mapWriterT,runWriterT,execWriterT) +import Control.Monad.Reader(ReaderT(ReaderT),mapReaderT,runReaderT) -- import Control.Monad.AdvSTM.Def(AdvSTM) import Control.Concurrent( ThreadId ) --import GHC.Conc( unsafeIOToSTM ) @@ -70,10 +70,14 @@ -- a new helper thread is forked that runs the retry actions, and, after the helper -- thread is done, the transaction retries. -- - -- Uses 'unsafeIOToSTM' to fork a helper thread that runs the retry - -- actions. - onRetry :: IO () -- ^ IO action that will be run on retry the transaction. - -> m () + -- /Note:/ When the transaction is retried, 'unsafeIOToSTM' is used to fork a + -- helper thread that runs the retry actions (if any). It is your + -- responsibility to ensure that your retry IO-actions are ``safe''. Any + -- exceptions occurring in the retry-thread will be thrown to the + -- thread where the transaction is running and immediately cause the transaction to be + -- aborted, since 'catchSTM' does not catch asynchronous exceptions. + onRetry :: IO () -- ^ IO action that will be run if the transaction is (explicitly) retried. + -> m () -- | See 'S.orElse' orElse :: m a -> m a -> m a @@ -91,12 +95,10 @@ -- | See 'S.always' always :: m Bool -> m () - -- | Runs a transaction atomically in the 'IO' monad. --- runAtomic :: m a -> IO a - -- | See 'S.catchSTM' catchSTM :: Exception e => m a -> (e -> m a) -> m a + -- | Lifts STM actions to 'MonadAdvSTM'. liftAdv :: S.STM a -> m a @@ -112,30 +114,44 @@ -- | See 'OldTVar.newTVar' newTVar :: a -> m (TVar a) +-- -- See 'S.atomically' +-- runAtomic :: m a -> IO a -- newTVarIO :: a -> IO (TVar a) +-- | A version of 'catchSTM' with the arguments swapped around. +handleSTM :: (MonadAdvSTM m, Exception e) => (e -> m a) -> m a -> m a +handleSTM = flip catchSTM -mapReaderT2 :: (m a -> n b -> o c) -> ReaderT w m a -> ReaderT w n b -> ReaderT w o c -mapReaderT2 f m1 m2 = ReaderT $ \r -> f (runReaderT m1 r) (runReaderT m2 r) -instance MonadAdvSTM m => MonadAdvSTM (ReaderT r m) where +-------------------------------------------------------------------------------- + + +mapStateT2 :: (m (a, s) -> n (b, s) -> o (c,s)) + -> StateT s m a -> StateT s n b -> StateT s o c +mapStateT2 f m1 m2 = StateT $ \s -> f (runStateT m1 s) (runStateT m2 s) + +liftAndSkipStateT f m = StateT $ \s -> let a = evalStateT m s + in do r <- f a + return (r,s) + +instance MonadAdvSTM m => MonadAdvSTM (StateT s m) where onCommit = lift . onCommit onRetry = lift . onRetry - orElse = mapReaderT2 orElse + orElse = mapStateT2 orElse retry = lift retry check = lift . check - alwaysSucceeds = mapReaderT alwaysSucceeds - - always = mapReaderT always - - - catchSTM m h = ReaderT (\r -> catchSTM (runReaderT m r) (\e -> runReaderT (h e) r)) + -- Note: The state modifications of the invariant action + -- are thrown away! + alwaysSucceeds = liftAndSkipStateT alwaysSucceeds + always = liftAndSkipStateT always + + catchSTM m h = StateT (\r -> catchSTM (runStateT m r) (\e -> runStateT (h e) r)) liftAdv = lift . liftAdv @@ -145,30 +161,43 @@ newTVar = lift . newTVar +-------------------------------------------------------------------------------- -mapStateT2 :: (m (a, s) -> n (b, s) -> o (c,s)) -> StateT s m a -> StateT s n b -> StateT s o c -mapStateT2 f m1 m2 = StateT $ \s -> f (runStateT m1 s) (runStateT m2 s) +mapWriterT2 :: (m (a, w) -> n (b, w) -> o (c,w)) + -> WriterT w m a -> WriterT w n b -> WriterT w o c +mapWriterT2 f m1 m2 = WriterT $ f (runWriterT m1) (runWriterT m2) +-- mapWriterT2 f m1 m2 = liftM f m1 `ap` m2 -liftStateT f m = StateT $ \s -> let a = evalStateT m s - in do r <- f a - return (r,s) +evalWriterT :: Monad m => WriterT w m a -> m a +evalWriterT m = do + (a,_) <- runWriterT m + return a -instance MonadAdvSTM m => MonadAdvSTM (StateT s m) where +liftAndSkipWriterT :: (Monad m,Monoid w) + => (m a -> m b) + -> WriterT w m a -> WriterT w m b +liftAndSkipWriterT f m = WriterT $ + let a = evalWriterT m + in do r <- f a + return (r,mempty) + +instance (MonadAdvSTM m, Monoid w) => MonadAdvSTM (WriterT w m) where onCommit = lift . onCommit onRetry = lift . onRetry - orElse = mapStateT2 orElse + orElse = mapWriterT2 orElse retry = lift retry check = lift . check - alwaysSucceeds = liftStateT alwaysSucceeds - - always = liftStateT always + -- Note: The writer-log modifications of the invariant action + -- are thrown away! + alwaysSucceeds = liftAndSkipWriterT alwaysSucceeds + always = liftAndSkipWriterT always - catchSTM m h = StateT (\r -> catchSTM (runStateT m r) (\e -> runStateT (h e) r)) + catchSTM m h = WriterT (catchSTM (runWriterT m) (\e -> runWriterT (h e))) liftAdv = lift . liftAdv @@ -178,32 +207,26 @@ newTVar = lift . newTVar - --- mapWriterT2 :: (m (a, w) -> n (b, w) -> o (c,w')) -> WriterT w m a -> WriterT w n b -> WriterT w' o c --- mapWriterT2 f m1 m2 = WriterT $ \s -> f (runWriterT m1 s) (runWriterT m2 s) +-------------------------------------------------------------------------------- -{- - - TODO: -liftWriterT f m = WriterT $ \s -> let a = runWriterT m s - in do r <- f a - return (r,s) +mapReaderT2 :: (m a -> n b -> o c) -> ReaderT r m a -> ReaderT r n b -> ReaderT r o c +mapReaderT2 f m1 m2 = ReaderT $ \r -> f (runReaderT m1 r) (runReaderT m2 r) -instance (MonadAdvSTM m, Monoid w) => MonadAdvSTM (WriterT w m) where +instance MonadAdvSTM m => MonadAdvSTM (ReaderT r m) where onCommit = lift . onCommit onRetry = lift . onRetry --- orElse = mapWriterT2 orElse + orElse = mapReaderT2 orElse retry = lift retry check = lift . check --- alwaysSucceeds = mapWriterT alwaysSucceeds + alwaysSucceeds = mapReaderT alwaysSucceeds + always = mapReaderT always --- always = mapWriterT always - - catchSTM m h = WriterT (\r -> catchSTM (runWriterT m r) (\e -> runWriterT (h e) r)) + catchSTM m h = ReaderT (\r -> catchSTM (runReaderT m r) (\e -> runReaderT (h e) r)) liftAdv = lift . liftAdv @@ -212,4 +235,6 @@ writeTVar tvar = lift . writeTVar tvar newTVar = lift . newTVar --} + + +-------------------------------------------------------------------------------- diff --git a/stm-io-hooks.cabal b/stm-io-hooks.cabal --- a/stm-io-hooks.cabal +++ b/stm-io-hooks.cabal @@ -19,11 +19,11 @@ Category: Concurrency Author: Peter Robinson 2009, Chris Kuklewicz 2006 -Maintainer: Peter Robinson +Maintainer: Peter Robinson License: BSD3 License-file: LICENSE Homepage: http://darcs.monoid.at/stm-io-hooks -Version: 0.3.0 +Version: 0.4.2 Build-type: Simple Cabal-Version: >= 1.2.3 @@ -54,5 +54,6 @@ ,DeriveDataTypeable ,RankNTypes ,ExistentialQuantification + ,UndecidableInstances