X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=4fc295bbe465478f48855129dfd67eb445601686;hb=81466110ff8104ca60e20d617bab83f6f78f0ec2;hp=42d27987e97828b09572e09af5da100beeb4ee8d;hpb=569dbeee1d922120ebb52ffd9487683bf7912ebd;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 42d2798..4fc295b 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -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 @@ -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 @@ -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