X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=8c542c3abc7dbbe607e4954d17a010e3aead604a;hb=0da51cdd6404332ba6531364e6b7de30cbc0333a;hp=96e0b3484acda8667fc55e9f4b30759dd5874ddf;hpb=a700f4ed45ddb3a5d16aee62b11febf721c915cc;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 96e0b34..8c542c3 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -37,13 +37,15 @@ module InteractiveEval ( #ifdef GHCI +#include "HsVersions.h" + import HscMain hiding (compileExpr) import HscTypes import TcRnDriver import Type hiding (typeKind) import TcType hiding (typeKind) import InstEnv -import Var hiding (setIdType) +import Var import Id import IdInfo import Name hiding ( varName ) @@ -76,7 +78,7 @@ import Foreign 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 @@ -88,13 +90,13 @@ import Foreign.StablePtr 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 @@ -315,11 +317,10 @@ foreign import ccall "&rts_breakpoint_io_action" -- thread doesn't die when it receives the exception... "this thread -- 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 only while we execute the user's code. We --- can't afford to lose the final putMVar, otherwise deadlock --- ensues. (#1583, #1922, #1946) +-- 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 +-- 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 @@ -337,6 +338,7 @@ sandboxIO dflags statusMVar thing = -- 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, @@ -354,7 +356,22 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn _ -> 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 @@ -406,7 +423,7 @@ resume (Session ref) step 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 @@ -457,16 +474,16 @@ moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan) 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 @@ -511,7 +528,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = 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 @@ -774,12 +791,12 @@ vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] 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 @@ -790,7 +807,7 @@ getContext :: Session -> IO ([Module],[Module]) 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 -> @@ -808,12 +825,12 @@ moduleIsInterpreted s modl = withSession s $ \h -> getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) getInfo s name = withSession s $ \hsc_env -> - do { mb_stuff <- tcRnGetInfo hsc_env name - ; case mb_stuff of - Nothing -> return Nothing - Just (thing, fixity, ispecs) -> do - { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) - ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } } + do mb_stuff <- tcRnGetInfo hsc_env name + case mb_stuff of + Nothing -> return Nothing + Just (thing, fixity, ispecs) -> do + let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) + return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) where plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec