stm-io-hooks 0.0.1 → 0.1.0

raw patch · 9 files changed

+274/−167 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Concurrent/AdvSTM.hs +151/−70
• Control/Concurrent/AdvSTM/TArray.hs +2/−2
• Control/Concurrent/AdvSTM/TChan.hs +7/−7
• Control/Concurrent/AdvSTM/TMVar.hs +11/−10
• Control/Concurrent/AdvSTM/TVar.hs +16/−18
• Control/Concurrent/AdvSTM/TVar.hs-boot +43/−0
• Control/Monad/AdvSTM.hs +0/−51
• Control/Monad/AdvSTM/Class.hs +34/−6
• stm-io-hooks.cabal +10/−3

@@ -12,8 +12,26 @@ --  -----------------------------------------------------------------------------  +-- 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(..)+                                  MonadAdvSTM( onCommit+                                            , unsafeOnRetry+                                            , orElse+                                            , retry+                                            , check+                                            , alwaysSucceeds+                                            , always+                                            , runAtomic+                                            , catchSTM+                                            , liftAdv+                                            , newTVar+                                            , readTVar+                                            , writeTVar+                                            )+                                                                   -- * Monad AdvSTM                                 , AdvSTM                                 , unsafeRetryWith@@ -25,20 +43,21 @@   import Prelude hiding (catch) import Control.Monad.AdvSTM.Def(AdvSTM(..),Env(..),TVarValue(..))-import Control.Monad.AdvSTM.Class(MonadAdvSTM(..))+import Control.Monad.AdvSTM.Class( MonadAdvSTM(..), TVar( TVar ), onCommitLock, currentTid, valueTVar ) -import Control.Exception(throw,catch,SomeException,fromException,try) -import Control.Monad(mplus,when)+import Control.Exception(throw,catch,SomeException,fromException,try,block,unblock,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.Concurrent.Chan(Chan,newChan,readChan,writeChan)-import Control.Concurrent.STM.TMVar(TMVar,putTMVar,takeTMVar)+import Control.Concurrent.STM.TMVar(TMVar,putTMVar,takeTMVar,newTMVar,tryTakeTMVar) -- import Control.Concurrent.STM.TChan(TChan,writeTChan) import Control.Concurrent.MVar(MVar,newEmptyMVar,takeMVar,tryTakeMVar,putMVar) import qualified Control.Concurrent.STM as S (STM,orElse,retry,catchSTM,atomically,check,always,alwaysSucceeds)-import Control.Concurrent.STM.TVar(TVar,newTVarIO,readTVar,writeTVar)+import qualified Control.Concurrent.STM.TVar as STVar -- (TVar,newTVarIO,readTVar,writeTVar) import GHC.Conc(unsafeIOToSTM) import Data.IORef(newIORef,readIORef,writeIORef)+import Data.Maybe(isJust,Maybe,fromJust)   -------------------------------------------------------------------------------- @@ -46,8 +65,8 @@ instance MonadAdvSTM AdvSTM where     onCommit ioaction = do         commitVar <- AdvSTM $ asks commitTVar-        commitFun <- liftAdv $ readTVar commitVar-        liftAdv $ writeTVar commitVar $ commitFun . (ioaction >>)+        commitFun <- liftAdv $ STVar.readTVar commitVar+        liftAdv $ STVar.writeTVar commitVar $ commitFun . (ioaction >>)      unsafeOnRetry ioaction = do         retryVar <- AdvSTM $ asks retryMVar@@ -61,7 +80,6 @@     retry = liftAdv S.retry       check = liftAdv . S.check-          alwaysSucceeds inv = unlift inv >>= liftAdv . S.alwaysSucceeds  @@ -75,10 +93,67 @@         let handler'' = \e -> case fromException e of                                     Nothing -> throw e                                     Just e' -> handler' e'-        liftAdv $ S.catchSTM action' (handler'') +        liftAdv $ S.catchSTM action' handler''      liftAdv = AdvSTM . lift  ++    -- | See 'STVar.newTVar'+    newTVar a = TVar `liftM` (liftAdv $ STVar.newTVar a) +                     `ap`    (liftAdv $ newTMVar ()) +                     `ap`    (liftAdv $ STVar.newTVar Nothing)+++    -- | Writes a value to a TVar. Blocks until the onCommit IO-action(s) are+    -- complete. See 'onCommit' for details.+    writeTVar tvar a = do +        commitLock <- liftAdv $ tryTakeTMVar (onCommitLock tvar)+        -- Get ThreadID of current transaction:+        curTid     <- AdvSTM $ asks transThreadId   +        storedTid  <- liftAdv $ STVar.readTVar (currentTid tvar) +        case commitLock of+            Nothing -> do+                if isJust storedTid && fromJust storedTid == curTid+                  then throw Deadlock       -- No transaction during onCommit-phase!+                  else retry+            Just _  -> do+                unless (isJust storedTid && (fromJust storedTid == curTid)) $ do+                    -- First write access, update the ThreadId:+                    liftAdv $ STVar.writeTVar (currentTid tvar) $ Just curTid+                    -- Add this TVar to the onCommit-listener list:+                    lsTVar <- AdvSTM $ asks listeners+                    ls     <- liftAdv $ STVar.readTVar lsTVar+                    -- Remember the old value for rollback:+                    oldval <- liftAdv $ STVar.readTVar (valueTVar tvar)+                    liftAdv $ STVar.writeTVar lsTVar $+                            (onCommitLock tvar,TVarValue (valueTVar tvar,oldval)) : ls+                +                liftAdv $ STVar.writeTVar (valueTVar tvar) a +                liftAdv $ putTMVar (onCommitLock tvar) ()+++    --------------------------------------------------------------------------------++    -- | Reads a value from a TVar. Blocks until the IO onCommit action(s) of +    -- the corresponding transaction are complete.+    -- See 'onCommit' for a more detailed description of this behaviour.+    readTVar tvar = do +        commitLock <- liftAdv $ tryTakeTMVar (onCommitLock tvar)+        case commitLock of+            Nothing -> do+                storedTid <- liftAdv $ STVar.readTVar (currentTid tvar) +                curTid    <- AdvSTM $ asks transThreadId   +                if isJust storedTid && fromJust storedTid == curTid+                  then throw Deadlock+                  else retry+            Just _ -> do+                result <- liftAdv $ STVar.readTVar $ valueTVar tvar+                liftAdv $ putTMVar (onCommitLock tvar) ()+                return result++    --------------------------------------------------------------------------------++ -- | Adds the IO action to the retry queue and then retries the transaction unsafeRetryWith :: (Monad m, MonadAdvSTM m) => IO () -> m b unsafeRetryWith io = unsafeOnRetry io >> retry@@ -88,22 +163,22 @@ --------------------------------------------------------------------------------  -+-- | See 'S.atomically' atomically :: AdvSTM a -> IO a atomically (AdvSTM action) = do     let debugging = False -- Switching this to True occasionally causes deadlocks (b/c unsafeIO)!-    debugTVar <- newTVarIO debugging+    debugTVar <- STVar.newTVarIO debugging     tid       <- myThreadId       -- ThreadId for controlling TVar access     debug "***************************************************************" 0 debugging     debug (show (tid,"Starting transaction...")) 1000000 debugging     -- Building the Reader monad environment-    commitVar <- newTVarIO id     -- IO actions to be run if the transaction commits+    commitVar <- STVar.newTVarIO id     -- IO actions to be run if the transaction commits     retryVar  <- newEmptyMVar     -- full if there's something todo before retrying-    commitListeners <- newTVarIO []  -    let env = Env { commitTVar    = commitVar       :: TVar (IO () -> IO ())+    commitListeners <- STVar.newTVarIO []  +    let env = Env { commitTVar    = commitVar       :: STVar.TVar (IO () -> IO ())                   , retryMVar     = retryVar        :: MVar (IO () -> IO ())                   , transThreadId = tid             :: ThreadId-                  , listeners     = commitListeners :: TVar [(TMVar (),TVarValue)] +                  , listeners     = commitListeners :: STVar.TVar [(TMVar (),TVarValue)]                    , debugModeVar  = debugTVar                   }      -- Setting up communication for the retry-helper thread:                  @@ -140,80 +215,86 @@      let wrappedAction = runReaderT action env `S.orElse` (check'retry) -    result <- S.atomically $ do -        debugSTM (show (tid,"wrappedAction: Running S.STM action...")) 0 debugging-        result <- wrappedAction-        debugSTM (show (tid,"wrappedAction: Finished S.STM action...")) 0 debugging-        ls     <- readTVar commitListeners -        -- Notify the TPVars that we're entering onCommit mode:-        debugSTM (show (tid,"wrappedAction: Notifying TVars that we're about to run onCommit...")) 0 debugging-        mapM_ (\(l,_) -> -                takeTMVar l       -- tell the TVar that we're going into onCommit mode-              ) ls-        return result+    -- Block interruptions from other threads for the rest of 'atomically'+    block $ do +        result <- S.atomically $ do +            debugSTM (show (tid,"wrappedAction: Running S.STM action...")) 0 debugging+            result <- wrappedAction+            debugSTM (show (tid,"wrappedAction: Finished S.STM action...")) 0 debugging+            ls     <- STVar.readTVar commitListeners +            -- Notify the TPVars that we're entering onCommit mode:+            debugSTM (show (tid,"wrappedAction: Notifying TVars that we're about to run onCommit...")) 0 debugging+            mapM_ (\(l,_) -> +                    takeTMVar l       -- tell the TVar that we're going into onCommit mode+                  ) ls+            return result -    let rollbackOnCommit = do-            debug "rollbackOnCommit: rolling back modified TVar values!" 0 debugging-            wait'retry'finished-            S.atomically $ do-                ls <- readTVar commitListeners-                mapM_ (\(l,TVarValue (oldValTVar,oldVal)) -> do -                        writeTVar oldValTVar oldVal  -- smthg went wrong, restore the old value -                        putTMVar l ()                -- ...and unblock the TVar-                      ) ls- -    -- Now try to run the onCommit IO actions:-    commitFun <- S.atomically $ readTVar commitVar-    commitFun (return ()) `catch` (\(e::SomeException) -> rollbackOnCommit >> throw e)+        let rollbackOnCommit = do+                debug "rollbackOnCommit: rolling back modified TVar values!" 0 debugging+                wait'retry'finished+                S.atomically $ do+                    ls <- STVar.readTVar commitListeners+                    mapM_ (\(l,TVarValue (oldValTVar,oldVal)) -> do +                            STVar.writeTVar oldValTVar oldVal  -- smthg went wrong, restore the old value +                            putTMVar l ()                -- ...and unblock the TVar+                          ) ls+     +        -- Now try to run the onCommit IO actions:+        commitFun <- S.atomically $ STVar.readTVar commitVar+        commitFun (return ()) `catch` (\(e::SomeException) -> rollbackOnCommit >> throw e) -    -- Everything's ok, so notify and unblock the TVars:-    debug (show (tid,"*********************")) 1000000 debugging-    debug (show (tid,"Notifying TPVars that we're done:")) 0 debugging-    S.atomically $ do -        ls <- readTVar commitListeners -        mapM_ (\(l,_) -> do -                putTMVar l ()                  -              ) ls-    wait'retry'finished-    debug (show (tid,"Transaction done; retry thread finished")) 1000000 debugging-    debug "************************************************************" 0 debugging-    return result+        -- Everything's ok, so notify and unblock the TVars:+        debug (show (tid,"*********************")) 1000000 debugging+        debug (show (tid,"Notifying TPVars that we're done:")) 0 debugging+        S.atomically $ do +            ls <- STVar.readTVar commitListeners +            mapM_ (\(l,_) -> do +                    putTMVar l ()                  +                  ) ls+        wait'retry'finished+        debug (show (tid,"Transaction done; retry thread finished")) 1000000 debugging+        debug "************************************************************" 0 debugging+        return result -    where-     -- Helper thread for the retry IO-actions-    spawn'retry'thread :: IO (Maybe (IO ())) -> IO () -> IO ThreadId-    spawn'retry'thread nextJob atEndAction = forkIO $ loop-      where loop = do-              may'job <- nextJob-              case may'job of-                Nothing -> atEndAction-                Just job -> do -                    res <- try job          -                    case res of-                        Left (e::SomeException)  -> throw e-                        Right _ -> loop-     +        where+         -- Helper thread for the retry IO-actions+        spawn'retry'thread :: IO (Maybe (IO ())) -> IO () -> IO ThreadId+        spawn'retry'thread nextJob atEndAction = forkIO $ loop+          where loop = do+                  may'job <- nextJob+                  case may'job of+                    Nothing -> atEndAction+                    Just job -> do +                        res <- try job          +                        case res of+                            Left (e::SomeException)  -> throw e+                            Right _ -> loop+        +    ++     -------------------------------------------------------------------------------- +-- | See 'unsafeIOToSTM' unsafeIOToAdvSTM :: IO a -> AdvSTM a unsafeIOToAdvSTM = liftAdv . unsafeIOToSTM  -------------------------------------------------------------------------------- --- | Switches the debug mode on or off+-- | Switches the debug mode on or off. -- /WARNING:/ Can lead to deadlocks!  debugMode :: Bool -> AdvSTM () debugMode switch = do     debVar <- AdvSTM $ asks debugModeVar -    liftAdv $ writeTVar debVar switch+    liftAdv $ STVar.writeTVar debVar switch  -- | Uses unsafeIOToSTM to output the Thread Id and a message and delays --- for a given number of ms+-- for a given number of time. -- /WARNING:/ Can lead to deadlocks!  debugAdvSTM :: String -> Int -> AdvSTM () debugAdvSTM msg delay = do      debVar <- AdvSTM $ asks debugModeVar-    debugging <- liftAdv $ readTVar debVar+    debugging <- liftAdv $ STVar.readTVar debVar     tid    <- AdvSTM $ asks transThreadId      liftAdv $ debugSTM (show (tid,msg)) delay debugging  

@@ -16,7 +16,7 @@  module Control.Concurrent.AdvSTM.TArray( TArray ) where-import Control.Concurrent.AdvSTM+import Control.Monad.AdvSTM( MonadAdvSTM ) import Control.Concurrent.AdvSTM.TVar  @@ -32,7 +32,7 @@  newtype TArray i e = TArray (Array i (TVar e)) -instance MArray TArray e AdvSTM where+instance MonadAdvSTM m => MArray TArray e m where     getBounds (TArray a) = return (bounds a)     newArray b e = do         a <- replicateM (rangeSize b) (newTVar e)

@@ -21,7 +21,7 @@                                      , isEmptyTChan                                      ) where-import Control.Concurrent.AdvSTM(AdvSTM,retry)+import Control.Monad.AdvSTM(MonadAdvSTM,retry) import Control.Concurrent.AdvSTM.TVar(TVar,readTVar,writeTVar,newTVar,newTVarIO)  -- | 'TChan' is an abstract type representing an unbounded FIFO channel.@@ -31,7 +31,7 @@ data TList a = TNil | TCons a (TVarList a)  -- |Build and returns a new instance of 'TChan'-newTChan :: AdvSTM (TChan a)+newTChan :: MonadAdvSTM m => m (TChan a) newTChan = do   hole <- newTVar TNil   read <- newTVar hole@@ -50,7 +50,7 @@   return (TChan read write)  -- |Write a value to a 'TChan'.-writeTChan :: TChan a -> a -> AdvSTM ()+writeTChan :: MonadAdvSTM m => TChan a -> a -> m () writeTChan (TChan _read write) a = do   listend <- readTVar write -- listend == TVar pointing to TNil   new_listend <- newTVar TNil@@ -58,7 +58,7 @@   writeTVar write new_listend  -- |Read the next value from the 'TChan'.-readTChan :: TChan a -> AdvSTM a+readTChan :: MonadAdvSTM m => TChan a -> m a readTChan (TChan read _write) = do   listhead <- readTVar read   head <- readTVar listhead@@ -72,21 +72,21 @@ -- either channel from then on will be available from both.  Hence this creates -- a kind of broadcast channel, where data written by anyone is seen by -- everyone else.-dupTChan :: TChan a -> AdvSTM (TChan a)+dupTChan :: MonadAdvSTM m => TChan a -> m (TChan a) dupTChan (TChan read write) = do   hole <- readTVar write     new_read <- newTVar hole   return (TChan new_read write)  -- |Put a data item back onto a channel, where it will be the next item read.-unGetTChan :: TChan a -> a -> AdvSTM ()+unGetTChan :: MonadAdvSTM m => TChan a -> a -> m () unGetTChan (TChan read _write) a = do    listhead <- readTVar read    newhead <- newTVar (TCons a listhead)    writeTVar read newhead  -- |Returns 'True' if the supplied 'TChan' is empty.-isEmptyTChan :: TChan a -> AdvSTM Bool+isEmptyTChan :: MonadAdvSTM m => TChan a -> m Bool isEmptyTChan (TChan read write) = do   listhead <- readTVar read   head <- readTVar listhead

@@ -31,7 +31,7 @@   ) where  import Control.Concurrent.AdvSTM.TVar(TVar,readTVar,writeTVar,newTVar,newTVarIO)-import Control.Concurrent.AdvSTM(AdvSTM,retry)+import Control.Monad.AdvSTM(MonadAdvSTM,retry)  newtype TMVar a = TMVar (TVar (Maybe a)) {- ^@@ -41,7 +41,7 @@ -}  -- |Create a 'TMVar' which contains the supplied value.-newTMVar :: a -> AdvSTM (TMVar a)+newTMVar :: MonadAdvSTM m => a -> m (TMVar a) newTMVar a = do   t <- newTVar (Just a)   return (TMVar t)@@ -56,7 +56,7 @@   return (TMVar t)  -- |Create a 'TMVar' which is initially empty.-newEmptyTMVar :: AdvSTM (TMVar a)+newEmptyTMVar :: MonadAdvSTM m => m (TMVar a) newEmptyTMVar = do   t <- newTVar Nothing   return (TMVar t)@@ -73,7 +73,7 @@ -- |Return the contents of the 'TMVar'.  If the 'TMVar' is currently -- empty, the transaction will 'retry'.  After a 'takeTMVar',  -- the 'TMVar' is left empty.-takeTMVar :: TMVar a -> AdvSTM a+takeTMVar :: MonadAdvSTM m => TMVar a -> m a takeTMVar (TMVar t) = do   m <- readTVar t   case m of@@ -84,7 +84,7 @@ -- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if -- the 'TMVar' was full with contents @a@.  After 'tryTakeTMVar', the -- 'TMVar' is left empty.-tryTakeTMVar :: TMVar a -> AdvSTM (Maybe a)+tryTakeTMVar :: MonadAdvSTM m => TMVar a -> m (Maybe a) tryTakeTMVar (TMVar t) = do   m <- readTVar t   case m of@@ -93,7 +93,7 @@  -- |Put a value into a 'TMVar'.  If the 'TMVar' is currently full, -- 'putTMVar' will 'retry'.-putTMVar :: TMVar a -> a -> AdvSTM ()+putTMVar :: MonadAdvSTM m => TMVar a -> a -> m () putTMVar (TMVar t) a = do   m <- readTVar t   case m of@@ -103,7 +103,7 @@ -- | A version of 'putTMVar' that does not 'retry'.  The 'tryPutTMVar' -- function attempts to put the value @a@ into the 'TMVar', returning -- 'True' if it was successful, or 'False' otherwise.-tryPutTMVar :: TMVar a -> a -> AdvSTM Bool+tryPutTMVar :: MonadAdvSTM m => TMVar a -> a -> m Bool tryPutTMVar (TMVar t) a = do   m <- readTVar t   case m of@@ -114,7 +114,7 @@   This is a combination of 'takeTMVar' and 'putTMVar'; ie. it takes the value   from the 'TMVar', puts it back, and also returns it. -}-readTMVar :: TMVar a -> AdvSTM a+readTMVar :: MonadAdvSTM m => TMVar a -> m a readTMVar (TMVar t) = do   m <- readTVar t   case m of@@ -122,7 +122,7 @@     Just a  -> return a  -- |Swap the contents of a 'TMVar' for a new value.-swapTMVar :: TMVar a -> a -> AdvSTM a+swapTMVar :: MonadAdvSTM m => TMVar a -> a -> m a swapTMVar (TMVar t) new = do   m <- readTVar t   case m of@@ -135,9 +135,10 @@ -- the state of the 'TMVar'. By the time you get to react on its result, -- the 'TMVar' may have been filled (or emptied) - so be extremely -- careful when using this operation.   Use 'tryTakeTMVar' instead if possible.-isEmptyTMVar :: TMVar a -> AdvSTM Bool+isEmptyTMVar :: MonadAdvSTM m => TMVar a -> m Bool isEmptyTMVar (TMVar t) = do   m <- readTVar t   case m of     Nothing -> return True     Just _  -> return False+

@@ -20,41 +20,39 @@                                      , writeTVar                                      ) where+import Control.Monad.AdvSTM.Class(readTVar,writeTVar,newTVar,TVar(TVar)) import qualified Control.Concurrent.STM.TVar as OldTVar-import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM.TMVar as OldTMVar+import Control.Monad(liftM,ap)+{-+import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM.TChan as OldTChan import Control.Exception(throw,Deadlock(Deadlock))-import Control.Concurrent.AdvSTM(liftAdv,orElse,retry)+import Control.Concurrent.AdvSTM(liftAdv,orElse,retry,readTVar,writeTVar,newTVar) import Control.Monad.AdvSTM.Def(AdvSTM(AdvSTM),transThreadId,listeners,TVarValue(TVarValue)) import Control.Concurrent(ThreadId)-import Control.Monad(liftM,ap,unless) import Control.Monad.Reader(asks) import Data.Maybe(isJust,Maybe,fromJust) import qualified Data.Set as S-+-} -------------------------------------------------------------------------------- -data TVar a = TVar -    { valueTVar    :: OldTVar.TVar a     -    , onCommitLock :: OldTMVar.TMVar ()  -    , currentTid   :: OldTVar.TVar (Maybe ThreadId)-    }+-- | See 'OldTVar.newTVarIO'+--+newTVarIO :: a -> IO (TVar a)+newTVarIO a = TVar `liftM` OldTVar.newTVarIO a+                   `ap`    OldTMVar.newTMVarIO ()+                   `ap`    OldTVar.newTVarIO Nothing  ---------------------------------------------------------------------------------+{- -- | See 'OldTVar.newTVar' newTVar :: a -> AdvSTM (TVar a) newTVar a = TVar `liftM` (liftAdv $ OldTVar.newTVar a)                   `ap`    (liftAdv $ OldTMVar.newTMVar ())                   `ap`    (liftAdv $ OldTVar.newTVar Nothing)---- | See 'OldTVar.newTVarIO'-newTVarIO :: a -> IO (TVar a)-newTVarIO a = TVar `liftM` OldTVar.newTVarIO a-                   `ap`    OldTMVar.newTMVarIO ()-                   `ap`    OldTVar.newTVarIO Nothing-+-}+{- --------------------------------------------------------------------------------  -- | Writes a value to a TVar. Blocks until the onCommit IO-action(s) are@@ -107,6 +105,6 @@             return result  ---------------------------------------------------------------------------------+-}  

@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.AdvSTM.TVar+-- Copyright   :  (c) Peter Robinson 2009+-- License     :  BSD-style (see the file LICENSE)+-- +-- Maintainer  :  Peter Robinson <robinson@ecs.tuwien.ac.at>+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- +--+-----------------------------------------------------------------------------++module Control.Concurrent.AdvSTM.TVar( TVar ) {- ( -- * TVars+                                       TVar +                                     , newTVar+                                     , newTVarIO+                                     , readTVar+                                     , writeTVar+                                     ) -}+where+import qualified Control.Concurrent.STM.TVar as OldTVar+import qualified Control.Concurrent.STM as STM+import qualified Control.Concurrent.STM.TMVar as OldTMVar+import qualified Control.Concurrent.STM.TChan as OldTChan+import Control.Exception(throw,Deadlock(Deadlock))+-- import Control.Concurrent.AdvSTM(liftAdv,orElse,retry)+-- import Control.Monad.AdvSTM.Def(AdvSTM(AdvSTM),transThreadId,listeners,TVarValue(TVarValue))+import Control.Concurrent(ThreadId)+import Control.Monad(liftM,ap,unless)+import Control.Monad.Reader(asks)+import Data.Maybe(isJust,Maybe,fromJust)+import qualified Data.Set as S++--------------------------------------------------------------------------------++data TVar a = TVar +    { valueTVar    :: OldTVar.TVar a     +    , onCommitLock :: OldTMVar.TMVar ()  +    , currentTid   :: OldTVar.TVar (Maybe ThreadId)+    }+

@@ -29,54 +29,3 @@ import Control.Monad(Monad,MonadPlus) import Control.Monad.Reader(MonadReader,ReaderT) -{---- | A type class for extended-STM monads. See 'AdvSTM' for a concrete--- instantiation-class Monad m => MonadAdvSTM m where-    -- | Takes an IO action that will be executed if the STM transaction commits. -    -- /Beware:/ If the IO action throws an exception, the effects of the STM -    -- action will still be visible.-    -- -    -- /Atomicity and Race Conditions:/ -    ---    -- * 'TVar', 'TChan', 'TArray' or 'TMVar': There is a race hole between the TM transaction -    -- and the execution of the IO action, i.e., other-    -- transactions might commit before the IO action is run. -    ---    -- * 'TTVar': When a 'TTVar' was modified in the TM action, it cannot be accessed by any -    -- other thread before the onCommit IO action was run. Forking-    -- another thread inside of the onCommit IO action breaks this atomicity-    -- guarantee.-    onCommit  :: IO a -> m ()--    -- | Adds the IO action to the retry-queue. If the transaction retries,-    -- a new thread is forked that runs the retry actions. When this thread is-    -- done, the transaction retries.-    onRetry   :: IO a -> m ()--    -- | See 'S.orElse'-    orElse :: m a -> m a -> m a--    -- | See 'S.retry'-    retry  :: m a--    -- | 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--} ----------------------------------------------------------------------------------{---- | Drop-in replacement for the STM monad-newtype AdvSTM a = AdvSTM (ReaderT Env S.STM a)-                deriving ( Functor-                         , Monad-                         , MonadPlus---                         , MonadReader Env-                         )---}

@@ -13,21 +13,31 @@ -- MonadAdvSTM (see package description). ----------------------------------------------------------------------------- -module Control.Monad.AdvSTM.Class( MonadAdvSTM(..))+module Control.Monad.AdvSTM.Class( MonadAdvSTM(..), TVar(TVar), valueTVar, onCommitLock, currentTid ) where  import Control.Exception(Exception,Deadlock) 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) import Control.Monad.AdvSTM.Def(AdvSTM)+import Control.Concurrent( ThreadId )+import GHC.Conc( unsafeIOToSTM )+-- import {-# SOURCE #-} Control.Concurrent.AdvSTM.TVar  +data TVar a = TVar +    { valueTVar    :: OldTVar.TVar a     +    , onCommitLock :: OldTMVar.TMVar ()  +    , currentTid   :: OldTVar.TVar (Maybe ThreadId)+    }  -- | A type class for extended-STM monads. For a concrete instantiation see -- 'AdvSTM' class Monad m => MonadAdvSTM m where -    -- | Takes an IO action that will be executed iff the transaction commits. +    -- | Takes an IO action that will be executed /iff/ the transaction commits.      --      -- * When a TVar was modified in a transaction and this transaction commits,     -- this update remains invisible to other threads until the corresponding @@ -55,14 +65,17 @@     -- | Adds an IO action to the retry job-queue. If the transaction retries,     -- a new helper thread is forked that runs the retry actions, and, after the helper      -- thread is done, the transaction retries.-    -- /Warning:/ Uses unsafeIOToSTM to fork a helper thread that runs the retry -    -- actions!-    unsafeOnRetry :: IO () -> m ()+    -- +    -- Uses 'unsafeIOToSTM' to fork a helper thread that runs the retry +    -- actions.  +    unsafeOnRetry :: IO () -- ^ IO action that will be run on retry the transaction.+                  -> m ()      -- | See 'S.orElse'     orElse :: m a -> m a -> m a -    -- | See 'S.retry'. Skips any IO actions added by unsafeOnRetry.+    -- | Runs any IO actions added by 'unsafeOnRetry' and then retries the+    -- transaction.     retry  :: m a      -- | See 'S.check'@@ -83,3 +96,18 @@     -- | Lifts STM actions to 'MonadAdvSTM'.     liftAdv   :: S.STM a -> m a  +    -- | Reads a value from a TVar. Blocks until the IO onCommit action(s) of +    -- the corresponding transaction are complete.+    -- See 'onCommit' for a more detailed description of this behaviour.+    readTVar :: TVar a -> m a++    -- | Writes a value to a TVar. Blocks until the onCommit IO-action(s) are+    -- complete. See 'onCommit' for details.+    writeTVar :: TVar a -> a -> m ()++    -- | See 'OldTVar.newTVar'+    newTVar :: a -> m (TVar a)++--    newTVarIO :: a -> IO (TVar a)++    

@@ -4,8 +4,15 @@     This library provides an STM monad with commit and retry IO hooks.      A retry-action is run (once) if the transaction retries, while commit-actions are      executed iff the transaction commits. The library also gives some atomicity-    guarantees for commit-actions, see documentation for details. +    guarantees for commit-actions:     .+    * When a TVar is modified in a transaction and this transaction commits,+    the update remains invisible to other threads until the corresponding +    onCommit action is run. +    .+    * If the onCommit action throws an exception, the original values of +    the modified TVars are restored.+    .     Note: Part of this library uses code from     the Haskell Wiki (see <http://haskell.org/haskellwiki/?title=New_monads/MonadAdvSTM>). Category:       Concurrency@@ -13,8 +20,8 @@ Maintainer:     Peter Robinson <robinson@ecs.tuwien.ac.at> License:        BSD3 License-file:   LICENSE-Homepage:       http://darcs.monoid.at/stm-io-hooks-Version:        0.0.1+-- Homepage:       http://darcs.monoid.at/stm-io-hooks+Version:        0.1.0  Build-type:     Simple                         Cabal-Version:  >= 1.2.3