Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
75736ff2
Commit
75736ff2
authored
Jul 09, 2010
by
Simon Marlow
Browse files
adapt to the new async exceptions API
parent
dc6ba4ba
Changes
6
Hide whitespace changes
Inline
Side-by-side
compiler/ghci/Linker.lhs
View file @
75736ff2
...
...
@@ -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 --
bloc
k, so we're safe from Ctrl-C in here
=
mask_
$ do --
mas
k, so we're safe from Ctrl-C in here
-- Initialise the linker (if it's not been done already)
initDynLinker dflags
...
...
compiler/main/HscTypes.lhs
View file @
75736ff2
...
...
@@ -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
...
...
compiler/main/InteractiveEval.hs
View file @
75736ff2
...
...
@@ -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
bloc
k from the parent, #1048), and unblock
-- thread blocked (forkIO inherits
mas
k 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
...
...
compiler/utils/Exception.hs
View file @
75736ff2
{-# 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
=
g
block
(
do
g
mask
$
\
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
=
g
block
(
do
r
<-
gunblock
a
`
gonException
`
sequel
g
mask
$
\
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
))
...
...
ghc.mk
View file @
75736ff2
...
...
@@ -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
...
...
ghc/GhciMonad.hs
View file @
75736ff2
...
...
@@ -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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment