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

Only include a single step of lookahead in traces

Browse Source 
Closes #120
This commit is contained in:
Michael Walker 2017-09-26 11:03:49 +01:00
parent 356e13018d
commit c8dfdb1d92
4 changed files with 56 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
dejafu/CHANGELOG.markdown
View File

@ -7,6 +7,17 @@ This project is versioned according to the [Package Versioning Policy](https://p
*de facto* standard Haskell versioning scheme.
unreleased
----------
### Test.DejaFu.Common
- Execution traces now only include a single item of lookahead (#120).
---------------------------------------------------------------------------------------------------
0.7.3.0
-------

19
dejafu/Test/DejaFu/Common.hs
View File

@ -63,14 +63,13 @@ module Test.DejaFu.Common
, runRefCont
) where
import Control.DeepSeq (NFData(..))
import Control.Exception (Exception(..), MaskingState(..))
import Control.Monad.Ref (MonadRef(..))
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Control.DeepSeq (NFData(..))
import Control.Exception (Exception(..), MaskingState(..))
import Control.Monad.Ref (MonadRef(..))
import Data.List (intercalate)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
-------------------------------------------------------------------------------
-- Identifiers
@ -741,9 +740,9 @@ instance NFData TAction where
-- decisions made, all the runnable threads and what they would do,
-- and the action a thread took in its step.
--
-- @since 0.5.0.0
-- @since unreleased
type Trace
= [(Decision, [(ThreadId, NonEmpty Lookahead)], ThreadAction)]
= [(Decision, [(ThreadId, Lookahead)], ThreadAction)]
-- | Scheduling decisions are based on the state of the running
-- program, and so we can capture some of that state in recording what

7
dejafu/Test/DejaFu/Conc/Internal.hs
View File

@ -19,10 +19,9 @@ import Control.Exception (MaskingState(..),
toException)
import Control.Monad.Ref (MonadRef, newRef, readRef,
writeRef)
import qualified Data.Foldable as F
import Data.Functor (void)
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty(..), fromList)
import Data.List.NonEmpty (fromList)
import qualified Data.Map.Strict as M
import Data.Maybe (fromJust, isJust)
import Data.Monoid ((<>))
@ -42,7 +41,7 @@ import Test.DejaFu.STM (Result(..),
-- | 'Trace' but as a sequence.
type SeqTrace
= Seq (Decision, [(ThreadId, NonEmpty Lookahead)], ThreadAction)
= Seq (Decision, [(ThreadId, Lookahead)], ThreadAction)
-- | Run a concurrent computation with a given 'Scheduler' and initial
-- state, returning a failure reason on error. Also returned is the
@ -96,7 +95,7 @@ runThreads sched memtype ref = go Seq.empty [] Nothing where
Nothing -> die sofar prior InternalError ctx'
Nothing -> die sofar prior Abort ctx'
where
(choice, g') = sched sofarSched prior (fromList $ map (\(t,l:|_) -> (t,l)) runnable') (cSchedState ctx)
(choice, g') = sched sofarSched prior (fromList runnable') (cSchedState ctx)
runnable' = [(t, lookahead (_continuation a)) | (t, a) <- sortOn fst $ M.assocs runnable]
runnable = M.filter (not . isBlocked) threadsc
threadsc = addCommitThreads (cWriteBuf ctx) threads

68
dejafu/Test/DejaFu/Conc/Internal/Common.hs
View File

@ -15,7 +15,6 @@
module Test.DejaFu.Conc.Internal.Common where
import Control.Exception (Exception, MaskingState(..))
import Data.List.NonEmpty (NonEmpty, fromList)
import Data.Map.Strict (Map)
import Test.DejaFu.Common
import Test.DejaFu.STM (STMLike)
@ -153,37 +152,36 @@ data Action n r =
-- * Scheduling & Traces
-- | Look as far ahead in the given continuation as possible.
lookahead :: Action n r -> NonEmpty Lookahead
lookahead = fromList . lookahead' where
lookahead' (AFork _ _ _) = [WillFork]
lookahead' (AMyTId _) = [WillMyThreadId]
lookahead' (AGetNumCapabilities _) = [WillGetNumCapabilities]
lookahead' (ASetNumCapabilities i k) = WillSetNumCapabilities i : lookahead' k
lookahead' (ANewMVar _ _) = [WillNewMVar]
lookahead' (APutMVar (MVar c _) _ k) = WillPutMVar c : lookahead' k
lookahead' (ATryPutMVar (MVar c _) _ _) = [WillTryPutMVar c]
lookahead' (AReadMVar (MVar c _) _) = [WillReadMVar c]
lookahead' (ATryReadMVar (MVar c _) _) = [WillTryReadMVar c]
lookahead' (ATakeMVar (MVar c _) _) = [WillTakeMVar c]
lookahead' (ATryTakeMVar (MVar c _) _) = [WillTryTakeMVar c]
lookahead' (ANewCRef _ _ _) = [WillNewCRef]
lookahead' (AReadCRef (CRef r _) _) = [WillReadCRef r]
lookahead' (AReadCRefCas (CRef r _) _) = [WillReadCRefCas r]
lookahead' (AModCRef (CRef r _) _ _) = [WillModCRef r]
lookahead' (AModCRefCas (CRef r _) _ _) = [WillModCRefCas r]
lookahead' (AWriteCRef (CRef r _) _ k) = WillWriteCRef r : lookahead' k
lookahead' (ACasCRef (CRef r _) _ _ _) = [WillCasCRef r]
lookahead' (ACommit t c) = [WillCommitCRef t c]
lookahead' (AAtom _ _) = [WillSTM]
lookahead' (AThrow _) = [WillThrow]
lookahead' (AThrowTo tid _ k) = WillThrowTo tid : lookahead' k
lookahead' (ACatching _ _ _) = [WillCatching]
lookahead' (APopCatching k) = WillPopCatching : lookahead' k
lookahead' (AMasking ms _ _) = [WillSetMasking False ms]
lookahead' (AResetMask b1 b2 ms k) = (if b1 then WillSetMasking else WillResetMasking) b2 ms : lookahead' k
lookahead' (ALift _) = [WillLiftIO]
lookahead' (AYield k) = WillYield : lookahead' k
lookahead' (AReturn k) = WillReturn : lookahead' k
lookahead' (AStop _) = [WillStop]
lookahead' (ASub _ _) = [WillSubconcurrency]
lookahead' (AStopSub k) = WillStopSubconcurrency : lookahead' k
lookahead :: Action n r -> Lookahead
lookahead (AFork _ _ _) = WillFork
lookahead (AMyTId _) = WillMyThreadId
lookahead (AGetNumCapabilities _) = WillGetNumCapabilities
lookahead (ASetNumCapabilities i _) = WillSetNumCapabilities i
lookahead (ANewMVar _ _) = WillNewMVar
lookahead (APutMVar (MVar c _) _ _) = WillPutMVar c
lookahead (ATryPutMVar (MVar c _) _ _) = WillTryPutMVar c
lookahead (AReadMVar (MVar c _) _) = WillReadMVar c
lookahead (ATryReadMVar (MVar c _) _) = WillTryReadMVar c
lookahead (ATakeMVar (MVar c _) _) = WillTakeMVar c
lookahead (ATryTakeMVar (MVar c _) _) = WillTryTakeMVar c
lookahead (ANewCRef _ _ _) = WillNewCRef
lookahead (AReadCRef (CRef r _) _) = WillReadCRef r
lookahead (AReadCRefCas (CRef r _) _) = WillReadCRefCas r
lookahead (AModCRef (CRef r _) _ _) = WillModCRef r
lookahead (AModCRefCas (CRef r _) _ _) = WillModCRefCas r
lookahead (AWriteCRef (CRef r _) _ _) = WillWriteCRef r
lookahead (ACasCRef (CRef r _) _ _ _) = WillCasCRef r
lookahead (ACommit t c) = WillCommitCRef t c
lookahead (AAtom _ _) = WillSTM
lookahead (AThrow _) = WillThrow
lookahead (AThrowTo tid _ _) = WillThrowTo tid
lookahead (ACatching _ _ _) = WillCatching
lookahead (APopCatching _) = WillPopCatching
lookahead (AMasking ms _ _) = WillSetMasking False ms
lookahead (AResetMask b1 b2 ms _) = (if b1 then WillSetMasking else WillResetMasking) b2 ms
lookahead (ALift _) = WillLiftIO
lookahead (AYield _) = WillYield
lookahead (AReturn _) = WillReturn
lookahead (AStop _) = WillStop
lookahead (ASub _ _) = WillSubconcurrency
lookahead (AStopSub _) = WillStopSubconcurrency