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

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: