module Control.Concurrent.AdvSTM.TVar(
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)
}
newTVar :: a -> AdvSTM (TVar a)
newTVar a = TVar `liftM` (liftAdv $ OldTVar.newTVar a)
`ap` (liftAdv $ OldTMVar.newTMVar ())
`ap` (liftAdv $ OldTVar.newTVar Nothing)
newTVarIO :: a -> IO (TVar a)
newTVarIO a = TVar `liftM` OldTVar.newTVarIO a
`ap` OldTMVar.newTMVarIO ()
`ap` OldTVar.newTVarIO Nothing
writeTVar :: TVar a -> a -> AdvSTM ()
writeTVar tvar a = do
commitLock <- liftAdv $ OldTMVar.tryTakeTMVar (onCommitLock tvar)
curTid <- AdvSTM $ asks transThreadId
storedTid <- liftAdv $ OldTVar.readTVar (currentTid tvar)
case commitLock of
Nothing -> do
if isJust storedTid && fromJust storedTid == curTid
then throw Deadlock
else retry
Just _ -> do
unless (isJust storedTid && (fromJust storedTid == curTid)) $ do
liftAdv $ OldTVar.writeTVar (currentTid tvar) $ Just curTid
lsTVar <- AdvSTM $ asks listeners
ls <- liftAdv $ OldTVar.readTVar lsTVar
oldval <- liftAdv $ OldTVar.readTVar (valueTVar tvar)
liftAdv $ OldTVar.writeTVar lsTVar $
(onCommitLock tvar,TVarValue (valueTVar tvar,oldval)) : ls
liftAdv $ OldTVar.writeTVar (valueTVar tvar) a
liftAdv $ OldTMVar.putTMVar (onCommitLock tvar) ()
readTVar :: TVar a -> AdvSTM a
readTVar tvar = do
commitLock <- liftAdv $ OldTMVar.tryTakeTMVar (onCommitLock tvar)
case commitLock of
Nothing -> do
storedTid <- liftAdv $ OldTVar.readTVar (currentTid tvar)
curTid <- AdvSTM $ asks transThreadId
if isJust storedTid && fromJust storedTid == curTid
then throw Deadlock
else retry
Just _ -> do
result <- liftAdv $ OldTVar.readTVar $ valueTVar tvar
liftAdv $ OldTMVar.putTMVar (onCommitLock tvar) ()
return result