X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=f7c5c019b0768484892cde9a682e9eff42f51500;hb=9608803049b49cacef9c452d079693a1111be036;hp=9e3137619cda0ed6f2ef7cd8d7b63ce04249bde9;hpb=3211a6a00826b85f732715e59c7c1a81b0586f14;p=ghc-hetmet.git diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 9e31376..f7c5c01 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -1,3 +1,6 @@ +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + ----------------------------------------------------------------------------- -- -- Monadery code used in InteractiveUI @@ -11,7 +14,7 @@ module GhciMonad where #include "HsVersions.h" import qualified GHC -import Outputable hiding (printForUser) +import Outputable hiding (printForUser, printForUserPartWay) import qualified Outputable import Panic hiding (showException) import Util @@ -20,17 +23,19 @@ import HscTypes import SrcLoc import Module import ObjLink +import Linker +import StaticFlags import Data.Maybe import Numeric -import Control.Exception as Exception import Data.Array import Data.Char import Data.Int ( Int64 ) import Data.IORef import Data.List -import Data.Typeable import System.CPUTime +import System.Directory +import System.Environment import System.IO import Control.Monad as Monad import GHC.Exts @@ -38,6 +43,8 @@ import GHC.Exts ----------------------------------------------------------------------------- -- GHCi monad +type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String]) + data GHCiState = GHCiState { progname :: String, @@ -50,12 +57,30 @@ data GHCiState = GHCiState prelude :: GHC.Module, break_ctr :: !Int, breaks :: ![(Int, BreakLocation)], - tickarrays :: ModuleEnv TickArray + tickarrays :: ModuleEnv TickArray, -- tickarrays caches the TickArray for loaded modules, -- so that we don't rebuild it each time the user sets -- a breakpoint. + -- ":" at the GHCi prompt repeats the last command, so we + -- remember is here: + last_command :: Maybe Command, + cmdqueue :: [String], + remembered_ctx :: [(CtxtCmd, [String], [String])], + -- we remember the :module commands between :loads, so that + -- on a :reload we can replay them. See bugs #2049, + -- \#1873, #1360. Previously we tried to remember modules that + -- were supposed to be in the context but currently had errors, + -- but this was complicated. Just replaying the :module commands + -- seems to be the right thing. + virtual_path :: FilePath, + ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) } +data CtxtCmd + = SetContext + | AddModules + | RemModules + type TickArray = Array Int [(BreakIndex,SrcSpan)] data GHCiOption @@ -69,15 +94,22 @@ data BreakLocation { breakModule :: !GHC.Module , breakLoc :: !SrcSpan , breakTick :: {-# UNPACK #-} !Int + , onBreakCmd :: String } - deriving Eq + +instance Eq BreakLocation where + loc1 == loc2 = breakModule loc1 == breakModule loc2 && + breakTick loc1 == breakTick loc2 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) + ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> + if null (onBreakCmd loc) + then empty + else doubleQuotes (text (onBreakCmd loc)) recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) recordBreak brkLoc = do @@ -101,28 +133,45 @@ startGHCi g state = do ref <- newIORef state; unGHCi g ref instance Monad GHCi where (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s - return a = GHCi $ \s -> return a + return a = GHCi $ \_ -> return a -ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a -ghciHandleDyn h (GHCi m) = GHCi $ \s -> - Exception.catchDyn (m s) (\e -> unGHCi (h e) s) +instance Functor GHCi where + fmap f m = m >>= return . f +ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a +ghciHandleGhcException h (GHCi m) = GHCi $ \s -> + handleGhcException (\e -> unGHCi (h e) s) (m s) + +getGHCiState :: GHCi GHCiState getGHCiState = GHCi $ \r -> readIORef r +setGHCiState :: GHCiState -> GHCi () setGHCiState s = GHCi $ \r -> writeIORef r s -- for convenience... +getSession :: GHCi Session getSession = getGHCiState >>= return . session +getPrelude :: GHCi Module getPrelude = getGHCiState >>= return . prelude GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session) + +no_saved_sess :: Session no_saved_sess = error "no saved_ses" + +saveSession :: GHCi () saveSession = getSession >>= io . writeIORef saved_sess + +splatSavedSession :: GHCi () splatSavedSession = io (writeIORef saved_sess no_saved_sess) + +restoreSession :: IO Session restoreSession = readIORef saved_sess +getDynFlags :: GHCi DynFlags getDynFlags = do s <- getSession io (GHC.getSessionDynFlags s) +setDynFlags :: DynFlags -> GHCi [PackageId] setDynFlags dflags = do s <- getSession io (GHC.setSessionDynFlags s dflags) @@ -143,7 +192,7 @@ unsetOption opt setGHCiState (st{ options = filter (/= opt) (options st) }) io :: IO a -> GHCi a -io m = GHCi { unGHCi = \s -> m >>= return } +io m = GHCi (\_ -> m) printForUser :: SDoc -> GHCi () printForUser doc = do @@ -151,6 +200,36 @@ printForUser doc = do unqual <- io (GHC.getPrintUnqual session) io $ Outputable.printForUser stdout unqual doc +printForUserPartWay :: SDoc -> GHCi () +printForUserPartWay doc = do + session <- getSession + unqual <- io (GHC.getPrintUnqual session) + io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc + +withVirtualPath :: GHCi a -> GHCi a +withVirtualPath m = do + ghci_wd <- io getCurrentDirectory -- Store the cwd of GHCi + st <- getGHCiState + io$ setCurrentDirectory (virtual_path st) + result <- m -- Evaluate in the virtual wd.. + vwd <- io getCurrentDirectory + setGHCiState (st{ virtual_path = vwd}) -- Update the virtual path + io$ setCurrentDirectory ghci_wd -- ..and restore GHCi wd + return result + +runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult +runStmt expr step = withVirtualPath$ do + session <- getSession + st <- getGHCiState + io$ withProgName (progname st) $ withArgs (args st) $ + GHC.runStmt session expr step + +resume :: GHC.SingleStep -> GHCi GHC.RunResult +resume step = withVirtualPath$ do + session <- getSession + io$ GHC.resume session step + + -- -------------------------------------------------------------------------- -- timing & statistics @@ -182,10 +261,11 @@ printTimes allocs psecs ----------------------------------------------------------------------------- -- reverting CAFs -revertCAFs :: IO () +revertCAFs :: GHCi () revertCAFs = do - rts_revertCAFs - turnOffBuffering + io $ rts_revertCAFs + s <- getGHCiState + when (not (ghc_e s)) $ io turnOffBuffering -- Have to turn off buffering again, because we just -- reverted stdout, stderr & stdin to their defaults. @@ -217,11 +297,8 @@ GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) initInterpBuffering :: GHC.Session -> IO () initInterpBuffering session = do -- make sure these are linked - mb_hval1 <- GHC.compileExpr session "System.IO.stdout" - mb_hval2 <- GHC.compileExpr session "System.IO.stderr" - mb_hval3 <- GHC.compileExpr session "System.IO.stdin" - when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $ - panic "interactiveUI:setBuffering" + dflags <- GHC.getSessionDynFlags session + initDynLinker dflags -- ToDo: we should really look up these names properly, but -- it's a fiddle and not all the bits are exposed via the GHC @@ -231,7 +308,7 @@ initInterpBuffering session mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure" let f ref (Just ptr) = writeIORef ref ptr - f ref Nothing = panic "interactiveUI:setBuffering2" + f _ Nothing = panic "interactiveUI:setBuffering2" zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr] [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] return ()