module Test.DPOR.Schedule
(
Scheduler
, Decision(..)
, tidOf
, decisionOf
, NonEmpty(..)
, randomSched
, roundRobinSched
, randomSchedNP
, roundRobinSchedNP
, makeNonPreemptive
) where
import Control.DeepSeq (NFData(..))
import Data.List.NonEmpty (NonEmpty(..), toList)
import System.Random (RandomGen, randomR)
type Scheduler tid action lookahead s
= [(Decision tid, action)]
-> Maybe (tid, action)
-> NonEmpty (tid, lookahead)
-> s
-> (Maybe tid, s)
data Decision tid =
Start tid
| Continue
| SwitchTo tid
deriving (Eq, Show)
instance NFData tid => NFData (Decision tid) where
rnf (Start tid) = rnf tid
rnf (SwitchTo tid) = rnf tid
rnf d = d `seq` ()
tidOf :: tid -> Decision tid -> tid
tidOf _ (Start t) = t
tidOf _ (SwitchTo t) = t
tidOf tid _ = tid
decisionOf :: (Eq tid, Foldable f)
=> Maybe tid
-> f tid
-> tid
-> Decision tid
decisionOf Nothing _ chosen = Start chosen
decisionOf (Just prior) runnable chosen
| prior == chosen = Continue
| prior `elem` runnable = SwitchTo chosen
| otherwise = Start chosen
randomSched :: RandomGen g => Scheduler tid action lookahead g
randomSched _ _ threads g = (Just $ threads' !! choice, g') where
(choice, g') = randomR (0, length threads' 1) g
threads' = map fst $ toList threads
roundRobinSched :: Ord tid => Scheduler tid action lookahead ()
roundRobinSched _ Nothing ((tid,_):|_) _ = (Just tid, ())
roundRobinSched _ (Just (prior, _)) threads _
| prior >= maximum threads' = (Just $ minimum threads', ())
| otherwise = (Just . minimum $ filter (>prior) threads', ())
where
threads' = map fst $ toList threads
randomSchedNP :: (RandomGen g, Eq tid) => Scheduler tid action lookahead g
randomSchedNP = makeNonPreemptive randomSched
roundRobinSchedNP :: Ord tid => Scheduler tid action lookahead ()
roundRobinSchedNP = makeNonPreemptive roundRobinSched
makeNonPreemptive :: Eq tid
=> Scheduler tid action lookahead s
-> Scheduler tid action lookahead s
makeNonPreemptive sched = newsched where
newsched trc p@(Just (prior, _)) threads s
| prior `elem` map fst (toList threads) = (Just prior, s)
| otherwise = sched trc p threads s
newsched trc Nothing threads s = sched trc Nothing threads s