X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=8374491891ceafc71ca7a5ab4d6ce6af6a20ee14;hb=ee26207114635c480dbc7518c0510545a6f62611;hp=d38046340af4d6108e3b04353649fce5dbc9bf9d;hpb=e1b8996040150d5b4027ebd50c2df1f24d79a531;p=ghc-hetmet.git diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index d380463..8374491 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 @@ -19,16 +22,21 @@ import DynFlags import HscTypes import SrcLoc import Module +import ObjLink +import Linker +import StaticFlags +import MonadUtils ( MonadIO, liftIO ) +import Exception +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.Environment import System.IO import Control.Monad as Monad import GHC.Exts @@ -36,6 +44,8 @@ import GHC.Exts ----------------------------------------------------------------------------- -- GHCi monad +type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String]) + data GHCiState = GHCiState { progname :: String, @@ -43,17 +53,33 @@ data GHCiState = GHCiState prompt :: String, editor :: String, stop :: String, - session :: GHC.Session, options :: [GHCiOption], 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. + ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) } +data CtxtCmd + = SetContext + | AddModules + | RemModules + type TickArray = Array Int [(BreakIndex,SrcSpan)] data GHCiOption @@ -67,15 +93,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 @@ -92,38 +125,89 @@ recordBreak brkLoc = do } return (False, oldCounter) -newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } +newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a } -startGHCi :: GHCi a -> GHCiState -> IO a -startGHCi g state = do ref <- newIORef state; unGHCi g ref +reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a +reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s + +reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a +reifyGHCi f = GHCi f' + where + -- f' :: IORef GHCiState -> Ghc a + f' gs = reifyGhc (f'' gs) + -- f'' :: IORef GHCiState -> Session -> IO a + f'' gs s = f (s, gs) + +startGHCi :: GHCi a -> GHCiState -> Ghc a +startGHCi g state = do ref <- liftIO $ 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 + +instance Functor GHCi where + fmap f m = m >>= return . f + +ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a +ghciHandleGhcException = handleGhcException -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) +getGHCiState :: GHCi GHCiState +getGHCiState = GHCi $ \r -> liftIO $ readIORef r +setGHCiState :: GHCiState -> GHCi () +setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s -getGHCiState = GHCi $ \r -> readIORef r -setGHCiState s = GHCi $ \r -> writeIORef r s +liftGhc :: Ghc a -> GHCi a +liftGhc m = GHCi $ \_ -> m + +instance MonadIO GHCi where + liftIO m = liftGhc $ liftIO m + +instance GhcMonad GHCi where + setSession s' = liftGhc $ setSession s' + getSession = liftGhc $ getSession + +instance ExceptionMonad GHCi where + gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) + gblock (GHCi m) = GHCi $ \r -> gblock (m r) + gunblock (GHCi m) = GHCi $ \r -> gunblock (m r) + +instance WarnLogMonad GHCi where + setWarnings warns = liftGhc $ setWarnings warns + getWarnings = liftGhc $ getWarnings -- for convenience... -getSession = getGHCiState >>= return . session +getPrelude :: GHCi Module getPrelude = getGHCiState >>= return . prelude -GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session) +GLOBAL_VAR(saved_sess, no_saved_sess, Session) + +no_saved_sess :: Session no_saved_sess = error "no saved_ses" -saveSession = getSession >>= io . writeIORef saved_sess + +saveSession :: GHCi () +saveSession = + liftGhc $ do + reifyGhc $ \s -> + writeIORef saved_sess s + +splatSavedSession :: GHCi () splatSavedSession = io (writeIORef saved_sess no_saved_sess) -restoreSession = readIORef saved_sess +-- restoreSession :: IO Session +-- restoreSession = readIORef saved_sess + +withRestoredSession :: Ghc a -> IO a +withRestoredSession ghc = do + s <- readIORef saved_sess + reflectGhc ghc s + +getDynFlags :: GHCi DynFlags getDynFlags = do - s <- getSession - io (GHC.getSessionDynFlags s) + GHC.getSessionDynFlags + +setDynFlags :: DynFlags -> GHCi [PackageId] setDynFlags dflags = do - s <- getSession - io (GHC.setSessionDynFlags s dflags) + GHC.setSessionDynFlags dflags isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt @@ -141,14 +225,32 @@ unsetOption opt setGHCiState (st{ options = filter (/= opt) (options st) }) io :: IO a -> GHCi a -io m = GHCi { unGHCi = \s -> m >>= return } +io = liftIO printForUser :: SDoc -> GHCi () printForUser doc = do - session <- getSession - unqual <- io (GHC.getPrintUnqual session) + unqual <- GHC.getPrintUnqual io $ Outputable.printForUser stdout unqual doc +printForUserPartWay :: SDoc -> GHCi () +printForUserPartWay doc = do + unqual <- GHC.getPrintUnqual + io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc + +runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult +runStmt expr step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e + return GHC.RunFailed) $ do + GHC.runStmt expr step + +resume :: GHC.SingleStep -> GHCi GHC.RunResult +resume step = GHC.resume step + -- -------------------------------------------------------------------------- -- timing & statistics @@ -171,7 +273,7 @@ foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 printTimes :: Integer -> Integer -> IO () printTimes allocs psecs - = do let secs = (fromIntegral psecs / (10^12)) :: Float + = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float secs_str = showFFloat (Just 2) secs putStrLn (showSDoc ( parens (text (secs_str "") <+> text "secs" <> comma <+> @@ -180,10 +282,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. @@ -194,56 +297,54 @@ foreign import ccall "revertCAFs" rts_revertCAFs :: IO () -- To flush buffers for the *interpreted* computation we need -- to refer to *its* stdout/stderr handles -GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) -GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) - -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"] +GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ()) +GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ()) +GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ()) -initInterpBuffering :: GHC.Session -> IO () -initInterpBuffering session - = 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" - - maybe_hval <- GHC.compileExpr session flush_cmd - case maybe_hval of - Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) - _ -> panic "interactiveUI:flush" - - GHC.setSessionDynFlags session dflags - GHC.workingDirectoryChanged session +-- After various attempts, I believe this is the least bad way to do +-- what we want. We know look up the address of the static stdin, +-- stdout, and stderr closures in the loaded base package, and each +-- time we need to refer to them we cast the pointer to a Handle. +-- This avoids any problems with the CAF having been reverted, because +-- we'll always get the current value. +-- +-- The previous attempt that didn't work was to compile an expression +-- like "hSetBuffering stdout NoBuffering" into an expression of type +-- IO () and run this expression each time we needed it, but the +-- problem is that evaluating the expression might cache the contents +-- of the Handle rather than referring to it from its static address +-- each time. There's no safe workaround for this. + +initInterpBuffering :: Ghc () +initInterpBuffering = do -- make sure these are linked + dflags <- GHC.getSessionDynFlags + liftIO $ do + 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 + -- interface. + mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure" + mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure" + mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure" + + let f ref (Just ptr) = writeIORef ref ptr + f _ Nothing = panic "interactiveUI:setBuffering2" + zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr] + [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] return () - flushInterpBuffers :: GHCi () flushInterpBuffers - = io $ do Monad.join (readIORef flush_interp) - return () + = io $ do getHandle stdout_ptr >>= hFlush + getHandle stderr_ptr >>= hFlush turnOffBuffering :: IO () turnOffBuffering - = do Monad.join (readIORef turn_off_buffering) - return () + = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr] + mapM_ (\h -> hSetBuffering h NoBuffering) hdls + +getHandle :: IORef (Ptr ()) -> IO Handle +getHandle ref = do + (Ptr addr) <- readIORef ref + case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)