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

1 files changed, 147 insertions, 0 deletions

diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs
new file mode 100644
index 0000000000..026e3eafbd
--- /dev/null
+++ b/libraries/ghci/GHCi/CreateBCO.hs
@@ -0,0 +1,147 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RecordWildCards #-}
+
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+module GHCi.CreateBCO (createBCOs) where
+
+import GHCi.ResolvedBCO
+import GHCi.RemoteTypes
+import SizedSeq
+
+import System.IO (fixIO)
+import Control.Monad
+import Data.Array.Base
+import Foreign hiding (newArray)
+import GHC.Arr          ( Array(..) )
+import GHC.Exts
+import GHC.IO
+-- import Debug.Trace
+
+createBCOs :: [ResolvedBCO] -> IO [HValueRef]
+createBCOs bcos = do
+  let n_bcos = length bcos
+  hvals <- fixIO $ \hvs -> do
+     let arr = listArray (0, n_bcos-1) hvs
+     mapM (createBCO arr) bcos
+  mapM mkHValueRef hvals
+
+createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
+createBCO arr bco
+   = do BCO bco# <- linkBCO' arr bco
+        -- Why do we need mkApUpd0 here?  Otherwise top-level
+        -- interpreted CAFs don't get updated after evaluation.  A
+        -- top-level BCO will evaluate itself and return its value
+        -- when entered, but it won't update itself.  Wrapping the BCO
+        -- in an AP_UPD thunk will take care of the update for us.
+        --
+        -- Furthermore:
+        --   (a) An AP thunk *must* point directly to a BCO
+        --   (b) A zero-arity BCO *must* be wrapped in an AP thunk
+        --   (c) An AP is always fully saturated, so we *can't* wrap
+        --       non-zero arity BCOs in an AP thunk.
+        --
+        if (resolvedBCOArity bco > 0)
+           then return (HValue (unsafeCoerce# bco#))
+           else case mkApUpd0# bco# of { (# final_bco #) ->
+                  return (HValue final_bco) }
+
+
+linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
+linkBCO' arr ResolvedBCO{..} = do
+  let
+      ptrs   = ssElts resolvedBCOPtrs
+      n_ptrs = sizeSS resolvedBCOPtrs
+
+      !(I# arity#)  = resolvedBCOArity
+
+      !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
+
+      barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
+      insns_barr = barr resolvedBCOInstrs
+      bitmap_barr = barr resolvedBCOBitmap
+      literals_barr = barr resolvedBCOLits
+
+  PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
+  IO $ \s ->
+    case unsafeFreezeArray# marr s of { (# s, arr #) ->
+    case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
+    io s
+    }}
+
+
+-- we recursively link any sub-BCOs while making the ptrs array
+mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
+mkPtrsArray arr n_ptrs ptrs = do
+  marr <- newPtrsArray (fromIntegral n_ptrs)
+  let
+    fill (ResolvedBCORef n) i =
+      writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!
+    fill (ResolvedBCOPtr r) i = do
+      hv <- localHValueRef r
+      writePtrsArrayHValue i hv marr
+    fill (ResolvedBCOStaticPtr r) i = do
+      writePtrsArrayPtr i (fromRemotePtr r)  marr
+    fill (ResolvedBCOPtrBCO bco) i = do
+      BCO bco# <- linkBCO' arr bco
+      writePtrsArrayBCO i bco# marr
+    fill (ResolvedBCOPtrLocal hv) i = do
+      writePtrsArrayHValue i hv marr
+  zipWithM_ fill ptrs [0..]
+  return marr
+
+data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)
+
+newPtrsArray :: Int -> IO PtrsArr
+newPtrsArray (I# i) = IO $ \s ->
+  case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)
+
+writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
+writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->
+  case writeArray# arr i hv s of s' -> (# s', () #)
+
+writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()
+writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->
+  case writeArrayAddr# arr i a# s of s' -> (# s', () #)
+
+-- This is rather delicate: convincing GHC to pass an Addr# as an Any but
+-- without making a thunk turns out to be surprisingly tricky.
+{-# NOINLINE writeArrayAddr# #-}
+writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
+writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s
+
+writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()
+writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
+  case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
+
+data BCO = BCO BCO#
+
+newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
+newBCO instrs lits ptrs arity bitmap = IO $ \s ->
+  case newBCO# instrs lits ptrs arity bitmap s of
+    (# s1, bco #) -> (# s1, BCO bco #)
+
+{- Note [BCO empty array]
+
+Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
+they are 2-word heap objects.  So let's make a single empty array and
+share it between all BCOs.
+-}
+
+data EmptyArr = EmptyArr ByteArray#
+
+{-# NOINLINE emptyArr #-}
+emptyArr :: EmptyArr
+emptyArr = unsafeDupablePerformIO $ IO $ \s ->
+  case newByteArray# 0# s of { (# s, arr #) ->
+  case unsafeFreezeByteArray# arr s of { (# s, farr #) ->
+  (# s, EmptyArr farr #)
+  }}