X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=8c542c3abc7dbbe607e4954d17a010e3aead604a;hb=0da51cdd6404332ba6531364e6b7de30cbc0333a;hp=4388c0b6bb8771f89fd55a9e628e495f31ebb97f;hpb=e314b86f6290e5440a46cd5cc29f7878cb78c6fb;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 4388c0b..8c542c3 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -45,7 +45,7 @@ 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 ) @@ -78,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 @@ -90,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 @@ -317,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 @@ -339,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, @@ -356,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 @@ -408,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 @@ -459,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 @@ -497,7 +512,7 @@ moveHist fn (Session ref) = do -- ----------------------------------------------------------------------------- -- After stopping at a breakpoint, add free variables to the environment result_fs :: FastString -result_fs = FSLIT("_result") +result_fs = fsLit "_result" bindLocalsAtBreakpoint :: HscEnv @@ -510,10 +525,10 @@ bindLocalsAtBreakpoint -- bind, all we can do is bind a local variable to the exception -- value. bindLocalsAtBreakpoint hsc_env apStack Nothing = do - let exn_fs = FSLIT("_exception") + 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_fs = fsLit "e" + 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 @@ -522,7 +537,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContext ictxt0 [exn_id] new_tyvars - span = mkGeneralSrcSpan FSLIT("") + span = mkGeneralSrcSpan (fsLit "") -- Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span) @@ -776,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 @@ -792,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 -> @@ -810,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