dejafu 0.7.0.2 → 0.7.1.0
raw patch · 9 files changed
+306/−84 lines, 9 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Test.DejaFu.STM: instance GHC.Base.Monad n => Control.Monad.STM.Class.MonadSTM (Test.DejaFu.STM.STMLike n r)
+ Test.DejaFu: DiscardResultAndTrace :: Discard
+ Test.DejaFu: DiscardTrace :: Discard
+ Test.DejaFu: data Discard
+ Test.DejaFu: defaultDiscarder :: Either Failure a -> Maybe Discard
+ Test.DejaFu: dejafuDiscard :: Show a => (Either Failure a -> Maybe Discard) -> Way -> MemType -> (forall t. ConcST t a) -> (String, Predicate a) -> IO Bool
+ Test.DejaFu: dejafuDiscardIO :: Show a => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcIO a -> (String, Predicate a) -> IO Bool
+ Test.DejaFu.Common: runRefCont :: MonadRef r n => (n () -> x) -> (a -> Maybe b) -> ((a -> x) -> x) -> n (x, r (Maybe b))
+ Test.DejaFu.Defaults: defaultDiscarder :: Either Failure a -> Maybe Discard
+ Test.DejaFu.SCT: DiscardResultAndTrace :: Discard
+ Test.DejaFu.SCT: DiscardTrace :: Discard
+ Test.DejaFu.SCT: data Discard
+ Test.DejaFu.SCT: instance Control.DeepSeq.NFData Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Classes.Eq Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Classes.Ord Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Enum.Bounded Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Enum.Enum Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Read.Read Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Show.Show Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: resultsSetDiscard :: (MonadRef r n, Ord a) => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))
+ Test.DejaFu.SCT: resultsSetDiscard' :: (MonadRef r n, Ord a, NFData a) => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))
+ Test.DejaFu.SCT: runSCTDiscard :: MonadRef r n => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.SCT: runSCTDiscard' :: (MonadRef r n, NFData a) => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.SCT: sctBoundDiscard :: MonadRef r n => (Either Failure a -> Maybe Discard) -> MemType -> Bounds -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.SCT: sctUniformRandomDiscard :: (MonadRef r n, RandomGen g) => (Either Failure a -> Maybe Discard) -> MemType -> g -> Int -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.SCT: sctWeightedRandomDiscard :: (MonadRef r n, RandomGen g) => (Either Failure a -> Maybe Discard) -> MemType -> g -> Int -> Int -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.STM: instance Control.Monad.STM.Class.MonadSTM (Test.DejaFu.STM.STMLike n r)
Files
- CHANGELOG.markdown +33/−0
- Test/DejaFu.hs +35/−3
- Test/DejaFu/Common.hs +17/−0
- Test/DejaFu/Conc/Internal.hs +43/−46
- Test/DejaFu/Defaults.hs +6/−0
- Test/DejaFu/SCT.hs +167/−27
- Test/DejaFu/STM.hs +1/−1
- Test/DejaFu/STM/Internal.hs +1/−5
- dejafu.cabal +3/−2
CHANGELOG.markdown view
@@ -6,6 +6,39 @@ This project is versioned according to the [Package Versioning Policy](https://pvp.haskell.org), the *de facto* standard Haskell versioning scheme. +0.7.1.0 [2017-08-10] (git tag: [dejafu-0.7.1.0][])+-------++https://hackage.haskell.org/package/dejafu-0.7.1.0++### Test.DejaFu++- Exposed the new SCT discard functions through `dejafuDiscard` and `dejafuDiscardIO`.++ There are no `dejafusDiscard` and `dejafusDiscardIO` functions because this would probably be+ confusing, as the traces are shared.++- The `Discard` type and `defaultDiscard` function are also exposed.++### Test.DejaFu.Defaults++- Added a new `defaultDiscarder` function, which discards nothing.++### Test.DejaFu.SCT++- Added new SCT functions to selectively discard results or traces, which can be a significant+ memory saving if you know what sorts of results you are interested in:+ - New type: `Discard`.+ - New functions: `runSCTDiscard`, `resultsSetDiscard`, `sctBoundDiscard`,+ `sctUniformRandomDiscard`, and `sctWeightedRandomDiscard`.+ - `resultsSet` and `resultsSet'` now discard traces as they are produced, rather than all at the+ end, greatly improving performance when traces are large.++[dejafu-0.7.1.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.1.0+++---------------------------------------------------------------------------------------------------+ 0.7.0.2 [2017-06-12] (git tag: [dejafu-0.7.0.2][]) -------
Test/DejaFu.hs view
@@ -107,6 +107,12 @@ , dejafusWay , dejafusWayIO + , Discard(..)+ , defaultDiscarder++ , dejafuDiscard+ , dejafuDiscardIO+ -- ** Memory Models -- | Threads running under modern multicore processors do not behave@@ -378,8 +384,27 @@ -> (String, Predicate a) -- ^ The predicate (with a name) to check -> IO Bool-dejafuWay way memtype conc test = dejafusWay way memtype conc [test]+dejafuWay = dejafuDiscard (const Nothing) +-- | Variant of 'dejafuWay' which can selectively discard results.+--+-- @since 0.7.1.0+dejafuDiscard :: Show a+ => (Either Failure a -> Maybe Discard)+ -- ^ Selectively discard results.+ -> Way+ -- ^ How to run the concurrent program.+ -> MemType+ -- ^ The memory model to use for non-synchronised @CRef@ operations.+ -> (forall t. ConcST t a)+ -- ^ The computation to test+ -> (String, Predicate a)+ -- ^ The predicate (with a name) to check+ -> IO Bool+dejafuDiscard discard way memtype conc (name, test) = do+ let traces = runST (runSCTDiscard discard way memtype conc)+ doTest name (test traces)+ -- | Variant of 'dejafu' which takes a collection of predicates to -- test, returning 'True' if all pass. --@@ -421,8 +446,15 @@ -- -- @since 0.6.0.0 dejafuWayIO :: Show a => Way -> MemType -> ConcIO a -> (String, Predicate a) -> IO Bool-dejafuWayIO way memtype concio test =- dejafusWayIO way memtype concio [test]+dejafuWayIO = dejafuDiscardIO (const Nothing)++-- | Variant of 'dejafuDiscard' for computations which do 'IO'.+--+-- @since 0.7.1.0+dejafuDiscardIO :: Show a => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcIO a -> (String, Predicate a) -> IO Bool+dejafuDiscardIO discard way memtype concio (name, test) = do+ traces <- runSCTDiscard discard way memtype concio+ doTest name (test traces) -- | Variant of 'dejafus' for computations which do 'IO'. --
Test/DejaFu/Common.hs view
@@ -56,10 +56,14 @@ -- * Memory models , MemType(..)++ -- * Miscellaneous+ , runRefCont ) where import Control.DeepSeq (NFData(..)) import Control.Exception (MaskingState(..))+import Control.Monad.Ref (MonadRef(..)) import Data.List (intercalate, nub, sort) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe, mapMaybe)@@ -738,6 +742,7 @@ -- -- @since 0.5.0.0 showTrace :: Trace -> String+showTrace [] = "<trace discarded>" showTrace trc = intercalate "\n" $ concatMap go trc : strkey where go (_,_,CommitCRef _ _) = "C-" go (Start (ThreadId _ i),_,_) = "S" ++ show i ++ "-"@@ -857,6 +862,18 @@ -- | @since 0.5.1.0 instance NFData MemType where rnf m = m `seq` ()++-------------------------------------------------------------------------------+-- Miscellaneous++-- | Run with a continuation that writes its value into a reference,+-- returning the computation and the reference. Using the reference+-- is non-blocking, it is up to you to ensure you wait sufficiently.+runRefCont :: MonadRef r n => (n () -> x) -> (a -> Maybe b) -> ((a -> x) -> x) -> n (x, r (Maybe b))+runRefCont act f k = do+ ref <- newRef Nothing+ let c = k (act . writeRef ref . f)+ pure (c, ref) ------------------------------------------------------------------------------- -- Utilities
Test/DejaFu/Conc/Internal.hs view
@@ -21,11 +21,10 @@ writeRef) import qualified Data.Foldable as F import Data.Functor (void)-import Data.List (sort)+import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty(..), fromList) import qualified Data.Map.Strict as M-import Data.Maybe (fromJust, isJust,- isNothing)+import Data.Maybe (fromJust, isJust) import Data.Monoid ((<>)) import Data.Sequence (Seq, (<|)) import qualified Data.Sequence as Seq@@ -57,16 +56,13 @@ -> M n r a -> n (Either Failure a, Context n r g, SeqTrace, Maybe (ThreadId, ThreadAction)) runConcurrency sched memtype g idsrc caps ma = do- ref <- newRef Nothing-- let c = runCont ma (AStop . writeRef ref . Just . Right)+ (c, ref) <- runRefCont AStop (Just . Right) (runM ma) let ctx = Context { cSchedState = g , cIdSource = idsrc , cThreads = launch' Unmasked initialThread (const c) M.empty , cWriteBuf = emptyBuffer , cCaps = caps }- (finalCtx, trace, finalAction) <- runThreads sched memtype ref ctx out <- readRef ref pure (fromJust out, finalCtx, trace, finalAction)@@ -90,42 +86,28 @@ | isTerminated = pure (ctx, sofar, prior) | isDeadlocked = die sofar prior Deadlock ctx | isSTMLocked = die sofar prior STMDeadlock ctx- | isAborted = die sofar prior Abort $ ctx { cSchedState = g' }- | isNonexistant = die sofar prior InternalError $ ctx { cSchedState = g' }- | isBlocked = die sofar prior InternalError $ ctx { cSchedState = g' }- | otherwise = do- stepped <- stepThread sched memtype chosen (_continuation $ fromJust thread) $ ctx { cSchedState = g' }- case stepped of- (Right ctx', actOrTrc) ->- let (_, trc) = getActAndTrc actOrTrc- threads' = if (interruptible <$> M.lookup chosen (cThreads ctx')) /= Just False- then unblockWaitingOn chosen (cThreads ctx')- else cThreads ctx'- sofarSched' = sofarSched <> map (\(d,_,a) -> (d,a)) (F.toList trc)- ctx'' = ctx' { cThreads = delCommitThreads threads' }- in go (sofar <> trc) sofarSched' (getPrior actOrTrc) ctx''- (Left failure, actOrTrc) ->- let (_, trc) = getActAndTrc actOrTrc- ctx' = ctx { cSchedState = g', cThreads = delCommitThreads threads }- in die (sofar <> trc) (getPrior actOrTrc) failure ctx'-+ | otherwise =+ let ctx' = ctx { cSchedState = g' }+ in case choice of+ Just chosen -> case M.lookup chosen threadsc of+ Just thread+ | isBlocked thread -> die sofar prior InternalError ctx'+ | otherwise -> step chosen thread ctx'+ 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)- chosen = fromJust choice- runnable' = [(t, nextActions t) | t <- sort $ M.keys runnable]- runnable = M.filter (isNothing . _blocking) threadsc- thread = M.lookup chosen threadsc+ runnable' = [(t, lookahead (_continuation a)) | (t, a) <- sortOn fst $ M.assocs runnable]+ runnable = M.filter (not . isBlocked) threadsc threadsc = addCommitThreads (cWriteBuf ctx) threads threads = cThreads ctx- isAborted = isNothing choice- isBlocked = isJust . _blocking $ fromJust thread- isNonexistant = isNothing thread+ isBlocked = isJust . _blocking isTerminated = initialThread `notElem` M.keys threads- isDeadlocked = M.null (M.filter (isNothing . _blocking) threads) &&+ isDeadlocked = M.null (M.filter (not . isBlocked) threads) && (((~= OnMVarFull undefined) <$> M.lookup initialThread threads) == Just True || ((~= OnMVarEmpty undefined) <$> M.lookup initialThread threads) == Just True || ((~= OnMask undefined) <$> M.lookup initialThread threads) == Just True)- isSTMLocked = M.null (M.filter (isNothing . _blocking) threads) &&+ isSTMLocked = M.null (M.filter (not . isBlocked) threads) && ((~= OnTVar []) <$> M.lookup initialThread threads) == Just True unblockWaitingOn tid = fmap unblock where@@ -133,22 +115,37 @@ Just (OnMask t) | t == tid -> thrd { _blocking = Nothing } _ -> thrd - decision- | Just chosen == (fst <$> prior) = Continue- | (fst <$> prior) `notElem` map (Just . fst) runnable' = Start chosen- | otherwise = SwitchTo chosen-- nextActions t = lookahead . _continuation . fromJust $ M.lookup t threadsc- die sofar' finalDecision reason finalCtx = do writeRef ref (Just $ Left reason) pure (finalCtx, sofar', finalDecision) - getActAndTrc (Single a) = (a, Seq.singleton (decision, runnable', a))- getActAndTrc (SubC as _) = (Subconcurrency, (decision, runnable', Subconcurrency) <| as)+ step chosen thread ctx' = do+ (res, actOrTrc) <- stepThread sched memtype chosen (_continuation thread) $ ctx { cSchedState = g' }+ let trc = getTrc actOrTrc+ let sofar' = sofar <> trc+ let sofarSched' = sofarSched <> map (\(d,_,a) -> (d,a)) (F.toList trc)+ let prior' = getPrior actOrTrc+ case res of+ Right ctx'' ->+ let threads' = if (interruptible <$> M.lookup chosen (cThreads ctx'')) /= Just False+ then unblockWaitingOn chosen (cThreads ctx'')+ else cThreads ctx''+ ctx''' = ctx'' { cThreads = delCommitThreads threads' }+ in go sofar' sofarSched' prior' ctx'''+ Left failure ->+ let ctx'' = ctx' { cThreads = delCommitThreads threads }+ in die sofar' prior' failure ctx''+ where+ decision+ | Just chosen == (fst <$> prior) = Continue+ | (fst <$> prior) `notElem` map (Just . fst) runnable' = Start chosen+ | otherwise = SwitchTo chosen - getPrior (Single a) = Just (chosen, a)- getPrior (SubC _ finalD) = finalD+ getTrc (Single a) = Seq.singleton (decision, runnable', a)+ getTrc (SubC as _) = (decision, runnable', Subconcurrency) <| as++ getPrior (Single a) = Just (chosen, a)+ getPrior (SubC _ finalD) = finalD -------------------------------------------------------------------------------- -- * Single-step execution
Test/DejaFu/Defaults.hs view
@@ -19,6 +19,12 @@ defaultWay :: Way defaultWay = systematically defaultBounds +-- | Do not discard any results.+--+-- @since 0.7.1.0+defaultDiscarder :: Either Failure a -> Maybe Discard+defaultDiscarder = const Nothing+ -- | The default memory model: @TotalStoreOrder@ -- -- @since 0.2.0.0
Test/DejaFu/SCT.hs view
@@ -18,9 +18,18 @@ , uniformly , swarmy , runSCT- , runSCT' , resultsSet++ -- ** Discarding variants+ , Discard(..)+ , runSCTDiscard+ , resultsSetDiscard++ -- ** Strict variants+ , runSCT' , resultsSet'+ , runSCTDiscard'+ , resultsSetDiscard' -- * Bounded Partial-order Reduction @@ -51,6 +60,7 @@ , Bounds(..) , noBounds , sctBound+ , sctBoundDiscard -- ** Pre-emption Bounding @@ -91,8 +101,11 @@ , sctUniformRandom , sctWeightedRandom+ , sctUniformRandomDiscard+ , sctWeightedRandomDiscard ) where +import Control.Applicative ((<|>)) import Control.DeepSeq (NFData(..)) import Control.Monad.Ref (MonadRef) import Data.List (foldl')@@ -201,21 +214,7 @@ -> ConcT r n a -- ^ The computation to run many times. -> n [(Either Failure a, Trace)]-runSCT (Systematic cb) memtype = sctBound memtype cb-runSCT (Weighted g lim use) memtype = sctWeightedRandom memtype g lim use-runSCT (Uniform g lim) memtype = sctUniformRandom memtype g lim---- | A strict variant of 'runSCT'.------ Demanding the result of this will force it to normal form, which--- may be more efficient in some situations.------ @since 0.6.0.0-runSCT' :: (MonadRef r n, NFData a)- => Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]-runSCT' way memtype conc = do- res <- runSCT way memtype conc- rnf res `seq` pure res+runSCT = runSCTDiscard (const Nothing) -- | Return the set of results of a concurrent program. --@@ -228,9 +227,68 @@ -> ConcT r n a -- ^ The computation to run many times. -> n (Set (Either Failure a))-resultsSet way memtype conc =- S.fromList . map fst <$> runSCT way memtype conc+resultsSet = resultsSetDiscard (const Nothing) +-- | An @Either Failure a -> Maybe Discard@ value can be used to+-- selectively discard results.+--+-- @since 0.7.1.0+data Discard+ = DiscardTrace+ -- ^ Discard the trace but keep the result. The result will appear+ -- to have an empty trace.+ | DiscardResultAndTrace+ -- ^ Discard the result and the trace. It will simply not be+ -- reported as a possible behaviour of the program.+ deriving (Eq, Show, Read, Ord, Enum, Bounded)++instance NFData Discard where+ rnf d = d `seq` ()++-- | A variant of 'runSCT' which can selectively discard results.+--+-- @since 0.7.1.0+runSCTDiscard :: MonadRef r n+ => (Either Failure a -> Maybe Discard)+ -- ^ Selectively discard results.+ -> Way+ -- ^ How to run the concurrent program.+ -> MemType+ -- ^ The memory model to use for non-synchronised @CRef@ operations.+ -> ConcT r n a+ -- ^ The computation to run many times.+ -> n [(Either Failure a, Trace)]+runSCTDiscard discard (Systematic cb) memtype = sctBoundDiscard discard memtype cb+runSCTDiscard discard (Weighted g lim use) memtype = sctWeightedRandomDiscard discard memtype g lim use+runSCTDiscard discard (Uniform g lim) memtype = sctUniformRandomDiscard discard memtype g lim++-- | A variant of 'resultsSet' which can selectively discard results.+--+-- @since 0.7.1.0+resultsSetDiscard :: (MonadRef r n, Ord a)+ => (Either Failure a -> Maybe Discard)+ -- ^ Selectively discard results. Traces are always discarded.+ -> Way+ -- ^ How to run the concurrent program.+ -> MemType+ -- ^ The memory model to use for non-synchronised @CRef@ operations.+ -> ConcT r n a+ -- ^ The computation to run many times.+ -> n (Set (Either Failure a))+resultsSetDiscard discard way memtype conc =+ let discard' efa = discard efa <|> Just DiscardTrace+ in S.fromList . map fst <$> runSCTDiscard discard' way memtype conc++-- | A strict variant of 'runSCT'.+--+-- Demanding the result of this will force it to normal form, which+-- may be more efficient in some situations.+--+-- @since 0.6.0.0+runSCT' :: (MonadRef r n, NFData a)+ => Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]+runSCT' = runSCTDiscard' (const Nothing)+ -- | A strict variant of 'resultsSet'. -- -- Demanding the result of this will force it to normal form, which@@ -239,10 +297,32 @@ -- @since 0.6.0.0 resultsSet' :: (MonadRef r n, Ord a, NFData a) => Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))-resultsSet' way memtype conc = do- res <- resultsSet' way memtype conc+resultsSet' = resultsSetDiscard' (const Nothing)++-- | A strict variant of 'runSCTDiscard'.+--+-- Demanding the result of this will force it to normal form, which+-- may be more efficient in some situations.+--+-- @since 0.7.1.0+runSCTDiscard' :: (MonadRef r n, NFData a)+ => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]+runSCTDiscard' discard way memtype conc = do+ res <- runSCTDiscard discard way memtype conc rnf res `seq` pure res +-- | A strict variant of 'resultsSetDiscard'.+--+-- Demanding the result of this will force it to normal form, which+-- may be more efficient in some situations.+--+-- @since 0.7.1.0+resultsSetDiscard' :: (MonadRef r n, Ord a, NFData a)+ => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))+resultsSetDiscard' discard way memtype conc = do+ res <- resultsSetDiscard discard way memtype conc+ rnf res `seq` pure res+ ------------------------------------------------------------------------------- -- Combined Bounds @@ -394,7 +474,22 @@ -> ConcT r n a -- ^ The computation to run many times -> n [(Either Failure a, Trace)]-sctBound memtype cb conc = go initialState where+sctBound = sctBoundDiscard (const Nothing)++-- | A variant of 'sctBound' which can selectively discard results.+--+-- @since 0.7.1.0+sctBoundDiscard :: MonadRef r n+ => (Either Failure a -> Maybe Discard)+ -- ^ Selectively discard results.+ -> MemType+ -- ^ The memory model to use for non-synchronised @CRef@ operations.+ -> Bounds+ -- ^ The combined bounds.+ -> ConcT r n a+ -- ^ The computation to run many times+ -> n [(Either Failure a, Trace)]+sctBoundDiscard discard memtype cb conc = go initialState where -- Repeatedly run the computation gathering all the results and -- traces into a list until there are no schedules remaining to try. go dp = case findSchedulePrefix dp of@@ -408,8 +503,8 @@ let newDPOR = addTrace conservative trace dp if schedIgnore s- then go newDPOR- else ((res, trace):) <$> go (addBacktracks bpoints newDPOR)+ then go newDPOR+ else checkDiscard discard res trace $ go (addBacktracks bpoints newDPOR) Nothing -> pure [] @@ -443,14 +538,32 @@ -> ConcT r n a -- ^ The computation to run many times. -> n [(Either Failure a, Trace)]-sctUniformRandom memtype g0 lim0 conc = go g0 (max 0 lim0) where+sctUniformRandom = sctUniformRandomDiscard (const Nothing)++-- | A variant of 'sctUniformRandom' which can selectively discard+-- results.+--+-- @since 0.7.1.0+sctUniformRandomDiscard :: (MonadRef r n, RandomGen g)+ => (Either Failure a -> Maybe Discard)+ -- ^ Selectively discard results.+ -> MemType+ -- ^ The memory model to use for non-synchronised @CRef@ operations.+ -> g+ -- ^ The random number generator.+ -> Int+ -- ^ The number of executions to perform.+ -> ConcT r n a+ -- ^ The computation to run many times.+ -> n [(Either Failure a, Trace)]+sctUniformRandomDiscard discard memtype g0 lim0 conc = go g0 (max 0 lim0) where go _ 0 = pure [] go g n = do (res, s, trace) <- runConcurrent (randSched $ \g' -> (1, g')) memtype (initialRandSchedState Nothing g) conc- ((res, trace):) <$> go (schedGen s) (n-1)+ checkDiscard discard res trace $ go (schedGen s) (n-1) -- | SCT via weighted random scheduling. --@@ -472,7 +585,27 @@ -> ConcT r n a -- ^ The computation to run many times. -> n [(Either Failure a, Trace)]-sctWeightedRandom memtype g0 lim0 use0 conc = go g0 (max 0 lim0) (max 1 use0) M.empty where+sctWeightedRandom = sctWeightedRandomDiscard (const Nothing)++-- | A variant of 'sctWeightedRandom' which can selectively discard+-- results.+--+-- @since 0.7.1.0+sctWeightedRandomDiscard :: (MonadRef r n, RandomGen g)+ => (Either Failure a -> Maybe Discard)+ -- ^ Selectively discard results.+ -> MemType+ -- ^ The memory model to use for non-synchronised @CRef@ operations.+ -> g+ -- ^ The random number generator.+ -> Int+ -- ^ The number of executions to perform.+ -> Int+ -- ^ The number of executions to use the same set of weights for.+ -> ConcT r n a+ -- ^ The computation to run many times.+ -> n [(Either Failure a, Trace)]+sctWeightedRandomDiscard discard memtype g0 lim0 use0 conc = go g0 (max 0 lim0) (max 1 use0) M.empty where go _ 0 _ _ = pure [] go g n 0 _ = go g n (max 1 use0) M.empty go g n use ws = do@@ -480,7 +613,7 @@ memtype (initialRandSchedState (Just ws) g) conc- ((res, trace):) <$> go (schedGen s) (n-1) (use-1) (schedWeights s)+ checkDiscard discard res trace $ go (schedGen s) (n-1) (use-1) (schedWeights s) ------------------------------------------------------------------------------- -- Utilities@@ -542,3 +675,10 @@ -- satisfied. (&+&) :: BoundFunc -> BoundFunc -> BoundFunc (&+&) b1 b2 ts dl = b1 ts dl && b2 ts dl++-- | Apply the discard function.+checkDiscard :: Functor f => (a -> Maybe Discard) -> a -> [b] -> f [(a, [b])] -> f [(a, [b])]+checkDiscard discard res trace rest = case discard res of+ Just DiscardResultAndTrace -> rest+ Just DiscardTrace -> ((res, []):) <$> rest+ Nothing -> ((res, trace):) <$> rest
Test/DejaFu/STM.hs view
@@ -71,7 +71,7 @@ instance MonadCatch (STMLike n r) where catch (S stm) handler = toSTM (SCatch (runSTM . handler) stm) -instance Monad n => C.MonadSTM (STMLike n r) where+instance C.MonadSTM (STMLike n r) where type TVar (STMLike n r) = TVar r retry = toSTM (const SRetry)
Test/DejaFu/STM/Internal.hs view
@@ -101,12 +101,8 @@ -- | Run a STM transaction, returning an action to undo its effects. doTransaction :: MonadRef r n => M n r a -> IdSource -> n (Result a, n (), IdSource, TTrace) doTransaction ma idsource = do- ref <- newRef Nothing-- let c = runCont ma (SStop . writeRef ref . Just . Right)-+ (c, ref) <- runRefCont SStop (Just . Right) (runCont ma) (idsource', undo, readen, written, trace) <- go ref c (pure ()) idsource [] [] []- res <- readRef ref case res of
dejafu.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: dejafu-version: 0.7.0.2+version: 0.7.1.0 synopsis: Systematic testing for Haskell concurrency. description:@@ -37,7 +37,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git- tag: dejafu-0.7.0.2+ tag: dejafu-0.7.1.0 library exposed-modules: Test.DejaFu@@ -67,6 +67,7 @@ , mtl >=2.2 && <2.3 , random >=1.0 && <1.2 , ref-fd >=0.4 && <0.5+ -- remove semigroups dep when GHC 8.4 is out , semigroups >=0.16 && <0.19 , transformers >=0.4 && <0.6 , transformers-base >=0.4 && <0.5