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

5 files changed, 218 insertions, 0 deletions

diff --git a/iserv/Main.hs b/iserv/Main.hs
new file mode 100644
index 0000000000..cbaf9277d5
--- /dev/null
+++ b/iserv/Main.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE RecordWildCards, GADTs, ScopedTypeVariables, RankNTypes #-}
+module Main (main) where
+
+import GHCi.Run
+import GHCi.TH
+import GHCi.Message
+import GHCi.Signals
+
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.Binary
+import Data.IORef
+import System.Environment
+import System.Exit
+import System.Posix
+import Text.Printf
+
+main :: IO ()
+main = do
+  (arg0:arg1:rest) <- getArgs
+  let wfd1 = read arg0; rfd2 = read arg1
+  verbose <- case rest of
+    ["-v"] -> return True
+    [] -> return False
+    _ -> die "iserv: syntax: iserv <write-fd> <read-fd> [-v]"
+  when verbose $ do
+    printf "GHC iserv starting (in: %d; out: %d)\n"
+      (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
+  inh <- fdToHandle rfd2
+  outh <- fdToHandle wfd1
+  installSignalHandlers
+  lo_ref <- newIORef Nothing
+  let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
+  uninterruptibleMask $ serv verbose pipe
+    -- we cannot allow any async exceptions while communicating, because
+    -- we will lose sync in the protocol, hence uninterruptibleMask.
+
+serv :: Bool -> Pipe -> (forall a .IO a -> IO a) -> IO ()
+serv verbose pipe@Pipe{..} restore = loop
+ where
+  loop = do
+    Msg msg <- readPipe pipe getMessage
+    discardCtrlC
+    when verbose $ putStrLn ("iserv: " ++ show msg)
+    case msg of
+      Shutdown -> return ()
+      RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
+      FinishTH st -> wrapRunTH $ finishTH pipe st
+      _other -> run msg >>= reply
+
+  reply :: forall a. (Binary a, Show a) => a -> IO ()
+  reply r = do
+    when verbose $ putStrLn ("iserv: return: " ++ show r)
+    writePipe pipe (put r)
+    loop
+
+  wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
+  wrapRunTH io = do
+    r <- try io
+    case r of
+      Left e
+        | Just (GHCiQException _ err) <- fromException e  -> do
+           when verbose $ putStrLn "iserv: QFail"
+           writePipe pipe (putMessage (QFail err))
+           loop
+        | otherwise -> do
+           when verbose $ putStrLn "iserv: QException"
+           str <- showException e
+           writePipe pipe (putMessage (QException str))
+           loop
+      Right a -> do
+        when verbose $ putStrLn "iserv: QDone"
+        writePipe pipe (putMessage QDone)
+        reply a
+
+  -- carefully when showing an exception, there might be other exceptions
+  -- lurking inside it.  If so, we return the inner exception instead.
+  showException :: SomeException -> IO String
+  showException e0 = do
+     r <- try $ evaluate (force (show (e0::SomeException)))
+     case r of
+       Left e -> showException e
+       Right str -> return str
+
+  -- throw away any pending ^C exceptions while we're not running
+  -- interpreted code.  GHC will also get the ^C, and either ignore it
+  -- (if this is GHCi), or tell us to quit with a Shutdown message.
+  discardCtrlC = do
+    r <- try $ restore $ return ()
+    case r of
+      Left UserInterrupt -> return () >> discardCtrlC
+      Left e -> throwIO e
+      _ -> return ()
diff --git a/iserv/Makefile b/iserv/Makefile
new file mode 100644
index 0000000000..f160978c19
--- /dev/null
+++ b/iserv/Makefile
@@ -0,0 +1,15 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+dir = iserv
+TOP = ..
+include $(TOP)/mk/sub-makefile.mk
diff --git a/iserv/ghc.mk b/iserv/ghc.mk
new file mode 100644
index 0000000000..4cae48299f
--- /dev/null
+++ b/iserv/ghc.mk
@@ -0,0 +1,67 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009-2012 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+#      http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+iserv_USES_CABAL = YES
+iserv_PACKAGE = iserv-bin
+
+ifeq "$(GhcDebugged)" "YES"
+iserv_stage2_MORE_HC_OPTS += -debug
+iserv_stage2_p_MORE_HC_OPTS += -debug
+iserv_stage2_dyn_MORE_HC_OPTS += -debug
+endif
+
+iserv_stage2_MORE_HC_OPTS += -threaded
+iserv_stage2_p_MORE_HC_OPTS += -threaded
+iserv_stage2_dyn_MORE_HC_OPTS += -threaded
+
+# Override the default way, because we want a specific version of this
+# program for each way.  Note that it's important to do this even for
+# the vanilla version, otherwise we get a dynamic executable when
+# DYNAMIC_GHC_PROGRAMS=YES.
+iserv_stage2_PROGRAM_WAY = v
+iserv_stage2_p_PROGRAM_WAY = p
+iserv_stage2_dyn_PROGRAM_WAY = dyn
+
+iserv_stage2_PROGNAME = ghc-iserv
+iserv_stage2_p_PROGNAME = ghc-iserv-prof
+iserv_stage2_dyn_PROGNAME = ghc-iserv-dyn
+
+iserv_stage2_MORE_HC_OPTS += -no-hs-main
+iserv_stage2_p_MORE_HC_OPTS += -no-hs-main
+iserv_stage2_dyn_MORE_HC_OPTS += -no-hs-main
+
+iserv_stage2_INSTALL = YES
+iserv_stage2_p_INSTALL = YES
+iserv_stage2_dyn_INSTALL = YES
+
+# Install in $(libexec), not in $(bindir)
+iserv_stage2_TOPDIR = YES
+iserv_stage2_p_TOPDIR = YES
+iserv_stage2_dyn_TOPDIR = YES
+
+iserv_stage2_INSTALL_INPLACE = YES
+iserv_stage2_p_INSTALL_INPLACE = YES
+iserv_stage2_dyn_INSTALL_INPLACE = YES
+
+$(eval $(call build-prog,iserv,stage2,1))
+
+ifneq "$(findstring p, $(GhcLibWays))" ""
+$(eval $(call build-prog,iserv,stage2_p,1))
+endif
+
+ifneq "$(findstring dyn, $(GhcLibWays))" ""
+$(eval $(call build-prog,iserv,stage2_dyn,1))
+endif
+
+all_ghc_stage2 : $(iserv-stage2_INPLACE)
+all_ghc_stage2 : $(iserv-stage2_p_INPLACE)
+all_ghc_stage2 : $(iserv-stage2_dyn_INPLACE)
diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal
new file mode 100644
index 0000000000..9dac158ebf
--- /dev/null
+++ b/iserv/iserv-bin.cabal
@@ -0,0 +1,26 @@
+Name: iserv-bin
+Version: 0.0
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: XXX
+Description:
+        XXX
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Executable iserv
+    Default-Language: Haskell2010
+    Main-Is: Main.hs
+    C-Sources: iservmain.c
+    Build-Depends: array      >= 0.5 && < 0.6,
+                   base       >= 4   && < 5,
+                   unix       >= 2.7 && < 2.8,
+                   binary     >= 0.7 && < 0.9,
+                   bytestring >= 0.10 && < 0.11,
+                   containers >= 0.5 && < 0.6,
+                   deepseq    >= 1.4 && < 1.5,
+                   ghci
diff --git a/iserv/iservmain.c b/iserv/iservmain.c
new file mode 100644
index 0000000000..f7eb5664c5
--- /dev/null
+++ b/iserv/iservmain.c
@@ -0,0 +1,16 @@
+#include "../rts/PosixSource.h"
+#include "Rts.h"
+
+#include "HsFFI.h"
+
+int main (int argc, char *argv[])
+{
+    RtsConfig conf = defaultRtsConfig;
+
+    // We never know what symbols GHC will look up in the future, so
+    // we must retain CAFs for running interpreted code.
+    conf.keep_cafs = 1;
+
+    extern StgClosure ZCMain_main_closure;
+    hs_main(argc, argv, &ZCMain_main_closure, conf);
+}