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

Give better errors from failing partial functions

Browse Source 
They still shouldn't fail, but this will make tracking down issues
like #141 in the future easier
This commit is contained in:
Michael Walker 2017-10-28 12:15:52 +01:00
parent 5838a921b7
commit 3c0b2d81ff
6 changed files with 71 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
dejafu/Test/DejaFu/Common.hs
View File

@ -66,17 +66,24 @@ module Test.DejaFu.Common
-- * Miscellaneous
, MonadFailException(..)
, runRefCont
, ehead
, etail
, eidx
, efromJust
, efromList
, fatal
) where
import Control.DeepSeq (NFData(..))
import Control.Exception (Exception(..), MaskingState(..),
SomeException, displayException)
import Control.Monad.Ref (MonadRef(..))
import Data.Function (on)
import Data.List (intercalate)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Control.DeepSeq (NFData(..))
import Control.Exception (Exception(..), MaskingState(..),
SomeException, displayException)
import Control.Monad.Ref (MonadRef(..))
import Data.Function (on)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
-------------------------------------------------------------------------------
-- Identifiers
@ -983,6 +990,42 @@ runRefCont act f k = do
let c = k (act . writeRef ref . f)
pure (c, ref)
-- | 'head' but with a better error message if it fails. Use this
-- only where it shouldn't fail!
ehead :: String -> [a] -> a
ehead _ (x:_) = x
ehead src _ = fatal src "head: empty list"
-- | 'tail' but with a better error message if it fails. Use this
-- only where it shouldn't fail!
etail :: String -> [a] -> [a]
etail _ (_:xs) = xs
etail src _ = fatal src "tail: empty list"
-- | '(!!)' but with a better error message if it fails. Use this
-- only where it shouldn't fail!
eidx :: String -> [a] -> Int -> a
eidx src xs i
| i < length xs = xs !! i
| otherwise = fatal src "(!!): index too large"
-- | 'fromJust' but with a better error message if it fails. Use this
-- only where it shouldn't fail!
efromJust :: String -> Maybe a -> a
efromJust _ (Just x) = x
efromJust src _ = fatal src "fromJust: Nothing"
-- | 'fromList' but with a better error message if it fails. Use this
-- only where it shouldn't fail!
efromList :: String -> [a] -> NonEmpty a
efromList _ (x:xs) = x:|xs
efromList src _ = fatal src "fromList: empty list"
-- | 'error' but saying where it came from
fatal :: String -> String -> a
fatal src msg = error ("(dejafu: " ++ src ++ ") " ++ msg)
-------------------------------------------------------------------------------
-- Utilities

11
dejafu/Test/DejaFu/Conc/Internal.hs
View File

@ -21,9 +21,8 @@ import Control.Monad.Ref (MonadRef, newRef, readRef,
writeRef)
import Data.Functor (void)
import Data.List (sortOn)
import Data.List.NonEmpty (fromList)
import qualified Data.Map.Strict as M
import Data.Maybe (fromJust, isJust)
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import Data.Sequence (Seq, (<|))
import qualified Data.Sequence as Seq
@ -64,7 +63,7 @@ runConcurrency sched memtype g idsrc caps ma = do
}
(finalCtx, trace, finalAction) <- runThreads sched memtype ref ctx
out <- readRef ref
pure (fromJust out, finalCtx, trace, finalAction)
pure (efromJust "runConcurrency" out, finalCtx, trace, finalAction)
-- | The context a collection of threads are running in.
data Context n r g = Context
@ -97,7 +96,7 @@ runThreads sched memtype ref = go Seq.empty Nothing where
Nothing -> die sofar prior InternalError ctx'
Nothing -> die sofar prior Abort ctx'
where
(choice, g') = scheduleThread sched prior (fromList runnable') (cSchedState ctx)
(choice, g') = scheduleThread sched prior (efromList "runThreads" runnable') (cSchedState ctx)
runnable' = [(t, lookahead (_continuation a)) | (t, a) <- sortOn fst $ M.assocs runnable]
runnable = M.filter (not . isBlocked) threadsc
threadsc = addCommitThreads (cWriteBuf ctx) threads
@ -290,7 +289,7 @@ stepThread sched memtype tid action ctx = case action of
wb' <- case memtype of
-- shouldn't ever get here
SequentialConsistency ->
error "Attempting to commit under SequentialConsistency"
fatal "stepThread.ACommit" "Attempting to commit under SequentialConsistency"
-- commit using the thread id.
TotalStoreOrder -> commitWrite (cWriteBuf ctx) (t, Nothing)
-- commit using the cref id.
@ -351,7 +350,7 @@ stepThread sched memtype tid action ctx = case action of
-- a function to run a computation with the current masking state.
AMasking m ma c ->
let a = runCont (ma umask) (AResetMask False False m' . c)
m' = _masking . fromJust $ M.lookup tid (cThreads ctx)
m' = _masking . efromJust "stepThread.AMasking" $ M.lookup tid (cThreads ctx)
umask mb = resetMask True m' >> mb >>= \b -> resetMask False m >> pure b
resetMask typ ms = cont $ \k -> AResetMask typ True ms $ k ()
threads' = goto a tid (mask m tid (cThreads ctx))

6
dejafu/Test/DejaFu/Conc/Internal/Memory.hs
View File

@ -26,7 +26,7 @@ module Test.DejaFu.Conc.Internal.Memory where
import Control.Monad.Ref (MonadRef, readRef,
writeRef)
import Data.Map.Strict (Map)
import Data.Maybe (fromJust, maybeToList)
import Data.Maybe (maybeToList)
import Data.Monoid ((<>))
import Data.Sequence (Seq, ViewL(..), singleton,
viewl, (><))
@ -160,7 +160,7 @@ tryPutIntoMVar = mutMVar NonBlocking
-- | Read from a @MVar@, blocking if empty.
readFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r)
-> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId])
readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . fromJust)
readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . efromJust "readFromMVar")
-- | Try to read from a @MVar@, not blocking if empty.
tryReadFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r)
@ -170,7 +170,7 @@ tryReadFromMVar = seeMVar NonEmptying NonBlocking
-- | Take from a @MVar@, blocking if empty.
takeFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r)
-> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId])
takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . fromJust)
takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . efromJust "takeFromMVar")
-- | Try to take from a @MVar@, not blocking if empty.
tryTakeFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r)

2
dejafu/Test/DejaFu/Conc/Internal/Threading.hs
View File

@ -92,7 +92,7 @@ catching h = M.adjust $ \thread ->
-- | Remove the most recent exception handler.
uncatching :: ThreadId -> Threads n r -> Threads n r
uncatching = M.adjust $ \thread -> thread { _handlers = tail $ _handlers thread }
uncatching = M.adjust $ \thread -> thread { _handlers = etail "uncatching" (_handlers thread) }
-- | Raise an exception in a thread.
except :: (MaskingState -> Action n r) -> [Handler n r] -> ThreadId -> Threads n r -> Threads n r

22
dejafu/Test/DejaFu/SCT/Internal.hs
View File

@ -22,7 +22,7 @@ import Data.List (nubBy, partition, sortOn)
import Data.List.NonEmpty (toList)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing,
import Data.Maybe (fromMaybe, isJust, isNothing,
listToMaybe)
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Sq
@ -157,7 +157,7 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
in case dporNext dpor of
Just (t, child)
| t == tid' -> dpor { dporNext = Just (tid', grow state' tid' rest child) }
| hasTodos child -> err "incorporateTrace" "replacing child with todos!"
| hasTodos child -> fatal "incorporateTrace" "replacing child with todos!"
_ ->
let taken = M.insert tid' a (dporTaken dpor)
sleep = dporSleep dpor `M.union` dporTaken dpor
@ -166,7 +166,7 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
, dporNext = Just (tid', subtree state' tid' sleep trc)
, dporDone = S.insert tid' (dporDone dpor)
}
grow _ _ [] _ = err "incorporateTrace" "trace exhausted without reading a to-do point!"
grow _ _ [] _ = fatal "incorporateTrace" "trace exhausted without reading a to-do point!"
-- check if there are to-do points in a tree
hasTodos dpor = not (M.null (dporTodo dpor)) || (case dporNext dpor of Just (_, dpor') -> hasTodos dpor'; _ -> False)
@ -193,7 +193,7 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
((d', _, a'):_) -> M.singleton (tidOf tid d') a'
[] -> M.empty
}
subtree _ _ _ [] = err "incorporateTrace" "subtree suffix empty!"
subtree _ _ _ [] = fatal "incorporateTrace" "subtree suffix empty!"
-- | Produce a list of new backtracking points from an execution
-- trace. These are then used to inform new \"to-do\" points in the
@ -251,7 +251,7 @@ findBacktrackSteps memtype backtrack boundKill = go initialDepState S.empty init
-- backtracking points.
doBacktrack killsEarly allThreads enabledThreads bs =
let tagged = reverse $ zip [0..] bs
idxs = [ (head is, False, u)
idxs = [ (ehead "doBacktrack.idxs" is, False, u)
| (u, n) <- enabledThreads
, v <- S.toList allThreads
, u /= v
@ -301,9 +301,9 @@ incorporateBacktrackSteps (b:bs) dpor = dpor' where
child = case dporNext dpor of
Just (t, d)
| t /= tid -> err "incorporateBacktrackSteps" "incorporating wrong trace!"
| t /= tid -> fatal "incorporateBacktrackSteps" "incorporating wrong trace!"
| otherwise -> incorporateBacktrackSteps bs d
Nothing -> err "incorporateBacktrackSteps" "child is missing!"
Nothing -> fatal "incorporateBacktrackSteps" "child is missing!"
incorporateBacktrackSteps [] dpor = dpor
-------------------------------------------------------------------------------
@ -416,7 +416,7 @@ backtrackAt toAll bs0 = backtrackAt' . nubBy ((==) `on` fst') . sortOn fst' wher
((i',c',t'):is') -> go i' bs (i'-i0-1) c' t' is'
[] -> bs
go i0 (b:bs) i c tid is = b : go i0 bs (i-1) c tid is
go _ [] _ _ _ _ = err "backtrackAt" "ran out of schedule whilst backtracking!"
go _ [] _ _ _ _ = fatal "backtrackAt" "ran out of schedule whilst backtracking!"
-- Backtrack to a single thread
backtrackTo tid c = M.insert tid c . bcktBacktracks
@ -495,7 +495,7 @@ dporSched memtype boundf = Scheduler $ \prior threads s ->
decision = decisionOf (fst <$> prior) (S.fromList tids)
-- Get the action of a thread
action t = fromJust $ lookup t threads'
action t = efromJust "dporSched.action" (lookup t threads')
-- The runnable thread IDs
tids = map fst threads'
@ -812,7 +812,3 @@ willYield _ = False
killsDaemons :: ThreadId -> Lookahead -> Bool
killsDaemons t WillStop = t == initialThread
killsDaemons _ _ = False
-- | Internal errors.
err :: String -> String -> a
err func msg = error (func ++ ": (internal error) " ++ msg)

2
dejafu/Test/DejaFu/Schedule.hs
View File

@ -98,7 +98,7 @@ randomSched = Scheduler go where
go _ threads g =
let threads' = map fst (toList threads)
(choice, g') = randomR (0, length threads' - 1) g
in (Just $ threads' !! choice, g')
in (Just $ eidx "randomSched" threads' choice, g')
-- | A round-robin scheduler which, at every step, schedules the
-- thread with the next 'ThreadId'.