X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=f7f2014ea29c5d25d6483cbc8b44845a5fcaedca;hb=182edd420fe8d5ec0d12fcabaec7d13416a77cd6;hp=d95fc599d48bd028425ff135b01d6b62d3606bc1;hpb=c78721146b8b2b181e2fccb3a65a366eef85345e;p=ghc-hetmet.git diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index d95fc59..f7f2014 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,101 @@ 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 + resume :: [EvalInProgress], + 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 + } + +-- The context of an evaluation in progress that stopped at a breakpoint +data EvalInProgress + = EvalInProgress + { evalStmt :: String, + evalSpan :: SrcSpan, + evalThreadId :: ThreadId, + evalResumeHandle :: GHC.ResumeHandle } + +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,38 +189,29 @@ 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 +popResume :: GHCi (Maybe EvalInProgress) +popResume = do + st <- getGHCiState + case (resume st) of + [] -> return Nothing + (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x) + +pushResume :: EvalInProgress -> GHCi () +pushResume eval = do + st <- getGHCiState + let oldResume = resume st + setGHCiState $ st { resume = eval : oldResume } + +discardResumeContext :: GHCi () +discardResumeContext = do + st <- getGHCiState + setGHCiState st { resume = [] } + +printForUser :: SDoc -> GHCi () +printForUser doc = do session <- getSession unqual <- io (GHC.getPrintUnqual session) - return $! showSDocForUser unqual doc - --- -------------------------------------------------------------------------- --- Inferior Sessions Exceptions (used by the debugger) - -data InfSessionException = - StopChildSession -- A child session requests to be stopped - | ChildSessionStopped String -- A child session has stopped - deriving Typeable - + io $ Outputable.printForUser stdout unqual doc -- -------------------------------------------------------------------------- -- timing & statistics @@ -175,14 +261,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"] + +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" @@ -192,6 +297,8 @@ initInterpBuffering session Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) _ -> panic "interactiveUI:flush" + GHC.setSessionDynFlags session dflags + GHC.workingDirectoryChanged session return ()