barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-12-24 05:55:18 +03:00
Code Issues Projects Releases Wiki Activity

Build a trace of thread actions in Fixed

Browse Source
This commit is contained in:
Michael Walker 2014-12-24 21:41:32 +00:00
parent c9a40a8f41
commit a1d637e87c
2 changed files with 135 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
Control/Monad/Conc/Fixed.hs
View File

@ -7,6 +7,8 @@
module Control.Monad.Conc.Fixed module Control.Monad.Conc.Fixed
( -- * The Conc Monad ( -- * The Conc Monad
Conc Conc
, Trace
, ThreadAction(..)
, runConc , runConc
, runConc' , runConc'
, liftIO , liftIO
@ -35,7 +37,7 @@ import Control.Applicative (Applicative(..), (<$>))
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Monad.Cont (Cont, cont, runCont) import Control.Monad.Cont (Cont, cont, runCont)
import Data.Map (Map) import Data.Map (Map)
import Data.Maybe (fromJust, isNothing) import Data.Maybe (catMaybes, fromJust, isNothing)
import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import System.Random (RandomGen, randomR) import System.Random (RandomGen, randomR)
@ -48,14 +50,14 @@ import qualified Data.Map as M
-- primitives of the concurrency. `spawn` is absent as it can be -- primitives of the concurrency. `spawn` is absent as it can be
-- derived from `new`, `fork` and `put`. -- derived from `new`, `fork` and `put`.
data Action = data Action =
Fork Action Action AFork Action Action
| forall t a. Put (CVar t a) a Action | forall t a. APut (CVar t a) a Action
| forall t a. TryPut (CVar t a) a (Bool -> Action) | forall t a. ATryPut (CVar t a) a (Bool -> Action)
| forall t a. Get (CVar t a) (a -> Action) | forall t a. AGet (CVar t a) (a -> Action)
| forall t a. Take (CVar t a) (a -> Action) | forall t a. ATake (CVar t a) (a -> Action)
| forall t a. TryTake (CVar t a) (Maybe a -> Action) | forall t a. ATryTake (CVar t a) (Maybe a -> Action)
| Lift (IO Action) | ALift (IO Action)
| Stop | AStop
-- | The @Conc@ monad itself. Under the hood, this uses continuations -- | The @Conc@ monad itself. Under the hood, this uses continuations
-- so it's able to interrupt and resume a monadic computation at any -- so it's able to interrupt and resume a monadic computation at any
@ -101,7 +103,7 @@ newtype CVar t a = V (IORef (Maybe a, [Block])) deriving Eq
-- possible. -- possible.
liftIO :: IO a -> Conc t a liftIO :: IO a -> Conc t a
liftIO ma = C $ cont lifted where liftIO ma = C $ cont lifted where
lifted c = Lift $ c <$> ma lifted c = ALift $ c <$> ma
-- | Run the provided computation concurrently, returning the result. -- | Run the provided computation concurrently, returning the result.
spawn :: Conc t a -> Conc t (CVar t a) spawn :: Conc t a -> Conc t (CVar t a)
@ -113,11 +115,11 @@ spawn ma = do
-- | Block on a 'CVar' until it is full, then read from it (without -- | Block on a 'CVar' until it is full, then read from it (without
-- emptying). -- emptying).
readCVar :: CVar t a -> Conc t a readCVar :: CVar t a -> Conc t a
readCVar cvar = C $ cont $ Get cvar readCVar cvar = C $ cont $ AGet cvar
-- | Run the provided computation concurrently. -- | Run the provided computation concurrently.
fork :: Conc t () -> Conc t () fork :: Conc t () -> Conc t ()
fork (C ma) = C $ cont $ \c -> Fork (runCont ma $ const Stop) $ c () fork (C ma) = C $ cont $ \c -> AFork (runCont ma $ const AStop) $ c ()
-- | Create a new empty 'CVar'. -- | Create a new empty 'CVar'.
newEmptyCVar :: Conc t (CVar t a) newEmptyCVar :: Conc t (CVar t a)
@ -127,20 +129,20 @@ newEmptyCVar = liftIO $ do
-- | Block on a 'CVar' until it is empty, then write to it. -- | Block on a 'CVar' until it is empty, then write to it.
putCVar :: CVar t a -> a -> Conc t () putCVar :: CVar t a -> a -> Conc t ()
putCVar cvar a = C $ cont $ \c -> Put cvar a $ c () putCVar cvar a = C $ cont $ \c -> APut cvar a $ c ()
-- | Put a value into a 'CVar' if there isn't one, without blocking. -- | Put a value into a 'CVar' if there isn't one, without blocking.
tryPutCVar :: CVar t a -> a -> Conc t Bool tryPutCVar :: CVar t a -> a -> Conc t Bool
tryPutCVar cvar a = C $ cont $ TryPut cvar a tryPutCVar cvar a = C $ cont $ ATryPut cvar a
-- | Block on a 'CVar' until it is full, then read from it (with -- | Block on a 'CVar' until it is full, then read from it (with
-- emptying). -- emptying).
takeCVar :: CVar t a -> Conc t a takeCVar :: CVar t a -> Conc t a
takeCVar cvar = C $ cont $ Take cvar takeCVar cvar = C $ cont $ ATake cvar
-- | Read a value from a 'CVar' if there is one, without blocking. -- | Read a value from a 'CVar' if there is one, without blocking.
tryTakeCVar :: CVar t a -> Conc t (Maybe a) tryTakeCVar :: CVar t a -> Conc t (Maybe a)
tryTakeCVar cvar = C $ cont $ TryTake cvar tryTakeCVar cvar = C $ cont $ ATryTake cvar
-- | Every thread has a unique identitifer. These are implemented as -- | Every thread has a unique identitifer. These are implemented as
-- integers, but you shouldn't assume they are necessarily contiguous. -- integers, but you shouldn't assume they are necessarily contiguous.
@ -157,6 +159,34 @@ type ThreadId = Int
-- thread. In either of those cases, the computation will be halted. -- thread. In either of those cases, the computation will be halted.
type Scheduler s = s -> ThreadId -> [ThreadId] -> (ThreadId, s) type Scheduler s = s -> ThreadId -> [ThreadId] -> (ThreadId, s)
-- | One of the outputs of the runner is a @Trace@, which is just a
-- log of threads and actions they have taken.
type Trace = [(ThreadId, ThreadAction)]
-- | All the actions that a thread can perform.
data ThreadAction =
Fork ThreadId
-- ^ Start a new thread.
| Put [ThreadId]
-- ^ Put into a 'CVar', possibly waking up some threads.
| BlockedPut
-- ^ Get blocked on a put.
| TryPut Bool [ThreadId]
-- ^ Try to put into a 'CVar', possibly waking up some threads.
| Read
-- ^ Read from a 'CVar'.
| BlockedRead
-- ^ Get blocked on a read.
| Take [ThreadId]
-- ^ Take from a 'CVar', possibly waking up some threads.
| BlockedTake
-- ^ Get blocked on a take.
| TryTake Bool [ThreadId]
-- ^ try to take from a 'CVar', possibly waking up some threads.
| IO
-- ^ Perform some IO.
deriving (Eq, Show)
-- | Run a concurrent computation with a given 'Scheduler' and initial -- | Run a concurrent computation with a given 'Scheduler' and initial
-- state, returning `Just result` if it terminates, and `Nothing` if a -- state, returning `Just result` if it terminates, and `Nothing` if a
-- deadlock is detected. -- deadlock is detected.
@ -170,17 +200,17 @@ type Scheduler s = s -> ThreadId -> [ThreadId] -> (ThreadId, s)
-- making your head hurt, check out the \"How `runST` works\" section -- making your head hurt, check out the \"How `runST` works\" section
-- of <https://ocharles.org.uk/blog/guest-posts/2014-12-18-rank-n-types.html> -- of <https://ocharles.org.uk/blog/guest-posts/2014-12-18-rank-n-types.html>
runConc :: Scheduler s -> s -> (forall t. Conc t a) -> IO (Maybe a) runConc :: Scheduler s -> s -> (forall t. Conc t a) -> IO (Maybe a)
runConc sched s ma = fst <$> runConc' sched s ma runConc sched s ma = (\(a,_,_) -> a) <$> runConc' sched s ma
-- | variant of 'runConc' which returns the final state of the -- | variant of 'runConc' which returns the final state of the
-- scheduler. -- scheduler and an execution trace.
runConc' :: Scheduler s -> s -> (forall t. Conc t a) -> IO (Maybe a, s) runConc' :: Scheduler s -> s -> (forall t. Conc t a) -> IO (Maybe a, s, Trace)
runConc' sched s ma = do runConc' sched s ma = do
mvar <- newEmptyMVar mvar <- newEmptyMVar
let (C c) = ma >>= liftIO . putMVar mvar . Just let (C c) = ma >>= liftIO . putMVar mvar . Just
s' <- runThreads (negate 1) sched s (M.fromList [(0, (runCont c $ const Stop, False))]) mvar (s', trace) <- runThreads [] (negate 1) sched s (M.fromList [(0, (runCont c $ const AStop, False))]) mvar
out <- takeMVar mvar out <- takeMVar mvar
return (out, s') return (out, s', reverse trace)
-- | A simple random scheduler which, at every step, picks a random -- | A simple random scheduler which, at every step, picks a random
-- thread to run. -- thread to run.
@ -223,15 +253,21 @@ data Block = WaitFull ThreadId | WaitEmpty ThreadId deriving Eq
-- | Run a collection of threads, until there are no threads left. -- | Run a collection of threads, until there are no threads left.
-- --
-- A thread is represented as a tuple of (next action, is blocked). -- A thread is represented as a tuple of (next action, is blocked).
runThreads :: ThreadId -> Scheduler s -> s -> Map ThreadId (Action, Bool) -> MVar (Maybe a) -> IO s --
runThreads prior sched s threads mvar -- Note: this returns the trace in reverse order, because it's more
| isTerminated = return s -- efficient to prepend to a list than append. As this function isn't
| isDeadlocked = putMVar mvar Nothing >> return s -- exposed to users of the library, this is just an internal gotcha to
| isBlocked = putStrLn "Attempted to run a blocked thread, assuming deadlock." >> putMVar mvar Nothing >> return s -- watch out for.
| isNonexistant = putStrLn "Attempted to run a nonexistant thread, assuming deadlock." >> putMVar mvar Nothing >> return s runThreads :: Trace -> ThreadId -> Scheduler s -> s -> Map ThreadId (Action, Bool) -> MVar (Maybe a) -> IO (s, Trace)
runThreads sofar prior sched s threads mvar
| isTerminated = return (s, sofar)
| isDeadlocked = putMVar mvar Nothing >> return (s, sofar)
| isBlocked = putStrLn "Attempted to run a blocked thread, assuming deadlock." >> putMVar mvar Nothing >> return (s, sofar)
| isNonexistant = putStrLn "Attempted to run a nonexistant thread, assuming deadlock." >> putMVar mvar Nothing >> return (s, sofar)
| otherwise = do | otherwise = do
threads' <- runThread (fst $ fromJust thread, chosen) threads (threads', act) <- runThread (fst $ fromJust thread, chosen) threads
runThreads chosen sched s' threads' mvar let sofar' = maybe sofar (\a -> (chosen, a) : sofar) act
runThreads sofar' chosen sched s' threads' mvar
where where
(chosen, s') = if prior == -1 then (0, s) else sched s prior $ M.keys runnable (chosen, s') = if prior == -1 then (0, s) else sched s prior $ M.keys runnable
@ -244,53 +280,69 @@ runThreads prior sched s threads mvar
-- | Run a single thread one step, by dispatching on the type of -- | Run a single thread one step, by dispatching on the type of
-- 'Action'. -- 'Action'.
runThread :: (Action, ThreadId) -> Map ThreadId (Action, Bool) -> IO (Map ThreadId (Action, Bool)) runThread :: (Action, ThreadId) -> Map ThreadId (Action, Bool) -> IO (Map ThreadId (Action, Bool), Maybe ThreadAction)
runThread (Fork a b, i) threads = return . goto b i $ launch a threads runThread (AFork a b, i) threads =
let (threads', newid) = launch a threads
in return (goto b i threads', Just $ Fork newid)
runThread (Put v a c, i) threads = do runThread (APut v a c, i) threads = do
let (V ref) = v let (V ref) = v
(val, blocks) <- readIORef ref (val, blocks) <- readIORef ref
case val of case val of
Just _ -> block v WaitEmpty i threads Just _ -> do
threads' <- block v WaitEmpty i threads
return (threads', Just BlockedPut)
Nothing -> do Nothing -> do
writeIORef ref (Just a, blocks) writeIORef ref (Just a, blocks)
goto c i <$> wake v WaitFull threads (threads', woken) <- wake v WaitFull threads
return (goto c i threads', Just $ Put woken)
runThread (TryPut v a c, i) threads = do runThread (ATryPut v a c, i) threads = do
let (V ref) = v let (V ref) = v
(val, blocks) <- readIORef ref (val, blocks) <- readIORef ref
case val of case val of
Just _ -> return $ goto (c False) i threads Just _ -> return (goto (c False) i threads, Just $ TryPut False [])
Nothing -> do Nothing -> do
writeIORef ref (Just a, blocks) writeIORef ref (Just a, blocks)
goto (c True) i <$> wake v WaitFull threads (threads', woken) <- wake v WaitFull threads
return (goto (c True) i threads', Just $ TryPut True woken)
runThread (Get v c, i) threads = do runThread (AGet v c, i) threads = do
let (V ref) = v let (V ref) = v
(val, _) <- readIORef ref (val, _) <- readIORef ref
case val of case val of
Just val' -> return $ goto (c val') i threads Just val' -> return (goto (c val') i threads, Just Read)
Nothing -> block v WaitFull i threads Nothing -> do
threads' <- block v WaitFull i threads
return (threads', Just BlockedRead)
runThread (Take v c, i) threads = do runThread (ATake v c, i) threads = do
let (V ref) = v let (V ref) = v
(val, blocks) <- readIORef ref (val, blocks) <- readIORef ref
case val of case val of
Just val' -> do Just val' -> do
writeIORef ref (Nothing, blocks) writeIORef ref (Nothing, blocks)
goto (c val') i <$> wake v WaitEmpty threads (threads', woken) <- wake v WaitEmpty threads
Nothing -> block v WaitFull i threads return (goto (c val') i threads', Just $ Take woken)
Nothing -> do
threads' <- block v WaitFull i threads
return (threads', Just BlockedTake)
runThread (TryTake v c, i) threads = do runThread (ATryTake v c, i) threads = do
let (V ref) = v let (V ref) = v
(val, _) <- readIORef ref (val, blocks) <- readIORef ref
return $ goto (c val) i threads case val of
Just _ -> do
writeIORef ref (Nothing, blocks)
(threads', woken) <- wake v WaitEmpty threads
return (goto (c val) i threads', Just $ TryTake True woken)
Nothing -> return (goto (c Nothing) i threads, Just $ TryTake False [])
runThread (Lift io, i) threads = do runThread (ALift io, i) threads = do
a <- io a <- io
return $ goto a i threads return (goto a i threads, Just IO)
runThread (Stop, i) threads = return $ kill i threads runThread (AStop, i) threads = return (kill i threads, Nothing)
-- | Replace the 'Action' of a thread. -- | Replace the 'Action' of a thread.
goto :: Ord k => a -> k -> Map k (a, b) -> Map k (a, b) goto :: Ord k => a -> k -> Map k (a, b) -> Map k (a, b)
@ -304,22 +356,28 @@ block (V ref) typ tid threads = do
return $ M.alter (\(Just (a, _)) -> Just (a, True)) tid threads return $ M.alter (\(Just (a, _)) -> Just (a, True)) tid threads
-- | Start a thread with the next free ID. -- | Start a thread with the next free ID.
launch :: (Ord k, Enum k) => a -> Map k (a, Bool) -> Map k (a, Bool) launch :: (Ord k, Enum k) => a -> Map k (a, Bool) -> (Map k (a, Bool), k)
launch a m = M.insert (succ . maximum $ M.keys m) (a, False) m launch a m = (M.insert k (a, False) m, k) where
k = succ . maximum $ M.keys m
-- | Kill a thread. -- | Kill a thread.
kill :: Ord k => k -> Map k (a, b) -> Map k (a, b) kill :: Ord k => k -> Map k (a, b) -> Map k (a, b)
kill = M.delete kill = M.delete
-- | Wake every thread blocked on a 'CVar' read. -- | Wake every thread blocked on a 'CVar' read/write.
wake :: Ord k => CVar t v -> (k -> Block) -> Map k (a, Bool) -> IO (Map k (a, Bool)) wake :: Ord k => CVar t v -> (k -> Block) -> Map k (a, Bool) -> IO (Map k (a, Bool), [k])
wake (V ref) typ = fmap M.fromList . mapM wake' . M.toList where wake (V ref) typ m = do
(m', woken) <- unzip <$> mapM wake' (M.toList m)
return (M.fromList m', catMaybes woken)
where
wake' a@(tid, (act, True)) = do wake' a@(tid, (act, True)) = do
let blck = typ tid let blck = typ tid
(val, blocks) <- readIORef ref (val, blocks) <- readIORef ref
if blck `elem` blocks if blck `elem` blocks
then writeIORef ref (val, filter (/= blck) blocks) >> return (tid, (act, False)) then writeIORef ref (val, filter (/= blck) blocks) >> return ((tid, (act, False)), Just tid)
else return a else return (a, Nothing)
wake' a = return a wake' a = return (a, Nothing)

25
Control/Monad/Conc/SCT.hs
View File

@ -34,7 +34,8 @@
module Control.Monad.Conc.SCT module Control.Monad.Conc.SCT
( -- *Systematic Concurrency Testing ( -- *Systematic Concurrency Testing
SCTScheduler SCTScheduler
, Trace , SchedTrace
, SCTTrace
, Decision(..) , Decision(..)
, runSCT , runSCT
@ -52,12 +53,15 @@ import System.Random (RandomGen)
-- | An @SCTScheduler@ is like a regular 'Scheduler', except it builds -- | An @SCTScheduler@ is like a regular 'Scheduler', except it builds
-- a trace of scheduling decisions made. -- a trace of scheduling decisions made.
type SCTScheduler s = Scheduler (s, Trace) type SCTScheduler s = Scheduler (s, SchedTrace)
-- | A @Trace@ is just a list of all the decisions that were made, -- | A @SchedTrace@ is just a list of all the decisions that were made,
-- with the alternative decisions that could have been made at each -- with the alternative decisions that could have been made at each
-- step. -- step
type Trace = [(Decision, [Decision])] type SchedTrace = [(Decision, [Decision])]
-- | A @SCTTrace@ is a combined 'SchedTrace' and 'Trace'.
type SCTTrace = [(Decision, [Decision], ThreadAction)]
-- | Scheduling decisions are based on the state of the running -- | Scheduling decisions are based on the state of the running
-- program, and so we can capture some of that state in recording what -- program, and so we can capture some of that state in recording what
@ -79,12 +83,15 @@ data Decision =
-- The initial state for each run is the final state of the last run, -- The initial state for each run is the final state of the last run,
-- so it is important that the scheduler actually maintain some -- so it is important that the scheduler actually maintain some
-- internal state, or all the results will be identical. -- internal state, or all the results will be identical.
runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> IO [(Maybe a, Trace)] runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> IO [(Maybe a, SCTTrace)]
runSCT _ _ 0 _ = return [] runSCT _ _ 0 _ = return []
runSCT sched s n c = do runSCT sched s n c = do
(res, (s', trace)) <- runConc' sched (s, [(Start 0, [])]) c (res, (s', strace), ttrace) <- runConc' sched (s, [(Start 0, [])]) c
rest <- runSCT sched s' (n - 1) c rest <- runSCT sched s' (n - 1) c
return $ (res, trace) : rest return $ (res, zipWith mktrace strace ttrace) : rest
where
mktrace (d, alts) (_, act) = (d, alts, act)
-- | A simple pre-emptive random scheduler. -- | A simple pre-emptive random scheduler.
sctRandom :: RandomGen g => SCTScheduler g sctRandom :: RandomGen g => SCTScheduler g
@ -109,7 +116,7 @@ toSCT sched (s, trace) prior threads = (tid, (s', trace ++ [(decision, alters)])
| otherwise = map Start $ filter (/=tid) threads | otherwise = map Start $ filter (/=tid) threads
-- | Pretty-print a scheduler trace. -- | Pretty-print a scheduler trace.
showTrace :: Trace -> String showTrace :: SchedTrace -> String
showTrace = trace "" 0 . map fst where showTrace = trace "" 0 . map fst where
trace prefix num (Start tid:ds) = thread prefix num ++ trace ("S" ++ show tid) 1 ds trace prefix num (Start tid:ds) = thread prefix num ++ trace ("S" ++ show tid) 1 ds
trace prefix num (SwitchTo tid:ds) = thread prefix num ++ trace ("P" ++ show tid) 1 ds trace prefix num (SwitchTo tid:ds) = thread prefix num ++ trace ("P" ++ show tid) 1 ds