mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-12-20 12:01:33 +03:00
68 lines
2.4 KiB
Haskell
68 lines
2.4 KiB
Haskell
{-# LANGUAGE RankNTypes #-}
|
|
|
|
-- | A runner for concurrent monads to systematically detect
|
|
-- concurrency errors such as data races and deadlocks.
|
|
--
|
|
-- As an example, consider this program, which has two locks and a
|
|
-- shared variable. Two threads are spawned, which claim the locks,
|
|
-- update the shared variable, and release the locks. The main thread
|
|
-- waits for them both to terminate, and returns the final result.
|
|
--
|
|
-- > bad :: ConcCVar (cvar t) (m t) => m t Int
|
|
-- > bad = do
|
|
-- > a <- newEmptyCVar
|
|
-- > b <- newEmptyCVar
|
|
-- >
|
|
-- > c <- newCVar 0
|
|
-- >
|
|
-- > j1 <- spawn $ lock a >> lock b >> modifyCVar_ c (return . succ) >> unlock b >> unlock a
|
|
-- > j2 <- spawn $ lock b >> lock a >> modifyCVar_ c (return . pred) >> unlock a >> unlock b
|
|
-- >
|
|
-- > takeCVar j1
|
|
-- > takeCVar j2
|
|
-- >
|
|
-- > takeCVar c
|
|
--
|
|
-- The correct result is 0, as it starts out as 0 and is incremented
|
|
-- and decremented by threads 1 and 2, respectively. However, note the
|
|
-- order of acquisition of the locks in the two threads. If thread 2
|
|
-- pre-empts thread 1 between the acquisition of the locks (or if
|
|
-- thread 1 pre-empts thread 2), a deadlock situation will arise, as
|
|
-- thread 1 will have lock `a` and be waiting on `b`, and thread 2
|
|
-- will have `b` and be waiting on `a`.
|
|
|
|
module Control.Monad.Conc.SCT
|
|
( -- *Systematic Concurrency Testing
|
|
SCTScheduler
|
|
, runSCT
|
|
, sctRandom
|
|
) where
|
|
|
|
import Control.Monad.Conc.Fixed
|
|
import System.Random (RandomGen, randomR)
|
|
|
|
-- | An @SCTScheduler@ is like a regular 'Scheduler', except it builds
|
|
-- a log of scheduling decisions made.
|
|
type SCTScheduler s = Scheduler (s, [ThreadId])
|
|
|
|
-- | Run a concurrent program under a given scheduler a number of
|
|
-- times, collecting the results and the scheduling that gave rise to
|
|
-- them.
|
|
--
|
|
-- The initial state for each run is the final state of the last run,
|
|
-- so it is important that the scheduler actually maintain some
|
|
-- internal state, or all the results will be identical.
|
|
runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> IO [(Maybe a, [ThreadId])]
|
|
runSCT sched s runs c = runSCT' s runs where
|
|
runSCT' _ 0 = return []
|
|
runSCT' s n = do
|
|
(res, (s', log)) <- runConc' sched (s, [0]) c
|
|
rest <- runSCT' s' $ n - 1
|
|
return $ (res, log) : rest
|
|
|
|
-- | A simple pre-emptive random scheduler.
|
|
sctRandom :: RandomGen g => SCTScheduler g
|
|
sctRandom (g, log) _ threads = (tid, (g', log ++ [tid])) where
|
|
(choice, g') = randomR (0, length threads - 1) g
|
|
tid = threads !! choice
|