From c8dfdb1d9236b3fb5d88beea735cd935be6052c0 Mon Sep 17 00:00:00 2001 From: Michael Walker Date: Tue, 26 Sep 2017 11:03:49 +0100 Subject: [PATCH] Only include a single step of lookahead in traces Closes #120 --- dejafu/CHANGELOG.markdown | 11 ++++ dejafu/Test/DejaFu/Common.hs | 19 +++--- dejafu/Test/DejaFu/Conc/Internal.hs | 7 +-- dejafu/Test/DejaFu/Conc/Internal/Common.hs | 68 +++++++++++----------- 4 files changed, 56 insertions(+), 49 deletions(-) diff --git a/dejafu/CHANGELOG.markdown b/dejafu/CHANGELOG.markdown index 49b0ca7..0be0c03 100644 --- a/dejafu/CHANGELOG.markdown +++ b/dejafu/CHANGELOG.markdown @@ -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 ------- diff --git a/dejafu/Test/DejaFu/Common.hs b/dejafu/Test/DejaFu/Common.hs index 8f94d4a..4ea0cb6 100644 --- a/dejafu/Test/DejaFu/Common.hs +++ b/dejafu/Test/DejaFu/Common.hs @@ -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 diff --git a/dejafu/Test/DejaFu/Conc/Internal.hs b/dejafu/Test/DejaFu/Conc/Internal.hs index f84ee37..2c8a542 100755 --- a/dejafu/Test/DejaFu/Conc/Internal.hs +++ b/dejafu/Test/DejaFu/Conc/Internal.hs @@ -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 diff --git a/dejafu/Test/DejaFu/Conc/Internal/Common.hs b/dejafu/Test/DejaFu/Conc/Internal/Common.hs index 64ec0b3..04c6154 100755 --- a/dejafu/Test/DejaFu/Conc/Internal/Common.hs +++ b/dejafu/Test/DejaFu/Conc/Internal/Common.hs @@ -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