diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -7,6 +7,28 @@ *de facto* standard Haskell versioning scheme. +0.7.3.0 +------- + +- **Date** 2017-09-26 +- **Git tag** [dejafu-0.7.3.0][] +- **Hackage** https://hackage.haskell.org/package/dejafu-0.7.3.0 + +### Test.DejaFu.Common + +- A new function `threadNames`, to get all named threads from a trace. + +### Miscellaneous + +- Escaping a mask by raising an exception now correctly restores the masking state (#118). +- Named threads which are only started by a pre-emption now show up in the trace (#101). + +[dejafu-0.7.3.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.3.0 + + +--------------------------------------------------------------------------------------------------- + + 0.7.2.0 ------- diff --git a/Test/DejaFu/Common.hs b/Test/DejaFu/Common.hs --- a/Test/DejaFu/Common.hs +++ b/Test/DejaFu/Common.hs @@ -48,6 +48,7 @@ , Trace , Decision(..) , showTrace + , threadNames , preEmpCount -- * Failures @@ -65,7 +66,7 @@ import Control.DeepSeq (NFData(..)) import Control.Exception (Exception(..), MaskingState(..)) import Control.Monad.Ref (MonadRef(..)) -import Data.List (intercalate, nub, sort) +import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) import Data.Maybe (fromMaybe, mapMaybe) import Data.Set (Set) @@ -778,12 +779,16 @@ go (SwitchTo (ThreadId _ i),_,_) = "P" ++ show i ++ "-" go (Continue,_,_) = "-" - strkey = [" " ++ show i ++ ": " ++ name | (i, name) <- key] + strkey = + [" " ++ show i ++ ": " ++ name | (i, name) <- threadNames trc] - key = sort . nub $ mapMaybe toKey trc where - toKey (Start (ThreadId (Just name) i), _, _) - | i > 0 = Just (i, name) - toKey _ = Nothing +-- | Get all named threads in the trace. +-- +-- @since 0.7.3.0 +threadNames :: Trace -> [(Int, String)] +threadNames = mapMaybe go where + go (_, _, Fork (ThreadId (Just name) i)) = Just (i, name) + go _ = Nothing -- | Count the number of pre-emptions in a schedule prefix. -- diff --git a/Test/DejaFu/Conc/Internal/Common.hs b/Test/DejaFu/Conc/Internal/Common.hs --- a/Test/DejaFu/Conc/Internal/Common.hs +++ b/Test/DejaFu/Conc/Internal/Common.hs @@ -41,6 +41,8 @@ fmap f m = M $ \ c -> runM m (c . f) instance Applicative (M n r) where + -- without the @AReturn@, a thread could lock up testing by + -- entering an infinite loop (eg: @forever (return ())@) pure x = M $ \c -> AReturn $ c x f <*> v = M $ \c -> runM f (\g -> runM v (c . g)) diff --git a/Test/DejaFu/Conc/Internal/Memory.hs b/Test/DejaFu/Conc/Internal/Memory.hs --- a/Test/DejaFu/Conc/Internal/Memory.hs +++ b/Test/DejaFu/Conc/Internal/Memory.hs @@ -23,12 +23,10 @@ -- Memory Models/, N. Zhang, M. Kusano, and C. Wang (2015). module Test.DejaFu.Conc.Internal.Memory where -import Control.Monad (when) import Control.Monad.Ref (MonadRef, readRef, writeRef) import Data.Map.Strict (Map) -import Data.Maybe (fromJust, isJust, - maybeToList) +import Data.Maybe (fromJust, maybeToList) import Data.Monoid ((<>)) import Data.Sequence (Seq, ViewL(..), singleton, viewl, (><)) diff --git a/Test/DejaFu/Conc/Internal/Threading.hs b/Test/DejaFu/Conc/Internal/Threading.hs --- a/Test/DejaFu/Conc/Internal/Threading.hs +++ b/Test/DejaFu/Conc/Internal/Threading.hs @@ -66,7 +66,7 @@ -- * Exceptions -- | An exception handler. -data Handler n r = forall e. Exception e => Handler (e -> Action n r) +data Handler n r = forall e. Exception e => Handler (e -> MaskingState -> Action n r) -- | Propagate an exception upwards, finding the closest handler -- which can deal with it. @@ -85,15 +85,22 @@ -- | Register a new exception handler. catching :: Exception e => (e -> Action n r) -> ThreadId -> Threads n r -> Threads n r -catching h = M.adjust $ \thread -> thread { _handlers = Handler h : _handlers thread } +catching h = M.adjust $ \thread -> + let ms0 = _masking thread + h' = Handler $ \e ms -> (if ms /= ms0 then AResetMask False False ms0 else id) (h e) + in thread { _handlers = h' : _handlers thread } -- | Remove the most recent exception handler. uncatching :: ThreadId -> Threads n r -> Threads n r uncatching = M.adjust $ \thread -> thread { _handlers = tail $ _handlers thread } -- | Raise an exception in a thread. -except :: Action n r -> [Handler n r] -> ThreadId -> Threads n r -> Threads n r -except act hs = M.adjust $ \thread -> thread { _continuation = act, _handlers = hs, _blocking = Nothing } +except :: (MaskingState -> Action n r) -> [Handler n r] -> ThreadId -> Threads n r -> Threads n r +except actf hs = M.adjust $ \thread -> thread + { _continuation = actf (_masking thread) + , _handlers = hs + , _blocking = Nothing + } -- | Set the masking state of a thread. mask :: MaskingState -> ThreadId -> Threads n r -> Threads n r diff --git a/Test/DejaFu/SCT.hs b/Test/DejaFu/SCT.hs --- a/Test/DejaFu/SCT.hs +++ b/Test/DejaFu/SCT.hs @@ -663,7 +663,7 @@ where ycount tnext = case lnext of WillYield -> M.alter (Just . maybe 1 (+1)) tnext sofar - _ -> M.alter (Just . maybe 0 id) tnext sofar + _ -> M.alter (Just . fromMaybe 0) tnext sofar -- | Determine if an action is a commit or not. isCommitRef :: ThreadAction -> Bool diff --git a/Test/DejaFu/SCT/Internal.hs b/Test/DejaFu/SCT/Internal.hs --- a/Test/DejaFu/SCT/Internal.hs +++ b/Test/DejaFu/SCT/Internal.hs @@ -22,8 +22,8 @@ import Data.List.NonEmpty (toList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, - isNothing, listToMaybe) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, + listToMaybe) import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Sq import Data.Set (Set) diff --git a/dejafu.cabal b/dejafu.cabal --- a/dejafu.cabal +++ b/dejafu.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: dejafu -version: 0.7.2.0 +version: 0.7.3.0 synopsis: Systematic testing for Haskell concurrency. description: @@ -37,7 +37,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: dejafu-0.7.2.0 + tag: dejafu-0.7.3.0 library exposed-modules: Test.DejaFu