diff options
| -rw-r--r-- | compiler/ghci/Linker.lhs | 4 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 12 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 6 | ||||
| -rw-r--r-- | compiler/utils/Exception.hs | 51 | ||||
| -rw-r--r-- | ghc.mk | 3 | ||||
| -rw-r--r-- | ghc/GhciMonad.hs | 15 |
6 files changed, 68 insertions, 23 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)) @@ -659,6 +659,9 @@ libraries/binary_dist-boot_HC_OPTS += -Wwarn # XXX hack: xhtml has warnings libraries/xhtml_dist-install_HC_OPTS += -Wwarn +# XXX hack: haskeline has warnings about deprecated use of block/unblock +libraries/haskeline_dist-install_HC_OPTS += -Wwarn + # ---------------------------------------------- # A useful pseudo-target .PHONY: stage1_libs diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index f1859d7d07..5494b4ea4c 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -189,6 +189,12 @@ instance ExceptionMonad GHCi where gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) gblock (GHCi m) = GHCi $ \r -> gblock (m r) gunblock (GHCi m) = GHCi $ \r -> gunblock (m r) + gmask f = + GHCi $ \s -> gmask $ \io_restore -> + let + g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s') + in + unGHCi (f g_restore) s instance WarnLogMonad GHCi where setWarnings warns = liftGhc $ setWarnings warns @@ -201,11 +207,14 @@ instance Haskeline.MonadException GHCi where catch = gcatch block = gblock unblock = gunblock + -- XXX when Haskeline's MonadException changes, we can drop our + -- deprecated block/unblock methods instance ExceptionMonad (InputT GHCi) where - gcatch = Haskeline.catch - gblock = Haskeline.block - gunblock = Haskeline.unblock + gcatch = Haskeline.catch + gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong + gblock = Haskeline.block + gunblock = Haskeline.unblock -- for convenience... getPrelude :: GHCi Module |