diff options
author | Simon Marlow <marlowsd@gmail.com> | 2015-11-18 16:42:24 +0000 |
---|---|---|
committer | Simon Marlow <marlowsd@gmail.com> | 2015-12-17 09:39:52 +0000 |
commit | 4905b83a2d448c65ccced385343d4e8124548a3b (patch) | |
tree | 070cf9e48f6fce668cd01d888b8da8b3772d1f53 /ghc | |
parent | 7221ad70daa363d77f60d96c3f6e1baa1d9bec81 (diff) | |
download | haskell-4905b83a2d448c65ccced385343d4e8124548a3b.tar.gz |
Remote GHCi, -fexternal-interpreter
Summary:
(Apologies for the size of this patch, I couldn't make a smaller one
that was validate-clean and also made sense independently)
(Some of this code is derived from GHCJS.)
This commit adds support for running interpreted code (for GHCi and
TemplateHaskell) in a separate process. The functionality is
experimental, so for now it is off by default and enabled by the flag
-fexternal-interpreter.
Reaosns we want this:
* compiling Template Haskell code with -prof does not require
building the code without -prof first
* when GHC itself is profiled, it can interpret unprofiled code, and
the same applies to dynamic linking. We would no longer need to
force -dynamic-too with TemplateHaskell, and we can load ordinary
objects into a dynamically-linked GHCi (and vice versa).
* An unprofiled GHCi can load and run profiled code, which means it
can use the stack-trace functionality provided by profiling without
taking the performance hit on the compiler that profiling would
entail.
Amongst other things; see
https://ghc.haskell.org/trac/ghc/wiki/RemoteGHCi for more details.
Notes on the implementation are in Note [Remote GHCi] in the new
module compiler/ghci/GHCi.hs. It probably needs more documenting,
feel free to suggest things I could elaborate on.
Things that are not currently implemented for -fexternal-interpreter:
* The GHCi debugger
* :set prog, :set args in GHCi
* `recover` in Template Haskell
* Redirecting stdin/stdout for the external process
These are all doable, I just wanted to get to a working validate-clean
patch first.
I also haven't done any benchmarking yet. I expect there to be slight hit
to link times for byte code and some penalty due to having to
serialize/deserialize TH syntax, but I don't expect it to be a serious
problem. There's also lots of low-hanging fruit in the byte code
generator/linker that we could exploit to speed things up.
Test Plan:
* validate
* I've run parts of the test suite with
EXTRA_HC_OPTS=-fexternal-interpreter, notably tests/ghci and tests/th.
There are a few failures due to the things not currently implemented
(see above).
Reviewers: simonpj, goldfire, ezyang, austin, alanz, hvr, niteria, bgamari, gibiansky, luite
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1562
Diffstat (limited to 'ghc')
-rw-r--r-- | ghc/GhciMonad.hs | 127 | ||||
-rw-r--r-- | ghc/InteractiveUI.hs | 65 | ||||
-rw-r--r-- | ghc/Main.hs | 46 | ||||
-rw-r--r-- | ghc/ghc-bin.cabal.in | 3 |
4 files changed, 123 insertions, 118 deletions
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index c1abe4f923..d8fa0e1146 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -22,7 +22,10 @@ module GhciMonad ( runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs, printForUser, printForUserPartWay, prettyLocations, - initInterpBuffering, turnOffBuffering, flushInterpBuffers, + initInterpBuffering, + turnOffBuffering, turnOffBuffering_, + flushInterpBuffers, + mkEvalWrapper ) where #include "HsVersions.h" @@ -31,14 +34,13 @@ import qualified GHC import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay) import qualified Outputable -import Util import DynFlags import FastString import HscTypes import SrcLoc import Module -import ObjLink -import Linker +import GHCi +import GHCi.RemoteTypes import Exception import Numeric @@ -48,7 +50,6 @@ import System.CPUTime import System.Environment import System.IO import Control.Monad -import GHC.Exts import System.Console.Haskeline (CompletionFunc, InputT) import qualified System.Console.Haskeline as Haskeline @@ -62,6 +63,7 @@ data GHCiState = GHCiState { progname :: String, args :: [String], + evalWrapper :: ForeignHValue, -- IO a -> IO a prompt :: String, prompt2 :: String, editor :: String, @@ -103,7 +105,12 @@ data GHCiState = GHCiState -- help text to display to a user short_help :: String, long_help :: String, - lastErrorLocations :: IORef [(FastString, Int)] + lastErrorLocations :: IORef [(FastString, Int)], + + -- hFlush stdout; hFlush stderr in the interpreter + flushStdHandles :: ForeignHValue, + -- hSetBuffering NoBuffering for stdin/stdout/stderr + noBuffering :: ForeignHValue } type TickArray = Array Int [(BreakIndex,SrcSpan)] @@ -282,18 +289,14 @@ printForUserPartWay doc = do runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult) runStmt expr step = do st <- getGHCiState - reifyGHCi $ \x -> - withProgName (progname st) $ - withArgs (args st) $ - reflectGHCi x $ do - GHC.handleSourceError (\e -> do GHC.printException e; - return Nothing) $ do - let opts = GHC.execOptions - { GHC.execSourceFile = progname st - , GHC.execLineNumber = line_number st - , GHC.execSingleStep = step } - r <- GHC.execStmt expr opts - return (Just r) + GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do + let opts = GHC.execOptions + { GHC.execSourceFile = progname st + , GHC.execLineNumber = line_number st + , GHC.execSingleStep = step + , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st)) + (EvalThis fhv) } + Just <$> GHC.execStmt expr opts runDecls :: String -> GHCi (Maybe [GHC.Name]) runDecls decls = do @@ -355,9 +358,9 @@ revertCAFs :: GHCi () revertCAFs = do liftIO rts_revertCAFs s <- getGHCiState - when (not (ghc_e s)) $ liftIO turnOffBuffering - -- Have to turn off buffering again, because we just - -- reverted stdout, stderr & stdin to their defaults. + when (not (ghc_e s)) turnOffBuffering + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. foreign import ccall "revertCAFs" rts_revertCAFs :: IO () -- Make it "safe", just in case @@ -366,54 +369,38 @@ 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(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 ()) - --- 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_GHCziIOziHandleziFD_stdin_closure" - mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure" - mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_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] - +-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly +initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue) +initInterpBuffering = do + nobuf <- GHC.compileExprRemote $ + "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++ + " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++ + " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }" + flush <- GHC.compileExprRemote $ + "do { System.IO.hFlush System.IO.stdout; " ++ + " System.IO.hFlush System.IO.stderr }" + return (nobuf, flush) + +-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter flushInterpBuffers :: GHCi () -flushInterpBuffers - = liftIO $ do getHandle stdout_ptr >>= hFlush - getHandle stderr_ptr >>= hFlush - -turnOffBuffering :: IO () -turnOffBuffering - = 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 addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval) +flushInterpBuffers = do + st <- getGHCiState + hsc_env <- GHC.getSession + liftIO $ evalIO hsc_env (flushStdHandles st) +-- | Turn off buffering for stdin, stdout, and stderr in the interpreter +turnOffBuffering :: GHCi () +turnOffBuffering = do + st <- getGHCiState + turnOffBuffering_ (noBuffering st) + +turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m () +turnOffBuffering_ fhv = do + hsc_env <- getSession + liftIO $ evalIO hsc_env fhv + +mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue +mkEvalWrapper progname args = + GHC.compileExprRemote $ + "\\m -> System.Environment.withProgName " ++ show progname ++ + "(System.Environment.withArgs " ++ show args ++ " m)" diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index ef4c673aaa..55df63771e 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -28,6 +28,7 @@ import GhciTags import Debugger -- The GHC interface +import GHCi import DynFlags import ErrUtils import GhcMonad ( modifySession ) @@ -38,7 +39,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), import HsImpExp import HsSyn import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, - setInteractivePrintName ) + setInteractivePrintName, hsc_dflags ) import Module import Name import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag ) @@ -102,7 +103,6 @@ import System.Posix hiding ( getEnv ) import qualified System.Win32 #endif -import GHC.Exts ( unsafeCoerce# ) import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) @@ -375,7 +375,7 @@ interactiveUI config srcs maybe_exprs = do _ <- liftIO $ newStablePtr stderr -- Initialise buffering for the *interpreted* I/O system - initInterpBuffering + (nobuffering, flush) <- initInterpBuffering -- The initial set of DynFlags used for interactive evaluation is the same -- as the global DynFlags, plus -XExtendedDefaultRules and @@ -391,29 +391,31 @@ interactiveUI config srcs maybe_exprs = do _ <- GHC.setProgramDynFlags $ progDynFlags { log_action = ghciLogAction lastErrLocationsRef } - liftIO $ when (isNothing maybe_exprs) $ do + when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): -- Turn buffering off for the compiled program's stdout/stderr - turnOffBuffering + turnOffBuffering_ nobuffering -- Turn buffering off for GHCi's stdout - hFlush stdout - hSetBuffering stdout NoBuffering + liftIO $ hFlush stdout + liftIO $ hSetBuffering stdout NoBuffering -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. - hSetBuffering stdin NoBuffering - hSetBuffering stderr NoBuffering + liftIO $ hSetBuffering stdin NoBuffering + liftIO $ hSetBuffering stderr NoBuffering #if defined(mingw32_HOST_OS) -- On Unix, stdin will use the locale encoding. The IO library -- doesn't do this on Windows (yet), so for now we use UTF-8, -- for consistency with GHC 6.10 and to make the tests work. - hSetEncoding stdin utf8 + liftIO $ hSetEncoding stdin utf8 #endif default_editor <- liftIO $ findEditor + eval_wrapper <- mkEvalWrapper default_progname default_args startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, GhciMonad.args = default_args, + evalWrapper = eval_wrapper, prompt = defPrompt config, prompt2 = defPrompt2 config, stop = default_stop, @@ -434,7 +436,9 @@ interactiveUI config srcs maybe_exprs = do ghc_e = isJust maybe_exprs, short_help = shortHelpText config, long_help = fullHelpText config, - lastErrorLocations = lastErrLocationsRef + lastErrorLocations = lastErrLocationsRef, + flushStdHandles = flush, + noBuffering = nobuffering } return () @@ -948,7 +952,7 @@ afterRunStmt step_here run_result = do Right names -> do show_types <- isOptionSet ShowType when show_types $ printTypeOfNames names - GHC.ExecBreak _ names mb_info + GHC.ExecBreak names mb_info | isNothing mb_info || step_here (GHC.resumeSpan $ head resumes) -> do mb_id_loc <- toBreakIdAndLocation mb_info @@ -1319,7 +1323,7 @@ defineMacro overwrite s = do body = nlHsVar compose_RDR `mkHsApp` step `mkHsApp` expr tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) new_expr = L (getLoc expr) $ ExprWithTySig body tySig - hv <- GHC.compileParsedExpr new_expr + hv <- GHC.compileParsedExprRemote new_expr let newCmd = Command { cmdName = macro_name , cmdAction = lift . runMacro hv @@ -1330,9 +1334,10 @@ defineMacro overwrite s = do -- later defined macros have precedence liftIO $ writeIORef macros_ref (newCmd : filtered) -runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool +runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do - str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s) + hsc_env <- GHC.getSession + str <- liftIO $ evalStringToIOString hsc_env fun s enqueueCommands (lines str) return False @@ -1360,9 +1365,10 @@ cmdCmd str = handleSourceError GHC.printException $ do expr <- GHC.parseExpr str -- > ghciStepIO str :: IO String let new_expr = step `mkHsApp` expr - hv <- GHC.compileParsedExpr new_expr + hv <- GHC.compileParsedExprRemote new_expr - cmds <- liftIO $ (unsafeCoerce# hv :: IO String) + hsc_env <- GHC.getSession + cmds <- liftIO $ evalString hsc_env hv enqueueCommands (lines cmds) -- | Generate a typed ghciStepIO expression @@ -2126,8 +2132,16 @@ showDynFlags show_all dflags = do setArgs, setOptions :: [String] -> GHCi () setProg, setEditor, setStop :: String -> GHCi () -setArgs args = modifyGHCiState (\st -> st { GhciMonad.args = args }) -setProg prog = modifyGHCiState (\st -> st { progname = prog }) +setArgs args = do + st <- getGHCiState + wrapper <- mkEvalWrapper (progname st) args + setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper } + +setProg prog = do + st <- getGHCiState + wrapper <- mkEvalWrapper prog (GhciMonad.args st) + setGHCiState st { progname = prog, evalWrapper = wrapper } + setEditor cmd = modifyGHCiState (\st -> st { editor = cmd }) setStop str@(c:_) | isDigit c @@ -2203,14 +2217,15 @@ newDynFlags interactive_only minus_opts = do -- if the package flags changed, reset the context and link -- the new packages. - dflags2 <- getDynFlags + hsc_env <- GHC.getSession + let dflags2 = hsc_dflags hsc_env when (packageFlags dflags2 /= packageFlags dflags0) $ do when (verbosity dflags2 > 0) $ liftIO . putStrLn $ "package flags have changed, resetting and loading new packages..." GHC.setTargets [] _ <- GHC.load LoadAllTargets - liftIO $ linkPackages dflags2 new_pkgs + liftIO $ linkPackages hsc_env new_pkgs -- package flags changed, we can't re-use any of the old context setContextAfterLoad False [] -- and copy the package state to the interactive DynFlags @@ -2226,10 +2241,12 @@ newDynFlags interactive_only minus_opts = do newLdInputs = drop ld0length (ldInputs dflags2) newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2) + hsc_env' = hsc_env { hsc_dflags = + dflags2 { ldInputs = newLdInputs + , cmdlineFrameworks = newCLFrameworks } } + when (not (null newLdInputs && null newCLFrameworks)) $ - liftIO $ linkCmdLineLibs $ - dflags2 { ldInputs = newLdInputs - , cmdlineFrameworks = newCLFrameworks } + liftIO $ linkCmdLineLibs hsc_env' return () diff --git a/ghc/Main.hs b/ghc/Main.hs index c85f0b3a8b..7d4e1e235c 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -166,20 +166,7 @@ main' postLoadMode dflags0 args flagWarnings = do DoAbiHash -> (OneShot, dflt_target, LinkBinary) _ -> (OneShot, dflt_target, LinkBinary) - let dflags1 = case lang of - HscInterpreted -> - let platform = targetPlatform dflags0 - dflags0a = updateWays $ dflags0 { ways = interpWays } - dflags0b = foldl gopt_set dflags0a - $ concatMap (wayGeneralFlags platform) - interpWays - dflags0c = foldl gopt_unset dflags0b - $ concatMap (wayUnsetGeneralFlags platform) - interpWays - in dflags0c - _ -> - dflags0 - dflags2 = dflags1{ ghcMode = mode, + let dflags1 = dflags0{ ghcMode = mode, hscTarget = lang, ghcLink = link, verbosity = case postLoadMode of @@ -191,14 +178,29 @@ main' postLoadMode dflags0 args flagWarnings = do -- can be overriden from the command-line -- XXX: this should really be in the interactive DynFlags, but -- we don't set that until later in interactiveUI - dflags3 | DoInteractive <- postLoadMode = imp_qual_enabled + dflags2 | DoInteractive <- postLoadMode = imp_qual_enabled | DoEval _ <- postLoadMode = imp_qual_enabled - | otherwise = dflags2 - where imp_qual_enabled = dflags2 `gopt_set` Opt_ImplicitImportQualified + | otherwise = dflags1 + where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files - (dflags4, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags3 args + (dflags3, fileish_args, dynamicFlagWarnings) <- + GHC.parseDynamicFlags dflags2 args + + let dflags4 = case lang of + HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) -> + let platform = targetPlatform dflags3 + dflags3a = updateWays $ dflags3 { ways = interpWays } + dflags3b = foldl gopt_set dflags3a + $ concatMap (wayGeneralFlags platform) + interpWays + dflags3c = foldl gopt_unset dflags3b + $ concatMap (wayUnsetGeneralFlags platform) + interpWays + in dflags3c + _ -> + dflags3 GHC.prettyPrintGhcErrors dflags4 $ do @@ -209,9 +211,6 @@ main' postLoadMode dflags0 args flagWarnings = do liftIO $ exitWith (ExitFailure 1)) $ do liftIO $ handleFlagWarnings dflags4 flagWarnings' - -- make sure we clean up after ourselves - GHC.defaultCleanupHandler dflags4 $ do - liftIO $ showBanner postLoadMode dflags4 let @@ -336,9 +335,10 @@ checkOptions mode dflags srcs objs = do -- -prof and --interactive are not a good combination when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays) - && isInterpretiveMode mode) $ + && isInterpretiveMode mode + && not (gopt Opt_ExternalInterpreter dflags)) $ do throwGhcException (UsageError - "--interactive can't be used with -prof or -static.") + "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).") -- -ohi sanity check if (isJust (outputHi dflags) && (isCompManagerMode mode || srcs `lengthExceeds` 1)) diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 90b8a55e5b..45193e36ee 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -44,7 +44,8 @@ Executable ghc GHC-Options: -Wall if flag(ghci) - Build-depends: deepseq >= 1.4 && < 1.5 + Build-depends: deepseq >= 1.4 && < 1.5, + ghci CPP-Options: -DGHCI GHC-Options: -fno-warn-name-shadowing Other-Modules: |