diff --git a/CHANGELOG.rst b/CHANGELOG.rst --- a/CHANGELOG.rst +++ b/CHANGELOG.rst @@ -7,6 +7,20 @@ .. _PVP: https://pvp.haskell.org/ +1.9.0.0 (2018-06-10) +-------------------- + +* Git: :tag:`dejafu-1.9.0.0` +* Hackage: :hackage:`dejafu-1.9.0.0` + +Changed +~~~~~~~ + +* (:issue:`190`) ``Test.DejaFu.Types.Throw`` and ``ThrowTo`` have a + ``Bool`` parameter, which is ``True`` if the exception kills the + thread. + + 1.8.0.0 (2018-06-03) -------------------- diff --git a/Test/DejaFu/Conc/Internal.hs b/Test/DejaFu/Conc/Internal.hs --- a/Test/DejaFu/Conc/Internal.hs +++ b/Test/DejaFu/Conc/Internal.hs @@ -539,7 +539,7 @@ ) Exception e -> do let act = STM trace [] - res' <- stepThrow act tid e ctx + res' <- stepThrow (const act) tid e ctx pure $ case res' of (Succeeded ctx', _, effect') -> (Succeeded ctx' { cIdSource = idSource' }, Single act, effect') (Failed err, _, effect') -> (Failed err, Single act, effect') @@ -573,7 +573,7 @@ ) Nothing -> pure (Succeeded ctx { cThreads = threads' } - , Single (ThrowTo t) + , Single (ThrowTo t False) , const (pure ()) ) @@ -686,7 +686,7 @@ -- | Handle an exception being thrown from an @AAtom@, @AThrow@, or -- @AThrowTo@. stepThrow :: (C.MonadConc n, Exception e) - => ThreadAction + => (Bool -> ThreadAction) -- ^ Action to include in the trace. -> ThreadId -- ^ The thread receiving the exception. @@ -698,19 +698,19 @@ stepThrow act tid e ctx@Context{..} = case propagate some tid cThreads of Just ts' -> pure ( Succeeded ctx { cThreads = ts' } - , Single act + , Single (act False) , const (pure ()) ) Nothing | tid == initialThread -> pure ( Failed (UncaughtException some) - , Single act + , Single (act True) , const (pure ()) ) | otherwise -> do ts' <- kill tid cThreads pure ( Succeeded ctx { cThreads = ts' } - , Single act + , Single (act True) , const (pure ()) ) where diff --git a/Test/DejaFu/Internal.hs b/Test/DejaFu/Internal.hs --- a/Test/DejaFu/Internal.hs +++ b/Test/DejaFu/Internal.hs @@ -187,8 +187,8 @@ rewind (BlockedSTM _) = WillSTM rewind Catching = WillCatching rewind PopCatching = WillPopCatching -rewind Throw = WillThrow -rewind (ThrowTo t) = WillThrowTo t +rewind (Throw _) = WillThrow +rewind (ThrowTo t _) = WillThrowTo t rewind (BlockedThrowTo t) = WillThrowTo t rewind (SetMasking b m) = WillSetMasking b m rewind (ResetMasking b m) = WillResetMasking b m @@ -292,7 +292,7 @@ tidsOf (TryTakeMVar _ _ tids) = S.fromList tids tidsOf (CommitCRef tid _) = S.singleton tid tidsOf (STM _ tids) = S.fromList tids -tidsOf (ThrowTo tid) = S.singleton tid +tidsOf (ThrowTo tid _) = S.singleton tid tidsOf (BlockedThrowTo tid) = S.singleton tid tidsOf _ = S.empty 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 @@ -368,8 +368,8 @@ (s, CasCRef (renumbered cridmap old) b) updateAction s@(tidmap, _, _, _) (STM tas olds) = (s, STM tas (map (renumbered tidmap) olds)) - updateAction s@(tidmap, _, _, _) (ThrowTo old) = - (s, ThrowTo (renumbered tidmap old)) + updateAction s@(tidmap, _, _, _) (ThrowTo old b) = + (s, ThrowTo (renumbered tidmap old) b) updateAction s@(tidmap, _, _, _) (BlockedThrowTo old) = (s, BlockedThrowTo (renumbered tidmap old)) updateAction s act = (s, act) diff --git a/Test/DejaFu/SCT/Internal/DPOR.hs b/Test/DejaFu/SCT/Internal/DPOR.hs --- a/Test/DejaFu/SCT/Internal/DPOR.hs +++ b/Test/DejaFu/SCT/Internal/DPOR.hs @@ -564,7 +564,7 @@ -- :( -- -- See #191 / #190 - check _ (ThrowTo t) tid _ | t == tid = True + check _ (ThrowTo t _) tid _ | t == tid = True check _ (BlockedThrowTo t) tid _ | t == tid = True -- can't re-order an unsynchronised write with something which synchronises that CRef. check _ (simplifyAction -> UnsynchronisedWrite r) _ (simplifyAction -> a) | synchronises a r = True @@ -581,10 +581,10 @@ -- actually blocked. 'dependent'' has to assume that all -- potentially-blocking operations can block, and so is more -- pessimistic in this case. - (ThrowTo t, ThrowTo u) + (ThrowTo t _, ThrowTo u _) | t == t2 && u == t1 -> canInterrupt ds t1 a1 || canInterrupt ds t2 a2 - (ThrowTo t, _) | t == t2 -> canInterrupt ds t2 a2 && a2 /= Stop - (_, ThrowTo t) | t == t1 -> canInterrupt ds t1 a1 && a1 /= Stop + (ThrowTo t _, _) | t == t2 -> canInterrupt ds t2 a2 && a2 /= Stop + (_, ThrowTo t _) | t == t1 -> canInterrupt ds t1 a1 && a1 /= Stop -- Dependency of STM transactions can be /greatly/ improved here, as -- the 'Lookahead' does not know which @TVar@s will be touched, and @@ -616,9 +616,9 @@ -- thread and if the actions can be interrupted. We can also -- slightly improve on that by not considering interrupting the -- normal termination of a thread: it doesn't make a difference. - (ThrowTo t, WillThrowTo u) + (ThrowTo t _, WillThrowTo u) | t == t2 && u == t1 -> canInterrupt ds t1 a1 || canInterruptL ds t2 l2 - (ThrowTo t, _) | t == t2 -> canInterruptL ds t2 l2 && l2 /= WillStop + (ThrowTo t _, _) | t == t2 -> canInterruptL ds t2 l2 && l2 /= WillStop (_, WillThrowTo t) | t == t1 -> canInterrupt ds t1 a1 && a1 /= Stop -- Another worst-case: assume all STM is dependent. @@ -732,6 +732,8 @@ Nothing -> masks updateMaskState tid (SetMasking _ ms) = M.insert tid ms updateMaskState tid (ResetMasking _ ms) = M.insert tid ms +updateMaskState tid (Throw True) = M.delete tid +updateMaskState _ (ThrowTo tid True) = M.delete tid updateMaskState tid Stop = M.delete tid updateMaskState _ _ = id diff --git a/Test/DejaFu/Types.hs b/Test/DejaFu/Types.hs --- a/Test/DejaFu/Types.hs +++ b/Test/DejaFu/Types.hs @@ -109,7 +109,7 @@ -- | All the actions that a thread can perform. -- --- @since 1.4.0.0 +-- @since 1.9.0.0 data ThreadAction = Fork ThreadId -- ^ Start a new thread. @@ -174,10 +174,12 @@ -- ^ Register a new exception handler | PopCatching -- ^ Pop the innermost exception handler from the stack. - | Throw - -- ^ Throw an exception. - | ThrowTo ThreadId - -- ^ Throw an exception to a thread. + | Throw Bool + -- ^ Throw an exception. If the 'Bool' is @True@, then this killed + -- the thread. + | ThrowTo ThreadId Bool + -- ^ Throw an exception to a thread. If the 'Bool' is @True@, then + -- this killed the thread. | BlockedThrowTo ThreadId -- ^ Get blocked on a 'throwTo'. | SetMasking Bool MaskingState @@ -238,8 +240,8 @@ rnf (BlockedSTM as) = rnf as rnf Catching = () rnf PopCatching = () - rnf Throw = () - rnf (ThrowTo t) = rnf t + rnf (Throw b) = rnf b + rnf (ThrowTo t b) = rnf (t, b) rnf (BlockedThrowTo t) = rnf t rnf (SetMasking b m) = rnf (b, show m) rnf (ResetMasking b m) = rnf (b, show m) 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: 1.8.0.0 +version: 1.9.0.0 synopsis: A library for unit-testing concurrent programs. description: @@ -33,7 +33,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: dejafu-1.8.0.0 + tag: dejafu-1.9.0.0 library exposed-modules: Test.DejaFu