throwSTM+catchSTM pollutes the masking state

The following program prints "(Unmasked,MaskedUninterruptible)"

{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Exception
import Control.Concurrent.STM
import GHC.Conc (STM(..))
import GHC.Prim (getMaskingState#)

getMaskingStateSTM = STM $ \s → case getMaskingState# s of
 (# s', i #) -> (# s', case i of 0# → Unmasked
                                 1# → MaskedUninterruptible
                                 _  → MaskedInterruptible #)

main = do
  mss ← atomically $ do
    ms1 ← getMaskingStateSTM
    (throwSTM Overflow) `catchSTM` (\(e ∷ SomeException) → return ())
    ms2 ← getMaskingStateSTM
    return (ms1, ms2)
  putStrLn $ show mss

I would be nice to have (un)maskAsyncExceptions+retry supported too, currenly

maskSTM (STM stm) = STM $ maskAsyncExceptions# stm

main = do
  mss ← atomically $ do
    ms1 ← getMaskingStateSTM
    maskSTM retry `orElse` return ()
    ms2 ← getMaskingStateSTM
    return (ms1, ms2)
  putStrLn $ show mss

prints "(Unmasked,MaskedInterruptible)"

Trac metadata

Trac field	Value
Version	7.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Runtime System
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system
Architecture