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. *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 0.7.3.0
------- -------

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

@ -63,14 +63,13 @@ module Test.DejaFu.Common
, runRefCont , runRefCont
) where ) where
import Control.DeepSeq (NFData(..)) import Control.DeepSeq (NFData(..))
import Control.Exception (Exception(..), MaskingState(..)) import Control.Exception (Exception(..), MaskingState(..))
import Control.Monad.Ref (MonadRef(..)) import Control.Monad.Ref (MonadRef(..))
import Data.List (intercalate) import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Maybe (fromMaybe, mapMaybe) import Data.Set (Set)
import Data.Set (Set) import qualified Data.Set as S
import qualified Data.Set as S
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- Identifiers -- Identifiers
@ -741,9 +740,9 @@ instance NFData TAction where
-- decisions made, all the runnable threads and what they would do, -- decisions made, all the runnable threads and what they would do,
-- and the action a thread took in its step. -- and the action a thread took in its step.
-- --
-- @since 0.5.0.0 -- @since unreleased
type Trace type Trace
= [(Decision, [(ThreadId, NonEmpty Lookahead)], ThreadAction)] = [(Decision, [(ThreadId, Lookahead)], ThreadAction)]
-- | Scheduling decisions are based on the state of the running -- | Scheduling decisions are based on the state of the running
-- program, and so we can capture some of that state in recording what -- 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) toException)
import Control.Monad.Ref (MonadRef, newRef, readRef, import Control.Monad.Ref (MonadRef, newRef, readRef,
writeRef) writeRef)
import qualified Data.Foldable as F
import Data.Functor (void) import Data.Functor (void)
import Data.List (sortOn) import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty(..), fromList) import Data.List.NonEmpty (fromList)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (fromJust, isJust) import Data.Maybe (fromJust, isJust)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
@ -42,7 +41,7 @@ import Test.DejaFu.STM (Result(..),
-- | 'Trace' but as a sequence. -- | 'Trace' but as a sequence.
type SeqTrace type SeqTrace
= Seq (Decision, [(ThreadId, NonEmpty Lookahead)], ThreadAction) = Seq (Decision, [(ThreadId, Lookahead)], ThreadAction)
-- | Run a concurrent computation with a given 'Scheduler' and initial -- | Run a concurrent computation with a given 'Scheduler' and initial
-- state, returning a failure reason on error. Also returned is the -- 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 InternalError ctx'
Nothing -> die sofar prior Abort ctx' Nothing -> die sofar prior Abort ctx'
where 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' = [(t, lookahead (_continuation a)) | (t, a) <- sortOn fst $ M.assocs runnable]
runnable = M.filter (not . isBlocked) threadsc runnable = M.filter (not . isBlocked) threadsc
threadsc = addCommitThreads (cWriteBuf ctx) threads 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 module Test.DejaFu.Conc.Internal.Common where
import Control.Exception (Exception, MaskingState(..)) import Control.Exception (Exception, MaskingState(..))
import Data.List.NonEmpty (NonEmpty, fromList)
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Test.DejaFu.Common import Test.DejaFu.Common
import Test.DejaFu.STM (STMLike) import Test.DejaFu.STM (STMLike)
@ -153,37 +152,36 @@ data Action n r =
-- * Scheduling & Traces -- * Scheduling & Traces
-- | Look as far ahead in the given continuation as possible. -- | Look as far ahead in the given continuation as possible.
lookahead :: Action n r -> NonEmpty Lookahead lookahead :: Action n r -> Lookahead
lookahead = fromList . lookahead' where lookahead (AFork _ _ _) = WillFork
lookahead' (AFork _ _ _) = [WillFork] lookahead (AMyTId _) = WillMyThreadId
lookahead' (AMyTId _) = [WillMyThreadId] lookahead (AGetNumCapabilities _) = WillGetNumCapabilities
lookahead' (AGetNumCapabilities _) = [WillGetNumCapabilities] lookahead (ASetNumCapabilities i _) = WillSetNumCapabilities i
lookahead' (ASetNumCapabilities i k) = WillSetNumCapabilities i : lookahead' k lookahead (ANewMVar _ _) = WillNewMVar
lookahead' (ANewMVar _ _) = [WillNewMVar] lookahead (APutMVar (MVar c _) _ _) = WillPutMVar c
lookahead' (APutMVar (MVar c _) _ k) = WillPutMVar c : lookahead' k lookahead (ATryPutMVar (MVar c _) _ _) = WillTryPutMVar c
lookahead' (ATryPutMVar (MVar c _) _ _) = [WillTryPutMVar c] lookahead (AReadMVar (MVar c _) _) = WillReadMVar c
lookahead' (AReadMVar (MVar c _) _) = [WillReadMVar c] lookahead (ATryReadMVar (MVar c _) _) = WillTryReadMVar c
lookahead' (ATryReadMVar (MVar c _) _) = [WillTryReadMVar c] lookahead (ATakeMVar (MVar c _) _) = WillTakeMVar c
lookahead' (ATakeMVar (MVar c _) _) = [WillTakeMVar c] lookahead (ATryTakeMVar (MVar c _) _) = WillTryTakeMVar c
lookahead' (ATryTakeMVar (MVar c _) _) = [WillTryTakeMVar c] lookahead (ANewCRef _ _ _) = WillNewCRef
lookahead' (ANewCRef _ _ _) = [WillNewCRef] lookahead (AReadCRef (CRef r _) _) = WillReadCRef r
lookahead' (AReadCRef (CRef r _) _) = [WillReadCRef r] lookahead (AReadCRefCas (CRef r _) _) = WillReadCRefCas r
lookahead' (AReadCRefCas (CRef r _) _) = [WillReadCRefCas r] lookahead (AModCRef (CRef r _) _ _) = WillModCRef r
lookahead' (AModCRef (CRef r _) _ _) = [WillModCRef r] lookahead (AModCRefCas (CRef r _) _ _) = WillModCRefCas r
lookahead' (AModCRefCas (CRef r _) _ _) = [WillModCRefCas r] lookahead (AWriteCRef (CRef r _) _ _) = WillWriteCRef r
lookahead' (AWriteCRef (CRef r _) _ k) = WillWriteCRef r : lookahead' k lookahead (ACasCRef (CRef r _) _ _ _) = WillCasCRef r
lookahead' (ACasCRef (CRef r _) _ _ _) = [WillCasCRef r] lookahead (ACommit t c) = WillCommitCRef t c
lookahead' (ACommit t c) = [WillCommitCRef t c] lookahead (AAtom _ _) = WillSTM
lookahead' (AAtom _ _) = [WillSTM] lookahead (AThrow _) = WillThrow
lookahead' (AThrow _) = [WillThrow] lookahead (AThrowTo tid _ _) = WillThrowTo tid
lookahead' (AThrowTo tid _ k) = WillThrowTo tid : lookahead' k lookahead (ACatching _ _ _) = WillCatching
lookahead' (ACatching _ _ _) = [WillCatching] lookahead (APopCatching _) = WillPopCatching
lookahead' (APopCatching k) = WillPopCatching : lookahead' k lookahead (AMasking ms _ _) = WillSetMasking False ms
lookahead' (AMasking ms _ _) = [WillSetMasking False ms] lookahead (AResetMask b1 b2 ms _) = (if b1 then WillSetMasking else WillResetMasking) b2 ms
lookahead' (AResetMask b1 b2 ms k) = (if b1 then WillSetMasking else WillResetMasking) b2 ms : lookahead' k lookahead (ALift _) = WillLiftIO
lookahead' (ALift _) = [WillLiftIO] lookahead (AYield _) = WillYield
lookahead' (AYield k) = WillYield : lookahead' k lookahead (AReturn _) = WillReturn
lookahead' (AReturn k) = WillReturn : lookahead' k lookahead (AStop _) = WillStop
lookahead' (AStop _) = [WillStop] lookahead (ASub _ _) = WillSubconcurrency
lookahead' (ASub _ _) = [WillSubconcurrency] lookahead (AStopSub _) = WillStopSubconcurrency
lookahead' (AStopSub k) = WillStopSubconcurrency : lookahead' k