import Type hiding (typeKind)
import TcType hiding (typeKind)
import InstEnv
-import Var hiding (setIdType)
+import Var
import Id
import IdInfo
import Name hiding ( varName )
import Foreign.C
import GHC.Exts
import Data.Array
-import Control.Exception as Exception
+import Exception
import Control.Concurrent
import Data.List (sortBy)
import Data.IORef
data RunResult
= RunOk [Name] -- ^ names bound by this evaluation
| RunFailed -- ^ statement failed compilation
- | RunException Exception -- ^ statement raised an exception
+ | RunException SomeException -- ^ statement raised an exception
| RunBreak ThreadId [Name] (Maybe BreakInfo)
data Status
= Break Bool HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint (Bool <=> was an exception)
- | Complete (Either Exception [HValue])
+ | Complete (Either SomeException [HValue])
-- ^ the computation completed with either an exception or a value
data Resume
-- not "Interrupted", we unset the exception flag before throwing.
--
rethrow :: DynFlags -> IO a -> IO a
+#if __GLASGOW_HASKELL__ < 609
rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
case e of
-- If -fbreak-on-error, we break unconditionally,
_ -> poke exceptionFlag 0
Exception.throwIO e
-
+#else
+rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
+ -- If -fbreak-on-error, we break unconditionally,
+ -- but with care of not breaking twice
+ if dopt Opt_BreakOnError dflags &&
+ not (dopt Opt_BreakOnException dflags)
+ then poke exceptionFlag 1
+ else case cast e of
+ -- If it is an "Interrupted" exception, we allow
+ -- a possible break by way of -fbreak-on-exception
+ Just Interrupted -> return ()
+ -- In any other case, we don't want to break
+ _ -> poke exceptionFlag 0
+
+ Exception.throwIO se
+#endif
withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do
resume = ic_resume ic
case resume of
- [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+ [] -> ghcError (ProgramError "not stopped at a breakpoint")
(r:rs) -> do
-- unbind the temporary locals by restoring the TypeEnv from
-- before the breakpoint, and drop this Resume from the
moveHist fn (Session ref) = do
hsc_env <- readIORef ref
case ic_resume (hsc_IC hsc_env) of
- [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+ [] -> ghcError (ProgramError "not stopped at a breakpoint")
(r:rs) -> do
let ix = resumeHistoryIx r
history = resumeHistory r
new_ix = fn ix
--
when (new_ix > length history) $
- throwDyn (ProgramError "no more logged breakpoints")
+ ghcError (ProgramError "no more logged breakpoints")
when (new_ix < 0) $
- throwDyn (ProgramError "already at the beginning of the history")
+ ghcError (ProgramError "already at the beginning of the history")
let
update_ic apStack mb_info = do
let exn_fs = fsLit "_exception"
exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
e_fs = fsLit "e"
- e_name = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
+ e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
vanillaIdInfo
mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
mkTopLevEnv hpt modl
= case lookupUFM hpt (moduleName modl) of
- Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
+ Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++
showSDoc (ppr modl)))
Just details ->
case mi_globals (hm_iface details) of
Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
+ ghcError (ProgramError ("mkTopLevEnv: not interpreted "
++ showSDoc (ppr modl)))
Just env -> return env
getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
return (ic_toplev_scope ic, ic_exports ic))
--- | Returns 'True' if the specified module is interpreted, and hence has
+-- | Returns @True@ if the specified module is interpreted, and hence has
-- its full top-level scope available.
moduleIsInterpreted :: Session -> Module -> IO Bool
moduleIsInterpreted s modl = withSession s $ \h ->