X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=5086022d05cd43303d7271b2a0b78a97305515d9;hb=86bec4298d582ef1d8f0a201d6a81145e1be9498;hp=04c5ffa7361dbcdc10c5f528ff9033677dda7f23;hpb=8bc615fdb45b8e3f2f3ef2167bbb379bf619aab2;p=ghc-hetmet.git diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 04c5ffa..5086022 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -1,20 +1,33 @@ +----------------------------------------------------------------------------- +-- +-- Monadery code used in InteractiveUI +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + module GhciMonad where #include "HsVersions.h" import qualified GHC -import {-#SOURCE#-} Debugger -import Breakpoints -import Outputable -import Panic hiding (showException) +import Outputable hiding (printForUser) +import qualified Outputable +import Panic hiding (showException) import Util +import DynFlags +import HscTypes +import SrcLoc +import Module import Numeric +import Control.Concurrent import Control.Exception as Exception +import Data.Array import Data.Char -import Data.Dynamic import Data.Int ( Int64 ) import Data.IORef +import Data.List import Data.Typeable import System.CPUTime import System.IO @@ -30,19 +43,92 @@ data GHCiState = GHCiState args :: [String], prompt :: String, editor :: String, + stop :: String, session :: GHC.Session, options :: [GHCiOption], prelude :: GHC.Module, - bkptTable :: IORef (BkptTable GHC.Module), - topLevel :: Bool + breaks :: !ActiveBreakPoints, + tickarrays :: ModuleEnv TickArray + -- tickarrays caches the TickArray for loaded modules, + -- so that we don't rebuild it each time the user sets + -- a breakpoint. } +type TickArray = Array Int [(BreakIndex,SrcSpan)] + data GHCiOption = ShowTiming -- show time/allocs after evaluation | ShowType -- show the type of expressions | RevertCAFs -- revert CAFs after every evaluation deriving Eq +data ActiveBreakPoints + = ActiveBreakPoints + { breakCounter :: !Int + , breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered + } + +instance Outputable ActiveBreakPoints where + ppr activeBrks = prettyLocations $ breakLocations activeBrks + +emptyActiveBreakPoints :: ActiveBreakPoints +emptyActiveBreakPoints + = ActiveBreakPoints { breakCounter = 0, breakLocations = [] } + +data BreakLocation + = BreakLocation + { breakModule :: !GHC.Module + , breakLoc :: !SrcSpan + , breakTick :: {-# UNPACK #-} !Int + } + deriving Eq + +prettyLocations :: [(Int, BreakLocation)] -> SDoc +prettyLocations [] = text "No active breakpoints." +prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs + +instance Outputable BreakLocation where + ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) + +getActiveBreakPoints :: GHCi ActiveBreakPoints +getActiveBreakPoints = liftM breaks getGHCiState + +-- don't reset the counter back to zero? +discardActiveBreakPoints :: GHCi () +discardActiveBreakPoints = do + st <- getGHCiState + let oldActiveBreaks = breaks st + newActiveBreaks = oldActiveBreaks { breakLocations = [] } + setGHCiState $ st { breaks = newActiveBreaks } + +deleteBreak :: Int -> GHCi () +deleteBreak identity = do + st <- getGHCiState + let oldActiveBreaks = breaks st + oldLocations = breakLocations oldActiveBreaks + newLocations = filter (\loc -> fst loc /= identity) oldLocations + newActiveBreaks = oldActiveBreaks { breakLocations = newLocations } + setGHCiState $ st { breaks = newActiveBreaks } + +recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) +recordBreak brkLoc = do + st <- getGHCiState + let oldActiveBreaks = breaks st + let oldLocations = breakLocations oldActiveBreaks + -- don't store the same break point twice + case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of + (nm:_) -> return (True, nm) + [] -> do + let oldCounter = breakCounter oldActiveBreaks + newCounter = oldCounter + 1 + newActiveBreaks = + oldActiveBreaks + { breakCounter = newCounter + , breakLocations = (oldCounter, brkLoc) : oldLocations + } + setGHCiState $ st { breaks = newActiveBreaks } + return (False, oldCounter) + newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } startGHCi :: GHCi a -> GHCiState -> IO a @@ -94,92 +180,13 @@ unsetOption opt io :: IO a -> GHCi a io m = GHCi { unGHCi = \s -> m >>= return } -isTopLevel :: GHCi Bool -isTopLevel = getGHCiState >>= return . topLevel - -getBkptTable :: GHCi (BkptTable GHC.Module) -getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable - io$ readIORef table_ref - -setBkptTable :: BkptTable GHC.Module -> GHCi () -setBkptTable new_table = do - table_ref <- getGHCiState >>= return . bkptTable - io$ writeIORef table_ref new_table - -modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi () -modifyBkptTable f = do - bt <- getBkptTable - new_bt <- io . evaluate$ f bt - setBkptTable new_bt - -showForUser :: SDoc -> GHCi String -showForUser doc = do +printForUser :: SDoc -> GHCi () +printForUser doc = do session <- getSession unqual <- io (GHC.getPrintUnqual session) - return $! showSDocForUser unqual doc - ------------------------------------------------------------------------------ --- User code exception handling - --- 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 - 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 - = ASSERTM (liftM not isTopLevel) >> throwDyn StopChildSession - - | Just (ChildSessionStopped msg) <- fromDynamic dyn - -- Revert CAFs and display some message - = 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) + io $ Outputable.printForUser stdout unqual doc -ghciUnblock :: GHCi a -> GHCi a -ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) - ------------------------------------------------------------------------------ +-- -------------------------------------------------------------------------- -- timing & statistics timeIt :: GHCi a -> GHCi a @@ -227,14 +234,33 @@ foreign import ccall "revertCAFs" rts_revertCAFs :: IO () GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) -no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++ - " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering" -flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr" +command_sequence :: [String] -> String +command_sequence = unwords . intersperse "Prelude.>>" + +no_buffer :: String -> String +no_buffer h = unwords ["System.IO.hSetBuffering", + "System.IO." ++ h, + "System.IO.NoBuffering"] -initInterpBuffering :: Session -> IO () +no_buf_cmd :: String +no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"] + +flush_buffer :: String -> String +flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h] + +flush_cmd :: String +flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"] + +initInterpBuffering :: GHC.Session -> IO () initInterpBuffering session - = do maybe_hval <- GHC.compileExpr session no_buf_cmd - + = do -- we don't want to be fooled by any modules lying around in the current + -- directory when we compile these code fragments, so set the import + -- path to be empty while we compile them. + dflags <- GHC.getSessionDynFlags session + GHC.setSessionDynFlags session dflags{importPaths=[]} + + maybe_hval <- GHC.compileExpr session no_buf_cmd + case maybe_hval of Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) other -> panic "interactiveUI:setBuffering" @@ -244,6 +270,8 @@ initInterpBuffering session Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) _ -> panic "interactiveUI:flush" + GHC.setSessionDynFlags session dflags + GHC.workingDirectoryChanged session return ()