From: Pepe Iborra Date: Sat, 6 Jan 2007 10:05:09 +0000 (+0000) Subject: Reload modules after ':break stop' X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c78721146b8b2b181e2fccb3a65a366eef85345e Reload modules after ':break stop' This is necessary to revert CAFs. Previously to this patch the user would get a msg "You may need to reload your modules". This patch takes care of that --- diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index df588aa..d95fc59 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -118,69 +118,16 @@ showForUser doc = do unqual <- io (GHC.getPrintUnqual session) return $! showSDocForUser unqual doc ------------------------------------------------------------------------------ --- User code exception handling +-- -------------------------------------------------------------------------- +-- Inferior Sessions Exceptions (used by the debugger) --- This hierarchy of exceptions is used to signal interruption of a child session -data BkptException = StopChildSession -- A child debugging session requests to be stopped - | ChildSessionStopped String +data InfSessionException = + StopChildSession -- A child session requests to be stopped + | ChildSessionStopped String -- A child session has stopped deriving Typeable --- This is the exception handler for exceptions generated by the --- user's code and exceptions coming from children sessions; --- it normally just prints out the exception. The --- handler must be recursive, in case showing the exception causes --- more exceptions to be raised. --- --- Bugfix: if the user closed stdout or stderr, the flushing will fail, --- raising another exception. We therefore don't put the recursive --- handler arond the flushing operation, so if stderr is closed --- GHCi will just die gracefully rather than going into an infinite loop. -handler :: Exception -> GHCi Bool -handler (DynException dyn) - | Just StopChildSession <- fromDynamic dyn - -- propagate to the parent session - = do ASSERTM (liftM not isTopLevel) - throwDyn StopChildSession - - | Just (ChildSessionStopped msg) <- fromDynamic dyn - -- Revert CAFs and display some message - = do ASSERTM (isTopLevel) - io (revertCAFs >> putStrLn msg) - return False - -handler exception = do - flushInterpBuffers - io installSignalHandlers - ghciHandle handler (showException exception >> return False) - -showException (DynException dyn) = - case fromDynamic dyn of - Nothing -> io (putStrLn ("*** Exception: (unknown)")) - Just Interrupted -> io (putStrLn "Interrupted.") - Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError - Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto - Just other_ghc_ex -> io (print other_ghc_ex) - -showException other_exception - = io (putStrLn ("*** Exception: " ++ show other_exception)) - ------------------------------------------------------------------------------ --- recursive exception handlers - --- Don't forget to unblock async exceptions in the handler, or if we're --- in an exception loop (eg. let a = error a in a) the ^C exception --- may never be delivered. Thanks to Marcin for pointing out the bug. -ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a -ghciHandle h (GHCi m) = GHCi $ \s -> - Exception.catch (m s) - (\e -> unGHCi (ghciUnblock (h e)) s) - -ghciUnblock :: GHCi a -> GHCi a -ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) - ------------------------------------------------------------------------------ +-- -------------------------------------------------------------------------- -- timing & statistics timeIt :: GHCi a -> GHCi a diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index b9b82ac..d6f557d 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -85,6 +85,7 @@ import System.Directory import System.IO import System.IO.Error as IO import Data.Char +import Data.Dynamic import Control.Monad as Monad import Foreign.StablePtr ( newStablePtr ) @@ -1366,6 +1367,61 @@ completeHomeModuleOrFile=completeNone completeBkpt = completeNone #endif +-- --------------------------------------------------------------------------- +-- User code exception handling + +-- This is the exception handler for exceptions generated by the +-- user's code and exceptions coming from children sessions; +-- it normally just prints out the exception. The +-- handler must be recursive, in case showing the exception causes +-- more exceptions to be raised. +-- +-- Bugfix: if the user closed stdout or stderr, the flushing will fail, +-- raising another exception. We therefore don't put the recursive +-- handler arond the flushing operation, so if stderr is closed +-- GHCi will just die gracefully rather than going into an infinite loop. +handler :: Exception -> GHCi Bool +handler (DynException dyn) + | Just StopChildSession <- fromDynamic dyn + -- propagate to the parent session + = ASSERTM (liftM not isTopLevel) >> throwDyn StopChildSession + + | Just (ChildSessionStopped msg) <- fromDynamic dyn + -- Reload modules and display some message + = ASSERTM (isTopLevel) >> io(putStrLn msg) >> return False + +handler exception = do + flushInterpBuffers + io installSignalHandlers + ghciHandle handler (showException exception >> return False) + +showException (DynException dyn) = + case fromDynamic dyn of + Nothing -> io (putStrLn ("*** Exception: (unknown)")) + Just Interrupted -> io (putStrLn "Interrupted.") + Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError + Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto + Just other_ghc_ex -> io (print other_ghc_ex) + +showException other_exception + = io (putStrLn ("*** Exception: " ++ show other_exception)) + +----------------------------------------------------------------------------- +-- recursive exception handlers + +-- Don't forget to unblock async exceptions in the handler, or if we're +-- in an exception loop (eg. let a = error a in a) the ^C exception +-- may never be delivered. Thanks to Marcin for pointing out the bug. + +ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a +ghciHandle h (GHCi m) = GHCi $ \s -> + Exception.catch (m s) + (\e -> unGHCi (ghciUnblock (h e)) s) + +ghciUnblock :: GHCi a -> GHCi a +ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) + + -- ---------------------------------------------------------------------------- -- Utils @@ -1450,8 +1506,8 @@ doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do prelude = prel_mod, topLevel = False } `catchDyn` ( - \StopChildSession -> evaluate$ - throwDyn (ChildSessionStopped "You may need to reload your modules") + \StopChildSession -> evaluate$ + throwDyn (ChildSessionStopped "") ) `finally` do writeIORef ref hsc_env putStrLn $ "Returning to normal execution..."