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)
-> [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
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
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
-- 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,
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
-- 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'.
-- 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))
# 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
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
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
projects / ghc-hetmet.git / commitdiff