barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-12-19 03:21:49 +03:00
Code Issues Projects Releases Wiki Activity

Fix issue with identifying only-read STM transactions as only creating new CTVars.

Browse Source
This commit is contained in:
Michael Walker 2015-07-08 18:18:56 +01:00
parent 426707f382
commit 05e2d2f1e4
3 changed files with 15 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Test/DejaFu/Deterministic/Internal.hs
View File

@ -231,12 +231,12 @@ stepThread fixed runconc runstm action idSource tid threads = case action of
let oldctvid = _nextCTVId idSource let oldctvid = _nextCTVId idSource
(res, newctvid) <- runstm stm oldctvid (res, newctvid) <- runstm stm oldctvid
case res of case res of
Success touched val Success readen written val
| any (<=oldctvid) touched -> | any (<oldctvid) readen || any (<oldctvid) written ->
let (threads', woken) = wake (OnCTVar touched) threads let (threads', woken) = wake (OnCTVar written) threads
in return $ Right (knows (map Right touched) tid $ goto (c val) tid threads', idSource { _nextCTVId = newctvid }, STM woken) in return $ Right (knows (map Right written) tid $ goto (c val) tid threads', idSource { _nextCTVId = newctvid }, STM woken)
| otherwise -> | otherwise ->
return $ Right (knows (map Right touched) tid $ goto (c val) tid threads, idSource { _nextCTVId = newctvid }, FreshSTM) return $ Right (knows (map Right written) tid $ goto (c val) tid threads, idSource { _nextCTVId = newctvid }, FreshSTM)
Retry touched -> Retry touched ->
let threads' = block (OnCTVar touched) tid threads let threads' = block (OnCTVar touched) tid threads
in return $ Right (threads', idSource { _nextCTVId = newctvid }, BlockedSTM) in return $ Right (threads', idSource { _nextCTVId = newctvid }, BlockedSTM)

4
Test/DejaFu/STM.hs
View File

@ -120,7 +120,7 @@ runTransactionST ma ctvid = do
(res, undo, ctvid') <- doTransaction fixedST (unS ma) ctvid (res, undo, ctvid') <- doTransaction fixedST (unS ma) ctvid
case res of case res of
Success _ _ -> return (res, ctvid') Success _ _ _ -> return (res, ctvid')
_ -> undo >> return (res, ctvid) _ -> undo >> return (res, ctvid)
where where
@ -135,7 +135,7 @@ runTransactionIO ma ctvid = do
(res, undo, ctvid') <- doTransaction fixedIO (unS ma) ctvid (res, undo, ctvid') <- doTransaction fixedIO (unS ma) ctvid
case res of case res of
Success _ _ -> return (res, ctvid') Success _ _ _ -> return (res, ctvid')
_ -> undo >> return (res, ctvid) _ -> undo >> return (res, ctvid)
where where

15
Test/DejaFu/STM/Internal.hs
View File

@ -55,8 +55,9 @@ type CTVarId = Int
-- | The result of an STM transaction, along with which 'CTVar's it -- | The result of an STM transaction, along with which 'CTVar's it
-- touched whilst executing. -- touched whilst executing.
data Result a = data Result a =
Success [CTVarId] a Success [CTVarId] [CTVarId] a
-- ^ The transaction completed successfully, and mutated the returned 'CTVar's. -- ^ The transaction completed successfully, reading the first list
-- 'CTVar's and writing to the second.
| Retry [CTVarId] | Retry [CTVarId]
-- ^ The transaction aborted by calling 'retry', and read the -- ^ The transaction aborted by calling 'retry', and read the
-- returned 'CTVar's. It should be retried when at least one of the -- returned 'CTVar's. It should be retried when at least one of the
@ -80,7 +81,7 @@ doTransaction fixed ma newctvid = do
res <- readRef (wref fixed) ref res <- readRef (wref fixed) ref
case res of case res of
Just (Right val) -> return (Success (nub written) val, undo, newctvid') Just (Right val) -> return (Success (nub readen) (nub written) val, undo, newctvid')
Just (Left exc) -> undo >> return (Exception exc, return (), newctvid) Just (Left exc) -> undo >> return (Exception exc, return (), newctvid)
Nothing -> undo >> return (Retry $ nub readen, return (), newctvid) Nothing -> undo >> return (Retry $ nub readen, return (), newctvid)
@ -117,13 +118,13 @@ stepTrans fixed act newctvid = case act of
stepCatch stm h c = do stepCatch stm h c = do
(res, undo, newctvid') <- doTransaction fixed stm newctvid (res, undo, newctvid') <- doTransaction fixed stm newctvid
case res of case res of
Success written val -> return (c val, undo, newctvid', [], written) Success readen written val -> return (c val, undo, newctvid', readen, written)
Retry readen -> return (ARetry, nothing, newctvid, readen, []) Retry readen -> return (ARetry, nothing, newctvid, readen, [])
Exception exc -> case fromException exc of Exception exc -> case fromException exc of
Just exc' -> do Just exc' -> do
(rese, undoe, newctvide') <- doTransaction fixed (h exc') newctvid (rese, undoe, newctvide') <- doTransaction fixed (h exc') newctvid
case rese of case rese of
Success written val -> return (c val, undoe, newctvide', [], written) Success readen written val -> return (c val, undoe, newctvide', readen, written)
Exception exce -> return (AThrow exce, nothing, newctvid, [], []) Exception exce -> return (AThrow exce, nothing, newctvid, [], [])
Retry readen -> return (ARetry, nothing, newctvid, readen, []) Retry readen -> return (ARetry, nothing, newctvid, readen, [])
Nothing -> return (AThrow exc, nothing, newctvid, [], []) Nothing -> return (AThrow exc, nothing, newctvid, [], [])
@ -149,12 +150,12 @@ stepTrans fixed act newctvid = case act of
stepOrElse a b c = do stepOrElse a b c = do
(resa, undoa, newctvida') <- doTransaction fixed a newctvid (resa, undoa, newctvida') <- doTransaction fixed a newctvid
case resa of case resa of
Success written val -> return (c val, undoa, newctvida', [], written) Success readen written val -> return (c val, undoa, newctvida', readen, written)
Exception exc -> return (AThrow exc, nothing, newctvid, [], []) Exception exc -> return (AThrow exc, nothing, newctvid, [], [])
Retry _ -> do Retry _ -> do
(resb, undob, newctvidb') <- doTransaction fixed b newctvid (resb, undob, newctvidb') <- doTransaction fixed b newctvid
case resb of case resb of
Success written val -> return (c val, undob, newctvidb', [], written) Success readen written val -> return (c val, undob, newctvidb', readen, written)
Exception exc -> return (AThrow exc, nothing, newctvid, [], []) Exception exc -> return (AThrow exc, nothing, newctvid, [], [])
Retry readen -> return (ARetry, nothing, newctvid, readen, []) Retry readen -> return (ARetry, nothing, newctvid, readen, [])