mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-12-18 19:11:37 +03:00
Implement BPOR for SCT, return to listy predicates.
This performs better with "real" code (the Par monad) but surprisingly does far worse with the included tests! The next thing to do is implement the orthogonal sleep sets algorithm to cut down on available choices even further and hopefully correct this issue. See also: "Bounded Partial-Order Reduction" [Coons, Musuvathi, McKinley 2013]
This commit is contained in:
Michael Walker
parent
23c350c4b1
commit
c12cbcf707
103
Test/DejaFu.hs
103
Test/DejaFu.hs
@ -90,7 +90,6 @@ import Control.Applicative ((<$>))
|
||||
import Control.Arrow (first)
|
||||
import Control.DeepSeq (NFData(..))
|
||||
import Control.Monad (when)
|
||||
import Data.List (partition)
|
||||
import Data.List.Extra
|
||||
import Test.DejaFu.Deterministic
|
||||
import Test.DejaFu.Deterministic.IO (ConcIO)
|
||||
@ -117,8 +116,8 @@ dejafus = dejafus' 2
|
||||
-- | Variant of 'dejafus' which takes a pre-emption bound.
|
||||
dejafus' :: (Eq a, Show a) => Int -> (forall t. Conc t a) -> [(String, Predicate a)] -> IO Bool
|
||||
dejafus' pb conc tests = do
|
||||
let traces = sctPreBound conc
|
||||
results <- mapM (\(name, test) -> doTest name $ runTest'' pb test traces) tests
|
||||
let traces = sctPreBound pb conc
|
||||
results <- mapM (\(name, test) -> doTest name $ test traces) tests
|
||||
return $ and results
|
||||
|
||||
-- | Variant of 'dejafus' for computations which do 'IO'.
|
||||
@ -128,9 +127,8 @@ dejafusIO = dejafusIO' 2
|
||||
-- | Variant of 'dejafus'' for computations which do 'IO'.
|
||||
dejafusIO' :: (Eq a, Show a) => Int -> (forall t. ConcIO t a) -> [(String, Predicate a)] -> IO Bool
|
||||
dejafusIO' pb concio tests = do
|
||||
traces <- sctPreBoundIO concio
|
||||
traces' <- mapM (sequenceIOTree $ Just pb) traces
|
||||
results <- mapM (\(name, test) -> doTest name $ runTest'' pb test traces') tests
|
||||
traces <- sctPreBoundIO pb concio
|
||||
results <- mapM (\(name, test) -> doTest name $ test traces) tests
|
||||
return $ and results
|
||||
|
||||
-- | Automatically test a computation. In particular, look for
|
||||
@ -185,25 +183,17 @@ runTestIO = runTestIO' 2
|
||||
|
||||
-- | Variant of 'runTest' which takes a pre-emption bound.
|
||||
runTest' :: Eq a => Int -> Predicate a -> (forall t. Conc t a) -> Result a
|
||||
runTest' pb predicate conc = runTest'' pb predicate $ sctPreBound conc
|
||||
|
||||
-- | Variant of 'runTest'' which takes a tree of results and a depth limit.
|
||||
runTest'' :: Eq a => Int -> Predicate a -> [SCTTree a] -> Result a
|
||||
runTest'' pb predicate results = predicate $ map (bound pb) results where
|
||||
bound 0 (SCTTree a t _) = SCTTree a t []
|
||||
bound n (SCTTree a t os) = SCTTree a t $ map (bound $ n - 1) os
|
||||
runTest' pb predicate conc = predicate $ sctPreBound pb conc
|
||||
|
||||
-- | Variant of 'runTest'' for computations which do 'IO'.
|
||||
runTestIO' :: Eq a => Int -> Predicate a -> (forall t. ConcIO t a) -> IO (Result a)
|
||||
runTestIO' pb predicate conc = do
|
||||
results <- sctPreBoundIO conc
|
||||
runTest'' pb predicate <$> mapM (sequenceIOTree $ Just pb) results
|
||||
runTestIO' pb predicate conc = predicate <$> sctPreBoundIO pb conc
|
||||
|
||||
-- * Predicates
|
||||
|
||||
-- | A @Predicate@ is a function which collapses a list of results
|
||||
-- into a 'Result'.
|
||||
type Predicate a = [SCTTree a] -> Result a
|
||||
type Predicate a = [(Either Failure a, Trace)] -> Result a
|
||||
|
||||
-- | Check that a computation never deadlocks.
|
||||
deadlocksNever :: Predicate a
|
||||
@ -237,33 +227,23 @@ alwaysSame = alwaysTrue2 (==)
|
||||
|
||||
-- | Check that the result of a computation is not always the same.
|
||||
notAlwaysSame :: Eq a => Predicate a
|
||||
notAlwaysSame ts = go ts Result { _pass = False, _casesChecked = 0, _failures = [] } where
|
||||
go (SCTTree a t offs:sibs) res = case (offs, sibs) of
|
||||
(SCTTree o u _:_, SCTTree s v _:_) -> case (a /= o, a /= s) of
|
||||
(True, True) -> incCC . incCC $ res { _pass = True }
|
||||
(True, False) -> incCC . incCC $ res { _pass = True, _failures = (a, t) : (s, v) : _failures res }
|
||||
(False, True) -> incCC . incCC $ res { _pass = True, _failures = (a, t) : (o, u) : _failures res }
|
||||
(False, False) -> go sibs . incCC . incCC $ res { _failures = (a, t) : (s, v) : (o, u) : _failures res }
|
||||
|
||||
(SCTTree o u _:_, [])
|
||||
| a /= o -> incCC $ res { _pass = True }
|
||||
| otherwise -> go (offs++sibs) . incCC $ res { _failures = (a, t) : (o, u) : _failures res }
|
||||
|
||||
([], SCTTree s v _:_)
|
||||
| a /= s -> incCC $ res { _pass = True }
|
||||
| otherwise -> go (offs++sibs) . incCC $ res { _failures = (a, t) : (s, v) : _failures res }
|
||||
|
||||
([], []) -> incCC res
|
||||
|
||||
go [] res = res
|
||||
notAlwaysSame [x] = Result { _pass = False, _casesChecked = 1, _failures = [x] }
|
||||
notAlwaysSame xs = go xs Result { _pass = False, _casesChecked = 0, _failures = [] } where
|
||||
go [y1,y2] res
|
||||
| fst y1 /= fst y2 = incCC res { _pass = True }
|
||||
| otherwise = incCC res { _failures = y1 : y2 : _failures res }
|
||||
go (y1:y2:ys) res
|
||||
| fst y1 /= fst y2 = go (y2:ys) . incCC $ res { _pass = True }
|
||||
| otherwise = go (y2:ys) . incCC $ res { _failures = y1 : y2 : _failures res }
|
||||
go _ res = res
|
||||
|
||||
-- | Check that the result of a unary boolean predicate is always
|
||||
-- true.
|
||||
alwaysTrue :: (Either Failure a -> Bool) -> Predicate a
|
||||
alwaysTrue p ts = go ts Result { _pass = True, _casesChecked = 0, _failures = [] } where
|
||||
go (SCTTree a t offs:sibs) res
|
||||
| p a = go (offs++sibs) . incCC $ res
|
||||
| otherwise = (go sibs res { _failures = (a, t) : _failures res }) { _pass = False, _casesChecked = 1+_casesChecked res }
|
||||
alwaysTrue p xs = go xs Result { _pass = True, _casesChecked = 0, _failures = filter (not . p . fst) xs } where
|
||||
go (y:ys) res
|
||||
| p (fst y) = go ys . incCC $ res
|
||||
| otherwise = incCC $ res { _pass = False }
|
||||
go [] res = res
|
||||
|
||||
-- | Check that the result of a binary boolean predicate is true
|
||||
@ -274,38 +254,29 @@ alwaysTrue p ts = go ts Result { _pass = True, _casesChecked = 0, _failures = []
|
||||
-- to the failures list.
|
||||
alwaysTrue2 :: (Either Failure a -> Either Failure a -> Bool) -> Predicate a
|
||||
alwaysTrue2 _ [_] = Result { _pass = True, _casesChecked = 1, _failures = [] }
|
||||
alwaysTrue2 p ts = go ts Result { _pass = True, _casesChecked = 0, _failures = [] } where
|
||||
go (SCTTree a t offs:sibs) res =
|
||||
let r' = dosibs res
|
||||
in if _pass r' then dooffs r' else dooffs r' { _casesChecked = _casesChecked r' }
|
||||
alwaysTrue2 p xs = go xs Result { _pass = True, _casesChecked = 0, _failures = failures xs } where
|
||||
go [y1,y2] res
|
||||
| p (fst y1) (fst y2) = incCC res
|
||||
| otherwise = incCC res { _pass = False }
|
||||
go (y1:y2:ys) res
|
||||
| p (fst y1) (fst y2) = go (y2:ys) . incCC $ res
|
||||
| otherwise = go (y2:ys) . incCC $ res { _pass = False }
|
||||
go _ res = res
|
||||
|
||||
where
|
||||
dosibs r = case partition (\(SCTTree x _ _) -> p a x) sibs of
|
||||
(good, []) -> go good (r { _casesChecked = length good + _casesChecked r })
|
||||
([], bad) -> r { _casesChecked = 1 + _casesChecked r
|
||||
, _failures = [(a,t)| _pass r] ++ map (\(SCTTree x y _) -> (x,y)) bad ++ _failures r
|
||||
, _pass = False }
|
||||
(good, bad) -> (go good r) { _casesChecked = length good + _casesChecked r
|
||||
, _failures = [(a,t)| _pass r] ++ map (\(SCTTree x y _) -> (x,y)) bad ++ _failures r
|
||||
, _pass = False }
|
||||
failures (y1:y2:ys)
|
||||
| p (fst y1) (fst y2) = failures (y2:ys)
|
||||
| otherwise = y1 : if null ys then [y2] else failures (y2:ys)
|
||||
failures _ = []
|
||||
|
||||
dooffs r = case partition (\(SCTTree x _ _) -> p a x) offs of
|
||||
(good, []) -> go good (r { _casesChecked = length good + _casesChecked r })
|
||||
([], bad) -> r { _casesChecked = 1 + _casesChecked r
|
||||
, _failures = [(a,t)| _pass r] ++ map (\(SCTTree x y _) -> (x,y)) bad ++ _failures r
|
||||
, _pass = False }
|
||||
(good, bad) -> (go good r) { _casesChecked = length good + _casesChecked r
|
||||
, _failures = [(a,t)| _pass r] ++ map (\(SCTTree x y _) -> (x,y)) bad ++ _failures r
|
||||
, _pass = False }
|
||||
go [] res = res
|
||||
-- alwaysTrue2 almost certainly reports the number of cases checked incorrectly.
|
||||
|
||||
-- | Check that the result of a unary boolean predicate is true at
|
||||
-- least once.
|
||||
somewhereTrue :: (Either Failure a -> Bool) -> Predicate a
|
||||
somewhereTrue p ts = go ts Result { _pass = False, _casesChecked = 0, _failures = [] } where
|
||||
go (SCTTree a t offs:sibs) res
|
||||
| p a = incCC res { _pass = True }
|
||||
| otherwise = go (offs++sibs) $ incCC res { _failures = (a, t) : _failures res }
|
||||
somewhereTrue p xs = go xs Result { _pass = False, _casesChecked = 0, _failures = filter (not . p . fst) xs } where
|
||||
go (y:ys) res
|
||||
| p (fst y) = incCC $ res { _pass = True }
|
||||
| otherwise = go ys . incCC $ res { _failures = y : _failures res }
|
||||
go [] res = res
|
||||
|
||||
-- * Internal
|
||||
|
||||
@ -34,13 +34,13 @@ module Test.DejaFu.Deterministic.Internal
|
||||
, Failure(..)
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Exception (MaskingState(..))
|
||||
import Control.Monad.Cont (cont, runCont)
|
||||
import Control.State
|
||||
import Data.List (sort)
|
||||
import Data.List.Extra
|
||||
import Data.Maybe (fromJust, isJust, isNothing)
|
||||
import Data.Maybe (fromJust, isJust, isNothing, listToMaybe)
|
||||
import Test.DejaFu.STM (CTVarId, Result(..))
|
||||
import Test.DejaFu.Deterministic.Internal.Common
|
||||
import Test.DejaFu.Deterministic.Internal.CVar
|
||||
@ -108,7 +108,7 @@ runThreads fixed runstm sched origg origthreads idsrc ref = go idsrc [] Nothing
|
||||
Left failure -> writeRef (wref fixed) ref (Just $ Left failure) >> return (g, idSource, sofar)
|
||||
|
||||
where
|
||||
(chosen, g') = sched g prior $ head runnable' :| tail runnable'
|
||||
(chosen, g') = sched g ((\p (_,_,a) -> (p,a)) <$> prior <*> listToMaybe sofar) $ head runnable' :| tail runnable'
|
||||
runnable' = [(t, nextAction t) | t <- sort $ M.keys runnable]
|
||||
runnable = M.filter (isNothing . _blocking) threads
|
||||
thread = M.lookup chosen threads
|
||||
|
||||
@ -112,7 +112,7 @@ initialIdSource = Id 0 0 0 0
|
||||
-- attempts to (a) schedule a blocked thread, or (b) schedule a
|
||||
-- nonexistent thread. In either of those cases, the computation will
|
||||
-- be halted.
|
||||
type Scheduler s = s -> Maybe ThreadId -> NonEmpty (ThreadId, ThreadAction') -> (ThreadId, s)
|
||||
type Scheduler s = s -> Maybe (ThreadId, ThreadAction) -> NonEmpty (ThreadId, ThreadAction') -> (ThreadId, s)
|
||||
|
||||
-- | One of the outputs of the runner is a @Trace@, which is a log of
|
||||
-- decisions made, alternative decisions (including what action would
|
||||
|
||||
@ -35,7 +35,7 @@ randomSchedNP = makeNP randomSched
|
||||
-- thread with the next 'ThreadId'.
|
||||
roundRobinSched :: Scheduler ()
|
||||
roundRobinSched _ Nothing _ = (0, ())
|
||||
roundRobinSched _ (Just prior) threads
|
||||
roundRobinSched _ (Just (prior, _)) threads
|
||||
| prior >= maximum threads' = (minimum threads', ())
|
||||
| otherwise = (minimum $ filter (>prior) threads', ())
|
||||
|
||||
@ -51,7 +51,7 @@ roundRobinSchedNP = makeNP roundRobinSched
|
||||
-- one.
|
||||
makeNP :: Scheduler s -> Scheduler s
|
||||
makeNP sched = newsched where
|
||||
newsched s (Just prior) threads
|
||||
newsched s p@(Just (prior, _)) threads
|
||||
| prior `elem` map fst (toList threads) = (prior, s)
|
||||
| otherwise = sched s (Just prior) threads
|
||||
| otherwise = sched s p threads
|
||||
newsched s Nothing threads = sched s Nothing threads
|
||||
|
||||
369
Test/DejaFu/SCT.hs
Normal file → Executable file
369
Test/DejaFu/SCT.hs
Normal file → Executable file
@ -2,282 +2,155 @@
|
||||
|
||||
-- | Systematic testing for concurrent computations.
|
||||
module Test.DejaFu.SCT
|
||||
( -- * Schedule Bounding
|
||||
-- | Schedule bounding is a means of cutting down the search space of
|
||||
-- schedules, by taking advantage of some intrinsic properties of
|
||||
-- schedules: such as the number of pre-emptions (pre-emption
|
||||
-- bounding), or the number of deviations from a deterministic
|
||||
-- scheduler (delay bounding); and then exploring all schedules
|
||||
-- within the bound.
|
||||
sctBounded
|
||||
, sctPreBound
|
||||
, sctDelayBound
|
||||
, sctBoundedIO
|
||||
, sctPreBoundIO
|
||||
, sctDelayBoundIO
|
||||
( -- * Bounded Partial-order Reduction
|
||||
|
||||
-- * Result Trees
|
||||
, SCTTree(..)
|
||||
, SCTTreeIO(..)
|
||||
, sequenceIOTree
|
||||
-- | We can characterise the state of a concurrent computation by
|
||||
-- considering the ordering of dependent events. This is a partial
|
||||
-- order: independent events can be performed in any order without
|
||||
-- affecting the result, and so are /not/ ordered.
|
||||
--
|
||||
-- Partial-order reduction is a technique for computing these
|
||||
-- partial orders, and only testing one total order for each
|
||||
-- partial order. This cuts down the amount of work to be done
|
||||
-- significantly. /Bounded/ partial-order reduction is a further
|
||||
-- optimisation, which only considers schedules within some bound.
|
||||
--
|
||||
-- This module provides both a generic function for BPOR, and also
|
||||
-- a pre-emption bounding BPOR runner, which is used by the
|
||||
-- "Test.DejaFu" module.
|
||||
|
||||
-- * Utilities
|
||||
, preEmpCount
|
||||
) where
|
||||
sctPreBound
|
||||
, sctPreBoundIO
|
||||
|
||||
import Control.Applicative ((<$>), (<*>), pure)
|
||||
, BacktrackStep(..)
|
||||
, sctBounded
|
||||
, sctBoundedIO
|
||||
|
||||
-- * Utilities
|
||||
, tidOf
|
||||
, tidTag
|
||||
, decisionOf
|
||||
, activeTid
|
||||
, preEmpCount
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Arrow (first)
|
||||
import Control.DeepSeq (NFData(..), force)
|
||||
import Data.Foldable (Foldable(foldMap))
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Traversable (Traversable(traverse), fmapDefault, foldMapDefault)
|
||||
import Data.List (nub)
|
||||
import Data.Map (Map)
|
||||
import Data.Maybe (mapMaybe, fromJust)
|
||||
import Test.DejaFu.Deterministic
|
||||
import Test.DejaFu.Deterministic.IO (ConcIO, runConcIO)
|
||||
import Test.DejaFu.SCT.Internal
|
||||
|
||||
{-# ANN module ("HLint: ignore Use record patterns" :: String) #-}
|
||||
|
||||
-- * Result trees
|
||||
|
||||
-- | Results are presented in a lazy tree, where each node contains a
|
||||
-- trace and a result. The children of a node represent those
|
||||
-- schedules obtainable from it on the next bounding level.
|
||||
data SCTTree a = SCTTree (Either Failure a) Trace [SCTTree a]
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Functor SCTTree where
|
||||
fmap = fmapDefault
|
||||
|
||||
instance Foldable SCTTree where
|
||||
foldMap = foldMapDefault
|
||||
|
||||
instance Traversable SCTTree where
|
||||
traverse f (SCTTree (Left x) t trees) = SCTTree (Left x) <$> pure t <*> traverse (traverse f) trees
|
||||
traverse f (SCTTree (Right x) t trees) = SCTTree . Right <$> f x <*> pure t <*> traverse (traverse f) trees
|
||||
|
||||
instance NFData a => NFData (SCTTree a) where
|
||||
rnf (SCTTree a t trees) = rnf (a, t, trees)
|
||||
|
||||
-- | Results which need IO to compute. Laziness is preserved by
|
||||
-- wrapping child nodes in an 'IO' list.
|
||||
data SCTTreeIO a = SCTTreeIO (Either Failure a) Trace (IO [SCTTreeIO a])
|
||||
|
||||
instance Functor SCTTreeIO where
|
||||
fmap f (SCTTreeIO a t iotrees) = SCTTreeIO (fmap f a) t $ fmap (map $ fmap f) iotrees
|
||||
|
||||
-- | Perform all of the 'IO' in an 'SCTTreeIO' from left to right. As
|
||||
-- '>>=' for IO is strict, this will evaluate the entire tree, which
|
||||
-- may be a lot of work. To counter this, a depth limit can optionally
|
||||
-- be provided, where children below level @0@ will not be present in
|
||||
-- the output.
|
||||
sequenceIOTree :: Maybe Int -> SCTTreeIO a -> IO (SCTTree a)
|
||||
sequenceIOTree (Just n) (SCTTreeIO a t iotrees)
|
||||
| n <= 0 = return $ SCTTree a t []
|
||||
| otherwise = do
|
||||
trees <- iotrees
|
||||
SCTTree a t <$> mapM (sequenceIOTree . Just $ n-1) trees
|
||||
sequenceIOTree Nothing (SCTTreeIO a t iotrees) = do
|
||||
trees <- iotrees
|
||||
SCTTree a t <$> mapM (sequenceIOTree Nothing) trees
|
||||
import qualified Data.Map as M
|
||||
|
||||
-- * Pre-emption bounding
|
||||
|
||||
-- | An SCT runner using a pre-emption bounding scheduler.
|
||||
sctPreBound :: (forall t. Conc t a) -> [SCTTree a]
|
||||
sctPreBound = sctBounded pbSiblings (pbOffspring False)
|
||||
sctPreBound :: Int -> (forall t. Conc t a) -> [(Either Failure a, Trace)]
|
||||
sctPreBound pb = sctBounded (pbBv pb) pbBacktrack pbInitialise
|
||||
|
||||
-- | Variant of 'sctPreBound' for computations which do 'IO'.
|
||||
sctPreBoundIO :: (forall t. ConcIO t a) -> IO [SCTTreeIO a]
|
||||
sctPreBoundIO = sctBoundedIO pbSiblings (pbOffspring True)
|
||||
sctPreBoundIO :: Int -> (forall t. ConcIO t a) -> IO [(Either Failure a, Trace)]
|
||||
sctPreBoundIO pb = sctBoundedIO (pbBv pb) pbBacktrack pbInitialise
|
||||
|
||||
-- | Return all modifications to this schedule which do not introduce
|
||||
-- extra pre-emptions.
|
||||
pbSiblings :: [(CVarId, Bool)] -> Trace -> [[Decision]]
|
||||
pbSiblings cvstate = siblings [] where
|
||||
siblings pref (t@(Start i, alts, _):ds) =
|
||||
let alters = [[a] | (a@(Start _), act) <- alts, doesntBlock pref act]
|
||||
balters = [[a] | (a@(Start _), act) <- alts, not $ doesntBlock pref act]
|
||||
in (if null alters then balters else alters) ++
|
||||
[Start i : o | o <- siblings (pref++[t]) ds, not $ null o]
|
||||
-- | Check if a schedule is in the bound.
|
||||
pbBv :: Int -> [Decision] -> Bool
|
||||
pbBv pb ds = preEmpCount ds <= pb
|
||||
|
||||
siblings pref (t@(SwitchTo i, alts, _):ds) =
|
||||
let alters = [[a] | (a@(SwitchTo _), act) <- alts, doesntBlock pref act]
|
||||
balters = [[a] | (a@(SwitchTo _), act) <- alts, not $ doesntBlock pref act]
|
||||
in (if null alters then balters else alters) ++
|
||||
[SwitchTo i : o | o <- siblings (pref++[t]) ds, not $ null o]
|
||||
-- | Add a backtrack point, and also conservatively add one prior to
|
||||
-- the most recent transition before that point. This may result in
|
||||
-- the same state being reached multiple times, but is needed because
|
||||
-- of the artificial dependency imposed by the bound.
|
||||
pbBacktrack :: [BacktrackStep] -> Int -> ThreadId -> [BacktrackStep]
|
||||
pbBacktrack bs i tid = backtrack (backtrack bs i tid) (maximum js) tid where
|
||||
js = 0:[j | ((_,t1), (j,t2)) <- (zip <*> tail) . zip [0..] $ tidTag (fst . _decision) 0 bs, t1 /= t2, j < i]
|
||||
|
||||
siblings pref (t@(d, _, _):ds) = [d : o | o <- siblings (pref++[t]) ds, not $ null o]
|
||||
siblings _ [] = []
|
||||
backtrack (b:bs) 0 t
|
||||
| t `elem` _runnable b = b { _backtrack = nub $ t : _backtrack b } : bs
|
||||
| otherwise = b { _backtrack = _runnable b } : bs
|
||||
backtrack (b:bs) n t = b : backtrack bs (n-1) t
|
||||
backtrack [] _ _ = error "Ran out of schedule whilst backtracking!"
|
||||
|
||||
-- TODO: Include also blocking on throwing exceptions to masked
|
||||
-- threads.
|
||||
doesntBlock pref (Put' c) = (c, False) `elem` updateCVState cvstate pref
|
||||
doesntBlock pref (Read' c) = (c, True) `elem` updateCVState cvstate pref
|
||||
doesntBlock pref (Take' c) = (c, True) `elem` updateCVState cvstate pref
|
||||
doesntBlock _ _ = True
|
||||
-- | Pick a new thread to run. Choose the current thread if available,
|
||||
-- otherwise add all runnable threads.
|
||||
pbInitialise :: Maybe (ThreadId, a) -> NonEmpty (ThreadId, b) -> NonEmpty ThreadId
|
||||
pbInitialise prior threads@((next, _):|rest) = case prior of
|
||||
Just (tid, _)
|
||||
| any (\(t, _) -> t == tid) $ toList threads -> tid:|[]
|
||||
_ -> next:|map fst rest
|
||||
|
||||
-- | Return all modifications to this schedule which do introduce an
|
||||
-- extra pre-emption. Only introduce pre-emptions around CVar actions
|
||||
-- and lifts.
|
||||
pbOffspring :: Bool -> [(CVarId, Bool)] -> Trace -> [[Decision]]
|
||||
pbOffspring lifts cvstate = offspring [] where
|
||||
offspring pref (t@(Continue, alts, ta):ds)
|
||||
| interesting lifts ta =
|
||||
let alters = [[n] | (n@(SwitchTo _), act) <- alts, doesntBlock pref act]
|
||||
balters = [[n] | (n@(SwitchTo _), act) <- alts, not $ doesntBlock pref act]
|
||||
in (if null alters then balters else alters) ++
|
||||
[Continue : n | n <- offspring (pref++[t]) ds, not $ null n]
|
||||
| otherwise = [Continue : n | n <- offspring (pref++[t]) ds, not $ null n]
|
||||
-- * BPOR
|
||||
|
||||
offspring pref (t@(d, _, _):ds) = [d : n | n <- offspring (pref++[t]) ds, not $ null n]
|
||||
offspring _ [] = []
|
||||
|
||||
-- TODO: Include also blocking on throwing exceptions to masked
|
||||
-- threads.
|
||||
doesntBlock pref (Put' c) = (c, False) `elem` updateCVState cvstate pref
|
||||
doesntBlock pref (Read' c) = (c, True) `elem` updateCVState cvstate pref
|
||||
doesntBlock pref (Take' c) = (c, True) `elem` updateCVState cvstate pref
|
||||
doesntBlock _ _ = True
|
||||
|
||||
-- | Check the pre-emption count of some scheduling decisions.
|
||||
preEmpCount :: [Decision] -> Int
|
||||
preEmpCount (SwitchTo _:ss) = 1 + preEmpCount ss
|
||||
preEmpCount (_:ss) = preEmpCount ss
|
||||
preEmpCount [] = 0
|
||||
|
||||
-- * Delay bounding
|
||||
|
||||
-- | An SCT runner using a delay-bounding scheduler.
|
||||
sctDelayBound :: (forall t. Conc t a) -> [SCTTree a]
|
||||
sctDelayBound = sctBounded (\_ _ -> []) (dbOffspring False)
|
||||
|
||||
-- | Variant of 'sctDelayBound' for computations which do 'IO'.
|
||||
sctDelayBoundIO :: (forall t. ConcIO t a) -> IO [SCTTreeIO a]
|
||||
sctDelayBoundIO = sctBoundedIO (\_ _ -> []) (dbOffspring True)
|
||||
|
||||
-- | Return all modifications to the schedule which introduce an extra
|
||||
-- delay. Only introduce delays around CVar actions and lifts.
|
||||
dbOffspring :: Bool -> [(CVarId, Bool)] -> Trace -> [[Decision]]
|
||||
dbOffspring lifts _ = offspring where
|
||||
offspring ((d, alts, ta):ds)
|
||||
| interesting lifts ta = [[fst n] | n <- alts] ++ [d : n | n <- offspring ds, not $ null n]
|
||||
| otherwise = [d : n | n <- dbOffspring lifts [] ds, not $ null n]
|
||||
offspring [] = []
|
||||
|
||||
-- * SCT runners
|
||||
|
||||
-- | SCT via schedule bounding. Results are proeduced as a lazy
|
||||
-- forest, where each level represents one bounding level.
|
||||
-- | SCT via BPOR.
|
||||
--
|
||||
-- Schedules are generated by running the computation with a
|
||||
-- deterministic scheduler with some initial list of decisions, after
|
||||
-- which non-pre-emptive decisions are made. The generated suffix is
|
||||
-- then used to generate \"siblings\" (schedule fragments which, when
|
||||
-- appended to the prefix, form the prefix of a new schedule which
|
||||
-- does not increase the bound), and \"offspring\" (like siblings, but
|
||||
-- the bound has been increased by one). It is important that siblings
|
||||
-- and offspring are unique, and that the same
|
||||
-- prefix+sibling/offspring cannot arise from two distinct traces, as
|
||||
-- otherwise the runner may loop. In addition to the trace, the
|
||||
-- sibling and offspring functions take a list of whether each 'CVar'
|
||||
-- existing at this point is full or not, allowing blocking behaviour
|
||||
-- to be factored into decision-making.
|
||||
-- which the supplied function is called. At each step of execution,
|
||||
-- possible-conflicting actions are looked for, if any are found,
|
||||
-- \"backtracking points\" are added, to cause the events to happen in
|
||||
-- a different order in a future execution.
|
||||
--
|
||||
-- For example, the siblings in the pre-emption bounding runner are
|
||||
-- those schedule fragments which, when appended to the prefix, form
|
||||
-- the prefix of a new schedule which does not introduce any new
|
||||
-- pre-emptions; and the offspring do introduce one new pre-emption.
|
||||
sctBounded :: ([(CVarId, Bool)] -> Trace -> [[Decision]])
|
||||
-- ^ Sibling generation function.
|
||||
-> ([(CVarId, Bool)] -> Trace -> [[Decision]])
|
||||
-- ^ Child generation function.
|
||||
-> (forall t. Conc t a) -> [SCTTree a]
|
||||
sctBounded siblings offspring c = go [] where
|
||||
go ds = case res of
|
||||
Left f -> SCTTree (Left f) trace [] : concatMap go sibs
|
||||
Right a -> SCTTree (Right a) trace (concatMap go offs) : concatMap go sibs
|
||||
-- Note that unlike with non-bounded partial-order reduction, this may
|
||||
-- do some redundant work as the introduction of a bound can make
|
||||
-- previously non-interfering events interfere with each other.
|
||||
sctBounded :: ([Decision] -> Bool)
|
||||
-- ^ Check if a prefix trace is within the bound.
|
||||
-> ([BacktrackStep] -> Int -> ThreadId -> [BacktrackStep])
|
||||
-- ^ Add a new backtrack point, this takes the history of
|
||||
-- the execution so far, the index to insert the
|
||||
-- backtracking point, and the thread to backtrack to. This
|
||||
-- may insert more than one backtracking point.
|
||||
-> (Maybe (ThreadId, ThreadAction) -> NonEmpty (ThreadId, ThreadAction') -> NonEmpty ThreadId)
|
||||
-- ^ Produce possible scheduling decisions, all will be
|
||||
-- tried.
|
||||
-> (forall t. Conc t a) -> [(Either Failure a, Trace)]
|
||||
sctBounded bv backtrack initialise c = go initialState where
|
||||
go bpor = case next bpor of
|
||||
Just (sched, bpor') ->
|
||||
-- Run the computation
|
||||
let (res, (_, bs), trace) = runConc (bporSched initialise) (sched, []) c
|
||||
-- Identify the backtracking points
|
||||
bpoints = findBacktrack False backtrack bs trace
|
||||
-- Add new nodes to the tree
|
||||
bpor'' = grow trace bpor'
|
||||
-- Add new backtracking information
|
||||
bpor''' = todo bv bpoints bpor''
|
||||
-- Loop
|
||||
in (res, trace) : go bpor'''
|
||||
|
||||
where
|
||||
(res, _, trace) = runConc prefixSched ds c
|
||||
|
||||
(p, suff) = splitAt (length ds) trace
|
||||
pref = map (\(a,_,_) -> a) p
|
||||
|
||||
cvstate = computeCVState p
|
||||
|
||||
sibs = [ pref ++ y | y <- siblings cvstate suff]
|
||||
offs = [ pref ++ y | y <- offspring cvstate suff]
|
||||
Nothing -> []
|
||||
|
||||
-- | Variant of 'sctBounded' for computations which do 'IO'.
|
||||
sctBoundedIO :: ([(CVarId, Bool)] -> Trace -> [[Decision]])
|
||||
-> ([(CVarId, Bool)] -> Trace -> [[Decision]])
|
||||
-> (forall t. ConcIO t a) -> IO [SCTTreeIO a]
|
||||
sctBoundedIO siblings offspring c = go [] where
|
||||
go ds = do
|
||||
(res, _, trace) <- runConcIO prefixSched ds c
|
||||
sctBoundedIO :: ([Decision] -> Bool)
|
||||
-> ([BacktrackStep] -> Int -> ThreadId -> [BacktrackStep])
|
||||
-> (Maybe (ThreadId, ThreadAction) -> NonEmpty (ThreadId, ThreadAction') -> NonEmpty ThreadId)
|
||||
-> (forall t. ConcIO t a) -> IO [(Either Failure a, Trace)]
|
||||
sctBoundedIO bv backtrack initialise c = go initialState where
|
||||
go bpor = case next bpor of
|
||||
Just (sched, bpor') -> do
|
||||
(res, (_, bs), trace) <- runConcIO (bporSched initialise) (sched, []) c
|
||||
|
||||
let (p, suff) = splitAt (length ds + 1) trace
|
||||
let pref = map (\(a,_,_) -> a) p
|
||||
let bpoints = findBacktrack True backtrack bs trace
|
||||
let bpor'' = grow trace bpor'
|
||||
let bpor''' = todo bv bpoints bpor''
|
||||
|
||||
let cvstate = computeCVState p
|
||||
((res, trace):) <$> go bpor'''
|
||||
|
||||
let sibs = [ pref ++ y | y <- siblings cvstate suff]
|
||||
let offs = [ pref ++ y | y <- offspring cvstate suff]
|
||||
Nothing -> return []
|
||||
|
||||
sibs' <- concat <$> mapM go sibs
|
||||
-- | BPOR scheduler: takes a list of decisions, and maintains a trace
|
||||
-- including the runnable threads, and the alternative choices allowed
|
||||
-- by the bound-specific initialise function.
|
||||
bporSched :: (Maybe (ThreadId, ThreadAction) -> NonEmpty (ThreadId, ThreadAction') -> NonEmpty ThreadId)
|
||||
-> Scheduler ([ThreadId], [(NonEmpty (ThreadId, ThreadAction'), [ThreadId])])
|
||||
bporSched initialise = force sched where
|
||||
-- If there is a decision available, make it
|
||||
sched (d:ds, bs) _ threads = (d, (ds, bs ++ [(threads, [])]))
|
||||
|
||||
return $ case res of
|
||||
Left f -> SCTTreeIO (Left f) trace (return []) : sibs'
|
||||
Right a -> SCTTreeIO (Right a) trace (concat <$> mapM go offs) : sibs'
|
||||
|
||||
-- | Compute the state of every 'CVar' after executing the given
|
||||
-- prefix trace. This assumes that the trace is valid (no double-puts,
|
||||
-- etc).
|
||||
computeCVState :: Trace -> [(CVarId, Bool)]
|
||||
computeCVState = updateCVState []
|
||||
|
||||
-- | Compute the state of every 'CVar' from the given starting point
|
||||
-- after executing the given prefix trace. This assumes that the trace
|
||||
-- is valid.
|
||||
updateCVState :: [(CVarId, Bool)] -> Trace -> [(CVarId, Bool)]
|
||||
updateCVState = foldl' go where
|
||||
go state (_, _, New c) = (c, False) : state
|
||||
go state (_, _, Put c _) = (c, True) : filter ((/=c) . fst) state
|
||||
go state (_, _, Take c _) = (c, False) : filter ((/=c) . fst) state
|
||||
go state (_, _, TryPut c b _) = (c, b) : filter ((/=c) . fst) state
|
||||
go state (_, _, TryTake c b _) = (c, not b) : filter ((/=c) . fst) state
|
||||
go state _ = state
|
||||
|
||||
-- * Prefix scheduler
|
||||
|
||||
-- | Scheduler which uses a list of scheduling decisions to drive the
|
||||
-- initial decisions.
|
||||
prefixSched :: Scheduler [Decision]
|
||||
prefixSched = force $ \s prior threads@((next,_):|_) -> case s of
|
||||
-- If we have a decision queued, make it.
|
||||
(Start t:ds) -> (t, ds)
|
||||
(Continue:ds) -> (fromMaybe 0 prior, ds)
|
||||
(SwitchTo t:ds) -> (t, ds)
|
||||
|
||||
-- Otherwise just use a non-pre-emptive scheduler.
|
||||
[] -> case prior of
|
||||
Just prior' | prior' `elem` map fst (toList threads) -> (prior', [])
|
||||
_ -> (next, [])
|
||||
|
||||
-- * Utils
|
||||
|
||||
-- | Check if a 'ThreadAction' might be an interesting candidate for
|
||||
-- pre-empting or delaying.
|
||||
interesting :: Bool -> ThreadAction -> Bool
|
||||
interesting _ (Put _ _) = True
|
||||
interesting _ (TryPut _ _ _) = True
|
||||
interesting _ (Take _ _) = True
|
||||
interesting _ (TryTake _ _ _) = True
|
||||
interesting _ (Read _) = True
|
||||
interesting _ (ReadRef _) = True
|
||||
interesting _ (ModRef _) = True
|
||||
interesting _ (STM _) = True
|
||||
interesting _ (ThrowTo _) = True
|
||||
interesting _ (SetMasking _ _) = True
|
||||
interesting _ (ResetMasking _ _ ) = True
|
||||
interesting l Lift = l
|
||||
interesting _ _ = False
|
||||
-- Otherwise query the initialise function for a list of possible
|
||||
-- choices, and make one of them arbitrarily (recording the others).
|
||||
sched ([], bs) prior threads = case initialise prior threads of
|
||||
(next:|rest) -> (next, ([], bs ++ [(threads, rest)]))
|
||||
|
||||
233
Test/DejaFu/SCT/Internal.hs
Executable file
233
Test/DejaFu/SCT/Internal.hs
Executable file
@ -0,0 +1,233 @@
|
||||
-- | Internal utilities and types for BPOR.
|
||||
module Test.DejaFu.SCT.Internal where
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Control.Arrow (first)
|
||||
import Control.DeepSeq (NFData(..))
|
||||
import Data.List (foldl', nub, sortBy)
|
||||
import Data.Ord (Down(..), comparing)
|
||||
import Data.Map (Map)
|
||||
import Data.Maybe (mapMaybe, fromJust)
|
||||
import Test.DejaFu.Deterministic
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
-- * BPOR state
|
||||
|
||||
-- | One step of the execution, including information for backtracking
|
||||
-- purposes. This backtracking information is used to generate new
|
||||
-- schedules.
|
||||
data BacktrackStep = BacktrackStep
|
||||
{ _decision :: (Decision, ThreadAction)
|
||||
-- ^ What happened at this step.
|
||||
, _runnable :: [ThreadId]
|
||||
-- ^ The threads runnable at this step
|
||||
, _backtrack :: [ThreadId]
|
||||
-- ^ The list of alternative threads to run.
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance NFData BacktrackStep where
|
||||
rnf b = rnf (_decision b, _runnable b, _backtrack b)
|
||||
|
||||
-- | BPOR execution is represented as a tree of states, characterised
|
||||
-- by the decisions that lead to that state.
|
||||
data BPOR = BPOR
|
||||
{ _brunnable :: [ThreadId]
|
||||
-- ^ What threads are runnable at this step.
|
||||
, _btodo :: [ThreadId]
|
||||
-- ^ Follow-on decisions still to make.
|
||||
, _bdone :: Map ThreadId BPOR
|
||||
}
|
||||
|
||||
-- | Initial BPOR state.
|
||||
initialState :: BPOR
|
||||
initialState = BPOR
|
||||
{ _brunnable = [0]
|
||||
, _btodo = [0]
|
||||
, _bdone = M.empty
|
||||
}
|
||||
|
||||
-- | Produce a new schedule from a BPOR tree. If there are no new
|
||||
-- schedules remaining, return 'Nothing'.
|
||||
--
|
||||
-- This returns the prefix with the most preemptions in, on the
|
||||
-- assumption that preemptions are likely to exhibit bugs, and so lead
|
||||
-- to earlier test failures.
|
||||
next :: BPOR -> Maybe ([ThreadId], BPOR)
|
||||
next = go 0 where
|
||||
go tid bpor =
|
||||
-- All the possible prefix traces from this point, with
|
||||
-- updated BPOR subtrees if taken from the done list.
|
||||
let prefixes = [Left t | t <- _btodo bpor] ++ mapMaybe go' (M.toList $ _bdone bpor)
|
||||
-- Sort by number of preemptions, in descending order.
|
||||
sorted = sortBy (comparing $ Down . preEmps tid bpor . either (:[]) fst) prefixes
|
||||
|
||||
in case sorted of
|
||||
-- If the schedule with the most preemptions is from the done list, update that.
|
||||
(Right (ts@(t:_), b):_) -> Just (ts, bpor { _bdone = M.insert t b $ _bdone bpor })
|
||||
-- If from the todo list, remove it.
|
||||
(Left t:_) -> Just ([t], bpor { _btodo = filter (/=t) $ _btodo bpor })
|
||||
|
||||
_ -> Nothing
|
||||
|
||||
go' (tid, bpor) = Right . first (tid:) <$> go tid bpor
|
||||
|
||||
preEmps tid bpor (t:ts) =
|
||||
let rest = preEmps t (fromJust . M.lookup t $ _bdone bpor) ts
|
||||
in if tid /= t && tid `elem` _brunnable bpor then 1 + rest else rest
|
||||
preEmps _ _ [] = 0::Int
|
||||
|
||||
-- | Produce a list of new backtracking points from an execution
|
||||
-- trace.
|
||||
findBacktrack :: Bool
|
||||
-> ([BacktrackStep] -> Int -> ThreadId -> [BacktrackStep])
|
||||
-> [(NonEmpty (ThreadId, ThreadAction'), [ThreadId])]
|
||||
-> Trace
|
||||
-> [BacktrackStep]
|
||||
findBacktrack deplifts backtrack = go [] where
|
||||
go bs ((e,i):is) ((d,_,a):ts) =
|
||||
let this = BacktrackStep { _decision = (d, a), _runnable = map fst . toList $ e, _backtrack = i }
|
||||
bs' = doBacktrack (toList e) bs
|
||||
in go (bs' ++ [this]) is ts
|
||||
go bs _ _ = bs
|
||||
|
||||
doBacktrack enabledThreads bs =
|
||||
let idxs = [ (maximum is, u)
|
||||
| (u, n) <- enabledThreads
|
||||
, v <- allThreads bs
|
||||
, u /= v
|
||||
, let is = [ i
|
||||
| (i, (t, b)) <- zip [0..] $ tidTag (fst . _decision) 0 bs
|
||||
, t == v
|
||||
, dependent deplifts (snd $ _decision b) (u, n)
|
||||
]
|
||||
, not $ null is] :: [(Int, ThreadId)]
|
||||
in foldl' (\bs (i, u) -> backtrack bs i u) bs idxs
|
||||
|
||||
allThreads = nub . concatMap _runnable
|
||||
|
||||
-- | Add a new trace to the tree, creating a new subtree.
|
||||
grow :: Trace -> BPOR -> BPOR
|
||||
grow = grow' 0 where
|
||||
grow' tid trc@((d, _, _):rest) bpor =
|
||||
let tid' = tidOf tid d
|
||||
in case M.lookup tid' $ _bdone bpor of
|
||||
Just bpor' -> bpor { _bdone = M.insert tid' (grow' tid' rest bpor') $ _bdone bpor }
|
||||
Nothing -> bpor { _bdone = M.insert tid' (subtree tid' trc) $ _bdone bpor }
|
||||
grow' _ [] bpor = bpor
|
||||
|
||||
subtree tid ((d, ts, a):rest) = BPOR
|
||||
{ _brunnable = tids tid d a ts
|
||||
, _btodo = []
|
||||
, _bdone = M.fromList $ case rest of
|
||||
((d', _, _):_) ->
|
||||
let tid' = tidOf tid d'
|
||||
in [(tid', subtree tid' rest)]
|
||||
[] -> []
|
||||
}
|
||||
|
||||
tids tid d (Fork t) ts = tidOf tid d : t : map (tidOf tid . fst) ts
|
||||
tids tid _ (BlockedPut _) ts = map (tidOf tid . fst) ts
|
||||
tids tid _ (BlockedRead _) ts = map (tidOf tid . fst) ts
|
||||
tids tid _ (BlockedTake _) ts = map (tidOf tid . fst) ts
|
||||
tids tid _ BlockedSTM ts = map (tidOf tid . fst) ts
|
||||
tids tid _ (BlockedThrowTo _) ts = map (tidOf tid . fst) ts
|
||||
tids tid _ Stop ts = map (tidOf tid . fst) ts
|
||||
tids tid d _ ts = tidOf tid d : map (tidOf tid . fst) ts
|
||||
|
||||
-- | Add new backtracking points, if they have not already been
|
||||
-- visited and fit into the bound.
|
||||
todo :: ([Decision] -> Bool) -> [BacktrackStep] -> BPOR -> BPOR
|
||||
todo bv = go 0 [] where
|
||||
go tid pref (b:bs) bpor =
|
||||
let bpor' = backtrack pref b bpor
|
||||
tid' = tidOf tid . fst $ _decision b
|
||||
in bpor' { _bdone = M.adjust (go tid' (pref++[fst $ _decision b]) bs) tid' $ _bdone bpor' }
|
||||
go _ _ _ bpor = bpor
|
||||
|
||||
backtrack pref b bpor =
|
||||
let todo' = nub $ _btodo bpor ++ [ t
|
||||
| t <- _backtrack b
|
||||
, bv $ pref ++ [decisionOf (Just $ activeTid pref) (_brunnable bpor) t]
|
||||
, t `notElem` M.keys (_bdone bpor)
|
||||
]
|
||||
in bpor { _btodo = todo' }
|
||||
|
||||
-- * Utilities
|
||||
|
||||
-- | Get the resultant 'ThreadId' of a 'Decision', with a default case
|
||||
-- for 'Continue'.
|
||||
tidOf :: ThreadId -> Decision -> ThreadId
|
||||
tidOf _ (Start t) = t
|
||||
tidOf _ (SwitchTo t) = t
|
||||
tidOf tid Continue = tid
|
||||
|
||||
-- | Tag a list of items encapsulating 'Decision's with 'ThreadId's,
|
||||
-- with an initial default case for 'Continue'.
|
||||
tidTag :: (a -> Decision) -> ThreadId -> [a] -> [(ThreadId, a)]
|
||||
tidTag df = go where
|
||||
go t (a:as) =
|
||||
let t' = tidOf t $ df a
|
||||
in (t', a) : go t' as
|
||||
go _ [] = []
|
||||
|
||||
-- | Get the 'Decision' that would have resulted in this 'ThreadId',
|
||||
-- given a prior 'ThreadId' (if any) and list of runnable threds.
|
||||
decisionOf :: Maybe ThreadId -> [ThreadId] -> ThreadId -> Decision
|
||||
decisionOf prior runnable chosen
|
||||
| prior == Just chosen = Continue
|
||||
| prior `elem` map Just runnable = SwitchTo chosen
|
||||
| otherwise = Start chosen
|
||||
|
||||
-- | Get the tid of the currently active thread after executing a
|
||||
-- series of decisions. The list MUST begin with a 'Start'.
|
||||
activeTid :: [Decision] -> ThreadId
|
||||
activeTid = foldl' go 0 where
|
||||
go _ (Start t) = t
|
||||
go _ (SwitchTo t) = t
|
||||
go t Continue = t
|
||||
|
||||
-- | Count the number of preemptions in a schedule
|
||||
preEmpCount :: [Decision] -> Int
|
||||
preEmpCount (SwitchTo _:ds) = 1 + preEmpCount ds
|
||||
preEmpCount (_:ds) = preEmpCount ds
|
||||
preEmpCount [] = 0
|
||||
|
||||
-- | Check if an action is dependent on another, assumes the actions
|
||||
-- are from different threads (two actions in the same thread are
|
||||
-- always dependent).
|
||||
dependent :: Bool -> ThreadAction -> (ThreadId, ThreadAction') -> Bool
|
||||
dependent deplifts Lift (_, Lift') = deplifts
|
||||
dependent _ (ThrowTo t) (t2, _) = t == t2
|
||||
dependent _ d1 (_, d2) = cref || cvar || ctvar where
|
||||
cref = Just True == ((\(r1, w1) (r2, w2) -> r1 == r2 && (w1 || w2)) <$> cref' d1 <*> cref'' d2)
|
||||
cref' (ReadRef r) = Just (r, False)
|
||||
cref' (ModRef r) = Just (r, True)
|
||||
cref' _ = Nothing
|
||||
cref'' (ReadRef' r) = Just (r, False)
|
||||
cref'' (ModRef' r) = Just (r, True)
|
||||
cref'' _ = Nothing
|
||||
|
||||
cvar = Just True == ((==) <$> cvar' d1 <*> cvar'' d2)
|
||||
cvar' (BlockedPut _) = Nothing
|
||||
cvar' (BlockedRead _) = Nothing
|
||||
cvar' (BlockedTake _) = Nothing
|
||||
cvar' (TryPut c _ _) = Just c
|
||||
cvar' (TryTake c _ _) = Just c
|
||||
cvar' (Put c _) = Just c
|
||||
cvar' (Read c) = Just c
|
||||
cvar' (Take c _) = Just c
|
||||
cvar' _ = Nothing
|
||||
cvar'' (TryPut' c) = Just c
|
||||
cvar'' (TryTake' c) = Just c
|
||||
cvar'' (Put' c) = Just c
|
||||
cvar'' (Read' c) = Just c
|
||||
cvar'' (Take' c) = Just c
|
||||
cvar'' _ = Nothing
|
||||
|
||||
ctvar = ctvar' d1 && ctvar'' d2
|
||||
ctvar' (STM _) = True
|
||||
ctvar' BlockedSTM = False
|
||||
ctvar' _ = False
|
||||
ctvar'' STM' = True
|
||||
ctvar'' _ = False
|
||||
@ -73,6 +73,7 @@ library
|
||||
, Test.DejaFu.Deterministic.Internal.Common
|
||||
, Test.DejaFu.Deterministic.Internal.CVar
|
||||
, Test.DejaFu.Deterministic.Internal.Threading
|
||||
, Test.DejaFu.SCT.Internal
|
||||
, Test.DejaFu.STM.Internal
|
||||
|
||||
, Control.State
|
||||
|
||||
Loading…
Reference in New Issue
Block a user