adapt to the new async exceptions API

4 files changed, 53 insertions, 20 deletions

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 6f3a99fb85..ebdeb327ad 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -692,7 +692,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
 linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
             -> IO (PersistentLinkerState, SuccessFlag)
 linkModules dflags pls linkables
-  = block $ do  -- don't want to be interrupted by ^C in here
+  = mask_ $ do  -- don't want to be interrupted by ^C in here
 	
 	let (objs, bcos) = partition isObjectLinkable 
                               (concatMap partitionLinkable linkables)
@@ -862,7 +862,7 @@ unload :: DynFlags
        -> [Linkable] -- ^ The linkables to *keep*.
        -> IO ()
 unload dflags linkables
-  = block $ do -- block, so we're safe from Ctrl-C in here
+  = mask_ $ do -- mask, so we're safe from Ctrl-C in here
   
 	-- Initialise the linker (if it's not been done already)
 	initDynLinker dflags
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index d5ded92905..156a04e0a6 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -325,6 +325,12 @@ instance ExceptionMonad Ghc where
       Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
   gblock (Ghc m)   = Ghc $ \s -> gblock (m s)
   gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
+  gmask f =
+      Ghc $ \s -> gmask $ \io_restore ->
+                             let
+                                g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
+                             in
+                                unGhc (f g_restore) s
 
 instance WarnLogMonad Ghc where
   setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
@@ -357,6 +363,12 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where
       GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
   gblock (GhcT m) = GhcT $ \s -> gblock (m s)
   gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
+  gmask f =
+      GhcT $ \s -> gmask $ \io_restore ->
+                           let
+                              g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
+                           in
+                              unGhcT (f g_restore) s
 
 instance MonadIO m => WarnLogMonad (GhcT m) where
   setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index db1fd418c6..9afd1ac90f 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -359,13 +359,13 @@ foreign import ccall "&rts_breakpoint_io_action"
 -- is not responding".
 -- 
 -- Careful here: there may be ^C exceptions flying around, so we start the new
--- thread blocked (forkIO inherits block from the parent, #1048), and unblock
+-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
 -- only while we execute the user's code.  We can't afford to lose the final
 -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
 sandboxIO dflags statusMVar thing =
-   block $ do  -- fork starts blocked
-     id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing)
+   mask $ \restore -> do  -- fork starts blocked
+     id <- forkIO $ do res <- Exception.try (restore $ rethrow dflags thing)
                        putMVar statusMVar (Complete res) -- empty: can't block
      withInterruptsSentTo id $ takeMVar statusMVar
 
diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs
index 63d61216a9..de7863454a 100644
--- a/compiler/utils/Exception.hs
+++ b/compiler/utils/Exception.hs
@@ -1,4 +1,4 @@
-
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
 module Exception
     (
     module Control.Exception,
@@ -10,6 +10,11 @@ import Prelude hiding (catch)
 
 import Control.Exception
 
+#if __GLASGOW_HASKELL__ < 613
+mask_ :: ((IO a -> IO a) -> IO b) -> IO b
+mask_ f = block (f unblock)
+#endif
+
 catchIO :: IO a -> (IOException -> IO a) -> IO a
 catchIO = catch
 
@@ -35,13 +40,9 @@ class Monad m => ExceptionMonad m where
   -- exception handling monad instead of just 'IO'.
   gcatch :: Exception e => m a -> (e -> m a) -> m a
 
-  -- | Generalised version of 'Control.Exception.block', allowing an arbitrary
+  -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary
   -- exception handling monad instead of just 'IO'.
-  gblock :: m a -> m a
-
-  -- | Generalised version of 'Control.Exception.unblock', allowing an
-  -- arbitrary exception handling monad instead of just 'IO'.
-  gunblock :: m a -> m a
+  gmask :: ((m a -> m a) -> m b) -> m b
 
   -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary
   -- exception handling monad instead of just 'IO'.
@@ -51,26 +52,46 @@ class Monad m => ExceptionMonad m where
   -- exception handling monad instead of just 'IO'.
   gfinally :: m a -> m b -> m a
 
-  gblock = id
-  gunblock = id
+  -- | DEPRECATED, here for backwards compatibilty.  Instances can
+  -- define either 'gmask', or both 'block' and 'unblock'.
+  gblock   :: m a -> m a
+  -- | DEPRECATED, here for backwards compatibilty  Instances can
+  -- define either 'gmask', or both 'block' and 'unblock'.
+  gunblock :: m a -> m a
+  -- XXX we're keeping these two methods for the time being because we
+  -- have to interact with Haskeline's MonadException class which
+  -- still has block/unblock; see GhciMonad.hs.
+
+  gmask    f = gblock (f gunblock)
+  gblock   f = gmask (\_ -> f)
+  gunblock f = f -- XXX wrong; better override this if you need it
 
   gbracket before after thing =
-    gblock (do
+    gmask $ \restore -> do
       a <- before
-      r <- gunblock (thing a) `gonException` after a
+      r <- restore (thing a) `gonException` after a
       _ <- after a
-      return r)
+      return r
 
   a `gfinally` sequel =
-    gblock (do
-      r <- gunblock a `gonException` sequel
+    gmask $ \restore -> do
+      r <- restore a `gonException` sequel
       _ <- sequel
-      return r)
+      return r
 
+#if __GLASGOW_HASKELL__ < 613
+instance ExceptionMonad IO where
+  gcatch    = catch
+  gmask f   = block $ f unblock
+  gblock    = block
+  gunblock  = unblock
+#else
 instance ExceptionMonad IO where
   gcatch    = catch
+  gmask f   = mask (\x -> f x)
   gblock    = block
   gunblock  = unblock
+#endif
 
 gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
 gtry act = gcatch (act >>= \a -> return (Right a))