dejafu 2.3.0.1 → 2.4.0.0

raw patch · 8 files changed

+84/−37 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.rst +25/−0
• Test/DejaFu/Conc/Internal.hs +8/−9
• Test/DejaFu/Conc/Internal/Threading.hs +9/−8
• Test/DejaFu/Internal.hs +9/−2
• Test/DejaFu/SCT/Internal.hs +3/−3
• Test/DejaFu/SCT/Internal/DPOR.hs +11/−5
• Test/DejaFu/Types.hs +17/−8
• dejafu.cabal +2/−2

@@ -6,6 +6,31 @@  .. _PVP: https://pvp.haskell.org/ +2.4.0.0 (2020-07-01)+--------------------++* Git: :tag:`dejafu-2.4.0.0`+* Hackage: :hackage:`dejafu-2.4.0.0`++Added+~~~~~++* Thread action constructor for STM transactions which throw an+  exception: ``Test.DejaFu.Types.ThreadAction`` ``ThrownSTM``++Changed+~~~~~~~++* ``Test.DejaFu.Types.ThreadAction``, ``Throw``, and ``ThrowTo`` now+  include the resultant masking state, and no bool.++Fixed+~~~~~++* (:issue:`324`) Jumping out of a restored mask into an exception+  handler now atomically restores the masking state.++ 2.3.0.1 (2020-06-24) -------------------- 

@@ -523,11 +523,10 @@            , effect            )     Exception e -> do-      let act = STM trace []-      res' <- stepThrow (const act) tid e ctx+      res' <- stepThrow (ThrownSTM trace) tid e ctx       pure $ case res' of-        (Succeeded ctx', _, effect') -> (Succeeded ctx' { cIdSource = idSource' }, act, effect')-        (Failed err, _, effect') -> (Failed err, act, effect')+        (Succeeded ctx', act, effect') -> (Succeeded ctx' { cIdSource = idSource' }, act, effect')+        (Failed err, act, effect') -> (Failed err, act, effect')  -- lift an action from the underlying monad into the @Conc@ -- computation.@@ -557,7 +556,7 @@            )        Nothing -> pure          (Succeeded ctx { cThreads = threads' }-         , ThrowTo t False+         , ThrowTo t Nothing          , const (pure ())          ) @@ -633,7 +632,7 @@ -- | Handle an exception being thrown from an @AAtom@, @AThrow@, or -- @AThrowTo@. stepThrow :: (MonadDejaFu n, Exception e)-  => (Bool -> ThreadAction)+  => (Maybe MaskingState -> ThreadAction)   -- ^ Action to include in the trace.   -> ThreadId   -- ^ The thread receiving the exception.@@ -645,19 +644,19 @@ stepThrow act tid e ctx@Context{..} = case propagate some tid cThreads of     Just ts' -> pure       ( Succeeded ctx { cThreads = ts' }-      , act False+      , act (Just . _masking $ elookup tid ts')       , const (pure ())       )     Nothing       | tid == initialThread -> pure         ( Failed (UncaughtException some)-        , act True+        , act Nothing         , const (pure ())         )       | otherwise -> do           ts' <- kill tid cThreads           pure ( Succeeded ctx { cThreads = ts' }-               , act True+               , act Nothing                , const (pure ())                )   where

@@ -4,7 +4,7 @@  -- | -- Module      : Test.DejaFu.Conc.Internal.Threading--- Copyright   : (c) 2016--2019 Michael Walker+-- Copyright   : (c) 2016--2020 Michael Walker -- License     : MIT -- Maintainer  : Michael Walker <mike@barrucadu.co.uk> -- Stability   : experimental@@ -70,7 +70,7 @@ -- * Exceptions  -- | An exception handler.-data Handler n = forall e. Exception e => Handler (e -> MaskingState -> Action n)+data Handler n = forall e. Exception e => Handler MaskingState (e -> Action n)  -- | Propagate an exception upwards, finding the closest handler -- which can deal with it.@@ -78,10 +78,10 @@ propagate e tid threads = raise <$> propagate' handlers where   handlers = _handlers (elookup tid threads) -  raise (act, hs) = except act hs tid threads+  raise (ms, act, hs) = except ms act hs tid threads    propagate' [] = Nothing-  propagate' (Handler h:hs) = maybe (propagate' hs) (\act -> Just (act, hs)) $ h <$> fromException e+  propagate' (Handler ms h:hs) = maybe (propagate' hs) (\act -> Just (ms, act, hs)) $ h <$> fromException e  -- | Check if a thread can be interrupted by an exception. interruptible :: Thread n -> Bool@@ -93,7 +93,7 @@ catching :: (Exception e, HasCallStack) => (e -> Action n) -> ThreadId -> Threads n -> Threads n catching h = eadjust $ \thread ->   let ms0 = _masking thread-      h'  = Handler $ \e ms -> (if ms /= ms0 then AResetMask False False ms0 else id) (h e)+      h'  = Handler ms0 h   in thread { _handlers = h' : _handlers thread }  -- | Remove the most recent exception handler.@@ -102,9 +102,10 @@   thread { _handlers = etail (_handlers thread) }  -- | Raise an exception in a thread.-except :: HasCallStack => (MaskingState -> Action n) -> [Handler n] -> ThreadId -> Threads n -> Threads n-except actf hs = eadjust $ \thread -> thread-  { _continuation = actf (_masking thread)+except :: HasCallStack => MaskingState -> Action n -> [Handler n] -> ThreadId -> Threads n -> Threads n+except ms act hs = eadjust $ \thread -> thread+  { _continuation = act+  , _masking = ms   , _handlers = hs   , _blocking = Nothing   }

@@ -136,6 +136,7 @@ tvarsWritten :: ThreadAction -> Set TVarId tvarsWritten act = S.fromList $ case act of   STM trc _ -> concatMap tvarsOf' trc+  ThrownSTM trc _ -> concatMap tvarsOf' trc   BlockedSTM trc -> concatMap tvarsOf' trc   _ -> [] @@ -150,6 +151,7 @@ tvarsRead :: ThreadAction -> Set TVarId tvarsRead act = S.fromList $ case act of   STM trc _ -> concatMap tvarsOf' trc+  ThrownSTM trc _ -> concatMap tvarsOf' trc   BlockedSTM trc -> concatMap tvarsOf' trc   _ -> [] @@ -190,6 +192,7 @@ rewind (CasIORef c _) = WillCasIORef c rewind (CommitIORef t c) = WillCommitIORef t c rewind (STM _ _) = WillSTM+rewind (ThrownSTM _ _) = WillSTM rewind (BlockedSTM _) = WillSTM rewind Catching = WillCatching rewind PopCatching = WillPopCatching@@ -374,8 +377,12 @@   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 (Throw Nothing) = M.delete tid+updateMaskState tid (Throw (Just ms)) = M.insert tid ms+updateMaskState tid (ThrownSTM _ Nothing) = M.delete tid+updateMaskState tid (ThrownSTM _ (Just ms)) = M.insert tid ms+updateMaskState _ (ThrowTo tid Nothing) = M.delete tid+updateMaskState _ (ThrowTo tid (Just ms)) = M.insert tid ms updateMaskState tid Stop = M.delete tid updateMaskState _ _ = id 

@@ -5,7 +5,7 @@  -- | -- Module      : Test.DejaFu.SCT.Internal--- Copyright   : (c) 2018--2019 Michael Walker+-- Copyright   : (c) 2018--2020 Michael Walker -- License     : MIT -- Maintainer  : Michael Walker <mike@barrucadu.co.uk> -- Stability   : experimental@@ -399,8 +399,8 @@     (s, CasIORef (renumbered cridmap old) b)   updateAction s@(tidmap, _, _, _) (STM tas olds) =     (s, STM tas (map (renumbered tidmap) olds))-  updateAction s@(tidmap, _, _, _) (ThrowTo old b) =-    (s, ThrowTo (renumbered tidmap old) b)+  updateAction s@(tidmap, _, _, _) (ThrowTo old ms) =+    (s, ThrowTo (renumbered tidmap old) ms)   updateAction s@(tidmap, _, _, _) (BlockedThrowTo old) =     (s, BlockedThrowTo (renumbered tidmap old))   updateAction s act = (s, act)

@@ -5,7 +5,7 @@  -- | -- Module      : Test.DejaFu.SCT.Internal.DPOR--- Copyright   : (c) 2015--2018 Michael Walker+-- Copyright   : (c) 2015--2020 Michael Walker -- License     : MIT -- Maintainer  : Michael Walker <mike@barrucadu.co.uk> -- Stability   : experimental@@ -590,10 +590,15 @@   -- Dependency of STM transactions can be /greatly/ improved here, as   -- the 'Lookahead' does not know which @TVar@s will be touched, and   -- so has to assume all transactions are dependent.-  (STM _ _, STM _ _)           -> checkSTM-  (STM _ _, BlockedSTM _)      -> checkSTM-  (BlockedSTM _, STM _ _)      -> checkSTM-  (BlockedSTM _, BlockedSTM _) -> checkSTM+  (STM _ _, STM _ _)       -> checkSTM+  (STM _ _, BlockedSTM _)  -> checkSTM+  (STM _ _, ThrownSTM _ _) -> checkSTM+  (BlockedSTM _, STM _ _)       -> checkSTM+  (BlockedSTM _, BlockedSTM _)  -> checkSTM+  (BlockedSTM _, ThrownSTM _ _) -> checkSTM+  (ThrownSTM _ _, STM _ _)       -> checkSTM+  (ThrownSTM _ _, BlockedSTM _)  -> checkSTM+  (ThrownSTM _ _, ThrownSTM _ _) -> checkSTM    _ -> dependent' safeIO ds t1 a1 t2 (rewind a2)     && dependent' safeIO ds t2 a2 t1 (rewind a1)@@ -625,6 +630,7 @@   -- Another worst-case: assume all STM is dependent.   (STM _ _, WillSTM) -> True   (BlockedSTM _, WillSTM) -> True+  (ThrownSTM _ _, WillSTM) -> True    -- the number of capabilities is essentially a global shared   -- variable

@@ -289,18 +289,23 @@   | STM [TAction] [ThreadId]   -- ^ An STM transaction was executed, possibly waking up some   -- threads.+  | ThrownSTM [TAction] (Maybe MaskingState)+  -- ^ An STM transaction threw an exception.  Give the resultant+  -- masking state after jumping to the exception handler (if the+  -- thread is still alive).   | BlockedSTM [TAction]   -- ^ Got blocked in an STM transaction.   | Catching   -- ^ Register a new exception handler   | PopCatching   -- ^ Pop the innermost exception handler from the stack.-  | 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.+  | Throw (Maybe MaskingState)+  -- ^ Throw an exception, and give the resultant masking state after+  -- jumping to the exception handler (if the thread is still alive).+  | ThrowTo ThreadId (Maybe MaskingState)+  -- ^ Throw an exception to a thread, and give the resultant masking+  -- state after jumping to the exception handler (if the thread is+  -- still alive).   | BlockedThrowTo ThreadId   -- ^ Get blocked on a 'throwTo'.   | SetMasking Bool MaskingState@@ -354,11 +359,15 @@   rnf (CasIORef c b) = rnf (c, b)   rnf (CommitIORef t c) = rnf (t, c)   rnf (STM as ts) = rnf (as, ts)+  rnf (ThrownSTM as (Just m)) = m `seq` rnf as+  rnf (ThrownSTM as Nothing) = rnf as   rnf (BlockedSTM as) = rnf as   rnf Catching = ()   rnf PopCatching = ()-  rnf (Throw b) = rnf b-  rnf (ThrowTo t b) = rnf (t, b)+  rnf (Throw (Just m)) = m `seq` ()+  rnf (Throw Nothing) = ()+  rnf (ThrowTo t (Just m)) = m `seq` rnf t+  rnf (ThrowTo t Nothing) = rnf t   rnf (BlockedThrowTo t) = rnf t   rnf (SetMasking b m) = rnf (b, show m)   rnf (ResetMasking b m) = rnf (b, show m)

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                dejafu-version:             2.3.0.1+version:             2.4.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-2.3.0.1+  tag:      dejafu-2.4.0.0  library   exposed-modules:     Test.DejaFu