Merge #3437

3437: MonadMaskingState r=coot a=coot

- io-sim: do not arbitrary set masking state in `Throw` or `ThrowTo`
- io-classes: `MonadMaskingState`
- io-sim: introduce various test for the masking state

Related to #3436



Co-authored-by: Marcin Szamotulski <[email protected]>

Author: iohk-bors[bot]

io-classes/src/Control/Monad/Class/MonadThrow.hs

@@ -10,7 +10,9 @@ module Control.Monad.Class.MonadThrow
   ( MonadThrow(..)
   , MonadCatch(..)
   , MonadMask(..)
+  , MonadMaskingState(..)
   , MonadEvaluate(..)
+  , MaskingState(..)
   , Exception(..)
   , SomeException
   , ExitCase(..)
@@ -20,7 +22,7 @@ module Control.Monad.Class.MonadThrow
   , throwM
   ) where
 
-import           Control.Exception (Exception (..), SomeException)
+import           Control.Exception (Exception (..), MaskingState, SomeException)
 import qualified Control.Exception as IO
 import           Control.Monad (liftM)
 import           Control.Monad.Except (ExceptT (..), lift, runExceptT)
@@ -183,6 +185,9 @@ class MonadCatch m => MonadMask m where
   uninterruptibleMask_ action = uninterruptibleMask $ \_ -> action
 
 
+class MonadMask m => MonadMaskingState m where
+  getMaskingState :: m MaskingState
+
 -- | Monads which can 'evaluate'.
 --
 class MonadThrow m => MonadEvaluate m where
@@ -223,6 +228,9 @@ instance MonadMask IO where
   uninterruptibleMask  = IO.uninterruptibleMask
   uninterruptibleMask_ = IO.uninterruptibleMask_
 
+instance MonadMaskingState IO where
+  getMaskingState = IO.getMaskingState
+
 instance MonadEvaluate IO where
   evaluate = IO.evaluate
 

io-sim/src/Control/Monad/IOSim/Internal.hs

@@ -97,7 +97,8 @@ import           Control.Monad.Class.MonadSay
 import           Control.Monad.Class.MonadST
 import           Control.Monad.Class.MonadSTM hiding (STM, TVar)
 import qualified Control.Monad.Class.MonadSTM as MonadSTM
-import           Control.Monad.Class.MonadThrow as MonadThrow
+import           Control.Monad.Class.MonadThrow hiding (getMaskingState)
+import qualified Control.Monad.Class.MonadThrow as MonadThrow
 import           Control.Monad.Class.MonadTime
 import           Control.Monad.Class.MonadTimer
 
@@ -174,9 +175,6 @@ type STMSim = STM
 type SimSTM = STM
 {-# DEPRECATED SimSTM "Use STMSim" #-}
 
-data MaskingState = Unmasked | MaskedInterruptible | MaskedUninterruptible
-  deriving (Eq, Ord, Show)
-
 --
 -- Monad class instances
 --
@@ -300,19 +298,22 @@ instance Exceptions.MonadCatch (IOSim s) where
 
 instance MonadMask (IOSim s) where
   mask action = do
-      b <- getMaskingState
+      b <- getMaskingStateImpl
       case b of
         Unmasked              -> block $ action unblock
         MaskedInterruptible   -> action block
         MaskedUninterruptible -> action blockUninterruptible
 
   uninterruptibleMask action = do
-      b <- getMaskingState
+      b <- getMaskingStateImpl
       case b of
         Unmasked              -> blockUninterruptible $ action unblock
         MaskedInterruptible   -> blockUninterruptible $ action block
         MaskedUninterruptible -> action blockUninterruptible
 
+instance MonadMaskingState (IOSim s) where
+    getMaskingState = getMaskingStateImpl
+
 instance Exceptions.MonadMask (IOSim s) where
   mask                = MonadThrow.mask
   uninterruptibleMask = MonadThrow.uninterruptibleMask
@@ -327,10 +328,10 @@ instance Exceptions.MonadMask (IOSim s) where
       return (b, c)
 
 
-getMaskingState :: IOSim s MaskingState
+getMaskingStateImpl :: IOSim s MaskingState
 unblock, block, blockUninterruptible :: IOSim s a -> IOSim s a
 
-getMaskingState        = IOSim  GetMaskState
+getMaskingStateImpl    = IOSim  GetMaskState
 unblock              a = IOSim (SetMaskState Unmasked a)
 block                a = IOSim (SetMaskState MaskedInterruptible a)
 blockUninterruptible a = IOSim (SetMaskState MaskedUninterruptible a)
@@ -1064,8 +1065,7 @@ schedule thread@Thread{
     ThrowTo e tid' _ | tid' == tid -> do
       -- Throw to ourself is equivalent to a synchronous throw,
       -- and works irrespective of masking state since it does not block.
-      let thread' = thread { threadControl = ThreadControl (Throw e) ctl
-                           , threadMasking = MaskedInterruptible }
+      let thread' = thread { threadControl = ThreadControl (Throw e) ctl }
       trace <- schedule thread' simstate
       return (SimTrace time tid tlbl (EventThrowTo e tid) trace)
 
@@ -1096,7 +1096,7 @@ schedule thread@Thread{
           let adjustTarget t@Thread{ threadControl = ThreadControl _ ctl' } =
                 t { threadControl = ThreadControl (Throw e) ctl'
                   , threadBlocked = False
-                  , threadMasking = MaskedInterruptible }
+                  }
               simstate'@SimState { threads = threads' }
                          = snd (unblockThreads [tid'] simstate)
               threads''  = Map.adjust adjustTarget tid' threads'
@@ -1290,9 +1290,13 @@ unwindControlStack e thread =
                       -- As per async exception rules, the handler is run masked
                      threadControl = ThreadControl (handler e')
                                                    (MaskFrame k maskst ctl),
-                     threadMasking = max maskst MaskedInterruptible
+                     threadMasking = atLeastInterruptibleMask maskst
                    }
 
+    atLeastInterruptibleMask :: MaskingState -> MaskingState
+    atLeastInterruptibleMask Unmasked = MaskedInterruptible
+    atLeastInterruptibleMask ms       = ms
+
 
 removeMinimums :: (Ord k, Ord p)
                => OrdPSQ k p a