Add MonadCatch instance for STM

- Add MonadCatch, MonadMask and Exception.MonadCatch interface for the
  STM.
- Add relevant entries for the StmA DSL.

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

@@ -22,7 +22,7 @@ newtype TQueueDefault m a = TQueue (TVar m ([a], [a]))
 labelTQueueDefault
   :: MonadLabelledSTM m
   => TQueueDefault m a -> String -> STM m ()
-labelTQueueDefault (TQueue queue) label =  labelTVar queue label
+labelTQueueDefault (TQueue queue) =  labelTVar queue
 
 traceTQueueDefault
   :: MonadTraceSTM m

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

@@ -175,6 +175,7 @@ runSTM (STM k) = k ReturnStm
 data StmA s a where
   ReturnStm    :: a -> StmA s a
   ThrowStm     :: SomeException -> StmA s a
+  CatchStm     :: Exception e => StmA s a -> (e -> StmA s a) -> (a -> StmA s b) -> StmA s b
 
   NewTVar      :: Maybe String -> x -> (TVar s x -> StmA s b) -> StmA s b
   LabelTVar    :: String -> TVar s a -> StmA s b -> StmA s b
@@ -190,6 +191,9 @@ data StmA s a where
                -> (Maybe a -> a -> ST s TraceValue)
                -> StmA s b -> StmA s b
 
+  SetMaskStateStm :: MaskingState -> STM s a -> (a -> StmA s b) -> StmA s b
+  GetMaskStateStm :: (MaskingState -> StmA s b) -> StmA s b
+
 -- Exported type
 type STMSim = STM
 
@@ -313,6 +317,38 @@ instance MonadThrow (STM s) where
 instance Exceptions.MonadThrow (STM s) where
   throwM = MonadThrow.throwIO
 
+instance MonadCatch (STM s) where
+    catch action handler =
+        STM $ oneShot $ \k -> CatchStm (runSTM action) (runSTM . handler) k
+
+
+getMaskingStateStmImpl :: STM s MaskingState
+unblockStm, blockStm, blockUninterruptibleStm :: STM s a -> STM s a
+
+getMaskingStateStmImpl    = STM GetMaskStateStm
+unblockStm              a = STM (SetMaskStateStm Unmasked a)
+blockStm                a = STM (SetMaskStateStm MaskedInterruptible a)
+blockUninterruptibleStm a = STM (SetMaskStateStm MaskedUninterruptible a)
+
+
+instance MonadMask (STM s) where
+    mask action = do
+      b <- getMaskingStateStmImpl
+      case b of
+        Unmasked              -> blockStm $ action unblockStm
+        MaskedInterruptible   -> action blockStm
+        MaskedUninterruptible -> action blockUninterruptibleStm
+
+    uninterruptibleMask action = do
+      b <- getMaskingStateStmImpl
+      case b of
+        Unmasked              -> blockUninterruptibleStm $ action unblockStm
+        MaskedInterruptible   -> blockUninterruptibleStm $ action blockStm
+        MaskedUninterruptible -> action blockUninterruptibleStm
+
+instance Exceptions.MonadCatch (STM s) where
+    catch = MonadThrow.catch
+
 instance MonadCatch (IOSim s) where
   catch action handler =
     IOSim $ oneShot $ \k -> Catch (runIOSim action) (runIOSim . handler) k

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

@@ -1212,6 +1212,18 @@ execAtomically time tid tlbl nextVid0 action0 k0 =
         -- TODO: step
         return $ SimPORTrace time tid (-1) tlbl (EventLog x) trace
 
+      CatchStm action' handler k ->
+        {-# SCC "execAtomically.go.CatchStm" #-} do
+        undefined
+
+      GetMaskStateStm x ->
+        {-# SCC "execAtomically.go.GetMaskStateStm" #-} do
+        undefined
+
+      SetMaskStateStm x m k ->
+        {-# SCC "execAtomically.go.SetMaskStateStm" #-} do
+        undefined
+
       where
         localInvariant =
             Map.keysSet written