Remote GHCi, -fexternal-interpreter
authorSimon Marlow <marlowsd@gmail.com>
Wed, 18 Nov 2015 16:42:24 +0000 (16:42 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Thu, 17 Dec 2015 09:39:52 +0000 (09:39 +0000)
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

101 files changed:
.gitignore
aclocal.m4
compiler/basicTypes/BasicTypes.hs
compiler/basicTypes/Literal.hs
compiler/coreSyn/MkCore.hs
compiler/deSugar/Coverage.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/ghci/ByteCodeAsm.hs
compiler/ghci/ByteCodeGen.hs
compiler/ghci/ByteCodeInstr.hs
compiler/ghci/ByteCodeItbls.hs
compiler/ghci/ByteCodeLink.hs
compiler/ghci/ByteCodeTypes.hs [new file with mode: 0644]
compiler/ghci/Debugger.hs
compiler/ghci/DebuggerUtils.hs
compiler/ghci/GHCi.hs [new file with mode: 0644]
compiler/ghci/Linker.hs
compiler/ghci/RtClosureInspect.hs
compiler/main/Annotations.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/DynamicLoading.hs
compiler/main/GHC.hs
compiler/main/GhcMake.hs
compiler/main/GhcPlugins.hs
compiler/main/Hooks.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.hs
compiler/main/InteractiveEval.hs
compiler/main/InteractiveEvalTypes.hs
compiler/main/SysTools.hs
compiler/specialise/SpecConstr.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcSplice.hs-boot
compiler/utils/Binary.hs
compiler/utils/Outputable.hs
compiler/utils/Panic.hs
ghc.mk
ghc/GhciMonad.hs
ghc/InteractiveUI.hs
ghc/Main.hs
ghc/ghc-bin.cabal.in
iserv/Main.hs [new file with mode: 0644]
iserv/Makefile [new file with mode: 0644]
iserv/ghc.mk [new file with mode: 0644]
iserv/iserv-bin.cabal [new file with mode: 0644]
iserv/iservmain.c [new file with mode: 0644]
libraries/ghc-boot/GHC/LanguageExtensions.hs
libraries/ghc-boot/GHC/Serialized.hs [moved from compiler/utils/Serialized.hs with 90% similarity]
libraries/ghc-boot/ghc-boot.cabal
libraries/ghci/GHCi/CreateBCO.hs [new file with mode: 0644]
libraries/ghci/GHCi/FFI.hsc [new file with mode: 0644]
libraries/ghci/GHCi/InfoTable.hsc [new file with mode: 0644]
libraries/ghci/GHCi/Message.hs [new file with mode: 0644]
libraries/ghci/GHCi/ObjLink.hs [moved from compiler/ghci/ObjLink.hs with 72% similarity]
libraries/ghci/GHCi/RemoteTypes.hs [new file with mode: 0644]
libraries/ghci/GHCi/ResolvedBCO.hs [new file with mode: 0644]
libraries/ghci/GHCi/Run.hs [new file with mode: 0644]
libraries/ghci/GHCi/Signals.hs [new file with mode: 0644]
libraries/ghci/GHCi/TH.hs [new file with mode: 0644]
libraries/ghci/GHCi/TH/Binary.hs [new file with mode: 0644]
libraries/ghci/GNUmakefile [new file with mode: 0644]
libraries/ghci/LICENSE [new file with mode: 0644]
libraries/ghci/SizedSeq.hs [new file with mode: 0644]
libraries/ghci/ghc.mk [new file with mode: 0644]
libraries/ghci/ghci.cabal [new file with mode: 0644]
rts/Interpreter.c
rules/build-prog.mk
rules/shell-wrapper.mk
testsuite/config/ghc
testsuite/driver/testlib.py
testsuite/tests/annotations/should_run/annrun01.hs
testsuite/tests/cabal/cabal04/Makefile
testsuite/tests/cabal/cabal04/all.T
testsuite/tests/ghc-api/T4891/T4891.hs
testsuite/tests/ghci.debugger/scripts/break006.stderr
testsuite/tests/ghci.debugger/scripts/break011.script
testsuite/tests/ghci.debugger/scripts/break011.stdout
testsuite/tests/ghci.debugger/scripts/break013.stdout
testsuite/tests/ghci.debugger/scripts/break024.stdout
testsuite/tests/ghci.debugger/scripts/print019.stderr
testsuite/tests/ghci/prog001/prog001-ext.stdout [new file with mode: 0644]
testsuite/tests/ghci/prog001/prog001.T
testsuite/tests/ghci/scripts/T10110A.hs
testsuite/tests/ghci/scripts/all.T
testsuite/tests/profiling/should_run/scc003.prof.sample
testsuite/tests/rts/LinkerUnload.hs
testsuite/tests/rts/T2615.hs
testsuite/tests/th/Makefile
testsuite/tests/th/TH_Roles2.stderr
testsuite/tests/th/TH_finalizer.hs [new file with mode: 0644]
testsuite/tests/th/TH_finalizer.stderr [new file with mode: 0644]
testsuite/tests/th/TH_spliceE5_prof_ext.hs [new file with mode: 0644]
testsuite/tests/th/TH_spliceE5_prof_ext.stdout [new file with mode: 0644]
testsuite/tests/th/TH_spliceE5_prof_ext_Lib.hs [new file with mode: 0644]
testsuite/tests/th/all.T
utils/ghctags/Main.hs

index bfd567e..ae23fbb 100644 (file)
@@ -72,6 +72,7 @@ _darcs/
 /ghc/stage1/
 /ghc/stage2/
 /ghc/stage3/
+/iserv/stage2*/
 
 # -----------------------------------------------------------------------------
 # specific generated files
index e46a19f..79b980a 100644 (file)
@@ -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"
index 4133eac..f8d4e8f 100644 (file)
@@ -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
-
 {-
 ************************************************************************
 *                                                                      *
index 5f3b75d..f1a99f7 100644 (file)
@@ -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]
index c3e445a..07db78a 100644 (file)
@@ -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))
 
 {-
 ************************************************************************
index 85f603f..958aa12 100644 (file)
@@ -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 $
index 8dc4e23..ae702ef 100644 (file)
@@ -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
index dc22eb6..d93b879 100644 (file)
@@ -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
-
index c69cede..875de87 100644 (file)
@@ -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
index f331214..f74b4c4 100644 (file)
@@ -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
+     AddrRep     -> FFIPointer
+     FloatRep    -> FFIFloat
+     DoubleRep   -> FFIDouble
+     _           -> panic "primRepToFFIType"
+  where
+    (signed_word, unsigned_word)
+       | wORD_SIZE dflags == 4  = (FFISInt32, FFIUInt32)
+       | wORD_SIZE dflags == 8  = (FFISInt64, FFIUInt64)
+       | otherwise              = panic "primTyDescChar"
+
 -- Make a dummy literal, to be used as a placeholder for FFI return
 -- values on the stack.
 mkDummyLiteral :: PrimRep -> Literal
@@ -1240,7 +1264,7 @@ implement_tagToId d s p arg names
            steps = map (mkStep label_exit) infos
 
        return (push_arg
-               `appOL` unitOL (PUSH_UBX (Left MachNullAddr) 1)
+               `appOL` unitOL (PUSH_UBX MachNullAddr 1)
                    -- Push bogus word (see Note [Implementing tagToEnum#])
                `appOL` concatOL steps
                `appOL` toOL [ LABEL label_fail, CASEFAIL,
@@ -1319,7 +1343,7 @@ pushAtom _ _ (AnnLit lit) = do
      dflags <- getDynFlags
      let code rep
              = let size_host_words = fromIntegral (argRepSizeW dflags rep)
-               in  return (unitOL (PUSH_UBX (Left lit) size_host_words),
+               in  return (unitOL (PUSH_UBX lit size_host_words),
                            size_host_words)
 
      case lit of
@@ -1332,42 +1356,16 @@ pushAtom _ _ (AnnLit lit) = do
         MachDouble _  -> code D
         MachChar _    -> code N
         MachNullAddr  -> code N
-        MachStr s     -> pushStr s
+        MachStr _     -> code N
         -- No LitInteger's should be left by the time this is called.
         -- CorePrep should have converted them all to a real core
         -- representation.
         LitInteger {} -> panic "pushAtom: LitInteger"
-     where
-        pushStr s
-           = let getMallocvilleAddr
-                    =
-                            -- we could grab the Ptr from the ForeignPtr,
-                            -- but then we have no way to control its lifetime.
-                            -- In reality it'll probably stay alive long enoungh
-                            -- by virtue of the global FastString table, but
-                            -- to be on the safe side we copy the string into
-                            -- a malloc'd area of memory.
-                                do let n = BS.length s
-                                   ptr <- ioToBc (mallocBytes (n+1))
-                                   recordMallocBc ptr
-                                   ioToBc (
-                                      BS.unsafeUseAsCString s $ \p -> do
-                                         memcpy ptr p (fromIntegral n)
-                                         pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
-                                         return ptr
-                                      )
-             in do
-                addr <- getMallocvilleAddr
-                -- Get the addr on the stack, untaggedly
-                return (unitOL (PUSH_UBX (Right addr) 1), 1)
 
 pushAtom _ _ expr
    = pprPanic "ByteCodeGen.pushAtom"
               (pprCoreExpr (deAnnotate (undefined, expr)))
 
-foreign import ccall unsafe "memcpy"
- memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
-
 
 -- -----------------------------------------------------------------------------
 -- Given a bunch of alts code and their discrs, do the donkey work
@@ -1627,15 +1625,13 @@ typeArgRep = toArgRep . typePrimRep
 -- -----------------------------------------------------------------------------
 -- The bytecode generator's monad
 
-type BcPtr = Either ItblPtr (Ptr ())
-
 data BcM_State
    = BcM_State
-        { bcm_dflags :: DynFlags
-        , uniqSupply :: UniqSupply       -- for generating fresh variable names
-        , thisModule :: Module           -- current module (for breakpoints)
-        , nextlabel :: Word16            -- for generating local labels
-        , malloced  :: [BcPtr]           -- thunks malloced for current BCO
+        { bcm_hsc_env :: HscEnv
+        , uniqSupply  :: UniqSupply      -- for generating fresh variable names
+        , thisModule  :: Module          -- current module (for breakpoints)
+        , nextlabel   :: Word16          -- for generating local labels
+        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
                                          -- Should be free()d when it is GCd
         , breakArray :: BreakArray       -- array of breakpoint flags
         }
@@ -1647,10 +1643,10 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r
+runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r
       -> IO (BcM_State, r)
-runBc dflags us this_mod modBreaks (BcM m)
-   = m (BcM_State dflags us this_mod 0 [] breakArray)
+runBc hsc_env us this_mod modBreaks (BcM m)
+   = m (BcM_State hsc_env us this_mod 0 [] breakArray)
    where
    breakArray = modBreaks_flags modBreaks
 
@@ -1684,19 +1680,18 @@ instance Monad BcM where
   return = pure
 
 instance HasDynFlags BcM where
-    getDynFlags = BcM $ \st -> return (st, bcm_dflags st)
+    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
 
-emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
-emitBc bco
-  = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
+getHscEnv :: BcM HscEnv
+getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
 
-recordMallocBc :: Ptr a -> BcM ()
-recordMallocBc a
-  = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
+emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc bco
+  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
 
-recordItblMallocBc :: ItblPtr -> BcM ()
-recordItblMallocBc a
-  = BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
+recordFFIBc :: Ptr () -> BcM ()
+recordFFIBc a
+  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
 
 getLabelBc :: BcM Word16
 getLabelBc
index 2de4941..4f2b82b 100644 (file)
@@ -6,17 +6,15 @@
 
 -- | ByteCodeInstrs: Bytecode instruction definitions
 module ByteCodeInstr (
-        BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..)
+        BCInstr(..), ProtoBCO(..), bciStackUse,
   ) where
 
 #include "HsVersions.h"
 #include "../includes/MachDeps.h"
 
-import ByteCodeItbls    ( ItblPtr )
-
+import ByteCodeTypes
 import StgCmmLayout     ( ArgRep(..) )
 import PprCore
-import Type
 import Outputable
 import FastString
 import Name
@@ -28,7 +26,6 @@ import VarSet
 import PrimOp
 import SMRep
 
-import Module (Module)
 import GHC.Exts
 import Data.Word
 
@@ -46,7 +43,7 @@ data ProtoBCO a
         -- what the BCO came from
         protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
         -- malloc'd pointers
-        protoBCOPtrs       :: [Either ItblPtr (Ptr ())]
+        protoBCOFFIs       :: [FFIInfo]
    }
 
 type LocalLabel = Word16
@@ -70,7 +67,7 @@ data BCInstr
    | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
 
    -- Pushing literals
-   | PUSH_UBX  (Either Literal (Ptr ())) Word16
+   | PUSH_UBX  Literal Word16
         -- push this int/float/double/addr, on the stack. Word16
         -- is # of words to copy from literal pool.  Eitherness reflects
         -- the difficulty of dealing with MachAddr here, mostly due to
@@ -144,28 +141,13 @@ data BCInstr
    -- Breakpoints
    | BRK_FUN          (MutableByteArray# RealWorld) Word16 BreakInfo
 
-data BreakInfo
-   = BreakInfo
-   { breakInfo_module :: Module
-   , breakInfo_number :: {-# UNPACK #-} !Int
-   , breakInfo_vars   :: [(Id,Word16)]
-   , breakInfo_resty  :: Type
-   }
-
-instance Outputable BreakInfo where
-   ppr info = text "BreakInfo" <+>
-              parens (ppr (breakInfo_module info) <+>
-                      ppr (breakInfo_number info) <+>
-                      ppr (breakInfo_vars info) <+>
-                      ppr (breakInfo_resty info))
-
 -- -----------------------------------------------------------------------------
 -- Printing bytecode instructions
 
 instance Outputable a => Outputable (ProtoBCO a) where
-   ppr (ProtoBCO name instrs bitmap bsize arity origin malloced)
+   ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)
       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
-                <+> text (show malloced) <> colon)
+                <+> text (show ffis) <> colon)
         $$ nest 3 (case origin of
                       Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
                                                        (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
@@ -210,19 +192,18 @@ instance Outputable BCInstr where
    ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)
    ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
 
-   ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
-   ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa)
-   ppr PUSH_APPLY_N             = text "PUSH_APPLY_N"
-   ppr PUSH_APPLY_V             = text "PUSH_APPLY_V"
-   ppr PUSH_APPLY_F             = text "PUSH_APPLY_F"
-   ppr PUSH_APPLY_D             = text "PUSH_APPLY_D"
-   ppr PUSH_APPLY_L             = text "PUSH_APPLY_L"
-   ppr PUSH_APPLY_P             = text "PUSH_APPLY_P"
-   ppr PUSH_APPLY_PP            = text "PUSH_APPLY_PP"
-   ppr PUSH_APPLY_PPP           = text "PUSH_APPLY_PPP"
-   ppr PUSH_APPLY_PPPP          = text "PUSH_APPLY_PPPP"
-   ppr PUSH_APPLY_PPPPP         = text "PUSH_APPLY_PPPPP"
-   ppr PUSH_APPLY_PPPPPP        = text "PUSH_APPLY_PPPPPP"
+   ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
+   ppr PUSH_APPLY_N          = text "PUSH_APPLY_N"
+   ppr PUSH_APPLY_V          = text "PUSH_APPLY_V"
+   ppr PUSH_APPLY_F          = text "PUSH_APPLY_F"
+   ppr PUSH_APPLY_D          = text "PUSH_APPLY_D"
+   ppr PUSH_APPLY_L          = text "PUSH_APPLY_L"
+   ppr PUSH_APPLY_P          = text "PUSH_APPLY_P"
+   ppr PUSH_APPLY_PP         = text "PUSH_APPLY_PP"
+   ppr PUSH_APPLY_PPP        = text "PUSH_APPLY_PPP"
+   ppr PUSH_APPLY_PPPP       = text "PUSH_APPLY_PPPP"
+   ppr PUSH_APPLY_PPPPP      = text "PUSH_APPLY_PPPPP"
+   ppr PUSH_APPLY_PPPPPP     = text "PUSH_APPLY_PPPPPP"
 
    ppr (SLIDE n d)           = text "SLIDE   " <+> ppr n <+> ppr d
    ppr (ALLOC_AP sz)         = text "ALLOC_AP   " <+> ppr sz
index 01420f5..5a3e6d3 100644 (file)
 --
 
 -- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes
-module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls, peekItbl
-                     , StgInfoTable(..)
-                     ) where
+module ByteCodeItbls ( mkITbls ) where
 
 #include "HsVersions.h"
 
+import ByteCodeTypes
+import GHCi
+import GHCi.RemoteTypes
 import DynFlags
-import Panic
-import Platform
+import HscTypes
 import Name             ( Name, getName )
 import NameEnv
 import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
 import Type             ( flattenRepType, repType, typePrimRep )
 import StgCmmLayout     ( mkVirtHeapOffsets )
-import CmmInfo          ( conInfoTableSizeB, profInfoTableSizeW )
 import Util
-
-import Control.Monad
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.State.Strict
-import Data.Maybe
-import Foreign
-import Foreign.C
-
-import GHC.Exts         ( Int(I#), addr2Int# )
-import GHC.Ptr          ( FunPtr(..) )
+import Panic
 
 {-
   Manufacturing of info tables for DataCons
 -}
 
-newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
-
-itblCode :: DynFlags -> ItblPtr -> Ptr ()
-itblCode dflags (ItblPtr ptr)
- | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags
- | otherwise            = castPtr ptr
-
-type ItblEnv = NameEnv (Name, ItblPtr)
-        -- We need the Name in the range so we know which
-        -- elements to filter out when unloading a module
+-- Make info tables for the data decls in this module
+mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv
+mkITbls hsc_env tcs =
+  foldr plusNameEnv emptyNameEnv <$>
+    mapM (mkITbl hsc_env) (filter isDataTyCon tcs)
+ where
+  mkITbl :: HscEnv -> TyCon -> IO ItblEnv
+  mkITbl hsc_env tc
+    | dcs `lengthIs` n -- paranoia; this is an assertion.
+    = make_constr_itbls hsc_env dcs
+       where
+          dcs = tyConDataCons tc
+          n   = tyConFamilySize tc
+  mkITbl _ _ = panic "mkITbl"
 
 mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
 mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
 
-
--- Make info tables for the data decls in this module
-mkITbls :: DynFlags -> [TyCon] -> IO ItblEnv
-mkITbls _ [] = return emptyNameEnv
-mkITbls dflags (tc:tcs) = do itbls  <- mkITbl dflags tc
-                             itbls2 <- mkITbls dflags tcs
-                             return (itbls `plusNameEnv` itbls2)
-
-mkITbl :: DynFlags -> TyCon -> IO ItblEnv
-mkITbl dflags tc
-   | not (isDataTyCon tc)
-   = return emptyNameEnv
-   | dcs `lengthIs` n -- paranoia; this is an assertion.
-   = make_constr_itbls dflags dcs
-     where
-        dcs = tyConDataCons tc
-        n   = tyConFamilySize tc
-
-mkITbl _ _ = error "Unmatched patter in mkITbl: assertion failed!"
-
-#include "../includes/rts/storage/ClosureTypes.h"
-cONSTR :: Int   -- Defined in ClosureTypes.h
-cONSTR = CONSTR
-
 -- Assumes constructors are numbered from zero, not one
-make_constr_itbls :: DynFlags -> [DataCon] -> IO ItblEnv
-make_constr_itbls dflags cons
-   = do is <- mapM mk_dirret_itbl (zip cons [0..])
-        return (mkItblEnv is)
-     where
-        mk_dirret_itbl (dcon, conNo)
-           = mk_itbl dcon conNo stg_interp_constr_entry
-
-        mk_itbl :: DataCon -> Int -> EntryFunPtr -> IO (Name,ItblPtr)
-        mk_itbl dcon conNo entry_addr = do
-           let rep_args = [ (typePrimRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ]
-               (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
-
-               ptrs'  = ptr_wds
-               nptrs' = tot_wds - ptr_wds
-               nptrs_really
-                  | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
-                  | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
-               code' = mkJumpToAddr dflags entry_addr
-               itbl  = StgInfoTable {
-                           entry = if ghciTablesNextToCode
-                                   then Nothing
-                                   else Just entry_addr,
-                           ptrs  = fromIntegral ptrs',
-                           nptrs = fromIntegral nptrs_really,
-                           tipe  = fromIntegral cONSTR,
-                           srtlen = fromIntegral conNo,
-                           code  = if ghciTablesNextToCode
-                                   then Just code'
-                                   else Nothing
-                        }
-
-               -- Make a piece of code to jump to "entry_label".
-               -- This is the only arch-dependent bit.
-           addrCon <- newExecConItbl dflags itbl (dataConIdentity dcon)
-                    --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
-                    --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
-                    --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
-           return (getName dcon, ItblPtr (castFunPtrToPtr addrCon))
-
-
--- Make code which causes a jump to the given address.  This is the
--- only arch-dependent bit of the itbl story.
-
--- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
-#include "nativeGen/NCG.h"
-
-type ItblCodes = Either [Word8] [Word32]
-
-funPtrToInt :: FunPtr a -> Int
-funPtrToInt (FunPtr a#) = I# (addr2Int# a#)
-
-mkJumpToAddr :: DynFlags -> EntryFunPtr -> ItblCodes
-mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
-    ArchSPARC ->
-        -- After some consideration, we'll try this, where
-        -- 0x55555555 stands in for the address to jump to.
-        -- According to includes/rts/MachRegs.h, %g3 is very
-        -- likely indeed to be baggable.
-        --
-        --   0000 07155555              sethi   %hi(0x55555555), %g3
-        --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
-        --   0008 81C0C000              jmp     %g3
-        --   000c 01000000              nop
-
-        let w32 = fromIntegral (funPtrToInt a)
-
-            hi22, lo10 :: Word32 -> Word32
-            lo10 x = x .&. 0x3FF
-            hi22 x = (x `shiftR` 10) .&. 0x3FFFF
-
-        in Right [ 0x07000000 .|. (hi22 w32),
-                   0x8610E000 .|. (lo10 w32),
-                   0x81C0C000,
-                   0x01000000 ]
-
-    ArchPPC ->
-        -- We'll use r12, for no particular reason.
-        -- 0xDEADBEEF stands for the address:
-        -- 3D80DEAD lis r12,0xDEAD
-        -- 618CBEEF ori r12,r12,0xBEEF
-        -- 7D8903A6 mtctr r12
-        -- 4E800420 bctr
-
-        let w32 = fromIntegral (funPtrToInt a)
-            hi16 x = (x `shiftR` 16) .&. 0xFFFF
-            lo16 x = x .&. 0xFFFF
-        in Right [ 0x3D800000 .|. hi16 w32,
-                   0x618C0000 .|. lo16 w32,
-                   0x7D8903A6, 0x4E800420 ]
-
-    ArchX86 ->
-        -- Let the address to jump to be 0xWWXXYYZZ.
-        -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
-        -- which is
-        -- B8 ZZ YY XX WW FF E0
-
-        let w32 = fromIntegral (funPtrToInt a) :: Word32
-            insnBytes :: [Word8]
-            insnBytes
-               = [0xB8, byte0 w32, byte1 w32,
-                        byte2 w32, byte3 w32,
-                  0xFF, 0xE0]
-        in
-            Left insnBytes
-
-    ArchX86_64 ->
-        -- Generates:
-        --      jmpq *.L1(%rip)
-        --      .align 8
-        -- .L1:
-        --      .quad <addr>
-        --
-        -- which looks like:
-        --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>
-        -- with addr at 10.
-        --
-        -- We need a full 64-bit pointer (we can't assume the info table is
-        -- allocated in low memory).  Assuming the info pointer is aligned to
-        -- an 8-byte boundary, the addr will also be aligned.
-
-        let w64 = fromIntegral (funPtrToInt a) :: Word64
-            insnBytes :: [Word8]
-            insnBytes
-               = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
-                  byte0 w64, byte1 w64, byte2 w64, byte3 w64,
-                  byte4 w64, byte5 w64, byte6 w64, byte7 w64]
-        in
-            Left insnBytes
-
-    ArchAlpha ->
-        let w64 = fromIntegral (funPtrToInt a) :: Word64
-        in Right [ 0xc3800000      -- br   at, .+4
-                 , 0xa79c000c      -- ldq  at, 12(at)
-                 , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
-                 , 0x47ff041f      -- nop
-                 , fromIntegral (w64 .&. 0x0000FFFF)
-                 , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
-
-    ArchARM { } ->
-        -- Generates Arm sequence,
-        --      ldr r1, [pc, #0]
-        --      bx r1
-        --
-        -- which looks like:
-        --     00000000 <.addr-0x8>:
-        --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>
-        --     4:       11ff2fe1    bx     r1
-        let w32 = fromIntegral (funPtrToInt a) :: Word32
-        in Left [ 0x00, 0x10, 0x9f, 0xe5
-                , 0x11, 0xff, 0x2f, 0xe1
-                , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
-
-    arch ->
-        panic ("mkJumpToAddr not defined for " ++ show arch)
-
-byte0 :: (Integral w) => w -> Word8
-byte0 w = fromIntegral w
-
-byte1, byte2, byte3, byte4, byte5, byte6, byte7
-       :: (Integral w, Bits w) => w -> Word8
-byte1 w = fromIntegral (w `shiftR` 8)
-byte2 w = fromIntegral (w `shiftR` 16)
-byte3 w = fromIntegral (w `shiftR` 24)
-byte4 w = fromIntegral (w `shiftR` 32)
-byte5 w = fromIntegral (w `shiftR` 40)
-byte6 w = fromIntegral (w `shiftR` 48)
-byte7 w = fromIntegral (w `shiftR` 56)
-
--- entry point for direct returns for created constr itbls
-foreign import ccall "&stg_interp_constr_entry"
-    stg_interp_constr_entry :: EntryFunPtr
-
-
-
-
--- Ultra-minimalist version specially for constructors
-#if SIZEOF_VOID_P == 8
-type HalfWord = Word32
-type FullWord = Word64
-#else
-type HalfWord = Word16
-type FullWord = Word32
-#endif
-
-data StgConInfoTable = StgConInfoTable {
-   conDesc   :: Ptr Word8,
-   infoTable :: StgInfoTable
-}
-
-sizeOfConItbl :: DynFlags -> StgConInfoTable -> Int
-sizeOfConItbl dflags conInfoTable
-      = sum [ fieldSz conDesc conInfoTable
-            , sizeOfItbl dflags (infoTable conInfoTable) ]
-
-pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable
-            -> StgConInfoTable
-            -> IO ()
-pokeConItbl dflags wr_ptr ex_ptr itbl
-      = flip evalStateT (castPtr wr_ptr) $ do
-           when ghciTablesNextToCode $ do
-               let con_desc = conDesc itbl `minusPtr`
-                      (ex_ptr `plusPtr` conInfoTableSizeB dflags)
-               store (fromIntegral con_desc :: Word32)
-               when (wORD_SIZE dflags == 8) $
-                  store (fromIntegral con_desc :: Word32)
-           store' (sizeOfItbl dflags) (pokeItbl dflags) (infoTable itbl)
-           unless ghciTablesNextToCode $ store (conDesc itbl)
-
-type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
-
-data StgInfoTable = StgInfoTable {
-   entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
-   ptrs   :: HalfWord,
-   nptrs  :: HalfWord,
-   tipe   :: HalfWord,
-   srtlen :: HalfWord,
-   code   :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
-  }
-
-sizeOfItbl :: DynFlags -> StgInfoTable -> Int
-sizeOfItbl dflags itbl
-      = sum
-        [
-         if ghciTablesNextToCode then 0 else fieldSz (fromJust . entry) itbl,
-         fieldSz ptrs itbl,
-         fieldSz nptrs itbl,
-         fieldSz tipe itbl,
-         fieldSz srtlen itbl,
-         if ghciTablesNextToCode then case mkJumpToAddr dflags undefined of
-                                      Left  xs -> sizeOf (head xs) * length xs
-                                      Right xs -> sizeOf (head xs) * length xs
-                                 else 0
-        ]
-        + if rtsIsProfiled then profInfoTableSizeW * wORD_SIZE dflags
-                           else 0
-
-pokeItbl :: DynFlags -> Ptr StgInfoTable -> StgInfoTable -> IO ()
-pokeItbl _ a0 itbl
-      = flip evalStateT (castPtr a0)
-      $ do
-           case entry itbl of
-               Nothing -> return ()
-               Just e  -> store e
-           when rtsIsProfiled $ do
-              store (0 :: FullWord)
-              store (0 :: FullWord)
-           store (ptrs   itbl)
-           store (nptrs  itbl)
-           store (tipe   itbl)
-           store (srtlen itbl)
-           case code itbl of
-               Nothing -> return ()
-               Just (Left  xs) -> mapM_ store xs
-               Just (Right xs) -> mapM_ store xs
-
-peekItbl :: DynFlags -> Ptr StgInfoTable -> IO StgInfoTable
-peekItbl dflags a0
-      = flip evalStateT (castPtr a0)
-      $ do
-           entry'  <- if ghciTablesNextToCode
-                      then return Nothing
-                      else liftM Just load
-           when rtsIsProfiled $ do
-              (_ :: Ptr FullWord) <- advance
-              (_ :: Ptr FullWord) <- advance
-              return ()
-           ptrs'   <- load
-           nptrs'  <- load
-           tipe'   <- load
-           srtlen' <- load
-           code'   <- if ghciTablesNextToCode
-                      then liftM Just $ case mkJumpToAddr dflags undefined of
-                                        Left xs ->
-                                            liftM Left $ sequence (replicate (length xs) load)
-                                        Right xs ->
-                                            liftM Right $ sequence (replicate (length xs) load)
-                      else return Nothing
-           return
-              StgInfoTable {
-                 entry  = entry',
-                 ptrs   = ptrs',
-                 nptrs  = nptrs',
-                 tipe   = tipe',
-                 srtlen = srtlen'
-                ,code   = code'
-              }
-
-fieldSz :: Storable b => (a -> b) -> a -> Int
-fieldSz sel x = sizeOf (sel x)
-
-type PtrIO = StateT (Ptr Word8) IO
-
-advance :: Storable a => PtrIO (Ptr a)
-advance = advance' sizeOf
-
-advance' :: (a -> Int) -> PtrIO (Ptr a)
-advance' fSizeOf = state adv
-    where adv addr = case castPtr addr of
-                     addrCast ->
-                         (addrCast,
-                          addr `plusPtr` sizeOfPointee fSizeOf addrCast)
-
-sizeOfPointee :: (a -> Int) -> Ptr a -> Int
-sizeOfPointee fSizeOf addr = fSizeOf (typeHack addr)
-    where typeHack = undefined :: Ptr a -> a
-
-store :: Storable a => a -> PtrIO ()
-store = store' sizeOf poke
-
-store' :: (a -> Int) -> (Ptr a -> a -> IO ()) -> a -> PtrIO ()
-store' fSizeOf fPoke x = do addr <- advance' fSizeOf
-                            lift (fPoke addr x)
-
-load :: Storable a => PtrIO a
-load = do addr <- advance
-          lift (peek addr)
-
-newExecConItbl :: DynFlags -> StgInfoTable -> [Word8] -> IO (FunPtr ())
-newExecConItbl dflags obj con_desc
-   = alloca $ \pcode -> do
-        let lcon_desc = length con_desc + 1{- null terminator -}
-            dummy_cinfo = StgConInfoTable { conDesc = nullPtr, infoTable = obj }
-            sz = fromIntegral (sizeOfConItbl dflags dummy_cinfo)
-               -- Note: we need to allocate the conDesc string next to the info
-               -- table, because on a 64-bit platform we reference this string
-               -- with a 32-bit offset relative to the info table, so if we
-               -- allocated the string separately it might be out of range.
-        wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
-        ex_ptr <- peek pcode
-        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
-                                    , infoTable = obj }
-        pokeConItbl dflags wr_ptr ex_ptr cinfo
-        pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc
-        _flushExec sz ex_ptr -- Cache flush (if needed)
-        return (castPtrToFunPtr ex_ptr)
-
-foreign import ccall unsafe "allocateExec"
-  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
-
-foreign import ccall unsafe "flushExec"
-  _flushExec :: CUInt -> Ptr a -> IO ()
+make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
+make_constr_itbls hsc_env cons =
+  mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
+ where
+  dflags = hsc_dflags hsc_env
+
+  mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
+  mk_itbl dcon conNo = do
+     let rep_args = [ (typePrimRep rep_arg,rep_arg)
+                    | arg <- dataConRepArgTys dcon
+                    , rep_arg <- flattenRepType (repType arg) ]
+
+         (tot_wds, ptr_wds, _) =
+             mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
+
+         ptrs'  = ptr_wds
+         nptrs' = tot_wds - ptr_wds
+         nptrs_really
+            | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
+            | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
+
+         descr = dataConIdentity dcon
+
+     r <- iservCmd hsc_env (MkConInfoTable  ptrs' nptrs_really conNo descr)
+     return (getName dcon, ItblPtr (fromRemotePtr r))
index b977f37..aa92ecc 100644 (file)
 -- | ByteCodeLink: Bytecode assembler and linker
 module ByteCodeLink (
         ClosureEnv, emptyClosureEnv, extendClosureEnv,
-        linkBCO, lookupStaticPtr, lookupName
-       ,lookupIE
+        linkBCO, lookupStaticPtr,
+        lookupIE,
+        nameToCLabel, linkFail
   ) where
 
 #include "HsVersions.h"
 
-import ByteCodeItbls
-import ByteCodeAsm
-import ObjLink
+import GHCi.RemoteTypes
+import GHCi.ResolvedBCO
+import GHCi.InfoTable
+import SizedSeq
 
-import DynFlags
-import BasicTypes
+import GHCi
+import ByteCodeTypes
+import HscTypes
 import Name
 import NameEnv
 import PrimOp
@@ -34,27 +37,21 @@ import Outputable
 import Util
 
 -- Standard libraries
-
-import Data.Array.Base
-
-import Control.Monad
-import Control.Monad.ST ( stToIO )
-
-import GHC.Arr          ( Array(..), STArray(..) )
+import Data.Array.Unboxed
+import Foreign.Ptr
 import GHC.IO           ( IO(..) )
 import GHC.Exts
-import GHC.Ptr          ( castPtr )
 
 {-
   Linking interpretables into something we can run
 -}
 
-type ClosureEnv = NameEnv (Name, HValue)
+type ClosureEnv = NameEnv (Name, ForeignHValue)
 
 emptyClosureEnv :: ClosureEnv
 emptyClosureEnv = emptyNameEnv
 
-extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
+extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
 extendClosureEnv cl_env pairs
   = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
 
@@ -62,173 +59,86 @@ extendClosureEnv cl_env pairs
   Linking interpretables into something we can run
 -}
 
-{-
-data BCO# = BCO# ByteArray#             -- instrs   :: Array Word16#
-                 ByteArray#             -- literals :: Array Word32#
-                 PtrArray#              -- ptrs     :: Array HValue
-                 ByteArray#             -- itbls    :: Array Addr#
--}
-
-linkBCO :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
-linkBCO dflags ie ce ul_bco
-   = do BCO bco# <- linkBCO' dflags ie ce ul_bco
-        -- SDM: Why do we need mkApUpd0 here?  I *think* it's because
-        -- 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.
-        --
-        -- Update: the above is true, but now we also have extra invariants:
-        --   (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 (unlinkedBCOArity ul_bco > 0)
-           then return (HValue (unsafeCoerce# bco#))
-           else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) }
-
-
-linkBCO' :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
-linkBCO' dflags ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS)
-   -- Raises an IO exception on failure
-   = do let literals = ssElts literalsSS
-            ptrs     = ssElts ptrsSS
-
-        linked_literals <- mapM (lookupLiteral dflags ie) literals
-
-        let n_literals = sizeSS literalsSS
-            n_ptrs     = sizeSS ptrsSS
-
-        ptrs_arr <- mkPtrsArray dflags ie ce n_ptrs ptrs
-
-        let
-            !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
-
-            litRange
-             | n_literals > 0     = (0, fromIntegral n_literals - 1)
-             | otherwise          = (1, 0)
-            literals_arr :: UArray Word Word
-            literals_arr = listArray litRange linked_literals
-            !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
-
-            !(I# arity#)  = arity
-
-        newBCO insns_barr literals_barr ptrs_parr arity# bitmap
-
-
--- we recursively link any sub-BCOs while making the ptrs array
-mkPtrsArray :: DynFlags -> ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue)
-mkPtrsArray dflags ie ce n_ptrs ptrs = do
-  let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0)
-  marr <- newArray_ ptrRange
-  let
-    fill (BCOPtrName n)     i = do
-        ptr <- lookupName ce n
-        unsafeWrite marr i ptr
-    fill (BCOPtrPrimOp op)  i = do
-        ptr <- lookupPrimOp op
-        unsafeWrite marr i ptr
-    fill (BCOPtrBCO ul_bco) i = do
-        BCO bco# <- linkBCO' dflags ie ce ul_bco
-        writeArrayBCO marr i bco#
-    fill (BCOPtrBreakInfo brkInfo) i =
-        unsafeWrite marr i (HValue (unsafeCoerce# brkInfo))
-    fill (BCOPtrArray brkArray) i =
-        unsafeWrite marr i (HValue (unsafeCoerce# brkArray))
-  zipWithM_ fill ptrs [0..]
-  unsafeFreeze marr
-
-newtype IOArray i e = IOArray (STArray RealWorld i e)
-
-instance MArray IOArray e IO where
-    getBounds (IOArray marr) = stToIO $ getBounds marr
-    getNumElements (IOArray marr) = stToIO $ getNumElements marr
-    newArray lu init = stToIO $ do
-        marr <- newArray lu init; return (IOArray marr)
-    newArray_ lu = stToIO $ do
-        marr <- newArray_ lu; return (IOArray marr)
-    unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
-    unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
-
--- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
-writeArrayBCO :: IOArray Word a -> Int -> BCO# -> IO ()
-writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
-  case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
-  (# s#, () #) }
-
-{-
-writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
-writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
-  case (unsafeCoerce# writeArray#) marr# 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 #)
-
-
-lookupLiteral :: DynFlags -> ItblEnv -> BCONPtr -> IO Word
-lookupLiteral _      _  (BCONPtrWord lit) = return lit
-lookupLiteral _      _  (BCONPtrLbl  sym) = do Ptr a# <- lookupStaticPtr sym
-                                               return (W# (int2Word# (addr2Int# a#)))
-lookupLiteral dflags ie (BCONPtrItbl nm)  = do Ptr a# <- lookupIE dflags ie nm
-                                               return (W# (int2Word# (addr2Int# a#)))
-
-lookupStaticPtr :: FastString -> IO (Ptr ())
-lookupStaticPtr addr_of_label_string
-   = do let label_to_find = unpackFS addr_of_label_string
-        m <- lookupSymbol label_to_find
-        case m of
-           Just ptr -> return ptr
-           Nothing  -> linkFail "ByteCodeLink: can't find label"
-                                label_to_find
-
-lookupPrimOp :: PrimOp -> IO HValue
-lookupPrimOp primop
-   = do let sym_to_find = primopToCLabel primop "closure"
-        m <- lookupSymbol sym_to_find
-        case m of
-           Just (Ptr addr) -> case addrToAny# addr of
-                                 (# a #) -> return (HValue a)
-           Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
-
-lookupName :: ClosureEnv -> Name -> IO HValue
-lookupName ce nm
-   = case lookupNameEnv ce nm of
-        Just (_,aa) -> return aa
-        Nothing
-           -> ASSERT2(isExternalName nm, ppr nm)
-              do let sym_to_find = nameToCLabel nm "closure"
-                 m <- lookupSymbol sym_to_find
-                 case m of
-                    Just (Ptr addr) -> case addrToAny# addr of
-                                          (# a #) -> return (HValue a)
-                    Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find
-
-lookupIE :: DynFlags -> ItblEnv -> Name -> IO (Ptr a)
-lookupIE dflags ie con_nm
-   = case lookupNameEnv ie con_nm of
-        Just (_, a) -> return (castPtr (itblCode dflags a))
-        Nothing
-           -> do -- try looking up in the object files.
-                 let sym_to_find1 = nameToCLabel con_nm "con_info"
-                 m <- lookupSymbol sym_to_find1
-                 case m of
-                    Just addr -> return addr
-                    Nothing
-                       -> do -- perhaps a nullary constructor?
-                             let sym_to_find2 = nameToCLabel con_nm "static_info"
-                             n <- lookupSymbol sym_to_find2
-                             case n of
-                                Just addr -> return addr
-                                Nothing   -> linkFail "ByteCodeLink.lookupIE"
-                                                (sym_to_find1 ++ " or " ++ sym_to_find2)
+linkBCO
+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> UnlinkedBCO
+  -> IO ResolvedBCO
+linkBCO hsc_env ie ce bco_ix
+           (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
+  lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0)
+  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix) (ssElts ptrs0)
+  return (ResolvedBCO arity insns bitmap
+            (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
+            (addListToSS emptySS ptrs))
+
+lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
+lookupLiteral _ _ (BCONPtrWord lit) = return lit
+lookupLiteral hsc_env _ (BCONPtrLbl  sym) = do
+  Ptr a# <- lookupStaticPtr hsc_env sym
+  return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral hsc_env ie (BCONPtrItbl nm)  = do
+  Ptr a# <- lookupIE hsc_env ie nm
+  return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral hsc_env _ (BCONPtrStr bs) = do
+  fromIntegral . ptrToWordPtr <$> mallocData hsc_env bs
+
+lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
+lookupStaticPtr hsc_env addr_of_label_string = do
+  m <- lookupSymbol hsc_env addr_of_label_string
+  case m of
+    Just ptr -> return ptr
+    Nothing  -> linkFail "ByteCodeLink: can't find label"
+                  (unpackFS addr_of_label_string)
+
+lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr a)
+lookupIE hsc_env ie con_nm =
+  case lookupNameEnv ie con_nm of
+    Just (_, ItblPtr a) -> return (castPtr (conInfoPtr a))
+    Nothing -> do -- try looking up in the object files.
+       let sym_to_find1 = nameToCLabel con_nm "con_info"
+       m <- lookupSymbol hsc_env sym_to_find1
+       case m of
+          Just addr -> return (castPtr addr)
+          Nothing
+             -> do -- perhaps a nullary constructor?
+                   let sym_to_find2 = nameToCLabel con_nm "static_info"
+                   n <- lookupSymbol hsc_env sym_to_find2
+                   case n of
+                      Just addr -> return (castPtr addr)
+                      Nothing   -> linkFail "ByteCodeLink.lookupIE"
+                                      (unpackFS sym_to_find1 ++ " or " ++
+                                       unpackFS sym_to_find2)
+
+lookupPrimOp :: HscEnv -> PrimOp -> IO RemotePtr
+lookupPrimOp hsc_env primop = do
+  let sym_to_find = primopToCLabel primop "closure"
+  m <- lookupSymbol hsc_env (mkFastString sym_to_find)
+  case m of
+    Just p -> return (toRemotePtr p)
+    Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
+
+resolvePtr
+  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> BCOPtr
+  -> IO ResolvedBCOPtr
+resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
+  | Just ix <- lookupNameEnv bco_ix nm =
+    return (ResolvedBCORef ix) -- ref to another BCO in this group
+  | Just (_, rhv) <- lookupNameEnv ce nm =
+    return (ResolvedBCOPtr (unsafeForeignHValueToHValueRef rhv))
+  | otherwise =
+    ASSERT2(isExternalName nm, ppr nm)
+    do let sym_to_find = nameToCLabel nm "closure"
+       m <- lookupSymbol hsc_env sym_to_find
+       case m of
+         Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
+         Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
+resolvePtr hsc_env _ _ _ (BCOPtrPrimOp op) =
+  ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
+resolvePtr hsc_env ie ce bco_ix (BCOPtrBCO bco) =
+  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix bco
+resolvePtr _ _ _ _ (BCOPtrBreakInfo break_info) =
+  return (ResolvedBCOPtrLocal (unsafeCoerce# break_info))
+resolvePtr _ _ _ _ (BCOPtrArray break_array) =
+  return (ResolvedBCOPtrLocal (unsafeCoerce# break_array))
 
 linkFail :: String -> String -> IO a
 linkFail who what
@@ -246,8 +156,9 @@ linkFail who what
                 ])
 
 
-nameToCLabel :: Name -> String -> String
-nameToCLabel n suffix = label where
+nameToCLabel :: Name -> String -> FastString
+nameToCLabel n suffix = mkFastString label
+  where
     encodeZ = zString . zEncodeFS
     (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
     packagePart = encodeZ (unitIdFS pkgKey)
@@ -268,4 +179,3 @@ primopToCLabel primop suffix = concat
     , zString (zEncodeFS (occNameFS (primOpOcc primop)))
     , '_':suffix
     ]
-
diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
new file mode 100644 (file)
index 0000000..0a8dd30
--- /dev/null
@@ -0,0 +1,90 @@
+{-# LANGUAGE MagicHash #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | Bytecode assembler types
+module ByteCodeTypes
+  ( CompiledByteCode(..), FFIInfo(..)
+  , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
+  , ItblEnv, ItblPtr(..)
+  , BreakInfo(..)
+  ) where
+
+import FastString
+import Id
+import Module
+import Name
+import NameEnv
+import Outputable
+import PrimOp
+import SizedSeq
+import Type
+
+import Foreign
+import Data.Array.Base  ( UArray(..) )
+import Data.ByteString (ByteString)
+import GHC.Exts
+
+
+data CompiledByteCode
+  = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
+             ItblEnv       -- A mapping from DataCons to their itbls
+             [FFIInfo]     -- ffi blocks we allocated
+                -- ToDo: we're not tracking strings that we malloc'd
+
+newtype FFIInfo = FFIInfo (Ptr ())
+  deriving Show
+
+instance Outputable CompiledByteCode where
+  ppr (ByteCode bcos _ _) = ppr bcos
+
+type ItblEnv = NameEnv (Name, ItblPtr)
+        -- We need the Name in the range so we know which
+        -- elements to filter out when unloading a module
+
+newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
+
+data UnlinkedBCO
+   = UnlinkedBCO {
+        unlinkedBCOName   :: Name,
+        unlinkedBCOArity  :: Int,
+        unlinkedBCOInstrs :: UArray Int Word16,         -- insns
+        unlinkedBCOBitmap :: UArray Int Word,           -- 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
+  | BCONPtrStr   ByteString
+
+data BreakInfo
+   = BreakInfo
+   { breakInfo_module :: Module
+   , breakInfo_number :: {-# UNPACK #-} !Int
+   , breakInfo_vars   :: [(Id,Word16)]
+   , breakInfo_resty  :: Type
+   }
+
+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" ]
+
+instance Outputable BreakInfo where
+   ppr info = text "BreakInfo" <+>
+              parens (ppr (breakInfo_module info) <+>
+                      ppr (breakInfo_number info) <+>
+                      ppr (breakInfo_vars info) <+>
+                      ppr (breakInfo_resty info))
index 2b9e732..5c6a02d 100644 (file)
@@ -17,6 +17,8 @@ module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
 import Linker
 import RtClosureInspect
 
+import GHCi
+import GHCi.RemoteTypes
 import GhcMonad
 import HscTypes
 import Id
@@ -117,7 +119,8 @@ bindSuspensions t = do
       let ids = [ mkVanillaGlobal name ty
                 | (name,ty) <- zip names tys]
           new_ic = extendInteractiveContextWithIds ictxt ids
-      liftIO $ extendLinkEnv (zip names hvals)
+      fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkHValueRef) hvals
+      liftIO $ extendLinkEnv (zip names fhvs)
       modifySession $ \_ -> hsc_env {hsc_IC = new_ic }
       return t'
      where
@@ -170,7 +173,8 @@ showTerm term = do
            let noop_log _ _ _ _ _ = return ()
                expr = "show " ++ showPpr dflags bname
            _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
-           txt_ <- withExtendedLinkEnv [(bname, val)]
+           fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkHValueRef val
+           txt_ <- withExtendedLinkEnv [(bname, fhv)]
                                        (GHC.compileExpr expr)
            let myprec = 10 -- application precedence. TODO Infix constructors
            let txt = unsafeCoerce# txt_ :: [a]
index d1ff913..096b809 100644 (file)
@@ -4,8 +4,8 @@ module DebuggerUtils (
        dataConInfoPtrToName,
   ) where
 
+import GHCi.InfoTable
 import CmmInfo ( stdInfoTableSizeB )
-import ByteCodeItbls
 import DynFlags
 import FastString
 import TcRnTypes
diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
new file mode 100644 (file)
index 0000000..d9c26c1
--- /dev/null
@@ -0,0 +1,499 @@
+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}
+
+--
+-- | Interacting with the interpreter, whether it is running on an
+-- external process or in the current process.
+--
+module GHCi
+  ( -- * High-level interface to the interpreter
+    evalStmt, EvalStatus(..), EvalResult(..), EvalExpr(..)
+  , resumeStmt
+  , abandonStmt
+  , evalIO
+  , evalString
+  , evalStringToIOString
+  , mallocData
+
+  -- * The object-code linker
+  , initObjLinker
+  , lookupSymbol
+  , lookupClosure
+  , loadDLL
+  , loadArchive
+  , loadObj
+  , unloadObj
+  , addLibrarySearchPath
+  , removeLibrarySearchPath
+  , resolveObjs
+  , findSystemLibrary
+
+  -- * Lower-level API using messages
+  , iservCmd, Message(..), withIServ, stopIServ
+  , iservCall, readIServ, writeIServ
+  , purgeLookupSymbolCache
+  , freeHValueRefs
+  , mkFinalizedHValue
+  , wormhole, wormholeRef
+  , mkEvalOpts
+  , fromEvalResult
+  ) where
+
+import GHCi.Message
+import GHCi.Run
+import GHCi.RemoteTypes
+import HscTypes
+import UniqFM
+import Panic
+import DynFlags
+#ifndef mingw32_HOST_OS
+import ErrUtils
+import Outputable
+#endif
+import Exception
+import BasicTypes
+import FastString
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Binary
+import Data.ByteString (ByteString)
+import Data.IORef
+import Foreign
+import System.Exit
+#ifndef mingw32_HOST_OS
+import Data.Maybe
+import System.Posix as Posix
+#endif
+import System.Process
+
+{- Note [Remote GHCi]
+
+When the flag -fexternal-interpreter is given to GHC, interpreted code
+is run in a separate process called iserv, and we communicate with the
+external process over a pipe using Binary-encoded messages.
+
+Motivation
+~~~~~~~~~~
+
+When the interpreted code is running in a separate process, it can
+use a different "way", e.g. profiled or dynamic.  This means
+
+- 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.
+
+- 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.
+
+For other reasons see RemoteGHCi on the wiki.
+
+Implementation Overview
+~~~~~~~~~~~~~~~~~~~~~~~
+
+The main pieces are:
+
+- libraries/ghci, containing:
+  - types for talking about remote values (GHCi.RemoteTypes)
+  - the message protocol (GHCi.Message),
+  - implementation of the messages (GHCi.Run)
+  - implementation of Template Haskell (GHCi.TH)
+  - a few other things needed to run interpreted code
+
+- top-level iserv directory, containing the codefor the external
+  server.  This is a fairly simple wrapper, most of the functionality
+  is provided by modules in libraries/ghci.
+
+- This module (GHCi) which provides the interface to the server used
+  by the rest of GHC.
+
+GHC works with and without -fexternal-interpreter.  With the flag, all
+interpreted code is run by the iserv binary.  Without the flag,
+interpreted code is run in the same process as GHC.
+
+Things that do not work with -fexternal-interpreter
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+dynCompileExpr cannot work, because we have no way to run code of an
+unknown type in the remote process.  This API fails with an error
+message if it is used with -fexternal-interpreter.
+-}
+
+-- | Run a command in the interpreter's context.  With
+-- @-fexternal-interpreter@, the command is serialized and sent to an
+-- external iserv process, and the response is deserialized (hence the
+-- @Binary@ constraint).  With @-fno-external-interpreter@ we execute
+-- the command directly here.
+iservCmd :: Binary a => HscEnv -> Message a -> IO a
+iservCmd hsc_env@HscEnv{..} msg
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+     withIServ hsc_env $ \iserv ->
+       uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
+         iservCall iserv msg
+ | otherwise = -- Just run it directly
+   run msg
+
+
+-- Note [uninterruptibleMask_ and iservCmd]
+--
+-- If we receive an async exception, such as ^C, while communicating
+-- with the iserv process then we will be out-of-sync and not be able
+-- to recoever.  Thus we use uninterruptibleMask_ during
+-- communication.  A ^C will be delivered to the iserv process (because
+-- signals get sent to the whole process group) which will interrupt
+-- the running computation and return an EvalException result.
+
+-- | Grab a lock on the 'IServ' and do something with it.
+-- Overloaded because this is used from TcM as well as IO.
+withIServ
+  :: (MonadIO m, ExceptionMonad m)
+  => HscEnv -> (IServ -> m a) -> m a
+withIServ HscEnv{..} action =
+  gmask $ \restore -> do
+    m <- liftIO $ takeMVar hsc_iserv
+      -- start the iserv process if we haven't done so yet
+    iserv <- maybe (liftIO $ startIServ hsc_dflags) return m
+               `gonException` (liftIO $ putMVar hsc_iserv Nothing)
+      -- free any ForeignHValues that have been garbage collected.
+    let iserv' = iserv{ iservPendingFrees = [] }
+    a <- (do
+      liftIO $ when (not (null (iservPendingFrees iserv))) $
+        iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
+        -- run the inner action
+      restore $ action iserv)
+          `gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))
+    liftIO $ putMVar hsc_iserv (Just iserv')
+    return a
+
+
+-- -----------------------------------------------------------------------------
+-- Wrappers around messages
+
+-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
+-- each of the results.
+evalStmt
+  :: HscEnv -> Bool -> EvalExpr ForeignHValue -> IO (EvalStatus [ForeignHValue])
+evalStmt hsc_env step foreign_expr = do
+  let dflags = hsc_dflags hsc_env
+  status <- withExpr foreign_expr $ \expr ->
+    iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)
+  handleEvalStatus hsc_env status
+ where
+  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
+  withExpr (EvalThis fhv) cont =
+    withForeignHValue fhv $ \hvref -> cont (EvalThis hvref)
+  withExpr (EvalApp fl fr) cont =
+    withExpr fl $ \fl' ->
+    withExpr fr $ \fr' ->
+    cont (EvalApp fl' fr')
+
+resumeStmt :: HscEnv -> Bool -> ForeignHValue -> IO (EvalStatus [ForeignHValue])
+resumeStmt hsc_env step resume_ctxt = do
+  let dflags = hsc_dflags hsc_env
+  status <- withForeignHValue resume_ctxt $ \rhv ->
+    iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
+  handleEvalStatus hsc_env status
+
+abandonStmt :: HscEnv -> ForeignHValue -> IO ()
+abandonStmt hsc_env resume_ctxt = do
+  withForeignHValue resume_ctxt $ \rhv ->
+    iservCmd hsc_env (AbandonStmt rhv)
+
+handleEvalStatus
+  :: HscEnv -> EvalStatus [HValueRef] -> IO (EvalStatus [ForeignHValue])
+handleEvalStatus hsc_env status =
+  case status of
+    EvalBreak a b c d -> return (EvalBreak a b c d)
+    EvalComplete alloc res ->
+      EvalComplete alloc <$> addFinalizer res
+ where
+  addFinalizer (EvalException e) = return (EvalException e)
+  addFinalizer (EvalSuccess rs) = do
+    EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs
+
+-- | Execute an action of type @IO ()@
+evalIO :: HscEnv -> ForeignHValue -> IO ()
+evalIO hsc_env fhv = do
+  liftIO $ withForeignHValue fhv $ \fhv ->
+    iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult
+
+-- | Execute an action of type @IO String@
+evalString :: HscEnv -> ForeignHValue -> IO String
+evalString hsc_env fhv = do
+  liftIO $ withForeignHValue fhv $ \fhv ->
+    iservCmd hsc_env (EvalString fhv) >>= fromEvalResult
+
+-- | Execute an action of type @String -> IO String@
+evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
+evalStringToIOString hsc_env fhv str = do
+  liftIO $ withForeignHValue fhv $ \fhv ->
+    iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult
+
+
+-- | Allocate and store the given bytes in memory, returning a pointer
+-- to the memory in the remote process.
+mallocData :: HscEnv -> ByteString -> IO (Ptr ())
+mallocData hsc_env bs = fromRemotePtr <$> iservCmd hsc_env (MallocData bs)
+
+
+-- -----------------------------------------------------------------------------
+-- Interface to the object-code linker
+
+initObjLinker :: HscEnv -> IO ()
+initObjLinker hsc_env = iservCmd hsc_env InitLinker
+
+lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol hsc_env@HscEnv{..} str
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+     -- Profiling of GHCi showed a lot of time and allocation spent
+     -- making cross-process LookupSymbol calls, so I added a GHC-side
+     -- cache which sped things up quite a lot.  We have to be careful
+     -- to purge this cache when unloading code though.
+     withIServ hsc_env $ \iserv@IServ{..} -> do
+       cache <- readIORef iservLookupSymbolCache
+       case lookupUFM cache str of
+         Just p -> return (Just p)
+         Nothing -> do
+           m <- uninterruptibleMask_ $
+                    iservCall iserv (LookupSymbol (unpackFS str))
+           case m of
+             Nothing -> return Nothing
+             Just r -> do
+               let p = fromRemotePtr r
+               writeIORef iservLookupSymbolCache $! addToUFM cache str p
+               return (Just p)
+ | otherwise =
+   fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+
+lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
+lookupClosure hsc_env str =
+  iservCmd hsc_env (LookupClosure str)
+
+purgeLookupSymbolCache :: HscEnv -> IO ()
+purgeLookupSymbolCache hsc_env@HscEnv{..} =
+ when (gopt Opt_ExternalInterpreter hsc_dflags) $
+   withIServ hsc_env $ \IServ{..} ->
+     writeIORef iservLookupSymbolCache emptyUFM
+
+
+-- | loadDLL loads a dynamic library using the OS's native linker
+-- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
+-- an absolute pathname to the file, or a relative filename
+-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL
+-- searches the standard locations for the appropriate library.
+--
+-- Returns:
+--
+-- Nothing      => success
+-- Just err_msg => failure
+loadDLL :: HscEnv -> String -> IO (Maybe String)
+loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)
+
+loadArchive :: HscEnv -> String -> IO ()
+loadArchive hsc_env str = iservCmd hsc_env (LoadArchive str)
+
+loadObj :: HscEnv -> String -> IO ()
+loadObj hsc_env str = iservCmd hsc_env (LoadObj str)
+
+unloadObj :: HscEnv -> String -> IO ()
+unloadObj hsc_env str = iservCmd hsc_env (UnloadObj str)
+
+addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
+addLibrarySearchPath hsc_env str =
+  fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)
+
+removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
+removeLibrarySearchPath hsc_env p =
+  iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))
+
+resolveObjs :: HscEnv -> IO SuccessFlag
+resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs
+
+findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
+findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
+
+
+-- -----------------------------------------------------------------------------
+-- Raw calls and messages
+
+-- | Send a 'Message' and receive the response from the iserv process
+iservCall :: Binary a => IServ -> Message a -> IO a
+iservCall iserv@IServ{..} msg =
+  remoteCall iservPipe msg
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Read a value from the iserv process
+readIServ :: IServ -> Get a -> IO a
+readIServ iserv@IServ{..} get =
+  readPipe iservPipe get
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Send a value to the iserv process
+writeIServ :: IServ -> Put -> IO ()
+writeIServ iserv@IServ{..} put =
+  writePipe iservPipe put
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+handleIServFailure :: IServ -> SomeException -> IO a
+handleIServFailure IServ{..} e = do
+  ex <- getProcessExitCode iservProcess
+  case ex of
+    Just (ExitFailure n) ->
+      throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
+    _ -> do
+      terminateProcess iservProcess
+      _ <- waitForProcess iservProcess
+      throw e
+
+-- -----------------------------------------------------------------------------
+-- Starting and stopping the iserv process
+
+startIServ :: DynFlags -> IO IServ
+#ifdef mingw32_HOST_OS
+startIServ _ = panic "startIServ"
+  -- should not be called, because we disable -fexternal-interpreter on Windows.
+  -- (see DynFlags.makeDynFlagsConsistent)
+#else
+startIServ dflags = do
+  let flavour
+        | WayProf `elem` ways dflags = "-prof"
+        | WayDyn `elem` ways dflags = "-dyn"
+        | otherwise = ""
+      prog = pgm_i dflags ++ flavour
+      opts = getOpts dflags opt_i
+  debugTraceMsg dflags 3 $ text "Starting " <> text prog
+  (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
+  (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
+  setFdOption rfd1 CloseOnExec True
+  setFdOption wfd2 CloseOnExec True
+  let args = show wfd1 : show rfd2 : opts
+  (_, _, _, ph) <- createProcess (proc prog args)
+  closeFd wfd1
+  closeFd rfd2
+  rh <- fdToHandle rfd1
+  wh <- fdToHandle wfd2
+  lo_ref <- newIORef Nothing
+  cache_ref <- newIORef emptyUFM
+  return $ IServ
+    { iservPipe = Pipe { pipeRead = rh
+                       , pipeWrite = wh
+                       , pipeLeftovers = lo_ref }
+    , iservProcess = ph
+    , iservLookupSymbolCache = cache_ref
+    , iservPendingFrees = []
+    }
+#endif
+
+stopIServ :: HscEnv -> IO ()
+#ifdef mingw32_HOST_OS
+stopIServ _ = return ()
+#else
+stopIServ HscEnv{..} =
+  gmask $ \_restore -> do
+    m <- takeMVar hsc_iserv
+    maybe (return ()) stop m
+    putMVar hsc_iserv Nothing
+ where
+  stop iserv = do
+    ex <- getProcessExitCode (iservProcess iserv)
+    if isJust ex
+       then return ()
+       else iservCall iserv Shutdown
+#endif
+
+-- -----------------------------------------------------------------------------
+{- Note [External GHCi pointers]
+
+We have the following ways to reference things in GHCi:
+
+HValue
+------
+
+HValue is a direct reference to an value in the local heap.  Obviously
+we cannot use this to refer to things in the external process.
+
+
+HValueRef
+---------
+
+HValueRef is a StablePtr to a heap-resident value.  When
+-fexternal-interpreter is used, this value resides in the external
+process's heap.  HValueRefs are mostly used to send pointers in
+messages between GHC and iserv.
+
+An HValueRef must be explicitly freed when no longer required, using
+freeHValueRefs, or by attaching a finalizer with mkForeignHValue.
+
+To get from an HValueRef to an HValue you can use 'wormholeRef', which
+fails with an error message if -fexternal-interpreter is in use.
+
+ForeignHValue
+-------------
+
+A ForeignHValue is an HValueRef with a finalizer that will free the
+'HValueRef' when it is gargabe collected.  We mostly use ForeignHValue
+on the GHC side.
+
+The finalizer adds the HValueRef to the iservPendingFrees list in the
+IServ record.  The next call to iservCmd will free any HValueRefs in
+the list.  It was done this way rather than calling iservCmd directly,
+because I didn't want to have arbitrary threads calling iservCmd.  In
+principle it would probably be ok, but it seems less hairy this way.
+-}
+
+-- | Creates a 'ForeignHValue' that will automatically release the
+-- 'HValueRef' when it is no longer referenced.
+mkFinalizedHValue :: HscEnv -> HValueRef -> IO ForeignHValue
+mkFinalizedHValue HscEnv{..} hvref = mkForeignHValue hvref free
+ where
+  !external = gopt Opt_ExternalInterpreter hsc_dflags
+
+  free :: IO ()
+  free
+    | not external = freeHValueRef hvref
+    | otherwise =
+      modifyMVar_ hsc_iserv $ \mb_iserv ->
+        case mb_iserv of
+          Nothing -> return Nothing -- already shut down
+          Just iserv@IServ{..} ->
+            return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})
+
+freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
+freeHValueRefs _ [] = return ()
+freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
+
+-- | Convert a 'ForeignHValue' to an 'HValue' directly.  This only works
+-- when the interpreter is running in the same process as the compiler,
+-- so it fails when @-fexternal-interpreter@ is on.
+wormhole :: DynFlags -> ForeignHValue -> IO HValue
+wormhole dflags r = wormholeRef dflags (unsafeForeignHValueToHValueRef r)
+
+-- | Convert an 'HValueRef' to an 'HValue' directly.  This only works
+-- when the interpreter is running in the same process as the compiler,
+-- so it fails when @-fexternal-interpreter@ is on.
+wormholeRef :: DynFlags -> HValueRef -> IO HValue
+wormholeRef dflags r
+  | gopt Opt_ExternalInterpreter dflags
+  = throwIO (InstallationError
+      "this operation requires -fno-external-interpreter")
+  | otherwise
+  = localHValueRef r
+
+-- -----------------------------------------------------------------------------
+-- Misc utils
+
+mkEvalOpts :: DynFlags -> Bool -> EvalOpts
+mkEvalOpts dflags step =
+  EvalOpts
+    { useSandboxThread = gopt Opt_GhciSandbox dflags
+    , singleStep = step
+    , breakOnException = gopt Opt_BreakOnException dflags
+    , breakOnError = gopt Opt_BreakOnError dflags }
+
+fromEvalResult :: EvalResult a -> IO a
+fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
+fromEvalResult (EvalSuccess a) = return a
index 7c10fae..11936c7 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
 {-# OPTIONS_GHC -fno-cse #-}
 --
 --  (c) The University of Glasgow 2002-2006
@@ -24,11 +24,12 @@ module Linker ( getHValue, showLinkerState,
 
 #include "HsVersions.h"
 
+import GHCi
+import GHCi.RemoteTypes
 import LoadIface
-import ObjLink
 import ByteCodeLink
-import ByteCodeItbls
 import ByteCodeAsm
+import ByteCodeTypes
 import TcRnMonad
 import Packages
 import DriverPhases
@@ -63,7 +64,6 @@ import Data.Maybe
 import Control.Concurrent.MVar
 
 import System.FilePath
-import System.IO
 import System.Directory
 
 import Exception
@@ -147,35 +147,46 @@ extendLoadedPkgs pkgs =
   modifyPLS_ $ \s ->
       return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
 
-extendLinkEnv :: [(Name,HValue)] -> IO ()
--- Automatically discards shadowed bindings
+extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
 extendLinkEnv new_bindings =
-  modifyPLS_ $ \pls ->
-    let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
-    in return pls{ closure_env = new_closure_env }
+  modifyPLS_ $ \pls -> do
+    let ce = closure_env pls
+    let new_ce = extendClosureEnv ce new_bindings
+    return pls{ closure_env = new_ce }
 
 deleteFromLinkEnv :: [Name] -> IO ()
 deleteFromLinkEnv to_remove =
-  modifyPLS_ $ \pls ->
-    let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
-    in return pls{ closure_env = new_closure_env }
+  modifyPLS_ $ \pls -> do
+    let ce = closure_env pls
+    let new_ce = delListFromNameEnv ce to_remove
+    return pls{ closure_env = new_ce }
 
 -- | Get the 'HValue' associated with the given name.
 --
 -- May cause loading the module that contains the name.
 --
 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
-getHValue :: HscEnv -> Name -> IO HValue
+getHValue :: HscEnv -> Name -> IO ForeignHValue
 getHValue hsc_env name = do
-  initDynLinker (hsc_dflags hsc_env)
+  initDynLinker hsc_env
   pls <- modifyPLS $ \pls -> do
            if (isExternalName name) then do
-             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
+             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan
+                              [nameModule name]
              if (failed ok) then throwGhcExceptionIO (ProgramError "")
                             else return (pls', pls')
             else
              return (pls, pls)
-  lookupName (closure_env pls) name
+  case lookupNameEnv (closure_env pls) name of
+    Just (_,aa) -> return aa
+    Nothing
+        -> ASSERT2(isExternalName name, ppr name)
+           do let sym_to_find = nameToCLabel name "closure"
+              m <- lookupClosure hsc_env (unpackFS sym_to_find)
+              case m of
+                Just hvref -> mkFinalizedHValue hsc_env hvref
+                Nothing -> linkFail "ByteCodeLink.lookupCE"
+                             (unpackFS sym_to_find)
 
 linkDependencies :: HscEnv -> PersistentLinkerState
                  -> SrcSpan -> [Module]
@@ -195,14 +206,14 @@ linkDependencies hsc_env pls span needed_mods = do
                                maybe_normal_osuf span needed_mods
 
    -- Link the packages and modules required
-   pls1 <- linkPackages' dflags pkgs pls
-   linkModules dflags pls1 lnks
+   pls1 <- linkPackages' hsc_env pkgs pls
+   linkModules hsc_env pls1 lnks
 
 
 -- | Temporarily extend the linker state.
 
 withExtendedLinkEnv :: (ExceptionMonad m) =>
-                       [(Name,HValue)] -> m a -> m a
+                       [(Name,ForeignHValue)] -> m a -> m a
 withExtendedLinkEnv new_env action
     = gbracket (liftIO $ extendLinkEnv new_env)
                (\_ -> reset_old_env)
@@ -219,19 +230,6 @@ withExtendedLinkEnv new_env action
                     new = delListFromNameEnv cur (map fst new_env)
                 in return pls{ closure_env = new }
 
--- filterNameMap removes from the environment all entries except
--- those for a given set of modules;
--- Note that this removes all *local* (i.e. non-isExternal) names too
--- (these are the temporary bindings from the command line).
--- Used to filter both the ClosureEnv and ItblEnv
-
-filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
-filterNameMap mods env
-   = filterNameEnv keep_elt env
-   where
-     keep_elt (n,_) = isExternalName n
-                      && (nameModule n `elem` mods)
-
 
 -- | Display the persistent linker state.
 showLinkerState :: DynFlags -> IO ()
@@ -268,41 +266,45 @@ showLinkerState dflags
 -- nothing.  This is useful in Template Haskell, where we call it before
 -- trying to link.
 --
-initDynLinker :: DynFlags -> IO ()
-initDynLinker dflags =
+initDynLinker :: HscEnv -> IO ()
+initDynLinker hsc_env =
   modifyPLS_ $ \pls0 -> do
     done <- readIORef v_InitLinkerDone
     if done then return pls0
             else do writeIORef v_InitLinkerDone True
-                    reallyInitDynLinker dflags
+                    reallyInitDynLinker hsc_env
 
-reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState
-reallyInitDynLinker dflags =
-    do  {  -- Initialise the linker state
-          let pls0 = emptyPLS dflags
+reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
+reallyInitDynLinker hsc_env = do
+  -- Initialise the linker state
+  let dflags = hsc_dflags hsc_env
+      pls0 = emptyPLS dflags
 
-          -- (a) initialise the C dynamic linker
-        ; initObjLinker
+  -- (a) initialise the C dynamic linker
+  initObjLinker hsc_env
 
-          -- (b) Load packages from the command-line (Note [preload packages])
-        ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0
+  -- (b) Load packages from the command-line (Note [preload packages])
+  pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0
 
-          -- steps (c), (d) and (e)
-        ; linkCmdLineLibs' dflags pls
-        }
+  -- steps (c), (d) and (e)
+  linkCmdLineLibs' hsc_env pls
 
-linkCmdLineLibs :: DynFlags -> IO ()
-linkCmdLineLibs dflags = do
-  initDynLinker dflags
+
+linkCmdLineLibs :: HscEnv -> IO ()
+linkCmdLineLibs hsc_env = do
+  initDynLinker hsc_env
   modifyPLS_ $ \pls -> do
-    linkCmdLineLibs' dflags pls
+    linkCmdLineLibs' hsc_env pls
+
+linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
+linkCmdLineLibs' hsc_env pls =
+  do
+      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
+                           , libraryPaths = lib_paths}) = hsc_dflags hsc_env
 
-linkCmdLineLibs' :: DynFlags -> PersistentLinkerState -> IO PersistentLinkerState
-linkCmdLineLibs' dflags@(DynFlags { ldInputs     = cmdline_ld_inputs
-                                  , libraryPaths = lib_paths}) pls =
-  do  -- (c) Link libraries from the command-line
+      -- (c) Link libraries from the command-line
       let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
-      libspecs <- mapM (locateLib dflags False lib_paths) minus_ls
+      libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls
 
       -- (d) Link .o files from the command-line
       classified_ld_inputs <- mapM (classifyLdInput dflags)
@@ -327,15 +329,15 @@ linkCmdLineLibs' dflags@(DynFlags { ldInputs     = cmdline_ld_inputs
                                ++ lib_paths
                                ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
                       in nub $ map normalise paths
-      pathCache <- mapM addLibrarySearchPath all_paths
+      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
 
-      pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls
+      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
                     cmdline_lib_specs
       maybePutStr dflags "final link ... "
-      ok <- resolveObjs
+      ok <- resolveObjs hsc_env
 
       -- DLLs are loaded, reset the search paths
-      mapM_ removeLibrarySearchPath $ reverse pathCache
+      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
 
       if succeeded ok then maybePutStrLn dflags "done"
       else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
@@ -377,56 +379,58 @@ classifyLdInput dflags f
         return Nothing
     where platform = targetPlatform dflags
 
-preloadLib :: DynFlags -> [String] -> [String] -> PersistentLinkerState
-           -> LibrarySpec -> IO PersistentLinkerState
-preloadLib dflags lib_paths framework_paths pls lib_spec
-  = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
-       case lib_spec of
-          Object static_ish
-             -> do (b, pls1) <- preload_static lib_paths static_ish
-                   maybePutStrLn dflags (if b  then "done"
-                                                else "not found")
-                   return pls1
-
-          Archive static_ish
-             -> do b <- preload_static_archive lib_paths static_ish
-                   maybePutStrLn dflags (if b  then "done"
-                                                else "not found")
-                   return pls
-
-          DLL dll_unadorned
-             -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned)
-                   case maybe_errstr of
-                      Nothing -> maybePutStrLn dflags "done"
-                      Just mm | platformOS platform /= OSDarwin ->
-                        preloadFailed mm lib_paths lib_spec
-                      Just mm | otherwise -> do
-                        -- As a backup, on Darwin, try to also load a .so file
-                        -- since (apparently) some things install that way - see
-                        -- ticket #8770.
-                        err2 <- loadDLL $ ("lib" ++ dll_unadorned) <.> "so"
-                        case err2 of
-                          Nothing -> maybePutStrLn dflags "done"
-                          Just _  -> preloadFailed mm lib_paths lib_spec
-                   return pls
-
-          DLLPath dll_path
-             -> do maybe_errstr <- loadDLL dll_path
-                   case maybe_errstr of
-                      Nothing -> maybePutStrLn dflags "done"
-                      Just mm -> preloadFailed mm lib_paths lib_spec
-                   return pls
-
-          Framework framework ->
-              if platformUsesFrameworks (targetPlatform dflags)
-              then do maybe_errstr <- loadFramework framework_paths framework
-                      case maybe_errstr of
-                         Nothing -> maybePutStrLn dflags "done"
-                         Just mm -> preloadFailed mm framework_paths lib_spec
-                      return pls
-              else panic "preloadLib Framework"
+preloadLib
+  :: HscEnv -> [String] -> [String] -> PersistentLinkerState
+  -> LibrarySpec -> IO PersistentLinkerState
+preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
+  maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
+  case lib_spec of
+    Object static_ish -> do
+      (b, pls1) <- preload_static lib_paths static_ish
+      maybePutStrLn dflags (if b  then "done" else "not found")
+      return pls1
+
+    Archive static_ish -> do
+      b <- preload_static_archive lib_paths static_ish
+      maybePutStrLn dflags (if b  then "done" else "not found")
+      return pls
+
+    DLL dll_unadorned -> do
+      maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)
+      case maybe_errstr of
+         Nothing -> maybePutStrLn dflags "done"
+         Just mm | platformOS platform /= OSDarwin ->
+           preloadFailed mm lib_paths lib_spec
+         Just mm | otherwise -> do
+           -- As a backup, on Darwin, try to also load a .so file
+           -- since (apparently) some things install that way - see
+           -- ticket #8770.
+           let libfile = ("lib" ++ dll_unadorned) <.> "so"
+           err2 <- loadDLL hsc_env libfile
+           case err2 of
+             Nothing -> maybePutStrLn dflags "done"
+             Just _  -> preloadFailed mm lib_paths lib_spec
+      return pls
+
+    DLLPath dll_path -> do
+      do maybe_errstr <- loadDLL hsc_env dll_path
+         case maybe_errstr of
+            Nothing -> maybePutStrLn dflags "done"
+            Just mm -> preloadFailed mm lib_paths lib_spec
+         return pls
+
+    Framework framework ->
+      if platformUsesFrameworks (targetPlatform dflags)
+      then do maybe_errstr <- loadFramework hsc_env framework_paths framework
+              case maybe_errstr of
+                 Nothing -> maybePutStrLn dflags "done"
+                 Just mm -> preloadFailed mm framework_paths lib_spec
+              return pls
+      else panic "preloadLib Framework"
 
   where
+    dflags = hsc_dflags hsc_env
+
     platform = targetPlatform dflags
 
     preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
@@ -445,9 +449,9 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
        = do b <- doesFileExist name
             if not b then return (False, pls)
                      else if dynamicGhc
-                             then  do pls1 <- dynLoadObjs dflags pls [name]
+                             then  do pls1 <- dynLoadObjs hsc_env pls [name]
                                       return (True, pls1)
-                             else  do loadObj name
+                             else  do loadObj hsc_env name
                                       return (True, pls)
 
     preload_static_archive _paths name
@@ -455,7 +459,7 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
             if not b then return False
                      else do if dynamicGhc
                                  then panic "Loading archives not supported"
-                                 else loadArchive name
+                                 else loadArchive hsc_env name
                              return True
 
 
@@ -471,12 +475,11 @@ preloadLib dflags lib_paths framework_paths pls lib_spec
 -- Raises an IO exception ('ProgramError') if it can't find a compiled
 -- version of the dependents to link.
 --
-linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
+linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
 linkExpr hsc_env span root_ul_bco
   = do {
      -- Initialise the linker (if it's not been done already)
-     let dflags = hsc_dflags hsc_env
-   ; initDynLinker dflags
+   ; initDynLinker hsc_env
 
      -- Take lock for the actual work.
    ; modifyPLS $ \pls0 -> do {
@@ -492,8 +495,10 @@ linkExpr hsc_env span root_ul_bco
          ce = closure_env pls
 
      -- Link the necessary packages and linkables
-   ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco]
-   ; return (pls, root_hval)
+
+   ; [(_,root_hvref)] <- linkSomeBCOs hsc_env ie ce [root_ul_bco]
+   ; fhv <- mkFinalizedHValue hsc_env root_hvref
+   ; return (pls, fhv)
    }}}
    where
      free_names = nameSetElems (bcoFreeNames root_ul_bco)
@@ -514,6 +519,11 @@ dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mk
 
 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
 checkNonStdWay dflags srcspan
+  | gopt Opt_ExternalInterpreter dflags = return Nothing
+    -- with -fexternal-interpreter we load the .o files, whatever way
+    -- they were built.  If they were built for a non-std way, then
+    -- we will use the appropriate variant of the iserv binary to load them.
+
   | interpWays == haskellWays = return Nothing
     -- Only if we are compiling with the same ways as GHC is built
     -- with, can we dynamically load those object files. (see #3604)
@@ -533,11 +543,19 @@ normalObjectSuffix = phaseInputExt StopLn
 
 failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
 failNonStd dflags srcspan = dieWith dflags srcspan $
-  ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
-  ptext (sLit "You need to build the program twice: once") <+>
-  ghciWay <> ptext (sLit ", and then") $$
-  ptext (sLit "in the desired way using -osuf to set the object file suffix.")
-    where ghciWay
+  ptext (sLit "Cannot load") <+> compWay <+>
+     ptext (sLit "objects when GHC is built") <+> ghciWay $$
+  ptext (sLit "To fix this, either:") $$
+  ptext (sLit "  (1) Use -fexternal-interprter, or") $$
+  ptext (sLit "  (2) Build the program twice: once") <+>
+                       ghciWay <> ptext (sLit ", and then") $$
+  ptext (sLit "      with") <+> compWay <+>
+     ptext (sLit "using -osuf to set a different object file suffix.")
+    where compWay
+            | WayDyn `elem` ways dflags = ptext (sLit "-dynamic")
+            | WayProf `elem` ways dflags = ptext (sLit "-prof")
+            | otherwise = ptext (sLit "normal")
+          ghciWay
             | dynamicGhc = ptext (sLit "with -dynamic")
             | rtsIsProfiled = ptext (sLit "with -prof")
             | otherwise = ptext (sLit "the normal way")
@@ -684,11 +702,10 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
 
   ********************************************************************* -}
 
-linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue]
-linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
+linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()
+linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv _) = do
     -- Initialise the linker (if it's not been done already)
-    let dflags = hsc_dflags hsc_env
-    initDynLinker dflags
+    initDynLinker hsc_env
 
     -- Take lock for the actual work.
     modifyPLS $ \pls0 -> do
@@ -704,10 +721,11 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
         ce = closure_env pls
 
     -- Link the necessary packages and linkables
-    (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs
-    let pls2 = pls { closure_env = final_gce,
-                     itbl_env    = ie }
-    return (pls2, ()) --hvals)
+    new_bindings <- linkSomeBCOs hsc_env ie ce unlinkedBCOs
+    nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings
+    let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
+                   , itbl_env    = ie }
+    return (pls2, ())
   where
     free_names =  concatMap (nameSetElems . bcoFreeNames) unlinkedBCOs
 
@@ -721,8 +739,6 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
     -- All wired-in names are in the base package, which we link
     -- by default, so we can safely ignore them here.
 
-
-
 {- **********************************************************************
 
               Loading a single module
@@ -731,7 +747,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
 
 linkModule :: HscEnv -> Module -> IO ()
 linkModule hsc_env mod = do
-  initDynLinker (hsc_dflags hsc_env)
+  initDynLinker hsc_env
   modifyPLS_ $ \pls -> do
     (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
     if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
@@ -745,21 +761,21 @@ linkModule hsc_env mod = do
 
   ********************************************************************* -}
 
-linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
+linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
             -> IO (PersistentLinkerState, SuccessFlag)
-linkModules dflags pls linkables
+linkModules hsc_env pls linkables
   = mask_ $ do  -- don't want to be interrupted by ^C in here
 
         let (objs, bcos) = partition isObjectLinkable
                               (concatMap partitionLinkable linkables)
 
                 -- Load objects first; they can't depend on BCOs
-        (pls1, ok_flag) <- dynLinkObjs dflags pls objs
+        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
 
         if failed ok_flag then
                 return (pls1, Failed)
           else do
-                pls2 <- dynLinkBCOs dflags pls1 bcos
+                pls2 <- dynLinkBCOs hsc_env pls1 bcos
                 return (pls2, Succeeded)
 
 
@@ -795,36 +811,37 @@ linkableInSet l objs_loaded =
 
   ********************************************************************* -}
 
-dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
+dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]
             -> IO (PersistentLinkerState, SuccessFlag)
-dynLinkObjs dflags pls objs = do
+dynLinkObjs hsc_env pls objs = do
         -- Load the object files and link them
         let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
             pls1                     = pls { objs_loaded = objs_loaded' }
             unlinkeds                = concatMap linkableUnlinked new_objs
             wanted_objs              = map nameOfObject unlinkeds
 
-        if dynamicGhc
-            then do pls2 <- dynLoadObjs dflags pls1 wanted_objs
+        if loadingDynamicHSLibs (hsc_dflags hsc_env)
+            then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
                     return (pls2, Succeeded)
-            else do mapM_ loadObj wanted_objs
+            else do mapM_ (loadObj hsc_env) wanted_objs
 
                     -- Link them all together
-                    ok <- resolveObjs
+                    ok <- resolveObjs hsc_env
 
                     -- If resolving failed, unload all our
                     -- object modules and carry on
                     if succeeded ok then do
                             return (pls1, Succeeded)
                       else do
-                            pls2 <- unload_wkr dflags [] pls1
+                            pls2 <- unload_wkr hsc_env [] pls1
                             return (pls2, Failed)
 
 
-dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath]
+dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
             -> IO PersistentLinkerState
-dynLoadObjs _      pls []   = return pls
-dynLoadObjs dflags pls objs = do
+dynLoadObjs _       pls []   = return pls
+dynLoadObjs hsc_env pls objs = do
+    let dflags = hsc_dflags hsc_env
     let platform = targetPlatform dflags
     (soFile, libPath , libName) <- newTempLibName dflags (soExt platform)
     let
@@ -860,7 +877,7 @@ dynLoadObjs dflags pls objs = do
     -- symbols in this link we must link all loaded packages again.
     linkDynLib dflags2 objs (pkgs_loaded pls)
     consIORef (filesToNotIntermediateClean dflags) soFile
-    m <- loadDLL soFile
+    m <- loadDLL hsc_env soFile
     case m of
         Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
         Just err -> panic ("Loading temp shared object failed: " ++ err)
@@ -884,9 +901,9 @@ rmDupLinkables already ls
   ********************************************************************* -}
 
 
-dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable]
+dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable]
             -> IO PersistentLinkerState
-dynLinkBCOs dflags pls bcos = do
+dynLinkBCOs hsc_env pls bcos = do
 
         let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
             pls1                     = pls { bcos_loaded = bcos_loaded' }
@@ -897,46 +914,49 @@ dynLinkBCOs dflags pls bcos = do
             cbcs      = map byteCodeOfObject unlinkeds
 
 
-            ul_bcos    = [b | ByteCode bs _  <- cbcs, b <- bs]
-            ies        = [ie | ByteCode _ ie <- cbcs]
+            ul_bcos    = [b | ByteCode bs _  <- cbcs, b <- bs]
+            ies        = [ie | ByteCode _ ie <- cbcs]
             gce       = closure_env pls
             final_ie  = foldr plusNameEnv (itbl_env pls) ies
 
-        (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos
-                -- XXX What happens to these linked_bcos?
+        names_and_refs <- linkSomeBCOs hsc_env final_ie gce ul_bcos
 
-        let pls2 = pls1 { closure_env = final_gce,
+        -- We only want to add the external ones to the ClosureEnv
+        let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
+
+        -- Immediately release any HValueRefs we're not going to add
+        freeHValueRefs hsc_env (map snd to_drop)
+        -- Wrap finalizers on the ones we want to keep
+        new_binds <- makeForeignNamedHValueRefs hsc_env to_add
+
+        let pls2 = pls1 { closure_env = extendClosureEnv gce new_binds,
                           itbl_env    = final_ie }
 
         return pls2
 
--- Link a bunch of BCOs and return them + updated closure env.
-linkSomeBCOs :: DynFlags
-             -> Bool    -- False <=> add _all_ BCOs to returned closure env
-                        -- True  <=> add only toplevel BCOs to closure env
+-- Link a bunch of BCOs and return references to their values
+linkSomeBCOs :: HscEnv
              -> ItblEnv
              -> ClosureEnv
              -> [UnlinkedBCO]
-             -> IO (ClosureEnv, [HValue])
-                        -- The returned HValues are associated 1-1 with
+             -> IO [(Name,HValueRef)]
+                        -- The returned HValueRefs are associated 1-1 with
                         -- the incoming unlinked BCOs.  Each gives the
                         -- value of the corresponding unlinked BCO
 
-linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
-   = do let nms = map unlinkedBCOName ul_bcos
-        hvals <- fixIO
-                    ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
-                               in  mapM (linkBCO dflags ie ce_out) ul_bcos )
-        let ce_all_additions = zip nms hvals
-            ce_top_additions = filter (isExternalName.fst) ce_all_additions
-            ce_additions     = if toplevs_only then ce_top_additions
-                                               else ce_all_additions
-            ce_out = -- make sure we're not inserting duplicate names into the
-                     -- closure environment, which leads to trouble.
-                     ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
-                     extendClosureEnv ce_in ce_additions
-        return (ce_out, hvals)
+linkSomeBCOs _ _ _ [] = return []
+linkSomeBCOs hsc_env ie ce ul_bcos = do
+  let names = map unlinkedBCOName ul_bcos
+      bco_ix = mkNameEnv (zip names [0..])
+  resolved <- mapM (linkBCO hsc_env ie ce bco_ix) ul_bcos
+  hvrefs <- iservCmd hsc_env (CreateBCOs resolved)
+  return (zip names hvrefs)
 
+-- | Useful to apply to the result of 'linkSomeBCOs'
+makeForeignNamedHValueRefs
+  :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
+makeForeignNamedHValueRefs hsc_env bindings =
+  mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings
 
 {- **********************************************************************
 
@@ -958,62 +978,85 @@ linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
 --
 --   * we also implicitly unload all temporary bindings at this point.
 --
-unload :: DynFlags
+unload :: HscEnv
        -> [Linkable] -- ^ The linkables to *keep*.
        -> IO ()
-unload dflags linkables
+unload hsc_env linkables
   = mask_ $ do -- mask, so we're safe from Ctrl-C in here
 
         -- Initialise the linker (if it's not been done already)
-        initDynLinker dflags
+        initDynLinker hsc_env
 
         new_pls
             <- modifyPLS $ \pls -> do
-                 pls1 <- unload_wkr dflags linkables pls
+                 pls1 <- unload_wkr hsc_env linkables pls
                  return (pls1, pls1)
 
-        debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
-        debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
+        let dflags = hsc_dflags hsc_env
+        debugTraceMsg dflags 3 $
+          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)
+        debugTraceMsg dflags 3 $
+          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)
         return ()
 
-unload_wkr :: DynFlags
+unload_wkr :: HscEnv
            -> [Linkable]                -- stable linkables
            -> PersistentLinkerState
            -> IO PersistentLinkerState
 -- Does the core unload business
 -- (the wrapper blocks exceptions and deals with the PLS get and put)
 
-unload_wkr _ linkables pls
-  = do  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
+unload_wkr hsc_env keep_linkables pls = do
+  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
+
+      discard keep l = not (linkableInSet l keep)
+
+      (objs_to_unload, remaining_objs_loaded) =
+         partition (discard objs_to_keep) (objs_loaded pls)
+      (bcos_to_unload, remaining_bcos_loaded) =
+         partition (discard bcos_to_keep) (bcos_loaded pls)
+
+  mapM_ unloadObjs objs_to_unload
+  mapM_ unloadObjs bcos_to_unload
+
+  -- If we unloaded any object files at all, we need to purge the cache
+  -- of lookupSymbol results.
+  when (not (null (objs_to_unload ++
+                   filter (not . null . linkableObjs) bcos_to_unload))) $
+    purgeLookupSymbolCache hsc_env
+
+  let bcos_retained = map linkableModule remaining_bcos_loaded
+
+      -- Note that we want to remove all *local*
+      -- (i.e. non-isExternal) names too (these are the
+      -- temporary bindings from the command line).
+      keep_name (n,_) = isExternalName n &&
+                        nameModule n `elem` bcos_retained
 
-        objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
-        bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
+      itbl_env'     = filterNameEnv keep_name (itbl_env pls)
+      closure_env'  = filterNameEnv keep_name (closure_env pls)
 
-        let bcos_retained = map linkableModule bcos_loaded'
-            itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
-            closure_env'  = filterNameMap bcos_retained (closure_env pls)
-            new_pls = pls { itbl_env = itbl_env',
-                            closure_env = closure_env',
-                            bcos_loaded = bcos_loaded',
-                            objs_loaded = objs_loaded' }
+      new_pls = pls { itbl_env = itbl_env',
+                      closure_env = closure_env',
+                      bcos_loaded = remaining_bcos_loaded,
+                      objs_loaded = remaining_objs_loaded }
 
-        return new_pls
+  return new_pls
   where
-    maybeUnload :: [Linkable] -> Linkable -> IO Bool
-    maybeUnload keep_linkables lnk
-      | linkableInSet lnk keep_linkables = return True
-      -- We don't do any cleanup when linking objects with the dynamic linker.
-      -- Doing so introduces extra complexity for not much benefit.
-      | dynamicGhc = return False
+    unloadObjs :: Linkable -> IO ()
+    unloadObjs lnk
+      | dynamicGhc = return ()
+        -- We don't do any cleanup when linking objects with the
+        -- dynamic linker.  Doing so introduces extra complexity for
+        -- not much benefit.
       | otherwise
-      = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
+      = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]
                 -- The components of a BCO linkable may contain
                 -- dot-o files.  Which is very confusing.
                 --
                 -- But the BCO parts can be unlinked just by
                 -- letting go of them (plus of course depopulating
                 -- the symbol table which is done in the main body)
-           return False
 
 {- **********************************************************************
 
@@ -1067,7 +1110,7 @@ showLS (Framework nm) = "(framework) " ++ nm
 -- automatically, and it doesn't matter what order you specify the input
 -- packages.
 --
-linkPackages :: DynFlags -> [UnitId] -> IO ()
+linkPackages :: HscEnv -> [UnitId] -> IO ()
 -- NOTE: in fact, since each module tracks all the packages it depends on,
 --       we don't really need to use the package-config dependencies.
 --
@@ -1076,19 +1119,21 @@ linkPackages :: DynFlags -> [UnitId] -> IO ()
 -- perhaps makes the error message a bit more localised if we get a link
 -- failure.  So the dependency walking code is still here.
 
-linkPackages dflags new_pkgs = do
+linkPackages hsc_env new_pkgs = do
   -- It's probably not safe to try to load packages concurrently, so we take
   -- a lock.
-  initDynLinker dflags
+  initDynLinker hsc_env
   modifyPLS_ $ \pls -> do
-    linkPackages' dflags new_pkgs pls
+    linkPackages' hsc_env new_pkgs pls
 
-linkPackages' :: DynFlags -> [UnitId] -> PersistentLinkerState
+linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState
              -> IO PersistentLinkerState
-linkPackages' dflags new_pks pls = do
+linkPackages' hsc_env new_pks pls = do
     pkgs' <- link (pkgs_loaded pls) new_pks
     return $! pls { pkgs_loaded = pkgs' }
   where
+     dflags = hsc_dflags hsc_env
+
      link :: [UnitId] -> [UnitId] -> IO [UnitId]
      link pkgs new_pkgs =
          foldM link_one pkgs new_pkgs
@@ -1101,18 +1146,19 @@ linkPackages' dflags new_pks pls = do
         = do {  -- Link dependents first
                pkgs' <- link pkgs (depends pkg_cfg)
                 -- Now link the package itself
-             ; linkPackage dflags pkg_cfg
+             ; linkPackage hsc_env pkg_cfg
              ; return (new_pkg : pkgs') }
 
         | otherwise
         = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unitIdString new_pkg))
 
 
-linkPackage :: DynFlags -> PackageConfig -> IO ()
-linkPackage dflags pkg
+linkPackage :: HscEnv -> PackageConfig -> IO ()
+linkPackage hsc_env pkg
    = do
-        let platform  = targetPlatform dflags
-            dirs      =  Packages.libraryDirs pkg
+        let dflags    = hsc_dflags hsc_env
+            platform  = targetPlatform dflags
+            dirs      = Packages.libraryDirs pkg
 
         let hs_libs   =  Packages.hsLibraries pkg
             -- The FFI GHCi import lib isn't needed as
@@ -1135,8 +1181,8 @@ linkPackage dflags pkg
                             else Packages.extraGHCiLibraries pkg)
                       ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
 
-        hs_classifieds    <- mapM (locateLib dflags True  dirs) hs_libs'
-        extra_classifieds <- mapM (locateLib dflags False dirs) extra_libs
+        hs_classifieds    <- mapM (locateLib hsc_env True  dirs) hs_libs'
+        extra_classifieds <- mapM (locateLib hsc_env False dirs) extra_libs
         let classifieds = hs_classifieds ++ extra_classifieds
 
         -- Complication: all the .so's must be loaded before any of the .o's.
@@ -1148,27 +1194,28 @@ linkPackage dflags pkg
         -- Add directories to library search paths
         let dll_paths  = map takeDirectory known_dlls
             all_paths  = nub $ map normalise $ dll_paths ++ dirs
-        pathCache <- mapM addLibrarySearchPath all_paths
+        pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
 
         maybePutStr dflags
             ("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
 
         -- See comments with partOfGHCi
         when (packageName pkg `notElem` partOfGHCi) $ do
-            loadFrameworks platform pkg
-            mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls)
+            loadFrameworks hsc_env platform pkg
+            mapM_ (load_dyn hsc_env)
+              (known_dlls ++ map (mkSOName platform) dlls)
 
         -- DLLs are loaded, reset the search paths
-        mapM_ removeLibrarySearchPath $ reverse pathCache
+        mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
 
         -- After loading all the DLLs, we can load the static objects.
         -- Ordering isn't important here, because we do one final link
         -- step to resolve everything.
-        mapM_ loadObj objs
-        mapM_ loadArchive archs
+        mapM_ (loadObj hsc_env) objs
+        mapM_ (loadArchive hsc_env) archs
 
         maybePutStr dflags "linking ... "
-        ok <- resolveObjs
+        ok <- resolveObjs hsc_env
         if succeeded ok
            then maybePutStrLn dflags "done."
            else let errmsg = "unable to load package `"
@@ -1180,33 +1227,44 @@ linkPackage dflags pkg
 -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,
 -- loadDLL is going to search the system paths to find the library.
 --
-load_dyn :: FilePath -> IO ()
-load_dyn dll = do r <- loadDLL dll
-                  case r of
-                    Nothing  -> return ()
-                    Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
-                                                              ++ dll ++ " (" ++ err ++ ")" ))
-
-loadFrameworks :: Platform -> PackageConfig -> IO ()
-loadFrameworks platform pkg
+load_dyn :: HscEnv -> FilePath -> IO ()
+load_dyn hsc_env dll = do
+  r <- loadDLL hsc_env dll
+  case r of
+    Nothing  -> return ()
+    Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
+                                                ++ dll ++ " (" ++ err ++ ")" ))
+
+loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
+loadFrameworks hsc_env platform pkg
     = when (platformUsesFrameworks platform) $ mapM_ load frameworks
   where
     fw_dirs    = Packages.frameworkDirs pkg
     frameworks = Packages.frameworks pkg
 
-    load fw = do  r <- loadFramework fw_dirs fw
+    load fw = do  r <- loadFramework hsc_env fw_dirs fw
                   case r of
                     Nothing  -> return ()
                     Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
                                                         ++ fw ++ " (" ++ err ++ ")" ))
 
+loadingDynamicHSLibs :: DynFlags -> Bool
+loadingDynamicHSLibs dflags
+  | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags
+  | otherwise = dynamicGhc
+
+loadingProfiledHSLibs :: DynFlags -> Bool
+loadingProfiledHSLibs dflags
+  | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+  | otherwise = rtsIsProfiled
+
 -- Try to find an object file for a given library in the given paths.
 -- If it isn't present, we assume that addDLL in the RTS can find it,
 -- which generally means that it should be a dynamic library in the
 -- standard system search path.
 
-locateLib :: DynFlags -> Bool -> [FilePath] -> String -> IO LibrarySpec
-locateLib dflags is_hs dirs lib
+locateLib :: HscEnv -> Bool -> [FilePath] -> String -> IO LibrarySpec
+locateLib hsc_env is_hs dirs lib
   | not is_hs
     -- For non-Haskell libraries (e.g. gmp, iconv):
     --   first look in library-dirs for a dynamic library (libfoo.so)
@@ -1224,15 +1282,12 @@ locateLib dflags is_hs dirs lib
     findArchive `orElse`
     assumeDll
 
-  | dynamicGhc
-    -- When the GHC package was compiled as dynamic library (=DYNAMIC set),
-    -- we search for .so libraries first.
+  | loading_dynamic_hs_libs -- search for .so libraries first.
   = findHSDll     `orElse`
     findDynObject `orElse`
     assumeDll
 
-  | rtsIsProfiled
-    -- When the GHC package is profiled, only a libHSfoo_p.a archive will do.
+  | loading_profiled_hs_libs -- only a libHSfoo_p.a archive will do.
   = findArchive `orElse`
     assumeDll
 
@@ -1244,10 +1299,15 @@ locateLib dflags is_hs dirs lib
     assumeDll
 
    where
+     dflags = hsc_dflags hsc_env
+
      obj_file     = lib <.> "o"
      dyn_obj_file = lib <.> "dyn_o"
      arch_file = "lib" ++ lib ++ lib_tag <.> "a"
-     lib_tag = if is_hs && rtsIsProfiled then "_p" else ""
+     lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
+
+     loading_profiled_hs_libs = loadingProfiledHSLibs dflags
+     loading_dynamic_hs_libs  = loadingDynamicHSLibs dflags
 
      hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
      hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
@@ -1265,7 +1325,7 @@ locateLib dflags is_hs dirs lib
                       in liftM2 (<|>) local linked
      findHSDll      = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
      findDll        = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file
-     findSysDll     = fmap (fmap $ DLL . takeFileName) $ findSystemLibrary so_name
+     findSysDll     = fmap (fmap $ DLL . takeFileName) $ findSystemLibrary hsc_env so_name
      tryGcc         = let short = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name     dirs
                           full  = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs
                       in liftM2 (<|>) short full
@@ -1297,8 +1357,8 @@ searchForLibUsingGcc dflags so dirs = do
 -- Darwin / MacOS X only: load a framework
 -- a framework is a dynamic library packaged inside a directory of the same
 -- name. They are searched for in different paths than normal libraries.
-loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
-loadFramework extraPaths rootname
+loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
+loadFramework hsc_env extraPaths rootname
    = do { either_dir <- tryIO getHomeDirectory
         ; let homeFrameworkPath = case either_dir of
                                   Left _ -> []
@@ -1306,7 +1366,7 @@ loadFramework extraPaths rootname
               ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
         ; mb_fwk <- findFile ps fwk_file
         ; case mb_fwk of
-            Just fwk_path -> loadDLL fwk_path
+            Just fwk_path -> loadDLL hsc_env fwk_path
             Nothing       -> return (Just "not found") }
                 -- Tried all our known library paths, but dlopen()
                 -- has no built-in paths for frameworks: give up
index 015126f..f71c904 100644 (file)
@@ -27,9 +27,9 @@ module RtClosureInspect(
 #include "HsVersions.h"
 
 import DebuggerUtils
-import ByteCodeItbls    ( StgInfoTable, peekItbl )
-import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
-import BasicTypes       ( HValue )
+import GHCi.RemoteTypes ( HValue )
+import qualified GHCi.InfoTable as InfoTable
+import GHCi.InfoTable (StgInfoTable, peekItbl)
 import HscTypes
 
 import DataCon
@@ -185,12 +185,12 @@ getClosureData dflags a =
                    -- into account the extra entry pointer when
                    -- !ghciTablesNextToCode, so we must adjust here:
                    iptr0 `plusPtr` negate (wORD_SIZE dflags)
-           itbl <- peekItbl dflags iptr1
-           let tipe = readCType (BCI.tipe itbl)
-               elems = fromIntegral (BCI.ptrs itbl)
+           itbl <- peekItbl iptr1
+           let tipe = readCType (InfoTable.tipe itbl)
+               elems = fromIntegral (InfoTable.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
                nptrs_data = [W# (indexWordArray# nptrs i)
-                              | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
+                            | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ]
            ASSERT(elems >= 0) return ()
            ptrsList `seq`
             return (Closure tipe iptr0 itbl ptrsList nptrs_data)
index a81ae80..052b061 100644 (file)
@@ -12,7 +12,8 @@ module Annotations (
 
         -- * AnnEnv for collecting and querying Annotations
         AnnEnv,
-        mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns,
+        mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv,
+        findAnns, findAnnsByTypeRep,
         deserializeAnns
     ) where
 
@@ -20,7 +21,7 @@ import Binary
 import Module           ( Module )
 import Name
 import Outputable
-import Serialized
+import GHC.Serialized
 import UniqFM
 import Unique
 
@@ -115,10 +116,17 @@ findAnns deserialize (MkAnnEnv ann_env)
   = (mapMaybe (fromSerialized deserialize))
     . (lookupWithDefaultUFM ann_env [])
 
+-- | Find the annotations attached to the given target as 'Typeable'
+--   values of your choice. If no deserializer is specified,
+--   only transient annotations will be returned.
+findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
+findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep
+  = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target
+    , tyrep' == tyrep ]
+
 -- | Deserialize all annotations of a given type. This happens lazily, that is
 --   no deserialization will take place until the [a] is actually demanded and
 --   the [a] can also be empty (the UniqFM is not filtered).
 deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
 deserializeAnns deserialize (MkAnnEnv ann_env)
   = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env
-
index 4692b21..c37cc65 100644 (file)
@@ -237,7 +237,7 @@ compileOne' m_tc_result mHscMessage
        needsLinker = needsTH || needsQQ
        isDynWay    = any (== WayDyn) (ways dflags0)
        isProfWay   = any (== WayProf) (ways dflags0)
-
+       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
 
        src_flavour = ms_hsc_src summary
        mod_name = ms_mod_name summary
@@ -245,9 +245,10 @@ compileOne' m_tc_result mHscMessage
        object_filename = ml_obj_file location
 
        -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
-       -- the linker can correctly load the object files.
-
-       dflags1 = if needsLinker && dynamicGhc && not isDynWay && not isProfWay
+       -- the linker can correctly load the object files.  This isn't necessary
+       -- when using -fexternal-interpreter.
+       dflags1 = if needsLinker && dynamicGhc && internalInterpreter &&
+                    not isDynWay && not isProfWay
                   then gopt_set dflags0 Opt_BuildDynamicToo
                   else dflags0
 
index e443926..03eb398 100644 (file)
@@ -72,8 +72,8 @@ module DynFlags (
         versionedAppDir,
         extraGccViaCFlags, systemPackageConfig,
         pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
-        pgm_windres, pgm_libtool, pgm_lo, pgm_lc,
-        opt_L, opt_P, opt_F, opt_c, opt_a, opt_l,
+        pgm_windres, pgm_libtool, pgm_lo, pgm_lc, pgm_i,
+        opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i,
         opt_windres, opt_lo, opt_lc,
 
 
@@ -428,6 +428,7 @@ data GeneralFlag
    | Opt_RelativeDynlibPaths
    | Opt_Hpc
    | Opt_FlatCache
+   | Opt_ExternalInterpreter
 
    -- PreInlining is on by default. The option is there just to see how
    -- bad things get if you turn it off!
@@ -884,6 +885,7 @@ data Settings = Settings {
   sPgm_libtool           :: String,
   sPgm_lo                :: (String,[Option]), -- LLVM: opt llvm optimiser
   sPgm_lc                :: (String,[Option]), -- LLVM: llc static compiler
+  sPgm_i                 :: String,
   -- options for particular phases
   sOpt_L                 :: [String],
   sOpt_P                 :: [String],
@@ -894,6 +896,7 @@ data Settings = Settings {
   sOpt_windres           :: [String],
   sOpt_lo                :: [String], -- LLVM: llvm optimiser
   sOpt_lc                :: [String], -- LLVM: llc static compiler
+  sOpt_i                 :: [String], -- iserv options
 
   sPlatformConstants     :: PlatformConstants
  }
@@ -944,6 +947,8 @@ pgm_lo                :: DynFlags -> (String,[Option])
 pgm_lo dflags = sPgm_lo (settings dflags)
 pgm_lc                :: DynFlags -> (String,[Option])
 pgm_lc dflags = sPgm_lc (settings dflags)
+pgm_i                 :: DynFlags -> String
+pgm_i dflags = sPgm_i (settings dflags)
 opt_L                 :: DynFlags -> [String]
 opt_L dflags = sOpt_L (settings dflags)
 opt_P                 :: DynFlags -> [String]
@@ -965,6 +970,8 @@ opt_lo                :: DynFlags -> [String]
 opt_lo dflags = sOpt_lo (settings dflags)
 opt_lc                :: DynFlags -> [String]
 opt_lc dflags = sOpt_lc (settings dflags)
+opt_i                 :: DynFlags -> [String]
+opt_i dflags = sOpt_i (settings dflags)
 
 -- | The directory for this version of ghc in the user's app directory
 -- (typically something like @~/.ghc/x86_64-linux-7.6.3@)
@@ -2188,6 +2195,8 @@ dynamic_flags = [
       (hasArg (\f -> alterSettings (\s -> s { sPgm_lo  = (f,[])})))
   , defFlag "pgmlc"
       (hasArg (\f -> alterSettings (\s -> s { sPgm_lc  = (f,[])})))
+  , defFlag "pgmi"
+      (hasArg (\f -> alterSettings (\s -> s { sPgm_i  =  f})))
   , defFlag "pgmL"
       (hasArg (\f -> alterSettings (\s -> s { sPgm_L   = f})))
   , defFlag "pgmP"
@@ -2214,6 +2223,8 @@ dynamic_flags = [
       (hasArg (\f -> alterSettings (\s -> s { sOpt_lo  = f : sOpt_lo s})))
   , defFlag "optlc"
       (hasArg (\f -> alterSettings (\s -> s { sOpt_lc  = f : sOpt_lc s})))
+  , defFlag "opti"
+      (hasArg (\f -> alterSettings (\s -> s { sOpt_i   = f : sOpt_i s})))
   , defFlag "optL"
       (hasArg (\f -> alterSettings (\s -> s { sOpt_L   = f : sOpt_L s})))
   , defFlag "optP"
@@ -2904,6 +2915,7 @@ fFlags = [
   flagSpec "error-spans"                      Opt_ErrorSpans,
   flagSpec "excess-precision"                 Opt_ExcessPrecision,
   flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,
+  flagSpec "external-interpreter"             Opt_ExternalInterpreter,
   flagSpec "flat-cache"                       Opt_FlatCache,
   flagSpec "float-in"                         Opt_FloatIn,
   flagSpec "force-recomp"                     Opt_ForceRecomp,
@@ -4158,6 +4170,33 @@ tARGET_MAX_WORD dflags
       8 -> toInteger (maxBound :: Word64)
       w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w)
 
+
+{- -----------------------------------------------------------------------------
+Note [DynFlags consistency]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are a number of number of DynFlags configurations which either
+do not make sense or lead to unimplemented or buggy codepaths in the
+compiler. makeDynFlagsConsistent is responsible for verifying the validity
+of a set of DynFlags, fixing any issues, and reporting them back to the
+caller.
+
+GHCi and -O
+---------------
+
+When using optimization, the compiler can introduce several things
+(such as unboxed tuples) into the intermediate code, which GHCi later
+chokes on since the bytecode interpreter can't handle this (and while
+this is arguably a bug these aren't handled, there are no plans to fix
+it.)
+
+While the driver pipeline always checks for this particular erroneous
+combination when parsing flags, we also need to check when we update
+the flags; this is because API clients may parse flags but update the
+DynFlags afterwords, before finally running code inside a session (see
+T10052 and #10052).
+-}
+
 -- | Resolve any internal inconsistencies in a set of 'DynFlags'.
 -- Returns the consistent 'DynFlags' as well as a list of warnings
 -- to report to the user.
@@ -4171,6 +4210,13 @@ makeDynFlagsConsistent dflags
     = let dflags' = gopt_unset dflags Opt_BuildDynamicToo
           warn    = "-dynamic-too is not supported on Windows"
       in loop dflags' warn
+ -- Disalbe -fexternal-interpreter on Windows.  This is a temporary measure;
+ -- all that is missing is the implementation of the interprocess communication
+ -- which uses pipes on POSIX systems. (#11100)
+ | os == OSMinGW32 && gopt Opt_ExternalInterpreter dflags
+    = let dflags' = gopt_unset dflags Opt_ExternalInterpreter
+          warn    = "-fexternal-interpreter is currently not supported on Windows"
+      in loop dflags' warn
  | hscTarget dflags == HscC &&
    not (platformUnregisterised (targetPlatform dflags))
     = if cGhcWithNativeCodeGen == "YES"
@@ -4211,6 +4257,7 @@ makeDynFlagsConsistent dflags
     = loop (updOptLevel 0 dflags) err
 
  | LinkInMemory <- ghcLink dflags
+ , not (gopt Opt_ExternalInterpreter dflags)
  , rtsIsProfiled
  , isObjectTarget (hscTarget dflags)
  , WayProf `notElem` ways dflags
@@ -4226,32 +4273,6 @@ makeDynFlagsConsistent dflags
           arch = platformArch platform
           os   = platformOS   platform
 
-{-
-Note [DynFlags consistency]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-There are a number of number of DynFlags configurations which either
-do not make sense or lead to unimplemented or buggy codepaths in the
-compiler. makeDynFlagsConsistent is responsible for verifying the validity
-of a set of DynFlags, fixing any issues, and reporting them back to the
-caller.
-
-GHCi and -O
----------------
-
-When using optimization, the compiler can introduce several things
-(such as unboxed tuples) into the intermediate code, which GHCi later
-chokes on since the bytecode interpreter can't handle this (and while
-this is arguably a bug these aren't handled, there are no plans to fix
-it.)
-
-While the driver pipeline always checks for this particular erroneous
-combination when parsing flags, we also need to check when we update
-the flags; this is because API clients may parse flags but update the
-DynFlags afterwords, before finally running code inside a session (see
-T10052 and #10052).
-
--}
 
 --------------------------------------------------------------------------
 -- Do not use unsafeGlobalDynFlags!
index 0d4b842..bbaf129 100644 (file)
@@ -24,6 +24,7 @@ module DynamicLoading (
 
 #ifdef GHCI
 import Linker           ( linkModule, getHValue )
+import GHCi             ( wormhole )
 import SrcLoc           ( noSrcSpan )
 import Finder           ( findImportedModule, cannotFindModule )
 import TcRnMonad        ( initTcInteractive, initIfaceTcRn )
@@ -38,7 +39,7 @@ import Plugins          ( Plugin, FrontendPlugin, CommandLineOption )
 import PrelNames        ( pluginTyConName, frontendPluginTyConName )
 
 import HscTypes
-import BasicTypes       ( HValue )
+import GHCi.RemoteTypes ( HValue )
 import Type             ( Type, eqType, mkTyConTy, pprTyThingCategory )
 import TyCon            ( TyCon )
 import Name             ( Name, nameModule_maybe )
@@ -170,7 +171,7 @@ getHValueSafely hsc_env val_name expected_type = do
                                    return ()
                     Nothing ->  return ()
                 -- Find the value that we just linked in and cast it given that we have proved it's type
-                hval <- getHValue hsc_env val_name
+                hval <- getHValue hsc_env val_name >>= wormhole dflags
                 return (Just hval)
              else return Nothing
         Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
index 74860a1..4bf9a58 100644 (file)
@@ -127,6 +127,8 @@ module GHC (
         -- ** Compiling expressions
         HValue, parseExpr, compileParsedExpr,
         InteractiveEval.compileExpr, dynCompileExpr,
+        ForeignHValue,
+        compileExprRemote, compileParsedExprRemote,
 
         -- ** Other
         runTcInteractive,   -- Desired by some clients (Trac #8878)
@@ -134,7 +136,7 @@ module GHC (
 
         -- ** The debugger
         SingleStep(..),
-        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
+        Resume(resumeStmt, resumeBreakInfo, resumeSpan,
                resumeHistory, resumeHistoryIx),
         History(historyBreakInfo, historyEnclosingDecls),
         GHC.getHistorySpan, getHistoryModule,
@@ -287,10 +289,12 @@ module GHC (
 #include "HsVersions.h"
 
 #ifdef GHCI
-import ByteCodeInstr
+import ByteCodeTypes
 import BreakArray
 import InteractiveEval
 import TcRnDriver       ( runTcInteractive )
+import GHCi
+import GHCi.RemoteTypes
 #endif
 
 import PprTyThing       ( pprFamInst )
@@ -405,22 +409,12 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
             ) $
   inner
 
--- | Install a default cleanup handler to remove temporary files deposited by
--- a GHC run.  This is separate from 'defaultErrorHandler', because you might
--- want to override the error handling, but still get the ordinary cleanup
--- behaviour.
-defaultCleanupHandler :: (ExceptionMonad m) =>
-                         DynFlags -> m a -> m a
-defaultCleanupHandler dflags inner =
-    -- make sure we clean up after ourselves
-    inner `gfinally`
-          (liftIO $ do
-              cleanTempFiles dflags
-              cleanTempDirs dflags
-          )
-          --  exceptions will be blocked while we clean the temporary files,
-          -- so there shouldn't be any difficulty if we receive further
-          -- signals.
+-- | This function is no longer necessary, cleanup is now done by
+-- runGhc/runGhcT.
+{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
+defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
+defaultCleanupHandler _ m = m
+ where _warning_suppression = m `gonException` undefined
 
 
 -- %************************************************************************
@@ -446,7 +440,8 @@ runGhc mb_top_dir ghc = do
   let session = Session ref
   flip unGhc session $ do
     initGhcMonad mb_top_dir
-    ghc
+    withCleanupSession ghc
+
   -- XXX: unregister interrupt handlers here?
 
 -- | Run function for 'GhcT' monad transformer.
@@ -469,7 +464,23 @@ runGhcT mb_top_dir ghct = do
   let session = Session ref
   flip unGhcT session $ do
     initGhcMonad mb_top_dir
-    ghct
+    withCleanupSession ghct
+
+withCleanupSession :: GhcMonad m => m a -> m a
+withCleanupSession ghc = ghc `gfinally` cleanup
+  where
+   cleanup = do
+      hsc_env <- getSession
+      let dflags = hsc_dflags hsc_env
+      liftIO $ do
+          cleanTempFiles dflags
+          cleanTempDirs dflags
+#ifdef GHCI
+          stopIServ hsc_env -- shut down the IServ
+#endif
+          --  exceptions will be blocked while we clean the temporary files,
+          -- so there shouldn't be any difficulty if we receive further
+          -- signals.
 
 -- | Initialise a GHC session.
 --
index f0dc300..41d4f1c 100644 (file)
@@ -532,7 +532,7 @@ unload :: HscEnv -> [Linkable] -> IO ()
 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
   = case ghcLink (hsc_dflags hsc_env) of
 #ifdef GHCI
-        LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
+        LinkInMemory -> Linker.unload hsc_env stable_linkables
 #else
         LinkInMemory -> panic "unload: no interpreter"
                                 -- urgh.  avoid warnings:
index c60b41e..2aef9b3 100644 (file)
@@ -18,7 +18,7 @@ module GhcPlugins(
         module TysWiredIn, module HscTypes, module BasicTypes,
         module VarSet, module VarEnv, module NameSet, module NameEnv,
         module UniqSet, module UniqFM, module FiniteMap,
-        module Util, module Serialized, module SrcLoc, module Outputable,
+        module Util, module GHC.Serialized, module SrcLoc, module Outputable,
         module UniqSupply, module Unique, module FastString
     ) where
 
@@ -75,7 +75,7 @@ import FiniteMap
 
 -- Common utilities
 import Util
-import Serialized
+import GHC.Serialized
 import SrcLoc
 import Outputable
 import UniqSupply
index f75214b..0b75bc5 100644 (file)
@@ -5,6 +5,7 @@
 -- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES
 -- stuff in compiler/ghc.mk makes DynFlags link to too much stuff
 
+{-# LANGUAGE CPP #-}
 module Hooks ( Hooks
              , emptyHooks
              , lookupHook
@@ -14,13 +15,17 @@ module Hooks ( Hooks
              , tcForeignImportsHook
              , tcForeignExportsHook
              , hscFrontendHook
+#ifdef GHCI
              , hscCompileCoreExprHook
+#endif
              , ghcPrimIfaceHook
              , runPhaseHook
              , runMetaHook
              , linkHook
              , runRnSpliceHook
+#ifdef GHCI
              , getValueSafelyHook
+#endif
              ) where
 
 import DynFlags
@@ -36,6 +41,9 @@ import TcRnTypes
 import Bag
 import RdrName
 import CoreSyn
+#ifdef GHCI
+import GHCi.RemoteTypes
+#endif
 import BasicTypes
 import Type
 import SrcLoc
@@ -55,21 +63,40 @@ import Data.Maybe
 --   uses the default built-in behaviour
 
 emptyHooks :: Hooks
-emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing
-                   Nothing Nothing Nothing Nothing Nothing Nothing
+emptyHooks = Hooks
+  { dsForeignsHook         = Nothing
+  , tcForeignImportsHook   = Nothing
+  , tcForeignExportsHook   = Nothing
+  , hscFrontendHook        = Nothing
+#ifdef GHCI
+  , hscCompileCoreExprHook = Nothing
+#endif
+  , ghcPrimIfaceHook       = Nothing
+  , runPhaseHook           = Nothing
+  , runMetaHook            = Nothing
+  , linkHook               = Nothing
+  , runRnSpliceHook        = Nothing
+#ifdef GHCI
+  , getValueSafelyHook     = Nothing
+#endif
+  }
 
 data Hooks = Hooks
   { dsForeignsHook         :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
   , tcForeignImportsHook   :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt))
   , tcForeignExportsHook   :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt))
   , hscFrontendHook        :: Maybe (ModSummary -> Hsc FrontendResult)
-  , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue)
+#ifdef GHCI
+  , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
+#endif
   , ghcPrimIfaceHook       :: Maybe ModIface
   , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
   , runMetaHook            :: Maybe (MetaHook TcM)
   , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
   , runRnSpliceHook        :: Maybe (HsSplice Name -> RnM (HsSplice Name))
+#ifdef GHCI
   , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
+#endif
   }
 
 getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a
index 0b60596..558341a 100644 (file)
@@ -90,7 +90,7 @@ module HscMain
 
 #ifdef GHCI
 import Id
-import BasicTypes       ( HValue )
+import GHCi.RemoteTypes ( ForeignHValue )
 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
 import Linker
 import CoreTidy         ( tidyExpr )
@@ -101,8 +101,6 @@ import VarEnv           ( emptyTidyEnv )
 import THNames          ( templateHaskellNames )
 import Panic
 import ConLike
-
-import GHC.Exts
 #endif
 
 import Module
@@ -162,6 +160,7 @@ import Stream (Stream)
 import Util
 
 import Data.List
+import Control.Concurrent
 import Control.Monad
 import Data.IORef
 import System.FilePath as FilePath
@@ -183,15 +182,20 @@ newHscEnv dflags = do
     us      <- mkSplitUniqSupply 'r'
     nc_var  <- newIORef (initNameCache us allKnownKeyNames)
     fc_var  <- newIORef emptyModuleEnv
-    return HscEnv {  hsc_dflags       = dflags,
-                     hsc_targets      = [],
-                     hsc_mod_graph    = [],
-                     hsc_IC           = emptyInteractiveContext dflags,
-                     hsc_HPT          = emptyHomePackageTable,
-                     hsc_EPS          = eps_var,
-                     hsc_NC           = nc_var,
-                     hsc_FC           = fc_var,
-                     hsc_type_env_var = Nothing }
+    iserv_mvar <- newMVar Nothing
+    return HscEnv {  hsc_dflags       = dflags
+                  ,  hsc_targets      = []
+                  ,  hsc_mod_graph    = []
+                  ,  hsc_IC           = emptyInteractiveContext dflags
+                  ,  hsc_HPT          = emptyHomePackageTable
+                  ,  hsc_EPS          = eps_var
+                  ,  hsc_NC           = nc_var
+                  ,  hsc_FC           = fc_var
+                  ,  hsc_type_env_var = Nothing
+#ifdef GHCI
+                  , hsc_iserv        = iserv_mvar
+#endif
+                  }
 
 
 allKnownKeyNames :: [Name]      -- Put here to avoid loops involving DsMeta,
@@ -1303,7 +1307,7 @@ hscInteractive hsc_env cgguts mod_summary = do
     prepd_binds <- {-# SCC "CorePrep" #-}
                    corePrepPgm hsc_env location core_binds data_tycons
     -----------------  Generate byte code ------------------
-    comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks
+    comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
     ------------------ Create f-x-dynamic C-side stuff ---
     (_istub_h_exists, istub_c_exists)
         <- outputForeignStubs dflags this_mod location foreign_stubs
@@ -1434,7 +1438,7 @@ IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
 --
 -- We return Nothing to indicate an empty statement (or comment only), not a
 -- parse error.
-hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
 
 -- | Compile a stmt all the way to an HValue, but don't run it
@@ -1445,7 +1449,9 @@ hscStmtWithLocation :: HscEnv
                     -> String -- ^ The statement
                     -> String -- ^ The source
                     -> Int    -- ^ Starting line
-                    -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+                    -> IO ( Maybe ([Id]
+                          , ForeignHValue {- IO [HValue] -}
+                          , FixityEnv))
 hscStmtWithLocation hsc_env0 stmt source linenumber =
   runInteractiveHsc hsc_env0 $ do
     maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
@@ -1458,7 +1464,9 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
 
 hscParsedStmt :: HscEnv
               -> GhciLStmt RdrName  -- ^ The parsed statement
-              -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+              -> IO ( Maybe ([Id]
+                    , ForeignHValue {- IO [HValue] -}
+                    , FixityEnv))
 hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
   -- Rename and typecheck it
   (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
@@ -1474,9 +1482,8 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
   -- Whereas the linker already knows to ignore 'interactive'
   let src_span = srcLocSpan interactiveSrcLoc
   hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
-  let hvals_io = unsafeCoerce# hval :: IO [HValue]
 
-  return $ Just (ids, hvals_io, fix_env)
+  return $ Just (ids, hval, fix_env)
 
 -- | Compile a decls
 hscDecls :: HscEnv
@@ -1518,8 +1525,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     {- Tidy -}
     (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
 
-    let dflags = hsc_dflags hsc_env
-        !CgGuts{ cg_module    = this_mod,
+    let !CgGuts{ cg_module    = this_mod,
                  cg_binds     = core_binds,
                  cg_tycons    = tycons,
                  cg_modBreaks = mod_breaks } = tidy_cg
@@ -1536,7 +1542,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
       liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons
 
     {- Generate byte code -}
-    cbc <- liftIO $ byteCodeGen dflags this_mod
+    cbc <- liftIO $ byteCodeGen hsc_env this_mod
                                 prepd_binds data_tycons mod_breaks
 
     let src_span = srcLocSpan interactiveSrcLoc
@@ -1715,11 +1721,11 @@ mkModGuts mod safe binds =
 %********************************************************************* -}
 
 #ifdef GHCI
-hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
 hscCompileCoreExpr hsc_env =
   lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
 
-hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
 hscCompileCoreExpr' hsc_env srcspan ds_expr
     = do { let dflags = hsc_dflags hsc_env
 
@@ -1736,7 +1742,8 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
          ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
 
            {- Convert to BCOs -}
-         ; bcos <- coreExprToBCOs dflags (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
+         ; bcos <- coreExprToBCOs hsc_env
+                     (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
 
            {- link it -}
          ; hval <- linkExpr hsc_env srcspan bcos
index 40c99f6..3766b57 100644 (file)
@@ -14,6 +14,9 @@ module HscTypes (
         Target(..), TargetId(..), pprTarget, pprTargetId,
         ModuleGraph, emptyMG,
         HscStatus(..),
+#ifdef GHCI
+        IServ(..),
+#endif
 
         -- * Hsc monad
         Hsc(..), runHsc, runInteractiveHsc,
@@ -130,8 +133,10 @@ module HscTypes (
 #include "HsVersions.h"
 
 #ifdef GHCI
-import ByteCodeAsm      ( CompiledByteCode )
+import ByteCodeTypes        ( CompiledByteCode )
 import InteractiveEvalTypes ( Resume )
+import GHCi.Message         ( Pipe )
+import GHCi.RemoteTypes     ( HValueRef )
 #endif
 
 import HsSyn
@@ -184,16 +189,19 @@ import Binary
 import ErrUtils
 import Platform
 import Util
-import Serialized       ( Serialized )
+import GHC.Serialized   ( Serialized )
 
 import Control.Monad    ( guard, liftM, when, ap )
+import Control.Concurrent
 import Data.Array       ( Array, array )
 import Data.IORef
 import Data.Time
 import Data.Word
 import Data.Typeable    ( Typeable )
 import Exception
+import Foreign
 import System.FilePath
+import System.Process   ( ProcessHandle )
 
 -- -----------------------------------------------------------------------------
 -- Compilation state
@@ -333,7 +341,7 @@ handleFlagWarnings dflags warns
 ************************************************************************
 -}
 
--- | Hscenv is like 'Session', except that some of the fields are immutable.
+-- | HscEnv is like 'Session', except that some of the fields are immutable.
 -- An HscEnv is used to compile a single module from plain Haskell source
 -- code (after preprocessing) to either C, assembly or C--.  Things like
 -- the module graph don't change during a single compilation.
@@ -394,12 +402,27 @@ data HscEnv
                 -- ^ Used for one-shot compilation only, to initialise
                 -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for
                 -- 'TcRunTypes.TcGblEnv'
+
+#ifdef GHCI
+        , hsc_iserv :: MVar (Maybe IServ)
+                -- ^ interactive server process.  Created the first
+                -- time it is needed.
+#endif
  }
 
 instance ContainsDynFlags HscEnv where
     extractDynFlags env = hsc_dflags env
     replaceDynFlags env dflags = env {hsc_dflags = dflags}
 
+#ifdef GHCI
+data IServ = IServ
+  { iservPipe :: Pipe
+  , iservProcess :: ProcessHandle
+  , iservLookupSymbolCache :: IORef (UniqFM (Ptr ()))
+  , iservPendingFrees :: [HValueRef]
+  }
+#endif
+
 -- | Retrieve the ExternalPackageState cache.
 hscEPS :: HscEnv -> IO ExternalPackageState
 hscEPS hsc_env = readIORef (hsc_EPS hsc_env)
index ac53382..2f819e4 100644 (file)
@@ -11,7 +11,7 @@
 
 module InteractiveEval (
 #ifdef GHCI
-        Status(..), Resume(..), History(..),
+        Resume(..), History(..),
         execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec,
         runDecls, runDeclsWithLocation,
         isStmt, isImport, isDecl,
@@ -36,6 +36,7 @@ module InteractiveEval (
         isModuleInterpreted,
         parseExpr, compileParsedExpr,
         compileExpr, dynCompileExpr,
+        compileExprRemote, compileParsedExprRemote,
         Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,
         -- * Depcreated API (remove in GHC 7.14)
         RunResult(..), runStmt, runStmtWithLocation,
@@ -48,11 +49,13 @@ module InteractiveEval (
 
 import InteractiveEvalTypes
 
+import GHCi
+import GHCi.Run
+import GHCi.RemoteTypes
 import GhcMonad
 import HscMain
 import HsSyn
 import HscTypes
-import BasicTypes ( HValue )
 import InstEnv
 import IfaceEnv   ( newInteractiveBinder )
 import FamInstEnv ( FamInst, orphNamesOfFamInst )
@@ -67,7 +70,7 @@ import Avail
 import RdrName
 import VarSet
 import VarEnv
-import ByteCodeInstr
+import ByteCodeTypes
 import Linker
 import DynFlags
 import Unique
@@ -88,25 +91,16 @@ import Bag
 import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
 import qualified Parser (parseStmt, parseModule, parseDeclaration)
 
-import System.Mem.Weak
 import System.Directory
 import Data.Dynamic
 import Data.Either
 import Data.List (find)
 import StringBuffer (stringToStringBuffer)
 import Control.Monad
-#if __GLASGOW_HASKELL__ >= 709
-import Foreign
-#else
-import Foreign.Safe
-#endif
-import Foreign.C
 import GHC.Exts
 import Data.Array
 import Exception
 import Control.Concurrent
-import System.IO.Unsafe
-import GHC.Conc         ( setAllocationCounter, getAllocationCounter )
 
 -- -----------------------------------------------------------------------------
 -- running a statement interactively
@@ -114,7 +108,7 @@ import GHC.Conc         ( setAllocationCounter, getAllocationCounter )
 getResumeContext :: GhcMonad m => m [Resume]
 getResumeContext = withSession (return . ic_resume . hsc_IC)
 
-mkHistory :: HscEnv -> HValue -> BreakInfo -> History
+mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
 mkHistory hsc_env hval bi = let
     decls = findEnclosingDecls hsc_env bi
     in History hval bi decls
@@ -166,6 +160,7 @@ execOptions = ExecOptions
   { execSingleStep = RunToCompletion
   , execSourceFile = "<interactive>"
   , execLineNumber = 1
+  , execWrap = EvalThis -- just run the statement, don't wrap it in anything
   }
 
 -- | Run a statement in the current interactive context.
@@ -177,12 +172,7 @@ execStmt
 execStmt stmt ExecOptions{..} = do
     hsc_env <- getSession
 
-    -- wait on this when we hit a breakpoint
-    breakMVar  <- liftIO $ newEmptyMVar
-    -- wait on this when a computation is running
-    statusMVar <- liftIO $ newEmptyMVar
-
-    -- Turn off -Wunused-local-binds when running a statement, to hide
+    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
     -- warnings about the implicit bindings we introduce.
     let ic       = hsc_IC hsc_env -- use the interactive dflags
         idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
@@ -201,9 +191,8 @@ execStmt stmt ExecOptions{..} = do
 
         status <-
           withVirtualCWD $
-            withBreakAction (isStep execSingleStep) idflags'
-               breakMVar statusMVar $ do
-                 liftIO $ sandboxIO idflags' statusMVar hval
+            liftIO $
+              evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
 
         let ic = hsc_IC hsc_env
             bindings = (ic_tythings ic, ic_rn_gbl_env ic)
@@ -211,7 +200,7 @@ execStmt stmt ExecOptions{..} = do
             size = ghciHistSize idflags'
 
         handleRunStatus execSingleStep stmt bindings ids
-                        breakMVar statusMVar status (emptyHistory size)
+                        status (emptyHistory size)
 
 -- | The type returned by the deprecated 'runStmt' and
 -- 'runStmtWithLocation' API
@@ -226,7 +215,7 @@ execResultToRunResult r =
   case r of
     ExecComplete{ execResult = Left ex } -> RunException ex
     ExecComplete{ execResult = Right names } -> RunOk names
-    ExecBreak{..} -> RunBreak breakThreadId breakNames breakInfo
+    ExecBreak{..} -> RunBreak (error "no breakThreadId") breakNames breakInfo
 
 -- Remove in GHC 7.14
 {-# DEPRECATED runStmt "use execStmt" #-}
@@ -249,7 +238,8 @@ runStmtWithLocation source linenumber expr step = do
 runDecls :: GhcMonad m => String -> m [Name]
 runDecls = runDeclsWithLocation "<interactive>" 1
 
-runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
+runDeclsWithLocation
+ :: GhcMonad m => String -> Int -> String -> m [Name]
 runDeclsWithLocation source linenumber expr =
   do
     hsc_env <- getSession
@@ -265,8 +255,12 @@ runDeclsWithLocation source linenumber expr =
 withVirtualCWD :: GhcMonad m => m a -> m a
 withVirtualCWD m = do
   hsc_env <- getSession
-  let ic = hsc_IC hsc_env
 
+    -- a virtual CWD is only necessary when we're running interpreted code in
+    -- the same process as the compiler.
+  if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do
+
+  let ic = hsc_IC hsc_env
   let set_cwd = do
         dir <- liftIO $ getCurrentDirectory
         case ic_cwd ic of
@@ -291,68 +285,67 @@ emptyHistory size = nilBL size
 
 handleRunStatus :: GhcMonad m
                 => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
-                -> MVar () -> MVar Status -> Status -> BoundedList History
+                -> EvalStatus [ForeignHValue] -> BoundedList History
                 -> m ExecResult
 
-handleRunStatus step expr bindings final_ids
-               breakMVar statusMVar status history
+handleRunStatus step expr bindings final_ids status history
   | RunAndLogSteps <- step = tracing
   | otherwise              = not_tracing
  where
   tracing
-    | Break is_exception apStack info tid <- status
+    | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status
     , not is_exception
     = do
        hsc_env <- getSession
+       let dflags = hsc_dflags hsc_env
+       info_hv <- liftIO $ wormholeRef dflags info_ref
+       let info = unsafeCoerce# info_hv :: BreakInfo
        b <- liftIO $ isBreakEnabled hsc_env info
        if b
          then not_tracing
            -- This breakpoint is explicitly enabled; we want to stop
            -- instead of just logging it.
          else do
-           let history' = mkHistory hsc_env apStack info `consBL` history
+           apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
+           let history' = mkHistory hsc_env apStack_fhv info `consBL` history
                  -- probably better make history strict here, otherwise
                  -- our BoundedList will be pointless.
            _ <- liftIO $ evaluate history'
-           status <- withBreakAction True (hsc_dflags hsc_env)
-                                     breakMVar statusMVar $ do
-                     liftIO $ mask_ $ do
-                        putMVar breakMVar ()  -- awaken the stopped thread
-                        redirectInterrupts tid $
-                          takeMVar statusMVar   -- and wait for the result
+           fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+           status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
            handleRunStatus RunAndLogSteps expr bindings final_ids
-                           breakMVar statusMVar status history'
+                           status history'
     | otherwise
     = not_tracing
 
   not_tracing
     -- Hit a breakpoint
-    | Break is_exception apStack info tid <- status
+    | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status
     = do
          hsc_env <- getSession
+         let dflags = hsc_dflags hsc_env
+         info_hv <- liftIO $ wormholeRef dflags info_ref
+         let info = unsafeCoerce# info_hv :: BreakInfo
+         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+         apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
          let mb_info | is_exception = Nothing
                      | otherwise    = Just info
          (hsc_env1, names, span) <- liftIO $
-           bindLocalsAtBreakpoint hsc_env apStack mb_info
+           bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info
          let
            resume = Resume
-             { resumeStmt = expr, resumeThreadId = tid
-             , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
+             { resumeStmt = expr, resumeContext = resume_ctxt_fhv
              , resumeBindings = bindings, resumeFinalIds = final_ids
-             , resumeApStack = apStack, resumeBreakInfo = mb_info
+             , resumeApStack = apStack_fhv, resumeBreakInfo = mb_info
              , resumeSpan = span, resumeHistory = toListBL history
              , resumeHistoryIx = 0 }
            hsc_env2 = pushResume hsc_env1 resume
 
          modifySession (\_ -> hsc_env2)
-         return (ExecBreak tid names mb_info)
-
-    -- Completed with an exception
-    | Complete (Left e) alloc <- status
-    = return (ExecComplete (Left e) alloc)
+         return (ExecBreak names mb_info)
 
     -- Completed successfully
-    | Complete (Right hvals) allocs <- status
+    | EvalComplete allocs (EvalSuccess hvals) <- status
     = do hsc_env <- getSession
          let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
              final_names = map getName final_ids
@@ -361,8 +354,12 @@ handleRunStatus step expr bindings final_ids
          modifySession (\_ -> hsc_env')
          return (ExecComplete (Right final_names) allocs)
 
+    -- Completed with an exception
+    | EvalComplete alloc (EvalException e) <- status
+    = return (ExecComplete (Left (fromSerializableException e)) alloc)
+
     | otherwise
-    = panic "handleRunStatus"  -- The above cases are in fact exhaustive
+    = panic "not_tracing" -- actually exhaustive, but GHC can't tell
 
 isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
 isBreakEnabled hsc_env inf =
@@ -376,148 +373,6 @@ isBreakEnabled hsc_env inf =
          return False
 
 
-foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt
-foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt
-
-setStepFlag :: IO ()
-setStepFlag = poke stepFlag 1
-resetStepFlag :: IO ()
-resetStepFlag = poke stepFlag 0
-
--- this points to the IO action that is executed when a breakpoint is hit
-foreign import ccall "&rts_breakpoint_io_action"
-   breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ()))
-
--- When running a computation, we redirect ^C exceptions to the running
--- thread.  ToDo: we might want a way to continue even if the target
--- thread doesn't die when it receives the exception... "this thread
--- is not responding".
---
--- Careful here: there may be ^C exceptions flying around, so we start the new
--- thread blocked (forkIO inherits mask from the parent, #1048), and unblock
--- only while we execute the user's code.  We can't afford to lose the final
--- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)
-sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
-sandboxIO dflags statusMVar thing =
-   mask $ \restore -> -- fork starts blocked
-     let runIt =
-           liftM (uncurry Complete) $
-           measureAlloc $
-           try $ restore $ rethrow dflags $ thing
-     in if gopt Opt_GhciSandbox dflags
-        then do tid <- forkIO $ do res <- runIt
-                                   putMVar statusMVar res -- empty: can't block
-                redirectInterrupts tid $
-                  takeMVar statusMVar
-
-        else -- GLUT on OS X needs to run on the main thread. If you
-             -- try to use it from another thread then you just get a
-             -- white rectangle rendered. For this, or anything else
-             -- with such restrictions, you can turn the GHCi sandbox off
-             -- and things will be run in the main thread.
-             --
-             -- BUT, note that the debugging features (breakpoints,
-             -- tracing, etc.) need the expression to be running in a
-             -- separate thread, so debugging is only enabled when
-             -- using the sandbox.
-             runIt
-
---
--- While we're waiting for the sandbox thread to return a result, if
--- the current thread receives an asynchronous exception we re-throw
--- it at the sandbox thread and continue to wait.
---
--- This is for two reasons:
---
---  * So that ^C interrupts runStmt (e.g. in GHCi), allowing the
---    computation to run its exception handlers before returning the
---    exception result to the caller of runStmt.
---
---  * clients of the GHC API can terminate a runStmt in progress
---    without knowing the ThreadId of the sandbox thread (#1381)
---
--- NB. use a weak pointer to the thread, so that the thread can still
--- be considered deadlocked by the RTS and sent a BlockedIndefinitely
--- exception.  A symptom of getting this wrong is that conc033(ghci)
--- will hang.
---
-redirectInterrupts :: ThreadId -> IO a -> IO a
-redirectInterrupts target wait
-  = do wtid <- mkWeakThreadId target
-       wait `catch` \e -> do
-          m <- deRefWeak wtid
-          case m of
-            Nothing -> wait
-            Just target -> do throwTo target (e :: SomeException); wait
-
-measureAlloc :: IO a -> IO (a,Word64)
-measureAlloc io = do
-  setAllocationCounter maxBound
-  a <- io
-  allocs <- getAllocationCounter
-  return (a, fromIntegral (maxBound::Int64) - fromIntegral allocs)
-
--- We want to turn ^C into a break when -fbreak-on-exception is on,
--- but it's an async exception and we only break for sync exceptions.
--- Idea: if we catch and re-throw it, then the re-throw will trigger
--- a break.  Great - but we don't want to re-throw all exceptions, because
--- then we'll get a double break for ordinary sync exceptions (you'd have
--- to :continue twice, which looks strange).  So if the exception is
--- not "Interrupted", we unset the exception flag before throwing.
---
-rethrow :: DynFlags -> IO a -> IO a
-rethrow dflags io = Exception.catch io $ \se -> do
-                   -- If -fbreak-on-error, we break unconditionally,
-                   --  but with care of not breaking twice
-                if gopt Opt_BreakOnError dflags &&
-                   not (gopt Opt_BreakOnException dflags)
-                    then poke exceptionFlag 1
-                    else case fromException se of
-                         -- If it is a "UserInterrupt" exception, we allow
-                         --  a possible break by way of -fbreak-on-exception
-                         Just UserInterrupt -> return ()
-                         -- In any other case, we don't want to break
-                         _ -> poke exceptionFlag 0
-
-                Exception.throwIO se
-
--- This function sets up the interpreter for catching breakpoints, and
--- resets everything when the computation has stopped running.  This
--- is a not-very-good way to ensure that only the interactive
--- evaluation should generate breakpoints.
-withBreakAction :: (ExceptionMonad m) =>
-                   Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
-withBreakAction step dflags breakMVar statusMVar act
- = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)
- where
-   setBreakAction = do
-     stablePtr <- newStablePtr onBreak
-     poke breakPointIOAction stablePtr
-     when (gopt Opt_BreakOnException dflags) $ poke exceptionFlag 1
-     when step $ setStepFlag
-     return stablePtr
-        -- Breaking on exceptions is not enabled by default, since it
-        -- might be a bit surprising.  The exception flag is turned off
-        -- as soon as it is hit, or in resetBreakAction below.
-
-   onBreak is_exception info apStack = do
-     tid <- myThreadId
-     putMVar statusMVar (Break is_exception apStack info tid)
-     takeMVar breakMVar
-
-   resetBreakAction stablePtr = do
-     poke breakPointIOAction noBreakStablePtr
-     poke exceptionFlag 0
-     resetStepFlag
-     freeStablePtr stablePtr
-
-noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ())
-noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
-
-noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
-noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
-noBreakAction True  _ _ = return () -- exception: just continue
-
 resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult
 resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step
 
@@ -547,22 +402,14 @@ resumeExec canLogSpan step
                                            (ic_tythings ic))
         liftIO $ Linker.deleteFromLinkEnv new_names
 
-        when (isStep step) $ liftIO setStepFlag
         case r of
-          Resume { resumeStmt = expr, resumeThreadId = tid
-                 , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar
+          Resume { resumeStmt = expr, resumeContext = fhv
                  , resumeBindings = bindings, resumeFinalIds = final_ids
-                 , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span
+                 , resumeApStack = apStack, resumeBreakInfo = info
+                 , resumeSpan = span
                  , resumeHistory = hist } -> do
                withVirtualCWD $ do
-                withBreakAction (isStep step) (hsc_dflags hsc_env)
-                                        breakMVar statusMVar $ do
-                status <- liftIO $ mask_ $ do
-                             putMVar breakMVar ()
-                                      -- this awakens the stopped thread...
-                             redirectInterrupts tid $
-                               takeMVar statusMVar
-                                      -- and wait for the result
+                status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
                 let prevHistoryLst = fromListBL 50 hist
                     hist' = case info of
                        Nothing -> prevHistoryLst
@@ -570,8 +417,7 @@ resumeExec canLogSpan step
                          | not $canLogSpan span -> prevHistoryLst
                          | otherwise -> mkHistory hsc_env apStack i `consBL`
                                                         fromListBL 50 hist
-                handleRunStatus step expr bindings final_ids
-                                breakMVar statusMVar status hist'
+                handleRunStatus step expr bindings final_ids status hist'
 
 back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
 back n = moveHist (+n)
@@ -626,7 +472,7 @@ result_fs = fsLit "_result"
 
 bindLocalsAtBreakpoint
         :: HscEnv
-        -> HValue
+        -> ForeignHValue
         -> Maybe BreakInfo
         -> IO (HscEnv, [Name], SrcSpan)
 
@@ -648,13 +494,12 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
        ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
 
    --
-   Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)]
+   Linker.extendLinkEnv [(exn_name, apStack)]
    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span)
 
 -- Just case: we stopped at a breakpoint, we have information about the location
 -- of the breakpoint and the free variables of the expression.
-bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
-
+bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do
    let
        mod_name  = moduleName (breakInfo_module info)
        hmi       = expectJust "bindLocalsAtBreakpoint" $
@@ -682,12 +527,12 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
    -- has been accidentally evaluated, or something else has gone wrong.
    -- So that we don't fall over in a heap when this happens, just don't
    -- bind any free variables instead, and we emit a warning.
+   apStack <- wormhole (hsc_dflags hsc_env) apStack_fhv
    mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets)
    when (any isNothing mb_hValues) $
       debugTraceMsg (hsc_dflags hsc_env) 1 $
           text "Warning: _result has been evaluated, some bindings have been lost"
 
-
    us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time
    let tv_subst     = newTyVars us free_tvs
        filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
@@ -706,8 +551,10 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
        ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
        names  = map idName new_ids
 
-   Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
-   when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
+   fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkHValueRef)
+             (catMaybes mb_hValues)
+   Linker.extendLinkEnv (zip names fhvs)
+   when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
    return (hsc_env1, if result_ok then result_name:names else names, span)
   where
@@ -791,7 +638,7 @@ abandon = do
       []    -> return False
       r:rs  -> do
          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
-         liftIO $ abandon_ r
+         liftIO $ abandonStmt hsc_env (resumeContext r)
          return True
 
 abandonAll :: GhcMonad m => m Bool
@@ -803,28 +650,9 @@ abandonAll = do
       []  -> return False
       rs  -> do
          modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
-         liftIO $ mapM_ abandon_ rs
+         liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
          return True
 
--- when abandoning a computation we have to
---      (a) kill the thread with an async exception, so that the
---          computation itself is stopped, and
---      (b) fill in the MVar.  This step is necessary because any
---          thunks that were under evaluation will now be updated
---          with the partial computation, which still ends in takeMVar,
---          so any attempt to evaluate one of these thunks will block
---          unless we fill in the MVar.
---      (c) wait for the thread to terminate by taking its status MVar.  This
---          step is necessary to prevent race conditions with
---          -fbreak-on-exception (see #5975).
---  See test break010.
-abandon_ :: Resume -> IO ()
-abandon_ r = do
-  killThread (resumeThreadId r)
-  putMVar (resumeBreakMVar r) ()
-  _ <- takeMVar (resumeStatMVar r)
-  return ()
-
 -- -----------------------------------------------------------------------------
 -- Bounded list, optimised for repeated cons
 
@@ -1058,10 +886,16 @@ compileExpr expr = do
   parsed_expr <- parseExpr expr
   compileParsedExpr parsed_expr
 
+-- | Compile an expression, run it and deliver the resulting HValue.
+compileExprRemote :: GhcMonad m => String -> m ForeignHValue
+compileExprRemote expr = do
+  parsed_expr <- parseExpr expr
+  compileParsedExprRemote parsed_expr
+
 -- | Compile an parsed expression (before renaming), run it and deliver
 -- the resulting HValue.
-compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue
-compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do
+compileParsedExprRemote :: GhcMonad m => LHsExpr RdrName -> m ForeignHValue
+compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
   -- > let _compileParsedExpr = expr
   -- Create let stmt from expr to make hscParsedStmt happy.
   -- We will ignore the returned [Id], namely [expr_id], and not really
@@ -1071,13 +905,21 @@ compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do
       let_stmt = L loc . LetStmt . L loc . HsValBinds $
         ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
 
-  Just (ids, hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
+  Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt
   updateFixityEnv fix_env
-  hvals <- liftIO hvals_io
-  case (ids, hvals) of
-    ([_expr_id], [hval]) -> return hval
+  status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
+  case status of
+    EvalComplete _ (EvalSuccess [hval]) -> return hval
+    EvalComplete _ (EvalException e) ->
+      liftIO $ throwIO (fromSerializableException e)
     _ -> panic "compileParsedExpr"
 
+compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue
+compileParsedExpr expr = do
+   fhv <- compileParsedExprRemote expr
+   dflags <- getDynFlags
+   liftIO $ wormhole dflags fhv
+
 -- | Compile an expression, run it and return the result as a Dynamic.
 dynCompileExpr :: GhcMonad m => String -> m Dynamic
 dynCompileExpr expr = do
@@ -1116,14 +958,16 @@ obtainTermFromVal hsc_env bound force ty x =
 
 obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
 obtainTermFromId hsc_env bound force id =  do
-              hv <- Linker.getHValue hsc_env (varName id)
-              cvObtainTerm hsc_env bound force (idType id) hv
+  let dflags = hsc_dflags hsc_env
+  hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
+  cvObtainTerm hsc_env bound force (idType id) hv
 
 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 reconstructType hsc_env bound id = do
-              hv <- Linker.getHValue hsc_env (varName id)
-              cvReconstructType hsc_env bound (idType id) hv
+  let dflags = hsc_dflags hsc_env
+  hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
+  cvReconstructType hsc_env bound (idType id) hv
 
 mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
 mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
index 7e6e837..98090bb 100644 (file)
 
 module InteractiveEvalTypes (
 #ifdef GHCI
-        Status(..), Resume(..), History(..), ExecResult(..),
+        Resume(..), History(..), ExecResult(..),
         SingleStep(..), isStep, ExecOptions(..)
 #endif
         ) where
 
 #ifdef GHCI
 
+import GHCi.RemoteTypes (ForeignHValue)
+import GHCi.Message (EvalExpr)
 import Id
-import BasicTypes
 import Name
 import RdrName
 import Type
-import ByteCodeInstr
+import ByteCodeTypes
 import SrcLoc
 import Exception
-import Control.Concurrent
 
 import Data.Word
 
@@ -34,6 +34,7 @@ data ExecOptions
      { execSingleStep :: SingleStep         -- ^ stepping mode
      , execSourceFile :: String             -- ^ filename (for errors)
      , execLineNumber :: Int                -- ^ line number (for errors)
+     , execWrap :: ForeignHValue -> EvalExpr ForeignHValue
      }
 
 data SingleStep
@@ -51,26 +52,17 @@ data ExecResult
        , execAllocation :: Word64
        }
   | ExecBreak
-       { breakThreadId :: ThreadId
-       , breakNames :: [Name]
+       { breakNames :: [Name]
        , breakInfo :: Maybe BreakInfo
        }
 
-data Status
-   = Break Bool HValue BreakInfo ThreadId
-          -- ^ the computation hit a breakpoint (Bool <=> was an exception)
-   | Complete (Either SomeException [HValue]) Word64
-          -- ^ the computation completed with either an exception or a value
-
 data Resume
    = Resume {
        resumeStmt      :: String,       -- the original statement
-       resumeThreadId  :: ThreadId,     -- thread running the computation
-       resumeBreakMVar :: MVar (),
-       resumeStatMVar  :: MVar Status,
+       resumeContext   :: ForeignHValue, -- thread running the computation
        resumeBindings  :: ([TyThing], GlobalRdrEnv),
        resumeFinalIds  :: [Id],         -- [Id] to bind on completion
-       resumeApStack   :: HValue,       -- The object from which we can get
+       resumeApStack   :: ForeignHValue, -- The object from which we can get
                                         -- value of the free variables.
        resumeBreakInfo :: Maybe BreakInfo,
                                         -- the breakpoint we stopped at
@@ -84,7 +76,7 @@ data Resume
 
 data History
    = History {
-        historyApStack   :: HValue,
+        historyApStack   :: ForeignHValue,
         historyBreakInfo :: BreakInfo,
         historyEnclosingDecls :: [String]  -- declarations enclosing the breakpoint
    }
index ad717a8..c7ca4a6 100644 (file)
@@ -187,6 +187,8 @@ initSysTools mbMinusB
            platformConstantsFile = top_dir </> "platformConstants"
            installed :: FilePath -> FilePath
            installed file = top_dir </> file
+           libexec :: FilePath -> FilePath
+           libexec file = top_dir </> "bin" </> file
 
        settingsStr <- readFile settingsFile
        platformConstantsStr <- readFile platformConstantsFile
@@ -265,10 +267,10 @@ initSysTools mbMinusB
 
              -- For all systems, unlit, split, mangle are GHC utilities
              -- architecture-specific stuff is done when building Config.hs
-           unlit_path = installed cGHC_UNLIT_PGM
+           unlit_path = libexec cGHC_UNLIT_PGM
 
              -- split is a Perl script
-           split_script  = installed cGHC_SPLIT_PGM
+           split_script  = libexec cGHC_SPLIT_PGM
 
        windres_path <- getSetting "windres command"
        libtool_path <- getSetting "libtool command"
@@ -305,6 +307,8 @@ initSysTools mbMinusB
        lc_prog <- getSetting "LLVM llc command"
        lo_prog <- getSetting "LLVM opt command"
 
+       let iserv_prog = libexec "ghc-iserv"
+
        let platform = Platform {
                           platformArch = targetArch,
                           platformOS   = targetOS,
@@ -344,6 +348,7 @@ initSysTools mbMinusB
                     sPgm_libtool = libtool_path,
                     sPgm_lo  = (lo_prog,[]),
                     sPgm_lc  = (lc_prog,[]),
+                    sPgm_i   = iserv_prog,
                     sOpt_L       = [],
                     sOpt_P       = [],
                     sOpt_F       = [],
@@ -353,6 +358,7 @@ initSysTools mbMinusB
                     sOpt_windres = [],
                     sOpt_lo      = [],
                     sOpt_lc      = [],
+                    sOpt_i       = [],
                     sPlatformConstants = platformConstants
              }
 
index ff46134..db56d69 100644 (file)
@@ -47,7 +47,7 @@ import DynFlags         ( DynFlags(..) )
 import StaticFlags      ( opt_PprStyle_Debug )
 import Maybes           ( orElse, catMaybes, isJust, isNothing )
 import Demand
-import Serialized       ( deserializeWithData )
+import GHC.Serialized   ( deserializeWithData )
 import Util
 import Pair
 import UniqSupply
index 6fc26f8..d30cf44 100644 (file)
@@ -28,7 +28,7 @@ module TcRnDriver (
     ) where
 
 #ifdef GHCI
-import {-# SOURCE #-} TcSplice ( runQuasi )
+import {-# SOURCE #-} TcSplice ( finishTH )
 import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
 import IfaceEnv( externaliseName )
 import TcHsType
@@ -485,11 +485,7 @@ tcRnSrcDecls explicit_mod_hdr decls
       ; setEnvs (tcg_env, tcl_env) $ do {
 
 #ifdef GHCI
-        -- Run all module finalizers
-        let th_modfinalizers_var = tcg_th_modfinalizers tcg_env
-      ; modfinalizers <- readTcRef th_modfinalizers_var
-      ; writeTcRef th_modfinalizers_var []
-      ; mapM_ runQuasi modfinalizers
+      ; finishTH
 #endif /* GHCI */
 
         -- wanted constraints from static forms
index 5797b8e..f5d5ed5 100644 (file)
@@ -101,6 +101,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
         th_topnames_var      <- newIORef emptyNameSet ;
         th_modfinalizers_var <- newIORef [] ;
         th_state_var         <- newIORef Map.empty ;
+        th_remote_state_var  <- newIORef Nothing ;
 #endif /* GHCI */
         let {
              dflags = hsc_dflags hsc_env ;
@@ -116,6 +117,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_th_topnames      = th_topnames_var,
                 tcg_th_modfinalizers = th_modfinalizers_var,
                 tcg_th_state         = th_state_var,
+                tcg_th_remote_state  = th_remote_state_var,
 #endif /* GHCI */
 
                 tcg_mod            = mod,
index 47d554d..c885bbd 100644 (file)
@@ -174,6 +174,7 @@ import qualified Control.Monad.Fail as MonadFail
 import Data.Map      ( Map )
 import Data.Dynamic  ( Dynamic )
 import Data.Typeable ( TypeRep )
+import GHCi.RemoteTypes
 
 import qualified Language.Haskell.TH as TH
 #endif
@@ -492,6 +493,7 @@ data TcGblEnv
         -- ^ Template Haskell module finalizers
 
         tcg_th_state :: TcRef (Map TypeRep Dynamic),
+        tcg_th_remote_state :: TcRef (Maybe ForeignHValue),
         -- ^ Template Haskell state
 #endif /* GHCI */
 
index 2074100..64f7d1d 100644 (file)
@@ -11,6 +11,8 @@ TcSplice: Template Haskell splices
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module TcSplice(
@@ -26,7 +28,8 @@ module TcSplice(
      -- called only in stage2 (ie GHCI is on)
      runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
      tcTopSpliceExpr, lookupThName_maybe,
-     defaultRunMeta, runMeta'
+     defaultRunMeta, runMeta',
+     finishTH
 #endif
       ) where
 
@@ -47,6 +50,9 @@ import TcUnify
 import TcEnv
 
 #ifdef GHCI
+import GHCi.Message
+import GHCi.RemoteTypes
+import GHCi
 import HscMain
         -- These imports are the reason that TcSplice
         -- is very high up the module hierarchy
@@ -89,7 +95,7 @@ import Id
 import IdInfo
 import DsExpr
 import DsMonad
-import Serialized
+import GHC.Serialized
 import ErrUtils
 import Util
 import Unique
@@ -109,9 +115,14 @@ import qualified Language.Haskell.TH.Syntax as TH
 import GHC.Desugar      ( AnnotationWrapper(..) )
 
 import qualified Data.IntSet as IntSet
-import qualified Data.Map as Map
+import Control.Exception
+import Data.Binary
+import Data.Binary.Get
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
 import Data.Dynamic  ( fromDynamic, toDyn )
-import Data.Typeable ( typeOf, Typeable, typeRep )
+import qualified Data.Map as Map
+import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
 import Data.Data (Data)
 import Data.Proxy    ( Proxy (..) )
 import GHC.Exts         ( unsafeCoerce# )
@@ -558,18 +569,28 @@ runAnnotation target expr = do
                ann_value = serialized
            }
 
-convertAnnotationWrapper :: AnnotationWrapper -> Either MsgDoc Serialized
-convertAnnotationWrapper  annotation_wrapper = Right $
-        case annotation_wrapper of
-            AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
-                -- Got the value and dictionaries: build the serialized value and
-                -- call it a day. We ensure that we seq the entire serialized value
-                -- in order that any errors in the user-written code for the
-                -- annotation are exposed at this point.  This is also why we are
-                -- doing all this stuff inside the context of runMeta: it has the
-                -- facilities to deal with user error in a meta-level expression
-                seqSerialized serialized `seq` serialized
-
+convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
+convertAnnotationWrapper fhv = do
+  dflags <- getDynFlags
+  if gopt Opt_ExternalInterpreter dflags
+    then do
+      Right <$> runTH THAnnWrapper fhv
+    else do
+      annotation_wrapper <- liftIO $ wormhole dflags fhv
+      return $ Right $
+        case unsafeCoerce# annotation_wrapper of
+           AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
+               -- Got the value and dictionaries: build the serialized value and
+               -- call it a day. We ensure that we seq the entire serialized value
+               -- in order that any errors in the user-written code for the
+               -- annotation are exposed at this point.  This is also why we are
+               -- doing all this stuff inside the context of runMeta: it has the
+               -- facilities to deal with user error in a meta-level expression
+               seqSerialized serialized `seq` serialized
+
+-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
+seqSerialized :: Serialized -> ()
+seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
 
 
 {-
@@ -583,12 +604,19 @@ convertAnnotationWrapper  annotation_wrapper = Right $
 runQuasi :: TH.Q a -> TcM a
 runQuasi act = TH.runQ act
 
-runQResult :: (a -> String) -> (SrcSpan -> a -> b) -> SrcSpan -> TH.Q a -> TcM b
-runQResult show_th f expr_span hval
-  = do { th_result <- TH.runQ hval
+runQResult
+  :: (a -> String)
+  -> (SrcSpan -> a -> b)
+  -> (ForeignHValue -> TcM a)
+  -> SrcSpan
+  -> ForeignHValue {- TH.Q a -}
+  -> TcM b
+runQResult show_th f runQ expr_span hval
+  = do { th_result <- runQ hval
        ; traceTc "Got TH result:" (text (show_th th_result))
        ; return (f expr_span th_result) }
 
+
 -----------------
 runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn)
         -> LHsExpr Id
@@ -599,15 +627,15 @@ runMeta unwrap e
 
 defaultRunMeta :: MetaHook TcM
 defaultRunMeta (MetaE r)
-  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
 defaultRunMeta (MetaP r)
-  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
 defaultRunMeta (MetaT r)
-  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
 defaultRunMeta (MetaD r)
-  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
 defaultRunMeta (MetaAW r)
-  = fmap r . runMeta' False (const empty) (const (return . convertAnnotationWrapper))
+  = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
     -- We turn off showing the code in meta-level exceptions because doing so exposes
     -- the toAnnotationWrapper function that we slap around the users code
 
@@ -635,7 +663,7 @@ runMetaD = runMeta metaRequestD
 ---------------
 runMeta' :: Bool                 -- Whether code should be printed in the exception message
          -> (hs_syn -> SDoc)                                    -- how to print the code
-         -> (SrcSpan -> x -> TcM (Either MsgDoc hs_syn))        -- How to run x
+         -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn))        -- How to run x
          -> LHsExpr Id           -- Of type x; typically x = Q TH.Exp, or something like that
          -> TcM hs_syn           -- Of type t
 runMeta' show_code ppr_hs run_and_convert expr
@@ -680,7 +708,7 @@ runMeta' show_code ppr_hs run_and_convert expr
         ; either_tval <- tryAllM $
                          setSrcSpan expr_span $ -- Set the span so that qLocation can
                                                 -- see where this splice is
-             do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
+             do { mb_result <- run_and_convert expr_span hval
                 ; case mb_result of
                     Left err     -> failWithTc err
                     Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
@@ -694,6 +722,7 @@ runMeta' show_code ppr_hs run_and_convert expr
         }}}
   where
     -- see Note [Concealed TH exceptions]
+    fail_with_exn :: Exception e => String -> e -> TcM a
     fail_with_exn phase exn = do
         exn_msg <- liftIO $ Panic.safeShowException exn
         let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
@@ -857,6 +886,125 @@ instance TH.Quasi TcM where
     dflags <- hsc_dflags <$> getTopEnv
     return $ map toEnum $ IntSet.elems $ extensionFlags dflags
 
+
+-- | Run all module finalizers
+finishTH :: TcM ()
+finishTH = do
+  hsc_env <- env_top <$> getEnv
+  dflags <- getDynFlags
+  if not (gopt Opt_ExternalInterpreter dflags)
+    then do
+      tcg <- getGblEnv
+      let th_modfinalizers_var = tcg_th_modfinalizers tcg
+      modfinalizers <- readTcRef th_modfinalizers_var
+      writeTcRef th_modfinalizers_var []
+      mapM_ runQuasi modfinalizers
+    else withIServ hsc_env $ \i -> do
+      tcg <- getGblEnv
+      th_state <- readTcRef (tcg_th_remote_state tcg)
+      case th_state of
+        Nothing -> return () -- TH was not started, nothing to do
+        Just fhv -> do
+          liftIO $ withForeignHValue fhv $ \rhv ->
+            writeIServ i (putMessage (FinishTH rhv))
+          () <- runRemoteTH i
+          writeTcRef (tcg_th_remote_state tcg) Nothing
+
+runTHExp :: ForeignHValue -> TcM TH.Exp
+runTHExp = runTH THExp
+
+runTHPat :: ForeignHValue -> TcM TH.Pat
+runTHPat = runTH THPat
+
+runTHType :: ForeignHValue -> TcM TH.Type
+runTHType = runTH THType
+
+runTHDec :: ForeignHValue -> TcM [TH.Dec]
+runTHDec = runTH THDec
+
+runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
+runTH ty fhv = do
+  hsc_env <- env_top <$> getEnv
+  dflags <- getDynFlags
+  if not (gopt Opt_ExternalInterpreter dflags)
+    then do
+       -- just run it in the local TcM
+      hv <- liftIO $ wormhole dflags fhv
+      r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
+      return r
+    else
+      -- run it on the server
+      withIServ hsc_env $ \i -> do
+        rstate <- getTHState i
+        loc <- TH.qLocation
+        liftIO $
+          withForeignHValue rstate $ \state_hv ->
+          withForeignHValue fhv $ \q_hv ->
+            writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
+        bs <- runRemoteTH i
+        return $! runGet get (LB.fromStrict bs)
+
+-- | communicate with a remotely-running TH computation until it
+-- finishes and returns a result.
+runRemoteTH :: Binary a => IServ -> TcM a
+runRemoteTH iserv = do
+  Msg msg <- liftIO $ readIServ iserv getMessage
+  case msg of
+    QDone -> liftIO $ readIServ iserv get
+    QException str -> liftIO $ throwIO (ErrorCall str)
+    QFail str -> fail str
+    _other -> do
+      r <- handleTHMessage msg
+      liftIO $ writeIServ iserv (put r)
+      runRemoteTH iserv
+
+getTHState :: IServ -> TcM ForeignHValue
+getTHState i = do
+  tcg <- getGblEnv
+  th_state <- readTcRef (tcg_th_remote_state tcg)
+  case th_state of
+    Just rhv -> return rhv
+    Nothing -> do
+      hsc_env <- env_top <$> getEnv
+      fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
+      writeTcRef (tcg_th_remote_state tcg) (Just fhv)
+      return fhv
+
+wrapTHResult :: TcM a -> TcM (THResult a)
+wrapTHResult tcm = do
+  e <- tryM tcm   -- only catch 'fail', treat everything else as catastrophic
+  case e of
+    Left e -> return (THException (show e))
+    Right a -> return (THComplete a)
+
+handleTHMessage :: Message a -> TcM a
+handleTHMessage msg = case msg of
+  NewName a -> wrapTHResult $ TH.qNewName a
+  Report b str -> wrapTHResult $ TH.qReport b str
+  LookupName b str -> wrapTHResult $ TH.qLookupName b str
+  Reify n -> wrapTHResult $ TH.qReify n
+  ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
+  ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
+  ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
+  ReifyAnnotations lookup tyrep ->
+    wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
+  ReifyModule m -> wrapTHResult $ TH.qReifyModule m
+  AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
+  AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
+  IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
+  ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
+  _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
+
+getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
+getAnnotationsByTypeRep th_name tyrep
+  = do { name <- lookupThAnnLookup th_name
+       ; topEnv <- getTopEnv
+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
+       ; tcg <- getGblEnv
+       ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
+       ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
+
 {-
 ************************************************************************
 *                                                                      *
index 50b7aac..7433620 100644 (file)
@@ -39,4 +39,5 @@ runMetaD :: LHsExpr TcId -> TcM [LHsDecl RdrName]
 
 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
 runQuasi :: TH.Q a -> TcM a
+finishTH :: TcM ()
 #endif
index ab5b772..b70304d 100644 (file)
@@ -81,6 +81,7 @@ import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
 import GHC.Real                 ( Ratio(..) )
+import GHC.Serialized
 
 type BinArray = ForeignPtr Word8
 
@@ -930,3 +931,12 @@ instance Binary SrcSpan where
                                       (mkSrcLoc f el ec))
             _ -> do s <- get bh
                     return (UnhelpfulSpan s)
+
+instance Binary Serialized where
+    put_ bh (Serialized the_type bytes) = do
+        put_ bh the_type
+        put_ bh bytes
+    get bh = do
+        the_type <- get bh
+        bytes <- get bh
+        return (Serialized the_type bytes)
index cda7475..c3bdf5e 100644 (file)
@@ -94,6 +94,7 @@ import Util
 import Platform
 import Pretty           ( Doc, Mode(..) )
 import Panic
+import GHC.Serialized
 
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
@@ -811,6 +812,9 @@ instance Outputable a => Outputable (SCC a) where
    ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
    ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
 
+instance Outputable Serialized where
+    ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type)
+
 {-
 ************************************************************************
 *                                                                      *
index 7823336..f1ccb7b 100644 (file)
@@ -20,10 +20,10 @@ module Panic (
      panic, sorry, assertPanic, trace,
      panicDoc, sorryDoc, pgmErrorDoc,
 
-     Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo,
+     Exception.Exception(..), showException, safeShowException,
+     try, tryMost, throwTo,
 
      installSignalHandlers,
-     pushInterruptTargetThread, popInterruptTargetThread
 ) where
 #include "HsVersions.h"
 
@@ -47,7 +47,7 @@ import GHC.ConsoleHandler
 #endif
 
 import GHC.Stack
-import System.Mem.Weak  ( Weak, deRefWeak )
+import System.Mem.Weak  ( deRefWeak )
 
 -- | GHC's own exception type
 --   error messages all take the form:
@@ -220,18 +220,15 @@ tryMost action = do r <- try action
 installSignalHandlers :: IO ()
 installSignalHandlers = do
   main_thread <- myThreadId
-  pushInterruptTargetThread main_thread
+  wtid <- mkWeakThreadId main_thread
 
   let
-      interrupt_exn = (toException UserInterrupt)
-
       interrupt = do
-        mt <- peekInterruptTargetThread
-        case mt of
+        r <- deRefWeak wtid
+        case r of
           Nothing -> return ()
-          Just t  -> throwTo t interrupt_exn
+          Just t  -> throwTo t UserInterrupt
 
-  --
 #if !defined(mingw32_HOST_OS)
   _ <- installHandler sigQUIT  (Catch interrupt) Nothing
   _ <- installHandler sigINT   (Catch interrupt) Nothing
@@ -254,29 +251,3 @@ installSignalHandlers = do
   _ <- installHandler (Catch sig_handler)
   return ()
 #endif
-
-{-# NOINLINE interruptTargetThread #-}
-interruptTargetThread :: MVar [Weak ThreadId]
-interruptTargetThread = unsafePerformIO (newMVar [])
-
-pushInterruptTargetThread :: ThreadId -> IO ()
-pushInterruptTargetThread tid = do
- wtid <- mkWeakThreadId tid
- modifyMVar_ interruptTargetThread $ return . (wtid :)
-
-peekInterruptTargetThread :: IO (Maybe ThreadId)
-peekInterruptTargetThread =
-  withMVar interruptTargetThread $ loop
- where
-   loop [] = return Nothing
-   loop (t:ts) = do
-     r <- deRefWeak t
-     case r of
-       Nothing -> loop ts
-       Just t  -> return (Just t)
-
-popInterruptTargetThread :: IO ()
-popInterruptTargetThread =
-  modifyMVar_ interruptTargetThread $
-   \tids -> return $! case tids of []     -> []
-                                   (_:ts) -> ts
diff --git a/ghc.mk b/ghc.mk
index 4aea480..883e0b3 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -457,6 +457,7 @@ PACKAGES_STAGE1 += terminfo
 endif
 endif
 PACKAGES_STAGE1 += haskeline
+PACKAGES_STAGE1 += ghci
 
 # See Note [No stage2 packages when CrossCompiling or Stage1Only].
 # See Note [Stage1Only vs stage=1] in mk/config.mk.in.
@@ -522,6 +523,9 @@ utils/ghc-pkg/dist-install/package-data.mk: $(fixed_pkg_prev)
 utils/hsc2hs/dist-install/package-data.mk: $(fixed_pkg_prev)
 utils/compare_sizes/dist-install/package-data.mk: $(fixed_pkg_prev)
 utils/runghc/dist-install/package-data.mk: $(fixed_pkg_prev)
+iserv/stage2/package-data.mk: $(fixed_pkg_prev)
+iserv/stage2_p/package-data.mk: $(fixed_pkg_prev)
+iserv/stage2_dyn/package-data.mk: $(fixed_pkg_prev)
 
 # the GHC package doesn't live in libraries/, so we add its dependency manually:
 compiler/stage2/package-data.mk: $(fixed_pkg_prev)
@@ -665,6 +669,9 @@ BUILD_DIRS += utils/mkUserGuidePart
 BUILD_DIRS += docs/users_guide
 BUILD_DIRS += utils/count_lines
 BUILD_DIRS += utils/compare_sizes
+ifeq "$(Windows_Host)" "NO"
+BUILD_DIRS += iserv
+endif
 
 # ----------------------------------------------
 # Actually include the sub-ghc.mk's
@@ -892,8 +899,10 @@ ifneq "$(INSTALL_LIBEXECS)" ""
        done
 # We rename ghc-stage2, so that the right program name is used in error
 # messages etc.
+ifeq "$(Windows_Host)" "NO"
        "$(MV)" "$(DESTDIR)$(ghclibexecdir)/bin/ghc-stage$(INSTALL_GHC_STAGE)" "$(DESTDIR)$(ghclibexecdir)/bin/ghc"
 endif
+endif
 
 install_topdirs: $(INSTALL_TOPDIR_BINS) $(INSTALL_TOPDIR_SCRIPTS)
        $(INSTALL_DIR) "$(DESTDIR)$(topdir)"
@@ -1054,7 +1063,7 @@ BIN_DIST_MK = $(BIN_DIST_PREP_DIR)/bindist.mk
 unix-binary-dist-prep:
        $(call removeTrees,bindistprep/)
        "$(MKDIRHIER)" $(BIN_DIST_PREP_DIR)
-       set -e; for i in packages LICENSE compiler ghc rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done
+       set -e; for i in packages LICENSE compiler ghc iserv rts libraries utils docs libffi includes driver mk rules Makefile aclocal.m4 config.sub config.guess install-sh settings.in ghc.mk inplace distrib/configure.ac distrib/README distrib/INSTALL; do ln -s ../../$$i $(BIN_DIST_PREP_DIR)/; done
        echo "HADDOCK_DOCS       = $(HADDOCK_DOCS)"       >> $(BIN_DIST_MK)
        echo "BUILD_SPHINX_HTML  = $(BUILD_SPHINX_HTML)"  >> $(BIN_DIST_MK)
        echo "BUILD_SPHINX_PDF   = $(BUILD_SPHINX_PDF)"   >> $(BIN_DIST_MK)
@@ -1507,4 +1516,3 @@ phase_0_builds: $(utils/deriveConstants_dist_depfile_c_asm)
 
 .PHONY: phase_1_builds
 phase_1_builds: $(PACKAGE_DATA_MKS)
-
index c1abe4f..d8fa0e1 100644 (file)
@@ -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)"
index ef4c673..55df637 100644 (file)
@@ -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 ()
 
index c85f0b3..7d4e1e2 100644 (file)
@@ -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))
index 90b8a55..45193e3 100644 (file)
@@ -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:
diff --git a/iserv/Main.hs b/iserv/Main.hs
new file mode 100644 (file)
index 0000000..cbaf927
--- /dev/null
@@ -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 (file)
index 0000000..f160978
--- /dev/null
@@ -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 (file)
index 0000000..4cae482
--- /dev/null
@@ -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 (file)
index 0000000..9dac158
--- /dev/null
@@ -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 (file)
index 0000000..f7eb566
--- /dev/null
@@ -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);
+}
index b108013..39c1b11 100644 (file)
@@ -8,8 +8,12 @@
 --
 -- A data type defining the language extensions supported by GHC.
 --
+{-# LANGUAGE DeriveGeneric #-}
 module GHC.LanguageExtensions ( Extension(..) ) where
 
+import GHC.Generics
+import Data.Binary
+
 -- | The language extensions known to GHC.
 data Extension
 -- See Note [Updating flag description in the User's Guide] in DynFlags
@@ -119,4 +123,6 @@ data Extension
    | Strict
    | StrictData
    | MonadFailDesugaring
-   deriving (Eq, Enum, Show)
+   deriving (Eq, Enum, Show, Generic)
+
+instance Binary Extension
similarity index 90%
rename from compiler/utils/Serialized.hs
rename to libraries/ghc-boot/GHC/Serialized.hs
index 41c1cea..39fa6a7 100644 (file)
@@ -1,14 +1,14 @@
 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 --
 -- (c) The University of Glasgow 2002-2006
 --
 -- Serialized values
 
-module Serialized (
+module GHC.Serialized (
     -- * Main Serialized data type
-    Serialized,
-    seqSerialized,
+    Serialized(..),
 
     -- * Going into and out of 'Serialized'
     toSerialized, fromSerialized,
@@ -17,32 +17,14 @@ module Serialized (
     serializeWithData, deserializeWithData,
   ) where
 
-import Binary
-import Outputable
-import FastString
-import Util
-
 import Data.Bits
 import Data.Word        ( Word8 )
-
 import Data.Data
 
 
 -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
 data Serialized = Serialized TypeRep [Word8]
 
-instance Outputable Serialized where
-    ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type)
-
-instance Binary Serialized where
-    put_ bh (Serialized the_type bytes) = do
-        put_ bh the_type
-        put_ bh bytes
-    get bh = do
-        the_type <- get bh
-        bytes <- get bh
-        return (Serialized the_type bytes)
-
 -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
 toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized
 toSerialized serialize what = Serialized (typeOf what) (serialize what)
@@ -54,11 +36,6 @@ fromSerialized deserialize (Serialized the_type bytes)
   | the_type == typeOf (undefined :: a) = Just (deserialize bytes)
   | otherwise                           = Nothing
 
--- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
-seqSerialized :: Serialized -> ()
-seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
-
-
 -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
 serializeWithData :: Data a => a -> [Word8]
 serializeWithData what = serializeWithData' what []
@@ -176,4 +153,3 @@ deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes
     go len bytes k
       | len <= 0  = k [] bytes
       | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:)))
-
index 883bbaf..4439153 100644 (file)
@@ -37,6 +37,7 @@ Library
             GHC.Lexeme
             GHC.PackageDb
             GHC.LanguageExtensions
+            GHC.Serialized
 
     build-depends: base       >= 4   && < 5,
                    binary     == 0.8.*,
diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs
new file mode 100644 (file)
index 0000000..026e3ea
--- /dev/null
@@ -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 #)
+  }}
diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc
new file mode 100644 (file)
index 0000000..36619ae
--- /dev/null
@@ -0,0 +1,149 @@
+-----------------------------------------------------------------------------
+--
+-- libffi bindings
+--
+-- (c) The University of Glasgow 2008
+--
+-----------------------------------------------------------------------------
+
+#include <ffi.h>
+
+{-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-}
+module GHCi.FFI
+  ( FFIType(..)
+  , FFIConv(..)
+  , prepForeignCall
+  , freeForeignCallInfo
+  ) where
+
+import Control.Exception
+import Data.Binary
+import GHC.Generics
+import Foreign
+import Foreign.C
+
+data FFIType
+  = FFIVoid
+  | FFIPointer
+  | FFIFloat
+  | FFIDouble
+  | FFISInt8
+  | FFISInt16
+  | FFISInt32
+  | FFISInt64
+  | FFIUInt8
+  | FFIUInt16
+  | FFIUInt32
+  | FFIUInt64
+  deriving (Show, Generic, Binary)
+
+data FFIConv
+  = FFICCall
+  | FFIStdCall
+  deriving (Show, Generic, Binary)
+
+
+prepForeignCall
+    :: FFIConv
+    -> [FFIType]          -- arg types
+    -> FFIType            -- result type
+    -> IO (Ptr ())        -- token for making calls (must be freed by caller)
+
+prepForeignCall cconv arg_types result_type = do
+  let n_args = length arg_types
+  arg_arr <- mallocArray n_args
+  pokeArray arg_arr (map ffiType arg_types)
+  cif <- mallocBytes (#const sizeof(ffi_cif))
+  let abi = convToABI cconv
+  r <- ffi_prep_cif cif abi (fromIntegral n_args) (ffiType result_type) arg_arr
+  if (r /= fFI_OK)
+     then throwIO (ErrorCall ("prepForeignCallFailed: " ++ show r))
+     else return (castPtr cif)
+
+freeForeignCallInfo :: Ptr () -> IO ()
+freeForeignCallInfo p = do
+  free ((#ptr ffi_cif, arg_types) p)
+  free p
+
+convToABI :: FFIConv -> C_ffi_abi
+convToABI FFICCall  = fFI_DEFAULT_ABI
+#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
+convToABI FFIStdCall = fFI_STDCALL
+#endif
+-- unknown conventions are mapped to the default, (#3336)
+convToABI _           = fFI_DEFAULT_ABI
+
+ffiType :: FFIType -> Ptr C_ffi_type
+ffiType FFIVoid     = ffi_type_void
+ffiType FFIPointer  = ffi_type_pointer
+ffiType FFIFloat    = ffi_type_float
+ffiType FFIDouble   = ffi_type_double
+ffiType FFISInt8    = ffi_type_sint8
+ffiType FFISInt16   = ffi_type_sint16
+ffiType FFISInt32   = ffi_type_sint32
+ffiType FFISInt64   = ffi_type_sint64
+ffiType FFIUInt8    = ffi_type_uint8
+ffiType FFIUInt16   = ffi_type_uint16
+ffiType FFIUInt32   = ffi_type_uint32
+ffiType FFIUInt64   = ffi_type_uint64
+
+data C_ffi_type
+data C_ffi_cif
+
+type C_ffi_status = (#type ffi_status)
+type C_ffi_abi    = (#type ffi_abi)
+
+foreign import ccall "&ffi_type_void"   ffi_type_void    :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_uint8"  ffi_type_uint8   :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_sint8"  ffi_type_sint8   :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_uint16" ffi_type_uint16  :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_sint16" ffi_type_sint16  :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_uint32" ffi_type_uint32  :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_sint32" ffi_type_sint32  :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_uint64" ffi_type_uint64  :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_sint64" ffi_type_sint64  :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_float"  ffi_type_float   :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_double" ffi_type_double  :: Ptr C_ffi_type
+foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type
+
+fFI_OK            :: C_ffi_status
+fFI_OK            = (#const FFI_OK)
+--fFI_BAD_ABI     :: C_ffi_status
+--fFI_BAD_ABI     = (#const FFI_BAD_ABI)
+--fFI_BAD_TYPEDEF :: C_ffi_status
+--fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF)
+
+fFI_DEFAULT_ABI :: C_ffi_abi
+fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI)
+#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
+fFI_STDCALL     :: C_ffi_abi
+fFI_STDCALL     = (#const FFI_STDCALL)
+#endif
+
+-- ffi_status ffi_prep_cif(ffi_cif *cif,
+--                         ffi_abi abi,
+--                         unsigned int nargs,
+--                         ffi_type *rtype,
+--                         ffi_type **atypes);
+
+foreign import ccall "ffi_prep_cif"
+  ffi_prep_cif :: Ptr C_ffi_cif         -- cif
+               -> C_ffi_abi             -- abi
+               -> CUInt                 -- nargs
+               -> Ptr C_ffi_type        -- result type
+               -> Ptr (Ptr C_ffi_type)  -- arg types
+               -> IO C_ffi_status
+
+-- Currently unused:
+
+-- void ffi_call(ffi_cif *cif,
+--               void (*fn)(),
+--               void *rvalue,
+--               void **avalue);
+
+-- foreign import ccall "ffi_call"
+--   ffi_call :: Ptr C_ffi_cif             -- cif
+--            -> FunPtr (IO ())            -- function to call
+--            -> Ptr ()                    -- put result here
+--            -> Ptr (Ptr ())              -- arg values
+--            -> IO ()
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
new file mode 100644 (file)
index 0000000..d9d6314
--- /dev/null
@@ -0,0 +1,348 @@
+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
+
+-- |
+-- Run-time info table support.  This module provides support for
+-- creating and reading info tables /in the running program/.
+-- We use the RTS data structures directly via hsc2hs.
+--
+module GHCi.InfoTable
+  ( mkConInfoTable
+  , peekItbl, StgInfoTable(..)
+  , conInfoPtr
+  ) where
+
+import Foreign
+import Foreign.C
+import GHC.Ptr
+import GHC.Exts
+import System.IO.Unsafe
+
+mkConInfoTable
+   :: Int     -- ptr words
+   -> Int     -- non-ptr words
+   -> Int     -- constr tag
+   -> [Word8]  -- con desc
+   -> IO (Ptr ())
+      -- resulting info table is allocated with allocateExec(), and
+      -- should be freed with freeExec().
+
+mkConInfoTable ptr_words nonptr_words tag con_desc =
+  castFunPtrToPtr <$> newExecConItbl itbl con_desc
+  where
+     entry_addr = stg_interp_constr_entry
+     code' = mkJumpToAddr entry_addr
+     itbl  = StgInfoTable {
+                 entry = if ghciTablesNextToCode
+                         then Nothing
+                         else Just entry_addr,
+                 ptrs  = fromIntegral ptr_words,
+                 nptrs = fromIntegral nonptr_words,
+                 tipe  = fromIntegral cONSTR,
+                 srtlen = fromIntegral tag,
+                 code  = if ghciTablesNextToCode
+                         then Just code'
+                         else Nothing
+              }
+
+
+-- -----------------------------------------------------------------------------
+-- Building machine code fragments for a constructor's entry code
+
+type ItblCodes = Either [Word8] [Word32]
+
+funPtrToInt :: FunPtr a -> Int
+funPtrToInt (FunPtr a) = I## (addr2Int## a)
+
+data Arch = ArchSPARC | ArchPPC | ArchX86 | ArchX86_64 | ArchAlpha | ArchARM
+ deriving Show
+
+platform :: Arch
+platform =
+#if defined(sparc_HOST_ARCH)
+       ArchSparc
+#elif defined(ppc_HOST_ARCH)
+       ArchPPC
+#elif defined(x86_HOST_ARCH)
+       ArchX86
+#elif defined(x86_64_HOST_ARCH)
+       ArchX86_64
+#elif defined(alpha_HOST_ARCH)
+       ArchAlpha
+#elif defined(arm_HOST_ARCH)
+       ArchARM
+#endif
+
+mkJumpToAddr :: EntryFunPtr -> ItblCodes
+mkJumpToAddr a = case platform of
+    ArchSPARC ->
+        -- After some consideration, we'll try this, where
+        -- 0x55555555 stands in for the address to jump to.
+        -- According to includes/rts/MachRegs.h, %g3 is very
+        -- likely indeed to be baggable.
+        --
+        --   0000 07155555              sethi   %hi(0x55555555), %g3
+        --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
+        --   0008 81C0C000              jmp     %g3
+        --   000c 01000000              nop
+
+        let w32 = fromIntegral (funPtrToInt a)
+
+            hi22, lo10 :: Word32 -> Word32
+            lo10 x = x .&. 0x3FF
+            hi22 x = (x `shiftR` 10) .&. 0x3FFFF
+
+        in Right [ 0x07000000 .|. (hi22 w32),
+                   0x8610E000 .|. (lo10 w32),
+                   0x81C0C000,
+                   0x01000000 ]
+
+    ArchPPC ->
+        -- We'll use r12, for no particular reason.
+        -- 0xDEADBEEF stands for the address:
+        -- 3D80DEAD lis r12,0xDEAD
+        -- 618CBEEF ori r12,r12,0xBEEF
+        -- 7D8903A6 mtctr r12
+        -- 4E800420 bctr
+
+        let w32 = fromIntegral (funPtrToInt a)
+            hi16 x = (x `shiftR` 16) .&. 0xFFFF
+            lo16 x = x .&. 0xFFFF
+        in Right [ 0x3D800000 .|. hi16 w32,
+                   0x618C0000 .|. lo16 w32,
+                   0x7D8903A6, 0x4E800420 ]
+
+    ArchX86 ->
+        -- Let the address to jump to be 0xWWXXYYZZ.
+        -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
+        -- which is
+        -- B8 ZZ YY XX WW FF E0
+
+        let w32 = fromIntegral (funPtrToInt a) :: Word32
+            insnBytes :: [Word8]
+            insnBytes
+               = [0xB8, byte0 w32, byte1 w32,
+                        byte2 w32, byte3 w32,
+                  0xFF, 0xE0]
+        in
+            Left insnBytes
+
+    ArchX86_64 ->
+        -- Generates:
+        --      jmpq *.L1(%rip)
+        --      .align 8
+        -- .L1:
+        --      .quad <addr>
+        --
+        -- which looks like:
+        --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>
+        -- with addr at 10.
+        --
+        -- We need a full 64-bit pointer (we can't assume the info table is
+        -- allocated in low memory).  Assuming the info pointer is aligned to
+        -- an 8-byte boundary, the addr will also be aligned.
+
+        let w64 = fromIntegral (funPtrToInt a) :: Word64
+            insnBytes :: [Word8]
+            insnBytes
+               = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
+                  byte0 w64, byte1 w64, byte2 w64, byte3 w64,
+                  byte4 w64, byte5 w64, byte6 w64, byte7 w64]
+        in
+            Left insnBytes
+
+    ArchAlpha ->
+        let w64 = fromIntegral (funPtrToInt a) :: Word64
+        in Right [ 0xc3800000      -- br   at, .+4
+                 , 0xa79c000c      -- ldq  at, 12(at)
+                 , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well
+                 , 0x47ff041f      -- nop
+                 , fromIntegral (w64 .&. 0x0000FFFF)
+                 , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
+
+    ArchARM { } ->
+        -- Generates Arm sequence,
+        --      ldr r1, [pc, #0]
+        --      bx r1
+        --
+        -- which looks like:
+        --     00000000 <.addr-0x8>:
+        --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>
+        --     4:       11ff2fe1    bx     r1
+        let w32 = fromIntegral (funPtrToInt a) :: Word32
+        in Left [ 0x00, 0x10, 0x9f, 0xe5
+                , 0x11, 0xff, 0x2f, 0xe1
+                , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
+
+
+byte0 :: (Integral w) => w -> Word8
+byte0 w = fromIntegral w
+
+byte1, byte2, byte3, byte4, byte5, byte6, byte7
+       :: (Integral w, Bits w) => w -> Word8
+byte1 w = fromIntegral (w `shiftR` 8)
+byte2 w = fromIntegral (w `shiftR` 16)
+byte3 w = fromIntegral (w `shiftR` 24)
+byte4 w = fromIntegral (w `shiftR` 32)
+byte5 w = fromIntegral (w `shiftR` 40)
+byte6 w = fromIntegral (w `shiftR` 48)
+byte7 w = fromIntegral (w `shiftR` 56)
+
+
+-- -----------------------------------------------------------------------------
+-- read & write intfo tables
+
+-- Get definitions for the structs, constants & config etc.
+#include "Rts.h"
+
+-- entry point for direct returns for created constr itbls
+foreign import ccall "&stg_interp_constr_entry"
+    stg_interp_constr_entry :: EntryFunPtr
+
+-- Ultra-minimalist version specially for constructors
+#if SIZEOF_VOID_P == 8
+type HalfWord = Word32
+#elif SIZEOF_VOID_P == 4
+type HalfWord = Word16
+#else
+#error Uknown SIZEOF_VOID_P
+#endif
+
+data StgConInfoTable = StgConInfoTable {
+   conDesc   :: Ptr Word8,
+   infoTable :: StgInfoTable
+}
+
+type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
+
+data StgInfoTable = StgInfoTable {
+   entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
+   ptrs   :: HalfWord,
+   nptrs  :: HalfWord,
+   tipe   :: HalfWord,
+   srtlen :: HalfWord,
+   code   :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
+  }
+
+pokeConItbl
+  :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
+  -> IO ()
+pokeConItbl wr_ptr ex_ptr itbl = do
+  let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)
+#if defined(TABLES_NEXT_TO_CODE)
+  (#poke StgConInfoTable, con_desc) wr_ptr _con_desc
+#else
+  (#poke StgConInfoTable, con_desc) wr_ptr (conDesc itbl)
+#endif
+  pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)
+
+sizeOfEntryCode :: Int
+sizeOfEntryCode
+  | not ghciTablesNextToCode = 0
+  | otherwise =
+     case mkJumpToAddr undefined of
+       Left  xs -> sizeOf (head xs) * length xs
+       Right xs -> sizeOf (head xs) * length xs
+
+pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
+pokeItbl a0 itbl = do
+#if !defined(TABLES_NEXT_TO_CODE)
+  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
+#endif
+  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
+  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
+  (#poke StgInfoTable, type) a0 (tipe itbl)
+  (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl)
+#if defined(TABLES_NEXT_TO_CODE)
+  let code_offset = (a0 `plusPtr` (#offset StgInfoTable, code))
+  case code itbl of
+    Nothing -> return ()
+    Just (Left xs) -> pokeArray code_offset xs
+    Just (Right xs) -> pokeArray code_offset xs
+#endif
+
+peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
+peekItbl a0 = do
+#if defined(TABLES_NEXT_TO_CODE)
+  let entry' = Nothing
+#else
+  entry' <- Just <$> (#peek StgInfoTable, entry) a0
+#endif
+  ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0
+  nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0
+  tipe' <- (#peek StgInfoTable, type) a0
+  srtlen' <- (#peek StgInfoTable, srt_bitmap) a0
+  return StgInfoTable
+    { entry  = entry'
+    , ptrs   = ptrs'
+    , nptrs  = nptrs'
+    , tipe   = tipe'
+    , srtlen = srtlen'
+    , code   = Nothing
+    }
+
+newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())
+newExecConItbl obj con_desc
+   = alloca $ \pcode -> do
+        let lcon_desc = length con_desc + 1{- null terminator -}
+            sz = fromIntegral ((#size StgConInfoTable) + sizeOfEntryCode)
+               -- Note: we need to allocate the conDesc string next to the info
+               -- table, because on a 64-bit platform we reference this string
+               -- with a 32-bit offset relative to the info table, so if we
+               -- allocated the string separately it might be out of range.
+        wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
+        ex_ptr <- peek pcode
+        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
+                                    , infoTable = obj }
+        pokeConItbl wr_ptr ex_ptr cinfo
+        pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc
+        _flushExec sz ex_ptr -- Cache flush (if needed)
+        return (castPtrToFunPtr ex_ptr)
+
+foreign import ccall unsafe "allocateExec"
+  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
+
+foreign import ccall unsafe "flushExec"
+  _flushExec :: CUInt -> Ptr a -> IO ()
+
+-- | Convert a pointer to an StgConInfo into an info pointer that can be
+-- used in the header of a closure.
+conInfoPtr :: Ptr () -> Ptr ()
+conInfoPtr ptr
+ | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable)
+ | otherwise            = ptr
+
+-- -----------------------------------------------------------------------------
+-- Constants and config
+
+wORD_SIZE :: Int
+wORD_SIZE = (#const SIZEOF_HSINT)
+
+fixedInfoTableSizeB :: Int
+fixedInfoTableSizeB = 2 * wORD_SIZE
+
+profInfoTableSizeB :: Int
+profInfoTableSizeB = (#size StgProfInfo)
+
+stdInfoTableSizeB :: Int
+stdInfoTableSizeB
+  = (if ghciTablesNextToCode then 0 else wORD_SIZE)
+  + (if rtsIsProfiled then profInfoTableSizeB else 0)
+  + fixedInfoTableSizeB
+
+conInfoTableSizeB :: Int
+conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE
+
+foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt
+
+rtsIsProfiled :: Bool
+rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0
+
+cONSTR :: Int   -- Defined in ClosureTypes.h
+cONSTR = (#const CONSTR)
+
+ghciTablesNextToCode :: Bool
+#ifdef TABLES_NEXT_TO_CODE
+ghciTablesNextToCode = True
+#else
+ghciTablesNextToCode = False
+#endif
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
new file mode 100644 (file)
index 0000000..bdf29cb
--- /dev/null
@@ -0,0 +1,386 @@
+{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving,
+    GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
+
+module GHCi.Message
+  ( Message(..), Msg(..)
+  , EvalStatus(..), EvalResult(..), EvalOpts(..), EvalExpr(..)
+  , SerializableException(..)
+  , THResult(..), THResultType(..)
+  , getMessage, putMessage
+  , Pipe(..), remoteCall, readPipe, writePipe
+  ) where
+
+import GHCi.RemoteTypes
+import GHCi.ResolvedBCO
+import GHCi.FFI
+import GHCi.TH.Binary ()
+
+import GHC.LanguageExtensions
+import Control.Exception
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import Data.IORef
+import Data.Typeable
+import GHC.Generics
+import qualified Language.Haskell.TH        as TH
+import qualified Language.Haskell.TH.Syntax as TH
+import System.Exit
+import System.IO
+import System.IO.Error
+
+-- -----------------------------------------------------------------------------
+-- The RPC protocol between GHC and the interactive server
+
+-- | A @Message a@ is a message that returns a value of type @a@
+data Message a where
+  -- | Exit the iserv process
+  Shutdown :: Message ()
+
+  -- RTS Linker -------------------------------------------
+
+  -- These all invoke the corresponding functions in the RTS Linker API.
+  InitLinker :: Message ()
+  LookupSymbol :: String -> Message (Maybe RemotePtr)
+  LookupClosure :: String -> Message (Maybe HValueRef)
+  LoadDLL :: String -> Message (Maybe String)
+  LoadArchive :: String -> Message () -- error?
+  LoadObj :: String -> Message () -- error?
+  UnloadObj :: String -> Message () -- error?
+  AddLibrarySearchPath :: String -> Message RemotePtr
+  RemoveLibrarySearchPath :: RemotePtr -> Message Bool
+  ResolveObjs :: Message Bool
+  FindSystemLibrary :: String -> Message (Maybe String)
+
+  -- Interpreter -------------------------------------------
+
+  -- | Create a set of BCO objects, and return HValueRefs to them
+  CreateBCOs :: [ResolvedBCO] -> Message [HValueRef]
+
+  -- | Release 'HValueRef's
+  FreeHValueRefs :: [HValueRef] -> Message ()
+
+  -- | Malloc some data and return a 'RemotePtr' to it
+  MallocData :: ByteString -> Message RemotePtr
+
+  -- | Calls 'GHCi.FFI.prepareForeignCall'
+  PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message RemotePtr
+
+  -- | Free data previously created by 'PrepFFI'
+  FreeFFI :: RemotePtr -> Message ()
+
+  -- | Create an info table for a constructor
+  MkConInfoTable
+   :: Int     -- ptr words
+   -> Int     -- non-ptr words
+   -> Int     -- constr tag
+   -> [Word8] -- constructor desccription
+   -> Message RemotePtr
+
+  -- | Evaluate a statement
+  EvalStmt
+    :: EvalOpts
+    -> EvalExpr HValueRef {- IO [a] -}
+    -> Message (EvalStatus [HValueRef]) {- [a] -}
+
+  -- | Resume evaluation of a statement after a breakpoint
+  ResumeStmt
+   :: EvalOpts
+   -> HValueRef {- ResumeContext -}
+   -> Message (EvalStatus [HValueRef])
+
+  -- | Abandon evaluation of a statement after a breakpoint
+  AbandonStmt
+   :: HValueRef {- ResumeContext -}
+   -> Message ()
+
+  -- | Evaluate something of type @IO String@
+  EvalString
+    :: HValueRef {- IO String -}
+    -> Message (EvalResult String)
+
+  -- | Evaluate something of type @String -> IO String@
+  EvalStringToString
+    :: HValueRef {- String -> IO String -}
+    -> String
+    -> Message (EvalResult String)
+
+  -- | Evaluate something of type @IO ()@
+  EvalIO
+   :: HValueRef {- IO a -}
+   -> Message (EvalResult ())
+
+  -- Template Haskell -------------------------------------------
+
+  -- | Start a new TH module, return a state token that should be
+  StartTH :: Message HValueRef {- GHCiQState -}
+
+  -- | Run TH module finalizers, and free the HValueRef
+  FinishTH :: HValueRef {- GHCiQState -} -> Message ()
+
+  -- | Evaluate a TH computation.
+  --
+  -- Returns a ByteString, because we have to force the result
+  -- before returning it to ensure there are no errors lurking
+  -- in it.  The TH types don't have NFData instances, and even if
+  -- they did, we have to serialize the value anyway, so we might
+  -- as well serialize it to force it.
+  RunTH
+   :: HValueRef {- GHCiQState -}
+   -> HValueRef {- e.g. TH.Q TH.Exp -}
+   -> THResultType
+   -> Maybe TH.Loc
+   -> Message ByteString {- e.g. TH.Exp -}
+
+  -- Template Haskell Quasi monad operations
+  NewName :: String -> Message (THResult TH.Name)
+  Report :: Bool -> String -> Message (THResult ())
+  LookupName :: Bool -> String -> Message (THResult (Maybe TH.Name))
+  Reify :: TH.Name -> Message (THResult TH.Info)
+  ReifyFixity :: TH.Name -> Message (THResult TH.Fixity)
+  ReifyInstances :: TH.Name -> [TH.Type] -> Message (THResult [TH.Dec])
+  ReifyRoles :: TH.Name -> Message (THResult [TH.Role])
+  ReifyAnnotations :: TH.AnnLookup -> TypeRep -> Message (THResult [ByteString])
+  ReifyModule :: TH.Module -> Message (THResult TH.ModuleInfo)
+
+  AddDependentFile :: FilePath -> Message (THResult ())
+  AddTopDecls :: [TH.Dec] -> Message (THResult ())
+  IsExtEnabled :: Extension -> Message (THResult Bool)
+  ExtsEnabled :: Message (THResult [Extension])
+
+  -- Template Haskell return values
+
+  -- | RunTH finished successfully; return value follows
+  QDone :: Message ()
+  -- | RunTH threw an exception
+  QException :: String -> Message ()
+  -- | RunTH called 'fail'
+  QFail :: String -> Message ()
+
+deriving instance Show (Message a)
+
+data EvalOpts = EvalOpts
+  { useSandboxThread :: Bool
+  , singleStep :: Bool
+  , breakOnException :: Bool
+  , breakOnError :: Bool
+  }
+  deriving (Generic, Show)
+
+instance Binary EvalOpts
+
+-- | We can pass simple expressions to EvalStmt, consisting of values
+-- and application.  This allows us to wrap the statement to be
+-- executed in another function, which is used by GHCi to implement
+-- :set args and :set prog.  It might be worthwhile to extend this
+-- little language in the future.
+data EvalExpr a
+  = EvalThis a
+  | EvalApp (EvalExpr a) (EvalExpr a)
+  deriving (Generic, Show)
+
+instance Binary a => Binary (EvalExpr a)
+
+data EvalStatus a
+  = EvalComplete Word64 (EvalResult a)
+  | EvalBreak Bool
+       HValueRef{- AP_STACK -}
+       HValueRef{- BreakInfo -}
+       HValueRef{- ResumeContext -}
+  deriving (Generic, Show)
+
+instance Binary a => Binary (EvalStatus a)
+
+data EvalResult a
+  = EvalException SerializableException
+  | EvalSuccess a
+  deriving (Generic, Show)
+
+instance Binary a => Binary (EvalResult a)
+
+-- SomeException can't be serialized because it contains dynamic
+-- types.  However, we do very limited things with the exceptions that
+-- are thrown by interpreted computations:
+--
+-- * We print them, e.g. "*** Exception: <something>"
+-- * UserInterrupt has a special meaning
+-- * In ghc -e, exitWith should exit with the appropraite exit code
+--
+-- So all we need to do is distinguish UserInterrupt and ExitCode, and
+-- all other exceptions can be represented by their 'show' string.
+--
+data SerializableException
+  = EUserInterrupt
+  | EExitCode ExitCode
+  | EOtherException String
+  deriving (Generic, Show)
+
+instance Binary ExitCode
+instance Binary SerializableException
+
+data THResult a
+  = THException String
+  | THComplete a
+  deriving (Generic, Show)
+
+instance Binary a => Binary (THResult a)
+
+data THResultType = THExp | THPat | THType | THDec | THAnnWrapper
+  deriving (Enum, Show, Generic)
+
+instance Binary THResultType
+
+data Msg = forall a . (Binary a, Show a) => Msg (Message a)
+
+getMessage :: Get Msg
+getMessage = do
+    b <- getWord8
+    case b of
+      0  -> Msg <$> return Shutdown
+      1  -> Msg <$> return InitLinker
+      2  -> Msg <$> LookupSymbol <$> get
+      3  -> Msg <$> LookupClosure <$> get
+      4  -> Msg <$> LoadDLL <$> get
+      5  -> Msg <$> LoadArchive <$> get
+      6  -> Msg <$> LoadObj <$> get
+      7  -> Msg <$> UnloadObj <$> get
+      8  -> Msg <$> AddLibrarySearchPath <$> get
+      9  -> Msg <$> RemoveLibrarySearchPath <$> get
+      10 -> Msg <$> return ResolveObjs
+      11 -> Msg <$> FindSystemLibrary <$> get
+      12 -> Msg <$> CreateBCOs <$> get
+      13 -> Msg <$> FreeHValueRefs <$> get
+      14 -> Msg <$> MallocData <$> get
+      15 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
+      16 -> Msg <$> FreeFFI <$> get
+      17 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get)
+      18 -> Msg <$> (EvalStmt <$> get <*> get)
+      19 -> Msg <$> (ResumeStmt <$> get <*> get)
+      20 -> Msg <$> (AbandonStmt <$> get)
+      21 -> Msg <$> (EvalString <$> get)
+      22 -> Msg <$> (EvalStringToString <$> get <*> get)
+      23 -> Msg <$> (EvalIO <$> get)
+      24 -> Msg <$> return StartTH
+      25 -> Msg <$> FinishTH <$> get
+      26 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
+      27 -> Msg <$> NewName <$> get
+      28 -> Msg <$> (Report <$> get <*> get)
+      29 -> Msg <$> (LookupName <$> get <*> get)
+      30 -> Msg <$> Reify <$> get
+      31 -> Msg <$> ReifyFixity <$> get
+      32 -> Msg <$> (ReifyInstances <$> get <*> get)
+      33 -> Msg <$> ReifyRoles <$> get
+      34 -> Msg <$> (ReifyAnnotations <$> get <*> get)
+      35 -> Msg <$> ReifyModule <$> get
+      36 -> Msg <$> AddDependentFile <$> get
+      37 -> Msg <$> AddTopDecls <$> get
+      38 -> Msg <$> (IsExtEnabled <$> get)
+      39 -> Msg <$> return ExtsEnabled
+      40 -> Msg <$> return QDone
+      41 -> Msg <$> QException <$> get
+      _  -> Msg <$> QFail <$> get
+
+putMessage :: Message a -> Put
+putMessage m = case m of
+  Shutdown                    -> putWord8 0
+  InitLinker                  -> putWord8 1
+  LookupSymbol str            -> putWord8 2  >> put str
+  LookupClosure str           -> putWord8 3  >> put str
+  LoadDLL str                 -> putWord8 4  >> put str
+  LoadArchive str             -> putWord8 5  >> put str
+  LoadObj str                 -> putWord8 6  >> put str
+  UnloadObj str               -> putWord8 7  >> put str
+  AddLibrarySearchPath str    -> putWord8 8  >> put str
+  RemoveLibrarySearchPath ptr -> putWord8 9  >> put ptr
+  ResolveObjs                 -> putWord8 10
+  FindSystemLibrary str       -> putWord8 11 >> put str
+  CreateBCOs bco              -> putWord8 12 >> put bco
+  FreeHValueRefs val          -> putWord8 13 >> put val
+  MallocData bs               -> putWord8 14 >> put bs
+  PrepFFI conv args res       -> putWord8 15 >> put conv >> put args >> put res
+  FreeFFI p                   -> putWord8 16 >> put p
+  MkConInfoTable p n t d      -> putWord8 17 >> put p >> put n >> put t >> put d
+  EvalStmt opts val           -> putWord8 18 >> put opts >> put val
+  ResumeStmt opts val         -> putWord8 19 >> put opts >> put val
+  AbandonStmt val             -> putWord8 20 >> put val
+  EvalString val              -> putWord8 21 >> put val
+  EvalStringToString str val  -> putWord8 22 >> put str >> put val
+  EvalIO val                  -> putWord8 23 >> put val
+  StartTH                     -> putWord8 24
+  FinishTH val                -> putWord8 25 >> put val
+  RunTH st q loc ty           -> putWord8 26 >> put st >> put q >> put loc >> put ty
+  NewName a                   -> putWord8 27 >> put a
+  Report a b                  -> putWord8 28 >> put a >> put b
+  LookupName a b              -> putWord8 29 >> put a >> put b
+  Reify a                     -> putWord8 30 >> put a
+  ReifyFixity a               -> putWord8 31 >> put a
+  ReifyInstances a b          -> putWord8 32 >> put a >> put b
+  ReifyRoles a                -> putWord8 33 >> put a
+  ReifyAnnotations a b        -> putWord8 34 >> put a >> put b
+  ReifyModule a               -> putWord8 35 >> put a
+  AddDependentFile a          -> putWord8 36 >> put a
+  AddTopDecls a               -> putWord8 37 >> put a
+  IsExtEnabled a              -> putWord8 38 >> put a
+  ExtsEnabled                 -> putWord8 39
+  QDone                       -> putWord8 40
+  QException a                -> putWord8 41 >> put a
+  QFail a                     -> putWord8 42 >> put a
+
+-- -----------------------------------------------------------------------------
+-- Reading/writing messages
+
+data Pipe = Pipe
+  { pipeRead :: Handle
+  , pipeWrite ::  Handle
+  , pipeLeftovers :: IORef (Maybe ByteString)
+  }
+
+remoteCall :: Binary a => Pipe -> Message a -> IO a
+remoteCall pipe msg = do
+  writePipe pipe (putMessage msg)
+  readPipe pipe get
+
+writePipe :: Pipe -> Put -> IO ()
+writePipe Pipe{..} put
+  | LB.null bs = return ()
+  | otherwise  = do
+    LB.hPut pipeWrite bs
+    hFlush pipeWrite
+ where
+  bs = runPut put
+
+readPipe :: Pipe -> Get a -> IO a
+readPipe Pipe{..} get = do
+  leftovers <- readIORef pipeLeftovers
+  m <- getBin pipeRead get leftovers
+  case m of
+    Nothing -> throw $
+      mkIOError eofErrorType "GHCi.Message.remoteCall" (Just pipeRead) Nothing
+    Just (result, new_leftovers) -> do
+      writeIORef pipeLeftovers new_leftovers
+      return result
+
+getBin
+  :: Handle -> Get a -> Maybe ByteString
+  -> IO (Maybe (a, Maybe ByteString))
+
+getBin h get leftover = go leftover (runGetIncremental get)
+ where
+   go Nothing (Done leftover _ msg) =
+     return (Just (msg, if B.null leftover then Nothing else Just leftover))
+   go _ Done{} = throwIO (ErrorCall "getBin: Done with leftovers")
+   go (Just leftover) (Partial fun) = do
+     go Nothing (fun (Just leftover))
+   go Nothing (Partial fun) = do
+     -- putStrLn "before hGetSome"
+     b <- B.hGetSome h (32*1024)
+     -- printf "hGetSome: %d\n" (B.length b)
+     if B.null b
+        then return Nothing
+        else go Nothing (fun (Just b))
+   go _lft (Fail _rest _off str) =
+     throwIO (ErrorCall ("getBin: " ++ str))
similarity index 72%
rename from compiler/ghci/ObjLink.hs
rename to libraries/ghci/GHCi/ObjLink.hs
index b1cfe61..710cffd 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 --
 --  (c) The University of Glasgow 2002-2006
 --
 
 -- | Primarily, this module consists of an interface to the C-land
 -- dynamic linker.
-module ObjLink (
-   initObjLinker,           -- :: IO ()
-   loadDLL,                 -- :: String   -> IO (Maybe String)
-   loadArchive,             -- :: String   -> IO ()
-   loadObj,                 -- :: String   -> IO ()
-   unloadObj,               -- :: String   -> IO ()
-   insertSymbol,            -- :: String   -> String -> Ptr a -> IO ()
-   lookupSymbol,            -- :: String   -> IO (Maybe (Ptr a))
-   resolveObjs,             -- :: IO SuccessFlag
-   addLibrarySearchPath,    -- :: FilePath -> IO (Ptr ())
-   removeLibrarySearchPath, -- :: Ptr ()   -> IO Bool
-   findSystemLibrary        -- :: FilePath -> IO (Maybe FilePath)
+module GHCi.ObjLink
+  ( initObjLinker
+  , loadDLL
+  , loadArchive
+  , loadObj
+  , unloadObj
+  , lookupSymbol
+  , lookupClosure
+  , resolveObjs
+  , addLibrarySearchPath
+  , removeLibrarySearchPath
+  , findSystemLibrary
   )  where
 
-import Panic
-import BasicTypes       ( SuccessFlag, successIf )
-import Config           ( cLeadingUnderscore )
-import Util
-
+import GHCi.RemoteTypes
 import Control.Monad    ( when )
 import Foreign.C
 import Foreign.Marshal.Alloc ( free )
 import Foreign          ( nullPtr )
-import GHC.Exts         ( Ptr(..) )
+import GHC.Exts
 import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )
 import System.FilePath  ( dropExtension, normalise )
 
-
 -- ---------------------------------------------------------------------------
 -- RTS Linker Interface
 -- ---------------------------------------------------------------------------
 
-insertSymbol :: String -> String -> Ptr a -> IO ()
-insertSymbol obj_name key symbol
-    = let str = prefixUnderscore key
-      in withFilePath obj_name $ \c_obj_name ->
-         withCAString str $ \c_str ->
-          c_insertSymbol c_obj_name c_str symbol
-
 lookupSymbol :: String -> IO (Maybe (Ptr a))
 lookupSymbol str_in = do
    let str = prefixUnderscore str_in
@@ -56,10 +46,18 @@ lookupSymbol str_in = do
         then return Nothing
         else return (Just addr)
 
+lookupClosure :: String -> IO (Maybe HValueRef)
+lookupClosure str = do
+  m <- lookupSymbol str
+  case m of
+    Nothing -> return Nothing
+    Just (Ptr addr) -> case addrToAny# addr of
+      (# a #) -> Just <$> mkHValueRef (HValue a)
+
 prefixUnderscore :: String -> String
 prefixUnderscore
- | cLeadingUnderscore == "YES" = ('_':)
- | otherwise                   = id
+ | cLeadingUnderscore = ('_':)
+ | otherwise          = id
 
 -- | loadDLL loads a dynamic library using the OS's native linker
 -- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
@@ -90,19 +88,19 @@ loadArchive :: String -> IO ()
 loadArchive str = do
    withFilePath str $ \c_str -> do
      r <- c_loadArchive c_str
-     when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
+     when (r == 0) (error ("loadArchive " ++ show str ++ ": failed"))
 
 loadObj :: String -> IO ()
 loadObj str = do
    withFilePath str $ \c_str -> do
      r <- c_loadObj c_str
-     when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
+     when (r == 0) (error ("loadObj " ++ show str ++ ": failed"))
 
 unloadObj :: String -> IO ()
 unloadObj str =
    withFilePath str $ \c_str -> do
      r <- c_unloadObj c_str
-     when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
+     when (r == 0) (error ("unloadObj " ++ show str ++ ": failed"))
 
 addLibrarySearchPath :: String -> IO (Ptr ())
 addLibrarySearchPath str =
@@ -120,10 +118,10 @@ findSystemLibrary str = do
                     free result
                     return $ Just path
 
-resolveObjs :: IO SuccessFlag
+resolveObjs :: IO Bool
 resolveObjs = do
    r <- c_resolveObjs
-   return (successIf (r /= 0))
+   return (r /= 0)
 
 -- ---------------------------------------------------------------------------
 -- Foreign declarations to RTS entry points which does the real work;
@@ -131,12 +129,30 @@ resolveObjs = do
 
 foreign import ccall unsafe "addDLL"                  c_addDLL                  :: CFilePath -> IO CString
 foreign import ccall unsafe "initLinker"              initObjLinker             :: IO ()
-foreign import ccall unsafe "insertSymbol"            c_insertSymbol            :: CFilePath -> CString -> Ptr a -> IO ()
-foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString   -> IO (Ptr a)
+foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString -> IO (Ptr a)
 foreign import ccall unsafe "loadArchive"             c_loadArchive             :: CFilePath -> IO Int
 foreign import ccall unsafe "loadObj"                 c_loadObj                 :: CFilePath -> IO Int
 foreign import c