mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-12-18 19:11:37 +03:00
Enable -Wall and fix all warnings
This commit is contained in:
parent
7819a3c7b0
commit
554fa84ec7
@ -23,7 +23,7 @@ module Control.Monad.Conc.CVar
|
||||
, unlock
|
||||
) where
|
||||
|
||||
import Control.Monad (liftM, void)
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Conc.Class
|
||||
|
||||
-- | Create a new @CVar@ containing a value.
|
||||
|
@ -15,7 +15,6 @@ module Control.Monad.Conc.Class where
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar (MVar, readMVar, newEmptyMVar, putMVar, tryPutMVar, takeMVar, tryTakeMVar)
|
||||
import Control.Monad (void)
|
||||
import Data.Maybe (maybe)
|
||||
|
||||
-- | @ConcFuture@ is the monad-conc alternative of 'ParFuture'. It
|
||||
-- abstracts Conc monads which support futures. In itself, this is not
|
||||
|
@ -35,8 +35,8 @@ import Control.Applicative (Applicative(..), (<$>))
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
|
||||
import Control.Monad.Cont (Cont, cont, runCont)
|
||||
import Data.Map (Map)
|
||||
import Data.Maybe (fromJust, fromMaybe, isNothing, isJust)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef')
|
||||
import Data.Maybe (fromJust, isNothing)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import System.Random (RandomGen, randomR)
|
||||
|
||||
import qualified Control.Monad.Conc.Class as C
|
||||
@ -197,9 +197,9 @@ randomSchedNP = makeNP randomSched
|
||||
-- | A round-robin scheduler which, at every step, schedules the
|
||||
-- thread with the next 'ThreadId'.
|
||||
roundRobinSched :: Scheduler ()
|
||||
roundRobinSched _ last threads
|
||||
| last >= maximum threads = (minimum threads, ())
|
||||
| otherwise = (minimum $ filter (>last) threads, ())
|
||||
roundRobinSched _ prior threads
|
||||
| prior >= maximum threads = (minimum threads, ())
|
||||
| otherwise = (minimum $ filter (>prior) threads, ())
|
||||
|
||||
-- | A round-robin scheduler which doesn't pre-empt the running
|
||||
-- thread.
|
||||
@ -210,9 +210,9 @@ roundRobinSchedNP = makeNP roundRobinSched
|
||||
-- one.
|
||||
makeNP :: Scheduler s -> Scheduler s
|
||||
makeNP sched = newsched where
|
||||
newsched s last threads
|
||||
| last `elem` threads = (last, s)
|
||||
| otherwise = sched s last threads
|
||||
newsched s prior threads
|
||||
| prior `elem` threads = (prior, s)
|
||||
| otherwise = sched s prior threads
|
||||
|
||||
-------------------- Internal stuff --------------------
|
||||
|
||||
@ -224,7 +224,7 @@ data Block = WaitFull ThreadId | WaitEmpty ThreadId deriving Eq
|
||||
--
|
||||
-- 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 last sched s threads mvar
|
||||
runThreads prior sched s threads mvar
|
||||
| isTerminated = return s
|
||||
| isDeadlocked = putMVar mvar Nothing >> return s
|
||||
| isBlocked = putStrLn "Attempted to run a blocked thread, assuming deadlock." >> putMVar mvar Nothing >> return s
|
||||
@ -234,7 +234,7 @@ runThreads last sched s threads mvar
|
||||
runThreads chosen sched s' threads' mvar
|
||||
|
||||
where
|
||||
(chosen, s') = if last == -1 then (0, s) else sched s last $ M.keys runnable
|
||||
(chosen, s') = if prior == -1 then (0, s) else sched s prior $ M.keys runnable
|
||||
runnable = M.filter (not . snd) threads
|
||||
thread = M.lookup chosen threads
|
||||
isBlocked = snd . fromJust $ M.lookup chosen threads
|
||||
@ -313,13 +313,13 @@ kill = M.delete
|
||||
|
||||
-- | Wake every thread blocked on a 'CVar' read.
|
||||
wake :: Ord k => CVar t v -> (k -> Block) -> Map k (a, Bool) -> IO (Map k (a, Bool))
|
||||
wake (V ref) typ = fmap M.fromList . mapM wake . M.toList where
|
||||
wake a@(tid, (act, True)) = do
|
||||
let block = typ tid
|
||||
wake (V ref) typ = fmap M.fromList . mapM wake' . M.toList where
|
||||
wake' a@(tid, (act, True)) = do
|
||||
let blck = typ tid
|
||||
(val, blocks) <- readIORef ref
|
||||
|
||||
if block `elem` blocks
|
||||
then writeIORef ref (val, filter (/= block) blocks) >> return (tid, (act, False))
|
||||
if blck `elem` blocks
|
||||
then writeIORef ref (val, filter (/= blck) blocks) >> return (tid, (act, False))
|
||||
else return a
|
||||
|
||||
wake a = return a
|
||||
wake' a = return a
|
||||
|
@ -48,7 +48,7 @@ module Control.Monad.Conc.SCT
|
||||
) where
|
||||
|
||||
import Control.Monad.Conc.Fixed
|
||||
import System.Random (RandomGen, randomR)
|
||||
import System.Random (RandomGen)
|
||||
|
||||
-- | An @SCTScheduler@ is like a regular 'Scheduler', except it builds
|
||||
-- a trace of scheduling decisions made.
|
||||
@ -80,12 +80,11 @@ data Decision =
|
||||
-- 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, Trace)]
|
||||
runSCT sched s runs c = runSCT' s runs where
|
||||
runSCT' _ 0 = return []
|
||||
runSCT' s n = do
|
||||
(res, (s', log)) <- runConc' sched (s, [(Start 0, [])]) c
|
||||
rest <- runSCT' s' $ n - 1
|
||||
return $ (res, log) : rest
|
||||
runSCT _ _ 0 _ = return []
|
||||
runSCT sched s n c = do
|
||||
(res, (s', trace)) <- runConc' sched (s, [(Start 0, [])]) c
|
||||
rest <- runSCT sched s' (n - 1) c
|
||||
return $ (res, trace) : rest
|
||||
|
||||
-- | A simple pre-emptive random scheduler.
|
||||
sctRandom :: RandomGen g => SCTScheduler g
|
||||
@ -98,24 +97,23 @@ sctRandomNP = toSCT randomSchedNP
|
||||
-- | Convert a 'Scheduler' to an 'SCTScheduler' by recording the
|
||||
-- trace.
|
||||
toSCT :: Scheduler s -> SCTScheduler s
|
||||
toSCT sched (s, log) last threads = (tid, (s', log ++ [(decision, alters)])) where
|
||||
(tid, s') = sched s last threads
|
||||
toSCT sched (s, trace) prior threads = (tid, (s', trace ++ [(decision, alters)])) where
|
||||
(tid, s') = sched s prior threads
|
||||
|
||||
decision | tid == last = Continue
|
||||
| last `elem` threads = SwitchTo tid
|
||||
| otherwise = Start tid
|
||||
decision | tid == prior = Continue
|
||||
| prior `elem` threads = SwitchTo tid
|
||||
| otherwise = Start tid
|
||||
|
||||
alters | tid == last = map SwitchTo $ filter (/=last) threads
|
||||
| last `elem` threads = Continue : map SwitchTo (filter (\t -> t /= last && t /= tid) threads)
|
||||
| otherwise = map Start $ filter (/=tid) threads
|
||||
alters | tid == prior = map SwitchTo $ filter (/=prior) threads
|
||||
| prior `elem` threads = Continue : map SwitchTo (filter (\t -> t /= prior && t /= tid) threads)
|
||||
| otherwise = map Start $ filter (/=tid) threads
|
||||
|
||||
-- | Pretty-print a scheduler trace.
|
||||
showTrace :: Trace -> String
|
||||
showTrace = trace "" 0 . map fst where
|
||||
trace log num (Start tid:ds) = thread log num ++ trace ("S" ++ show tid) 1 ds
|
||||
trace log num (Continue:ds) = trace log (num + 1) ds
|
||||
trace log num (SwitchTo tid:ds) = thread log num ++ trace ("P" ++ show tid) 1 ds
|
||||
trace log num [] = thread log num
|
||||
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 (Continue:ds) = trace prefix (num + 1) ds
|
||||
trace prefix num [] = thread prefix num
|
||||
|
||||
thread "" _ = ""
|
||||
thread log num = log ++ replicate num '-'
|
||||
thread prefix num = prefix ++ replicate num '-'
|
||||
|
@ -29,4 +29,5 @@ library
|
||||
, random
|
||||
, transformers
|
||||
-- hs-source-dirs:
|
||||
default-language: Haskell2010
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
Loading…
Reference in New Issue
Block a user