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 ...@@ -692,7 +692,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
linkModules :: DynFlags -> PersistentLinkerState -> [Linkable] linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
-> IO (PersistentLinkerState, SuccessFlag) -> IO (PersistentLinkerState, SuccessFlag)
linkModules dflags pls linkables 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 let (objs, bcos) = partition isObjectLinkable
(concatMap partitionLinkable linkables) (concatMap partitionLinkable linkables)
...@@ -862,7 +862,7 @@ unload :: DynFlags ...@@ -862,7 +862,7 @@ unload :: DynFlags
-> [Linkable] -- ^ The linkables to *keep*. -> [Linkable] -- ^ The linkables to *keep*.
-> IO () -> IO ()
unload dflags linkables 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) -- Initialise the linker (if it's not been done already)
initDynLinker dflags initDynLinker dflags
......
...@@ -325,6 +325,12 @@ instance ExceptionMonad Ghc where ...@@ -325,6 +325,12 @@ instance ExceptionMonad Ghc where
Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
gblock (Ghc m) = Ghc $ \s -> gblock (m s) gblock (Ghc m) = Ghc $ \s -> gblock (m s)
gunblock (Ghc m) = Ghc $ \s -> gunblock (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 instance WarnLogMonad Ghc where
setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
...@@ -357,6 +363,12 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where ...@@ -357,6 +363,12 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where
GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
gblock (GhcT m) = GhcT $ \s -> gblock (m s) gblock (GhcT m) = GhcT $ \s -> gblock (m s)
gunblock (GhcT m) = GhcT $ \s -> gunblock (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 instance MonadIO m => WarnLogMonad (GhcT m) where
setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
......
...@@ -359,13 +359,13 @@ foreign import ccall "&rts_breakpoint_io_action" ...@@ -359,13 +359,13 @@ foreign import ccall "&rts_breakpoint_io_action"
-- is not responding". -- is not responding".
-- --
-- Careful here: there may be ^C exceptions flying around, so we start the new -- 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 -- only while we execute the user's code. We can't afford to lose the final
-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946) -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
sandboxIO dflags statusMVar thing = sandboxIO dflags statusMVar thing =
block $ do -- fork starts blocked mask $ \restore -> do -- fork starts blocked
id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing) id <- forkIO $ do res <- Exception.try (restore $ rethrow dflags thing)
putMVar statusMVar (Complete res) -- empty: can't block putMVar statusMVar (Complete res) -- empty: can't block
withInterruptsSentTo id $ takeMVar statusMVar withInterruptsSentTo id $ takeMVar statusMVar
......
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Exception module Exception
( (
module Control.Exception, module Control.Exception,
...@@ -10,6 +10,11 @@ import Prelude hiding (catch) ...@@ -10,6 +10,11 @@ import Prelude hiding (catch)
import Control.Exception 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 :: IO a -> (IOException -> IO a) -> IO a
catchIO = catch catchIO = catch
...@@ -35,13 +40,9 @@ class Monad m => ExceptionMonad m where ...@@ -35,13 +40,9 @@ class Monad m => ExceptionMonad m where
-- exception handling monad instead of just 'IO'. -- exception handling monad instead of just 'IO'.
gcatch :: Exception e => m a -> (e -> m a) -> m a 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'. -- exception handling monad instead of just 'IO'.
gblock :: m a -> m a gmask :: ((m a -> m a) -> m b) -> m b
-- | Generalised version of 'Control.Exception.unblock', allowing an
-- arbitrary exception handling monad instead of just 'IO'.
gunblock :: m a -> m a
-- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary
-- exception handling monad instead of just 'IO'. -- exception handling monad instead of just 'IO'.
...@@ -51,26 +52,46 @@ class Monad m => ExceptionMonad m where ...@@ -51,26 +52,46 @@ class Monad m => ExceptionMonad m where
-- exception handling monad instead of just 'IO'. -- exception handling monad instead of just 'IO'.
gfinally :: m a -> m b -> m a gfinally :: m a -> m b -> m a
gblock = id -- | DEPRECATED, here for backwards compatibilty. Instances can
gunblock = id -- 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 = gbracket before after thing =
gblock (do gmask $ \restore -> do
a <- before a <- before
r <- gunblock (thing a) `gonException` after a r <- restore (thing a) `gonException` after a
_ <- after a _ <- after a
return r) return r
a `gfinally` sequel = a `gfinally` sequel =
gblock (do gmask $ \restore -> do
r <- gunblock a `gonException` sequel r <- restore a `gonException` sequel
_ <- 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 instance ExceptionMonad IO where
gcatch = catch gcatch = catch
gmask f = mask (\x -> f x)
gblock = block gblock = block
gunblock = unblock gunblock = unblock
#endif
gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
gtry act = gcatch (act >>= \a -> return (Right a)) gtry act = gcatch (act >>= \a -> return (Right a))
......
...@@ -659,6 +659,9 @@ libraries/binary_dist-boot_HC_OPTS += -Wwarn ...@@ -659,6 +659,9 @@ libraries/binary_dist-boot_HC_OPTS += -Wwarn
# XXX hack: xhtml has warnings # XXX hack: xhtml has warnings
libraries/xhtml_dist-install_HC_OPTS += -Wwarn 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 # A useful pseudo-target
.PHONY: stage1_libs .PHONY: stage1_libs
......
...@@ -189,6 +189,12 @@ instance ExceptionMonad GHCi where ...@@ -189,6 +189,12 @@ instance ExceptionMonad GHCi where
gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
gblock (GHCi m) = GHCi $ \r -> gblock (m r) gblock (GHCi m) = GHCi $ \r -> gblock (m r)
gunblock (GHCi m) = GHCi $ \r -> gunblock (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 instance WarnLogMonad GHCi where
setWarnings warns = liftGhc $ setWarnings warns setWarnings warns = liftGhc $ setWarnings warns
...@@ -201,11 +207,14 @@ instance Haskeline.MonadException GHCi where ...@@ -201,11 +207,14 @@ instance Haskeline.MonadException GHCi where
catch = gcatch catch = gcatch
block = gblock block = gblock
unblock = gunblock unblock = gunblock
-- XXX when Haskeline's MonadException changes, we can drop our
-- deprecated block/unblock methods
instance ExceptionMonad (InputT GHCi) where instance ExceptionMonad (InputT GHCi) where
gcatch = Haskeline.catch gcatch = Haskeline.catch
gblock = Haskeline.block gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
gunblock = Haskeline.unblock gblock = Haskeline.block
gunblock = Haskeline.unblock
-- for convenience... -- for convenience...
getPrelude :: GHCi Module getPrelude :: GHCi Module
......
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