Commit 4905b83a authored by Simon Marlow's avatar Simon Marlow

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
parent 7221ad70
......@@ -72,6 +72,7 @@ _darcs/
/ghc/stage1/
/ghc/stage2/
/ghc/stage3/
/iserv/stage2*/
# -----------------------------------------------------------------------------
# specific generated files
......
......@@ -467,7 +467,7 @@ AC_DEFUN([FP_SETTINGS],
SettingsPerlCommand='$topdir/../perl/perl.exe'
SettingsDllWrapCommand="\$topdir/../${mingw_bin_prefix}dllwrap.exe"
SettingsWindresCommand="\$topdir/../${mingw_bin_prefix}windres.exe"
SettingsTouchCommand='$topdir/touchy.exe'
SettingsTouchCommand='$topdir/bin/touchy.exe'
else
SettingsCCompilerCommand="$WhatGccIsCalled"
SettingsHaskellCPPCommand="$HaskellCPPCmd"
......
......@@ -86,8 +86,6 @@ module BasicTypes(
FractionalLit(..), negateFractionalLit, integralFractionalLit,
HValue(..),
SourceText,
IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit
......@@ -99,7 +97,6 @@ import SrcLoc ( Located,unLoc )
import StaticFlags( opt_PprStyle_Debug )
import Data.Data hiding (Fixity)
import Data.Function (on)
import GHC.Exts (Any)
{-
************************************************************************
......@@ -1165,8 +1162,6 @@ instance Ord FractionalLit where
instance Outputable FractionalLit where
ppr = text . fl_text
newtype HValue = HValue Any
{-
************************************************************************
* *
......
......@@ -106,13 +106,13 @@ data Literal
(Maybe Int)
FunctionOrData
-- ^ A label literal. Parameters:
--
-- 1) The name of the symbol mentioned in the declaration
--
-- 2) The size (in bytes) of the arguments
-- the label expects. Only applicable with
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
--
-- 1) The name of the symbol mentioned in the declaration
--
-- 2) The size (in bytes) of the arguments
-- the label expects. Only applicable with
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
| LitInteger Integer Type -- ^ Integer literals
-- See Note [Integer literals]
......
......@@ -278,15 +278,16 @@ mkStringExprFS str
| all safeChar chars
= do unpack_id <- lookupId unpackCStringName
return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str))))
return (App (Var unpack_id) lit)
| otherwise
= do unpack_id <- lookupId unpackCStringUtf8Name
return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str))))
= do unpack_utf8_id <- lookupId unpackCStringUtf8Name
return (App (Var unpack_utf8_id) lit)
where
chars = unpackFS str
safeChar c = ord c >= 1 && ord c <= 0x7F
lit = Lit (MachStr (fastStringToByteString str))
{-
************************************************************************
......
......@@ -981,7 +981,9 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
coveragePasses :: DynFlags -> [TickishType]
coveragePasses dflags =
ifa (hscTarget dflags == HscInterpreted) Breakpoints $
ifa (hscTarget dflags == HscInterpreted &&
not (gopt Opt_ExternalInterpreter dflags)) Breakpoints $
-- TODO: breakpoints don't work with -fexternal-interpreter yet
ifa (gopt Opt_Hpc dflags) HpcTicks $
ifa (gopt Opt_SccProfilingOn dflags &&
profAuto dflags /= NoProfAuto) ProfNotes $
......
......@@ -64,6 +64,9 @@ Library
else
Build-Depends: unix
if flag(ghci)
Build-Depends: ghci
GHC-Options: -Wall -fno-warn-name-shadowing
if flag(ghci)
......@@ -467,7 +470,6 @@ Library
Pair
Panic
Pretty
Serialized
State
Stream
StringBuffer
......@@ -578,6 +580,7 @@ Library
if flag(ghci)
Exposed-Modules:
Convert
ByteCodeTypes
ByteCodeAsm
ByteCodeGen
ByteCodeInstr
......@@ -586,6 +589,6 @@ Library
Debugger
LibFFI
Linker
ObjLink
RtClosureInspect
DebuggerUtils
GHCi
......@@ -580,7 +580,6 @@ compiler_stage2_dll0_MODULES = \
PrimOp \
RdrName \
Rules \
Serialized \
SrcLoc \
StaticFlags \
StringBuffer \
......@@ -609,49 +608,8 @@ ifeq "$(GhcWithInterpreter)" "YES"
# These files are reacheable from DynFlags
# only by GHCi-enabled code (see #9552)
compiler_stage2_dll0_MODULES += \
Bitmap \
BlockId \
ByteCodeAsm \
ByteCodeInstr \
ByteCodeItbls \
CLabel \
Cmm \
CmmCallConv \
CmmExpr \
CmmInfo \
CmmMachOp \
CmmNode \
CmmSwitch \
CmmUtils \
CodeGen.Platform \
CodeGen.Platform.ARM \
CodeGen.Platform.ARM64 \
CodeGen.Platform.NoRegs \
CodeGen.Platform.PPC \
CodeGen.Platform.PPC_Darwin \
CodeGen.Platform.SPARC \
CodeGen.Platform.X86 \
CodeGen.Platform.X86_64 \
Hoopl \
Hoopl.Dataflow \
InteractiveEvalTypes \
MkGraph \
PprCmm \
PprCmmDecl \
PprCmmExpr \
Reg \
RegClass \
SMRep \
StgCmmArgRep \
StgCmmClosure \
StgCmmEnv \
StgCmmLayout \
StgCmmMonad \
StgCmmProf \
StgCmmTicky \
StgCmmUtils \
StgSyn \
Stream
ByteCodeTypes \
InteractiveEvalTypes
endif
compiler_stage2_dll0_HS_OBJS = \
......@@ -769,4 +727,3 @@ ghc/stage1/package-data.mk : compiler/stage1/inplace-pkg-config-munged
endif
endif
......@@ -8,8 +8,7 @@
module ByteCodeAsm (
assembleBCOs, assembleBCO,
CompiledByteCode(..),
UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames,
bcoFreeNames,
SizedSeq, sizeSS, ssElts,
iNTERP_STACK_CHECK_THRESH
) where
......@@ -18,12 +17,13 @@ module ByteCodeAsm (
import ByteCodeInstr
import ByteCodeItbls
import ByteCodeTypes
import HscTypes
import Name
import NameSet
import Literal
import TyCon
import PrimOp
import FastString
import StgCmmLayout ( ArgRep(..) )
import SMRep
......@@ -32,6 +32,9 @@ import Outputable
import Platform
import Util
-- From iserv
import SizedSeq
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
#endif
......@@ -47,6 +50,7 @@ import Data.Array.Base ( UArray(..) )
import Data.Array.Unsafe( castSTUArray )
import qualified Data.ByteString as B
import Foreign
import Data.Char ( ord )
import Data.List
......@@ -54,44 +58,12 @@ import Data.Map (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
-- CompiledByteCode represents the result of byte-code
-- compiling a bunch of functions and data types
data CompiledByteCode
= ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
ItblEnv -- A mapping from DataCons to their itbls
instance Outputable CompiledByteCode where
ppr (ByteCode bcos _) = ppr bcos
data UnlinkedBCO
= UnlinkedBCO {
unlinkedBCOName :: Name,
unlinkedBCOArity :: Int,
unlinkedBCOInstrs :: ByteArray#, -- insns
unlinkedBCOBitmap :: ByteArray#, -- bitmap
unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs
unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
}
data BCOPtr
= BCOPtrName Name
| BCOPtrPrimOp PrimOp
| BCOPtrBCO UnlinkedBCO
| BCOPtrBreakInfo BreakInfo
| BCOPtrArray (MutableByteArray# RealWorld)
data BCONPtr
= BCONPtrWord Word
| BCONPtrLbl FastString
| BCONPtrItbl Name
-- | Finds external references. Remember to remove the names
-- defined by this group of BCOs themselves
bcoFreeNames :: UnlinkedBCO -> NameSet
......@@ -105,12 +77,6 @@ bcoFreeNames bco
map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
)
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
= sep [text "BCO", ppr nm, text "with",
ppr (sizeSS lits), text "lits",
ppr (sizeSS ptrs), text "ptrs" ]
-- -----------------------------------------------------------------------------
-- The bytecode assembler
......@@ -122,11 +88,11 @@ instance Outputable UnlinkedBCO where
-- bytecode address in this BCO.
-- Top level assembler fn.
assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs dflags proto_bcos tycons
= do itblenv <- mkITbls dflags tycons
bcos <- mapM (assembleBCO dflags) proto_bcos
return (ByteCode bcos itblenv)
assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons = do
itblenv <- mkITbls hsc_env tycons
bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
return (ByteCode bcos itblenv (concat (map protoBCOFFIs proto_bcos)))
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
......@@ -161,15 +127,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
ASSERT(n_insns == sizeSS final_insns) return ()
let asm_insns = ssElts final_insns
barr a = case a of UArray _lo _hi _n b -> b
insns_arr = Array.listArray (0, n_insns - 1) asm_insns
!insns_barr = barr insns_arr
insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
bitmap_arr = mkBitmapArray bsize bitmap
!bitmap_barr = barr bitmap_arr
ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
......@@ -191,23 +151,6 @@ type AsmState = (SizedSeq Word16,
SizedSeq BCONPtr,
SizedSeq BCOPtr)
data SizedSeq a = SizedSeq !Word [a]
emptySS :: SizedSeq a
emptySS = SizedSeq 0 []
addToSS :: SizedSeq a -> a -> SizedSeq a
addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)
addListToSS :: SizedSeq a -> [a] -> SizedSeq a
addListToSS (SizedSeq n r_xs) xs
= SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)
ssElts :: SizedSeq a -> [a]
ssElts (SizedSeq _ r_xs) = reverse r_xs
sizeSS :: SizedSeq a -> Word
sizeSS (SizedSeq n _) = n
data Operand
= Op Word
| SmallOp Word16
......@@ -365,9 +308,7 @@ assembleI dflags i = case i of
-> do let ul_bco = assembleBCO dflags proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p]
PUSH_UBX (Left lit) nws -> do np <- literal lit
emit bci_PUSH_UBX [Op np, SmallOp nws]
PUSH_UBX (Right aa) nws -> do np <- addr aa
PUSH_UBX lit nws -> do np <- literal lit
emit bci_PUSH_UBX [Op np, SmallOp nws]
PUSH_APPLY_N -> emit bci_PUSH_APPLY_N []
......@@ -437,7 +378,9 @@ assembleI dflags i = case i of
literal (MachChar c) = int (ord c)
literal (MachInt64 ii) = int64 (fromIntegral ii)
literal (MachWord64 ii) = int64 (fromIntegral ii)
literal other = pprPanic "ByteCodeAsm.literal" (ppr other)
literal (MachStr bs) = lit [BCONPtrStr (bs `B.snoc` 0)]
-- MachStr requires a zero-terminator when emitted
literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger"
litlabel fs = lit [BCONPtrLbl fs]
addr = words . mkLitPtr
......
......@@ -9,11 +9,13 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
import ByteCodeInstr
import ByteCodeItbls
import ByteCodeAsm
import ByteCodeLink
import LibFFI
import ByteCodeTypes
import GHCi
import GHCi.FFI
import GHCi.RemoteTypes
import BasicTypes
import DynFlags
import Outputable
import Platform
......@@ -45,7 +47,6 @@ import OrdList
import Data.List
import Foreign
import Foreign.C
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
......@@ -59,8 +60,6 @@ import Data.Maybe
import Module
import Control.Arrow ( second )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
......@@ -69,42 +68,43 @@ import Data.Ord
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
byteCodeGen :: DynFlags
byteCodeGen :: HscEnv
-> Module
-> CoreProgram
-> [TyCon]
-> ModBreaks
-> IO CompiledByteCode
byteCodeGen dflags this_mod binds tycs modBreaks
= do showPass dflags "ByteCodeGen"
byteCodeGen hsc_env this_mod binds tycs modBreaks
= do let dflags = hsc_dflags hsc_env
showPass dflags "ByteCodeGen"
let flatBinds = [ (bndr, simpleFreeVars rhs)
| (bndr, rhs) <- flattenBinds binds]
us <- mkSplitUniqSupply 'y'
(BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos)
<- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds)
(BcM_State _hsc_env _us _this_mod _final_ctr ffis _, proto_bcos)
<- runBc hsc_env us this_mod modBreaks (mapM schemeTopBind flatBinds)
when (notNull mallocd)
when (notNull ffis)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
assembleBCOs dflags proto_bcos tycs
where
assembleBCOs hsc_env proto_bcos tycs
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
-- Returns: (the root BCO for this expression,
-- a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
coreExprToBCOs :: HscEnv
-> Module
-> CoreExpr
-> IO UnlinkedBCO
coreExprToBCOs dflags this_mod expr
= do showPass dflags "ByteCodeGen"
coreExprToBCOs hsc_env this_mod expr
= do let dflags = hsc_dflags hsc_env
showPass dflags "ByteCodeGen"
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
......@@ -115,7 +115,7 @@ coreExprToBCOs dflags this_mod expr
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
<- runBc dflags us this_mod emptyModBreaks $
<- runBc hsc_env us this_mod emptyModBreaks $
schemeTopBind (invented_id, simpleFreeVars expr)
when (notNull mallocd)
......@@ -184,9 +184,9 @@ mkProtoBCO
-> Word16
-> [StgWord]
-> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
-> [FFIInfo]
-> ProtoBCO name
mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
......@@ -194,7 +194,7 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallo
protoBCOBitmapSize = bitmap_size,
protoBCOArity = arity,
protoBCOExpr = origin,
protoBCOPtrs = mallocd_blocks
protoBCOFFIs = ffis
}
where
-- Overestimate the stack usage (in words) of this BCO,
......@@ -1042,27 +1042,23 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
void marshall_code ( StgWord* ptr_to_top_of_stack )
-}
-- resolve static address
get_target_info = do
maybe_static_target =
case target of
DynamicTarget
-> return (False, panic "ByteCodeGen.generateCCall(dyn)")
DynamicTarget -> Nothing
StaticTarget _ _ _ False ->
panic "generateCCall: unexpected FFI value import"
StaticTarget _ target _ True
-> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
return (True, res)
panic "generateCCall: unexpected FFI value import"
StaticTarget _ target _ True ->
Just (MachLabel target mb_size IsFunction)
where
stdcall_adj_target
mb_size
| OSMinGW32 <- platformOS (targetPlatform dflags)
, StdCallConv <- cconv
= let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in
mkFastString (unpackFS target ++ '@':show size)
= Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
| otherwise
= target
= Nothing
(is_static, static_target_addr) <- get_target_info
let
is_static = isJust maybe_static_target
-- Get the arg reps, zapping the leading Addr# in the dynamic case
a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
......@@ -1073,8 +1069,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- push the Addr#
(push_Addr, d_after_Addr)
| is_static
= (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
| Just machlabel <- maybe_static_target
= (toOL [PUSH_UBX machlabel addr_sizeW],
d_after_args + fromIntegral addr_sizeW)
| otherwise -- is already on the stack
= (nilOL, d_after_args)
......@@ -1086,7 +1082,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
r_lit = mkDummyLiteral r_rep
push_r = (if returns_void
then nilOL
else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
else unitOL (PUSH_UBX r_lit r_sizeW))
-- generate the marshalling code we're going to call
......@@ -1096,16 +1092,26 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- is. See comment in Interpreter.c with the CCALL instruction.
stk_offset = trunc16 $ d_after_r - s
conv = case cconv of
CCallConv -> FFICCall
StdCallConv -> FFIStdCall
_ -> panic "ByteCodeGen: unexpected calling convention"
-- the only difference in libffi mode is that we prepare a cif
-- describing the call type by calling libffi, and we attach the
-- address of this to the CCALL instruction.
token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep
let addr_of_marshaller = castPtrToFunPtr token
recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
let ffires = primRepToFFIType dflags r_rep
ffiargs = map (primRepToFFIType dflags) a_reps
hsc_env <- getHscEnv
rp <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
let token = fromRemotePtr rp
recordFFIBc token
let
-- do the call
do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
do_call = unitOL (CCALL stk_offset token
(fromIntegral (fromEnum (playInterruptible safety))))
-- slide and return
wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
......@@ -1116,6 +1122,24 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
)
primRepToFFIType :: DynFlags -> PrimRep -> FFIType
primRepToFFIType dflags r
= case r of
VoidRep -> FFIVoid
IntRep -> signed_word
WordRep -> unsigned_word
Int64Rep -> FFISInt64
Word64Rep -> FFIUInt64