Commit 75736ff2 authored by Simon Marlow's avatar Simon Marlow

adapt to the new async exceptions API

parent dc6ba4ba
......@@ -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
......
......@@ -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
......
......@@ -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
......
{-# 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
......
......@@ -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,9 +207,12 @@ 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
gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
gblock = Haskeline.block
gunblock = Haskeline.unblock
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment