summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Marlow <marlowsd@gmail.com>2015-11-18 16:42:24 +0000
committerSimon Marlow <marlowsd@gmail.com>2015-12-17 09:39:52 +0000
commit4905b83a2d448c65ccced385343d4e8124548a3b (patch)
tree070cf9e48f6fce668cd01d888b8da8b3772d1f53
parent7221ad70daa363d77f60d96c3f6e1baa1d9bec81 (diff)
downloadhaskell-4905b83a2d448c65ccced385343d4e8124548a3b.tar.gz
Remote GHCi, -fexternal-interpreter
Summary: (Apologies for the size of this patch, I couldn't make a smaller one that was validate-clean and also made sense independently) (Some of this code is derived from GHCJS.) This commit adds support for running interpreted code (for GHCi and TemplateHaskell) in a separate process. The functionality is experimental, so for now it is off by default and enabled by the flag -fexternal-interpreter. Reaosns we want this: * compiling Template Haskell code with -prof does not require building the code without -prof first * when GHC itself is profiled, it can interpret unprofiled code, and the same applies to dynamic linking. We would no longer need to force -dynamic-too with TemplateHaskell, and we can load ordinary objects into a dynamically-linked GHCi (and vice versa). * An unprofiled GHCi can load and run profiled code, which means it can use the stack-trace functionality provided by profiling without taking the performance hit on the compiler that profiling would entail. Amongst other things; see https://ghc.haskell.org/trac/ghc/wiki/RemoteGHCi for more details. Notes on the implementation are in Note [Remote GHCi] in the new module compiler/ghci/GHCi.hs. It probably needs more documenting, feel free to suggest things I could elaborate on. Things that are not currently implemented for -fexternal-interpreter: * The GHCi debugger * :set prog, :set args in GHCi * `recover` in Template Haskell * Redirecting stdin/stdout for the external process These are all doable, I just wanted to get to a working validate-clean patch first. I also haven't done any benchmarking yet. I expect there to be slight hit to link times for byte code and some penalty due to having to serialize/deserialize TH syntax, but I don't expect it to be a serious problem. There's also lots of low-hanging fruit in the byte code generator/linker that we could exploit to speed things up. Test Plan: * validate * I've run parts of the test suite with EXTRA_HC_OPTS=-fexternal-interpreter, notably tests/ghci and tests/th. There are a few failures due to the things not currently implemented (see above). Reviewers: simonpj, goldfire, ezyang, austin, alanz, hvr, niteria, bgamari, gibiansky, luite Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D1562
-rw-r--r--.gitignore1
-rw-r--r--aclocal.m42
-rw-r--r--compiler/basicTypes/BasicTypes.hs5
-rw-r--r--compiler/basicTypes/Literal.hs14
-rw-r--r--compiler/coreSyn/MkCore.hs7
-rw-r--r--compiler/deSugar/Coverage.hs4
-rw-r--r--compiler/ghc.cabal.in7
-rw-r--r--compiler/ghc.mk47
-rw-r--r--compiler/ghci/ByteCodeAsm.hs93
-rw-r--r--compiler/ghci/ByteCodeGen.hs175
-rw-r--r--compiler/ghci/ByteCodeInstr.hs55
-rw-r--r--compiler/ghci/ByteCodeItbls.hs437
-rw-r--r--compiler/ghci/ByteCodeLink.hs284
-rw-r--r--compiler/ghci/ByteCodeTypes.hs90
-rw-r--r--compiler/ghci/Debugger.hs8
-rw-r--r--compiler/ghci/DebuggerUtils.hs2
-rw-r--r--compiler/ghci/GHCi.hs499
-rw-r--r--compiler/ghci/Linker.hs544
-rw-r--r--compiler/ghci/RtClosureInspect.hs14
-rw-r--r--compiler/main/Annotations.hs14
-rw-r--r--compiler/main/DriverPipeline.hs9
-rw-r--r--compiler/main/DynFlags.hs77
-rw-r--r--compiler/main/DynamicLoading.hs5
-rw-r--r--compiler/main/GHC.hs51
-rw-r--r--compiler/main/GhcMake.hs2
-rw-r--r--compiler/main/GhcPlugins.hs4
-rw-r--r--compiler/main/Hooks.hs33
-rw-r--r--compiler/main/HscMain.hs55
-rw-r--r--compiler/main/HscTypes.hs29
-rw-r--r--compiler/main/InteractiveEval.hs332
-rw-r--r--compiler/main/InteractiveEvalTypes.hs26
-rw-r--r--compiler/main/SysTools.hs10
-rw-r--r--compiler/specialise/SpecConstr.hs2
-rw-r--r--compiler/typecheck/TcRnDriver.hs8
-rw-r--r--compiler/typecheck/TcRnMonad.hs2
-rw-r--r--compiler/typecheck/TcRnTypes.hs2
-rw-r--r--compiler/typecheck/TcSplice.hs200
-rw-r--r--compiler/typecheck/TcSplice.hs-boot1
-rw-r--r--compiler/utils/Binary.hs10
-rw-r--r--compiler/utils/Outputable.hs4
-rw-r--r--compiler/utils/Panic.hs43
-rw-r--r--ghc.mk12
-rw-r--r--ghc/GhciMonad.hs127
-rw-r--r--ghc/InteractiveUI.hs65
-rw-r--r--ghc/Main.hs46
-rw-r--r--ghc/ghc-bin.cabal.in3
-rw-r--r--iserv/Main.hs94
-rw-r--r--iserv/Makefile15
-rw-r--r--iserv/ghc.mk67
-rw-r--r--iserv/iserv-bin.cabal26
-rw-r--r--iserv/iservmain.c16
-rw-r--r--libraries/ghc-boot/GHC/LanguageExtensions.hs8
-rw-r--r--libraries/ghc-boot/GHC/Serialized.hs (renamed from compiler/utils/Serialized.hs)30
-rw-r--r--libraries/ghc-boot/ghc-boot.cabal1
-rw-r--r--libraries/ghci/GHCi/CreateBCO.hs147
-rw-r--r--libraries/ghci/GHCi/FFI.hsc149
-rw-r--r--libraries/ghci/GHCi/InfoTable.hsc348
-rw-r--r--libraries/ghci/GHCi/Message.hs386
-rw-r--r--libraries/ghci/GHCi/ObjLink.hs (renamed from compiler/ghci/ObjLink.hs)88
-rw-r--r--libraries/ghci/GHCi/RemoteTypes.hs91
-rw-r--r--libraries/ghci/GHCi/ResolvedBCO.hs62
-rw-r--r--libraries/ghci/GHCi/Run.hs308
-rw-r--r--libraries/ghci/GHCi/Signals.hs46
-rw-r--r--libraries/ghci/GHCi/TH.hs175
-rw-r--r--libraries/ghci/GHCi/TH/Binary.hs73
-rw-r--r--libraries/ghci/GNUmakefile4
-rw-r--r--libraries/ghci/LICENSE31
-rw-r--r--libraries/ghci/SizedSeq.hs37
-rw-r--r--libraries/ghci/ghc.mk5
-rw-r--r--libraries/ghci/ghci.cabal41
-rw-r--r--rts/Interpreter.c7
-rw-r--r--rules/build-prog.mk18
-rw-r--r--rules/shell-wrapper.mk2
-rw-r--r--testsuite/config/ghc5
-rw-r--r--testsuite/driver/testlib.py23
-rw-r--r--testsuite/tests/annotations/should_run/annrun01.hs2
-rw-r--r--testsuite/tests/cabal/cabal04/Makefile3
-rw-r--r--testsuite/tests/cabal/cabal04/all.T2
-rw-r--r--testsuite/tests/ghc-api/T4891/T4891.hs19
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break006.stderr4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break011.script3
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break011.stdout12
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break013.stdout2
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break024.stdout4
-rw-r--r--testsuite/tests/ghci.debugger/scripts/print019.stderr2
-rw-r--r--testsuite/tests/ghci/prog001/prog001-ext.stdout4
-rw-r--r--testsuite/tests/ghci/prog001/prog001.T4
-rw-r--r--testsuite/tests/ghci/scripts/T10110A.hs1
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T12
-rw-r--r--testsuite/tests/profiling/should_run/scc003.prof.sample48
-rw-r--r--testsuite/tests/rts/LinkerUnload.hs4
-rw-r--r--testsuite/tests/rts/T2615.hs2
-rw-r--r--testsuite/tests/th/Makefile7
-rw-r--r--testsuite/tests/th/TH_Roles2.stderr5
-rw-r--r--testsuite/tests/th/TH_finalizer.hs11
-rw-r--r--testsuite/tests/th/TH_finalizer.stderr2
-rw-r--r--testsuite/tests/th/TH_spliceE5_prof_ext.hs14
-rw-r--r--testsuite/tests/th/TH_spliceE5_prof_ext.stdout1
-rw-r--r--testsuite/tests/th/TH_spliceE5_prof_ext_Lib.hs8
-rw-r--r--testsuite/tests/th/all.T10
-rw-r--r--utils/ghctags/Main.hs8
101 files changed, 4173 insertions, 1784 deletions
diff --git a/.gitignore b/.gitignore
index bfd567eaf6..ae23fbbb4d 100644
--- a/.gitignore
+++ b/.gitignore
@@ -72,6 +72,7 @@ _darcs/
/ghc/stage1/
/ghc/stage2/
/ghc/stage3/
+/iserv/stage2*/
# -----------------------------------------------------------------------------
# specific generated files
diff --git a/aclocal.m4 b/aclocal.m4
index e46a19f475..79b980a5ab 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -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"
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index 4133eac35f..f8d4e8fe3e 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -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
-
{-
************************************************************************
* *
diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs
index 5f3b75dafa..f1a99f7980 100644
--- a/compiler/basicTypes/Literal.hs
+++ b/compiler/basicTypes/Literal.hs
@@ -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]
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index c3e445a2bc..07db78a931 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -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))
{-
************************************************************************
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 85f603fac1..958aa12eab 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -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 $
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 8dc4e23efa..ae702ef788 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -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
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index dc22eb6ac5..d93b87963b 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -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
-
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index c69cede7f3..875de879cb 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -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
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index f331214892..f74b4c439a 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -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
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
index 2de4941aa6..4f2b82ba27 100644
--- a/compiler/ghci/ByteCodeInstr.hs
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -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
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index 01420f5e34..5a3e6d3e1a 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -5,416 +5,69 @@
--
-- | 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))
diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
index b977f370d3..aa92ecc610 100644
--- a/compiler/ghci/ByteCodeLink.hs
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -12,18 +12,21 @@
-- | 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
index 0000000000..0a8dd304b6
--- /dev/null
+++ b/compiler/ghci/ByteCodeTypes.hs
@@ -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))
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 2b9e732c4b..5c6a02d3ff 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -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]
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index d1ff9134ec..096b809c26 100644
--- a/compiler/ghci/DebuggerUtils.hs
+++ b/compiler/ghci/DebuggerUtils.hs
@@ -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
index 0000000000..d9c26c1d47
--- /dev/null
+++ b/compiler/ghci/GHCi.hs
@@ -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
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 7c10fae331..11936c7c75 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -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
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 015126fae9..f71c904454 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -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)
diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs
index a81ae80614..052b0615e7 100644
--- a/compiler/main/Annotations.hs
+++ b/compiler/main/Annotations.hs
@@ -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
-
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 4692b21520..c37cc6536e 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e443926d0f..03eb39846c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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!
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index 0d4b84252f..bbaf12978b 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -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
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 74860a1c03..4bf9a5845f 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -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.
--
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index f0dc3005f1..41d4f1c592 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -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:
diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs
index c60b41ec50..2aef9b3510 100644
--- a/compiler/main/GhcPlugins.hs
+++ b/compiler/main/GhcPlugins.hs
@@ -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
diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs
index f75214b4f4..0b75bc599d 100644
--- a/compiler/main/Hooks.hs
+++ b/compiler/main/Hooks.hs
@@ -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
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 0b60596123..558341aebc 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 40c99f6436..3766b57df1 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -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)
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index ac53382a78..2f819e4a60 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -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
diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs
index 7e6e837bea..98090bbaed 100644
--- a/compiler/main/InteractiveEvalTypes.hs
+++ b/compiler/main/InteractiveEvalTypes.hs
@@ -10,22 +10,22 @@
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
}
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index ad717a8a88..c7ca4a6481 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -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
}
diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
index ff4613448e..db56d6995b 100644
--- a/compiler/specialise/SpecConstr.hs
+++ b/compiler/specialise/SpecConstr.hs
@@ -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
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 6fc26f85eb..d30cf44765 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -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
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 5797b8e8ac..f5d5ed553b 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -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,
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 47d554d50a..c885bbdb04 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -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 */
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 2074100f84..64f7d1d311 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -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) }
+
{-
************************************************************************
* *
diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot
index 50b7aac98f..743362024b 100644
--- a/compiler/typecheck/TcSplice.hs-boot
+++ b/compiler/typecheck/TcSplice.hs-boot
@@ -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
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index ab5b772eec..b70304d785 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -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)
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index cda74755ca..c3bdf5eb79 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -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)
+
{-
************************************************************************
* *
diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs
index 782333633a..f1ccb7b5a5 100644
--- a/compiler/utils/Panic.hs
+++ b/compiler/utils/Panic.hs
@@ -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 4aea48078f..883e0b3008 100644
--- 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)
-
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index c1abe4f923..d8fa0e1146 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -22,7 +22,10 @@ module GhciMonad (
runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,
printForUser, printForUserPartWay, prettyLocations,
- initInterpBuffering, turnOffBuffering, flushInterpBuffers,
+ initInterpBuffering,
+ turnOffBuffering, turnOffBuffering_,
+ flushInterpBuffers,
+ mkEvalWrapper
) where
#include "HsVersions.h"
@@ -31,14 +34,13 @@ import qualified GHC
import GhcMonad hiding (liftIO)
import Outputable hiding (printForUser, printForUserPartWay)
import qualified Outputable
-import Util
import DynFlags
import FastString
import HscTypes
import SrcLoc
import Module
-import ObjLink
-import Linker
+import GHCi
+import GHCi.RemoteTypes
import Exception
import Numeric
@@ -48,7 +50,6 @@ import System.CPUTime
import System.Environment
import System.IO
import Control.Monad
-import GHC.Exts
import System.Console.Haskeline (CompletionFunc, InputT)
import qualified System.Console.Haskeline as Haskeline
@@ -62,6 +63,7 @@ data GHCiState = GHCiState
{
progname :: String,
args :: [String],
+ evalWrapper :: ForeignHValue, -- IO a -> IO a
prompt :: String,
prompt2 :: String,
editor :: String,
@@ -103,7 +105,12 @@ data GHCiState = GHCiState
-- help text to display to a user
short_help :: String,
long_help :: String,
- lastErrorLocations :: IORef [(FastString, Int)]
+ lastErrorLocations :: IORef [(FastString, Int)],
+
+ -- hFlush stdout; hFlush stderr in the interpreter
+ flushStdHandles :: ForeignHValue,
+ -- hSetBuffering NoBuffering for stdin/stdout/stderr
+ noBuffering :: ForeignHValue
}
type TickArray = Array Int [(BreakIndex,SrcSpan)]
@@ -282,18 +289,14 @@ printForUserPartWay doc = do
runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
runStmt expr step = do
st <- getGHCiState
- reifyGHCi $ \x ->
- withProgName (progname st) $
- withArgs (args st) $
- reflectGHCi x $ do
- GHC.handleSourceError (\e -> do GHC.printException e;
- return Nothing) $ do
- let opts = GHC.execOptions
- { GHC.execSourceFile = progname st
- , GHC.execLineNumber = line_number st
- , GHC.execSingleStep = step }
- r <- GHC.execStmt expr opts
- return (Just r)
+ GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
+ let opts = GHC.execOptions
+ { GHC.execSourceFile = progname st
+ , GHC.execLineNumber = line_number st
+ , GHC.execSingleStep = step
+ , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))
+ (EvalThis fhv) }
+ Just <$> GHC.execStmt expr opts
runDecls :: String -> GHCi (Maybe [GHC.Name])
runDecls decls = do
@@ -355,9 +358,9 @@ revertCAFs :: GHCi ()
revertCAFs = do
liftIO rts_revertCAFs
s <- getGHCiState
- when (not (ghc_e s)) $ liftIO turnOffBuffering
- -- Have to turn off buffering again, because we just
- -- reverted stdout, stderr & stdin to their defaults.
+ when (not (ghc_e s)) turnOffBuffering
+ -- Have to turn off buffering again, because we just
+ -- reverted stdout, stderr & stdin to their defaults.
foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
-- Make it "safe", just in case
@@ -366,54 +369,38 @@ foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
-- To flush buffers for the *interpreted* computation we need
-- to refer to *its* stdout/stderr handles
-GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
-GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
-GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
-
--- After various attempts, I believe this is the least bad way to do
--- what we want. We know look up the address of the static stdin,
--- stdout, and stderr closures in the loaded base package, and each
--- time we need to refer to them we cast the pointer to a Handle.
--- This avoids any problems with the CAF having been reverted, because
--- we'll always get the current value.
---
--- The previous attempt that didn't work was to compile an expression
--- like "hSetBuffering stdout NoBuffering" into an expression of type
--- IO () and run this expression each time we needed it, but the
--- problem is that evaluating the expression might cache the contents
--- of the Handle rather than referring to it from its static address
--- each time. There's no safe workaround for this.
-
-initInterpBuffering :: Ghc ()
-initInterpBuffering = do -- make sure these are linked
- dflags <- GHC.getSessionDynFlags
- liftIO $ do
- initDynLinker dflags
-
- -- ToDo: we should really look up these names properly, but
- -- it's a fiddle and not all the bits are exposed via the GHC
- -- interface.
- mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdin_closure"
- mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stdout_closure"
- mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziIOziHandleziFD_stderr_closure"
-
- let f ref (Just ptr) = writeIORef ref ptr
- f _ Nothing = panic "interactiveUI:setBuffering2"
- zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
- [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
-
+-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
+initInterpBuffering = do
+ nobuf <- GHC.compileExprRemote $
+ "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++
+ " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++
+ " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"
+ flush <- GHC.compileExprRemote $
+ "do { System.IO.hFlush System.IO.stdout; " ++
+ " System.IO.hFlush System.IO.stderr }"
+ return (nobuf, flush)
+
+-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
flushInterpBuffers :: GHCi ()
-flushInterpBuffers
- = liftIO $ do getHandle stdout_ptr >>= hFlush
- getHandle stderr_ptr >>= hFlush
-
-turnOffBuffering :: IO ()
-turnOffBuffering
- = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
- mapM_ (\h -> hSetBuffering h NoBuffering) hdls
-
-getHandle :: IORef (Ptr ()) -> IO Handle
-getHandle ref = do
- (Ptr addr) <- readIORef ref
- case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval)
+flushInterpBuffers = do
+ st <- getGHCiState
+ hsc_env <- GHC.getSession
+ liftIO $ evalIO hsc_env (flushStdHandles st)
+-- | Turn off buffering for stdin, stdout, and stderr in the interpreter
+turnOffBuffering :: GHCi ()
+turnOffBuffering = do
+ st <- getGHCiState
+ turnOffBuffering_ (noBuffering st)
+
+turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
+turnOffBuffering_ fhv = do
+ hsc_env <- getSession
+ liftIO $ evalIO hsc_env fhv
+
+mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
+mkEvalWrapper progname args =
+ GHC.compileExprRemote $
+ "\\m -> System.Environment.withProgName " ++ show progname ++
+ "(System.Environment.withArgs " ++ show args ++ " m)"
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index ef4c673aaa..55df63771e 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -28,6 +28,7 @@ import GhciTags
import Debugger
-- The GHC interface
+import GHCi
import DynFlags
import ErrUtils
import GhcMonad ( modifySession )
@@ -38,7 +39,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
import HsImpExp
import HsSyn
import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
- setInteractivePrintName )
+ setInteractivePrintName, hsc_dflags )
import Module
import Name
import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )
@@ -102,7 +103,6 @@ import System.Posix hiding ( getEnv )
import qualified System.Win32
#endif
-import GHC.Exts ( unsafeCoerce# )
import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
import GHC.IO.Handle ( hFlushAll )
import GHC.TopHandler ( topHandler )
@@ -375,7 +375,7 @@ interactiveUI config srcs maybe_exprs = do
_ <- liftIO $ newStablePtr stderr
-- Initialise buffering for the *interpreted* I/O system
- initInterpBuffering
+ (nobuffering, flush) <- initInterpBuffering
-- The initial set of DynFlags used for interactive evaluation is the same
-- as the global DynFlags, plus -XExtendedDefaultRules and
@@ -391,29 +391,31 @@ interactiveUI config srcs maybe_exprs = do
_ <- GHC.setProgramDynFlags $
progDynFlags { log_action = ghciLogAction lastErrLocationsRef }
- liftIO $ when (isNothing maybe_exprs) $ do
+ when (isNothing maybe_exprs) $ do
-- Only for GHCi (not runghc and ghc -e):
-- Turn buffering off for the compiled program's stdout/stderr
- turnOffBuffering
+ turnOffBuffering_ nobuffering
-- Turn buffering off for GHCi's stdout
- hFlush stdout
- hSetBuffering stdout NoBuffering
+ liftIO $ hFlush stdout
+ liftIO $ hSetBuffering stdout NoBuffering
-- We don't want the cmd line to buffer any input that might be
-- intended for the program, so unbuffer stdin.
- hSetBuffering stdin NoBuffering
- hSetBuffering stderr NoBuffering
+ liftIO $ hSetBuffering stdin NoBuffering
+ liftIO $ hSetBuffering stderr NoBuffering
#if defined(mingw32_HOST_OS)
-- On Unix, stdin will use the locale encoding. The IO library
-- doesn't do this on Windows (yet), so for now we use UTF-8,
-- for consistency with GHC 6.10 and to make the tests work.
- hSetEncoding stdin utf8
+ liftIO $ hSetEncoding stdin utf8
#endif
default_editor <- liftIO $ findEditor
+ eval_wrapper <- mkEvalWrapper default_progname default_args
startGHCi (runGHCi srcs maybe_exprs)
GHCiState{ progname = default_progname,
GhciMonad.args = default_args,
+ evalWrapper = eval_wrapper,
prompt = defPrompt config,
prompt2 = defPrompt2 config,
stop = default_stop,
@@ -434,7 +436,9 @@ interactiveUI config srcs maybe_exprs = do
ghc_e = isJust maybe_exprs,
short_help = shortHelpText config,
long_help = fullHelpText config,
- lastErrorLocations = lastErrLocationsRef
+ lastErrorLocations = lastErrLocationsRef,
+ flushStdHandles = flush,
+ noBuffering = nobuffering
}
return ()
@@ -948,7 +952,7 @@ afterRunStmt step_here run_result = do
Right names -> do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames names
- GHC.ExecBreak _ names mb_info
+ GHC.ExecBreak names mb_info
| isNothing mb_info ||
step_here (GHC.resumeSpan $ head resumes) -> do
mb_id_loc <- toBreakIdAndLocation mb_info
@@ -1319,7 +1323,7 @@ defineMacro overwrite s = do
body = nlHsVar compose_RDR `mkHsApp` step `mkHsApp` expr
tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
new_expr = L (getLoc expr) $ ExprWithTySig body tySig
- hv <- GHC.compileParsedExpr new_expr
+ hv <- GHC.compileParsedExprRemote new_expr
let newCmd = Command { cmdName = macro_name
, cmdAction = lift . runMacro hv
@@ -1330,9 +1334,10 @@ defineMacro overwrite s = do
-- later defined macros have precedence
liftIO $ writeIORef macros_ref (newCmd : filtered)
-runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
+runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
- str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)
+ hsc_env <- GHC.getSession
+ str <- liftIO $ evalStringToIOString hsc_env fun s
enqueueCommands (lines str)
return False
@@ -1360,9 +1365,10 @@ cmdCmd str = handleSourceError GHC.printException $ do
expr <- GHC.parseExpr str
-- > ghciStepIO str :: IO String
let new_expr = step `mkHsApp` expr
- hv <- GHC.compileParsedExpr new_expr
+ hv <- GHC.compileParsedExprRemote new_expr
- cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
+ hsc_env <- GHC.getSession
+ cmds <- liftIO $ evalString hsc_env hv
enqueueCommands (lines cmds)
-- | Generate a typed ghciStepIO expression
@@ -2126,8 +2132,16 @@ showDynFlags show_all dflags = do
setArgs, setOptions :: [String] -> GHCi ()
setProg, setEditor, setStop :: String -> GHCi ()
-setArgs args = modifyGHCiState (\st -> st { GhciMonad.args = args })
-setProg prog = modifyGHCiState (\st -> st { progname = prog })
+setArgs args = do
+ st <- getGHCiState
+ wrapper <- mkEvalWrapper (progname st) args
+ setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }
+
+setProg prog = do
+ st <- getGHCiState
+ wrapper <- mkEvalWrapper prog (GhciMonad.args st)
+ setGHCiState st { progname = prog, evalWrapper = wrapper }
+
setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })
setStop str@(c:_) | isDigit c
@@ -2203,14 +2217,15 @@ newDynFlags interactive_only minus_opts = do
-- if the package flags changed, reset the context and link
-- the new packages.
- dflags2 <- getDynFlags
+ hsc_env <- GHC.getSession
+ let dflags2 = hsc_dflags hsc_env
when (packageFlags dflags2 /= packageFlags dflags0) $ do
when (verbosity dflags2 > 0) $
liftIO . putStrLn $
"package flags have changed, resetting and loading new packages..."
GHC.setTargets []
_ <- GHC.load LoadAllTargets
- liftIO $ linkPackages dflags2 new_pkgs
+ liftIO $ linkPackages hsc_env new_pkgs
-- package flags changed, we can't re-use any of the old context
setContextAfterLoad False []
-- and copy the package state to the interactive DynFlags
@@ -2226,10 +2241,12 @@ newDynFlags interactive_only minus_opts = do
newLdInputs = drop ld0length (ldInputs dflags2)
newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
+ hsc_env' = hsc_env { hsc_dflags =
+ dflags2 { ldInputs = newLdInputs
+ , cmdlineFrameworks = newCLFrameworks } }
+
when (not (null newLdInputs && null newCLFrameworks)) $
- liftIO $ linkCmdLineLibs $
- dflags2 { ldInputs = newLdInputs
- , cmdlineFrameworks = newCLFrameworks }
+ liftIO $ linkCmdLineLibs hsc_env'
return ()
diff --git a/ghc/Main.hs b/ghc/Main.hs
index c85f0b3a8b..7d4e1e235c 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -166,20 +166,7 @@ main' postLoadMode dflags0 args flagWarnings = do
DoAbiHash -> (OneShot, dflt_target, LinkBinary)
_ -> (OneShot, dflt_target, LinkBinary)
- let dflags1 = case lang of
- HscInterpreted ->
- let platform = targetPlatform dflags0
- dflags0a = updateWays $ dflags0 { ways = interpWays }
- dflags0b = foldl gopt_set dflags0a
- $ concatMap (wayGeneralFlags platform)
- interpWays
- dflags0c = foldl gopt_unset dflags0b
- $ concatMap (wayUnsetGeneralFlags platform)
- interpWays
- in dflags0c
- _ ->
- dflags0
- dflags2 = dflags1{ ghcMode = mode,
+ let dflags1 = dflags0{ ghcMode = mode,
hscTarget = lang,
ghcLink = link,
verbosity = case postLoadMode of
@@ -191,14 +178,29 @@ main' postLoadMode dflags0 args flagWarnings = do
-- can be overriden from the command-line
-- XXX: this should really be in the interactive DynFlags, but
-- we don't set that until later in interactiveUI
- dflags3 | DoInteractive <- postLoadMode = imp_qual_enabled
+ dflags2 | DoInteractive <- postLoadMode = imp_qual_enabled
| DoEval _ <- postLoadMode = imp_qual_enabled
- | otherwise = dflags2
- where imp_qual_enabled = dflags2 `gopt_set` Opt_ImplicitImportQualified
+ | otherwise = dflags1
+ where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified
-- The rest of the arguments are "dynamic"
-- Leftover ones are presumably files
- (dflags4, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags3 args
+ (dflags3, fileish_args, dynamicFlagWarnings) <-
+ GHC.parseDynamicFlags dflags2 args
+
+ let dflags4 = case lang of
+ HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
+ let platform = targetPlatform dflags3
+ dflags3a = updateWays $ dflags3 { ways = interpWays }
+ dflags3b = foldl gopt_set dflags3a
+ $ concatMap (wayGeneralFlags platform)
+ interpWays
+ dflags3c = foldl gopt_unset dflags3b
+ $ concatMap (wayUnsetGeneralFlags platform)
+ interpWays
+ in dflags3c
+ _ ->
+ dflags3
GHC.prettyPrintGhcErrors dflags4 $ do
@@ -209,9 +211,6 @@ main' postLoadMode dflags0 args flagWarnings = do
liftIO $ exitWith (ExitFailure 1)) $ do
liftIO $ handleFlagWarnings dflags4 flagWarnings'
- -- make sure we clean up after ourselves
- GHC.defaultCleanupHandler dflags4 $ do
-
liftIO $ showBanner postLoadMode dflags4
let
@@ -336,9 +335,10 @@ checkOptions mode dflags srcs objs = do
-- -prof and --interactive are not a good combination
when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
- && isInterpretiveMode mode) $
+ && isInterpretiveMode mode
+ && not (gopt Opt_ExternalInterpreter dflags)) $
do throwGhcException (UsageError
- "--interactive can't be used with -prof or -static.")
+ "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
-- -ohi sanity check
if (isJust (outputHi dflags) &&
(isCompManagerMode mode || srcs `lengthExceeds` 1))
diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in
index 90b8a55e5b..45193e36ee 100644
--- a/ghc/ghc-bin.cabal.in
+++ b/ghc/ghc-bin.cabal.in
@@ -44,7 +44,8 @@ Executable ghc
GHC-Options: -Wall
if flag(ghci)
- Build-depends: deepseq >= 1.4 && < 1.5
+ Build-depends: deepseq >= 1.4 && < 1.5,
+ ghci
CPP-Options: -DGHCI
GHC-Options: -fno-warn-name-shadowing
Other-Modules:
diff --git a/iserv/Main.hs b/iserv/Main.hs
new file mode 100644
index 0000000000..cbaf9277d5
--- /dev/null
+++ b/iserv/Main.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE RecordWildCards, GADTs, ScopedTypeVariables, RankNTypes #-}
+module Main (main) where
+
+import GHCi.Run
+import GHCi.TH
+import GHCi.Message
+import GHCi.Signals
+
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.Binary
+import Data.IORef
+import System.Environment
+import System.Exit
+import System.Posix
+import Text.Printf
+
+main :: IO ()
+main = do
+ (arg0:arg1:rest) <- getArgs
+ let wfd1 = read arg0; rfd2 = read arg1
+ verbose <- case rest of
+ ["-v"] -> return True
+ [] -> return False
+ _ -> die "iserv: syntax: iserv <write-fd> <read-fd> [-v]"
+ when verbose $ do
+ printf "GHC iserv starting (in: %d; out: %d)\n"
+ (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
+ inh <- fdToHandle rfd2
+ outh <- fdToHandle wfd1
+ installSignalHandlers
+ lo_ref <- newIORef Nothing
+ let pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}
+ uninterruptibleMask $ serv verbose pipe
+ -- we cannot allow any async exceptions while communicating, because
+ -- we will lose sync in the protocol, hence uninterruptibleMask.
+
+serv :: Bool -> Pipe -> (forall a .IO a -> IO a) -> IO ()
+serv verbose pipe@Pipe{..} restore = loop
+ where
+ loop = do
+ Msg msg <- readPipe pipe getMessage
+ discardCtrlC
+ when verbose $ putStrLn ("iserv: " ++ show msg)
+ case msg of
+ Shutdown -> return ()
+ RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
+ FinishTH st -> wrapRunTH $ finishTH pipe st
+ _other -> run msg >>= reply
+
+ reply :: forall a. (Binary a, Show a) => a -> IO ()
+ reply r = do
+ when verbose $ putStrLn ("iserv: return: " ++ show r)
+ writePipe pipe (put r)
+ loop
+
+ wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
+ wrapRunTH io = do
+ r <- try io
+ case r of
+ Left e
+ | Just (GHCiQException _ err) <- fromException e -> do
+ when verbose $ putStrLn "iserv: QFail"
+ writePipe pipe (putMessage (QFail err))
+ loop
+ | otherwise -> do
+ when verbose $ putStrLn "iserv: QException"
+ str <- showException e
+ writePipe pipe (putMessage (QException str))
+ loop
+ Right a -> do
+ when verbose $ putStrLn "iserv: QDone"
+ writePipe pipe (putMessage QDone)
+ reply a
+
+ -- carefully when showing an exception, there might be other exceptions
+ -- lurking inside it. If so, we return the inner exception instead.
+ showException :: SomeException -> IO String
+ showException e0 = do
+ r <- try $ evaluate (force (show (e0::SomeException)))
+ case r of
+ Left e -> showException e
+ Right str -> return str
+
+ -- throw away any pending ^C exceptions while we're not running
+ -- interpreted code. GHC will also get the ^C, and either ignore it
+ -- (if this is GHCi), or tell us to quit with a Shutdown message.
+ discardCtrlC = do
+ r <- try $ restore $ return ()
+ case r of
+ Left UserInterrupt -> return () >> discardCtrlC
+ Left e -> throwIO e
+ _ -> return ()
diff --git a/iserv/Makefile b/iserv/Makefile
new file mode 100644
index 0000000000..f160978c19
--- /dev/null
+++ b/iserv/Makefile
@@ -0,0 +1,15 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+dir = iserv
+TOP = ..
+include $(TOP)/mk/sub-makefile.mk
diff --git a/iserv/ghc.mk b/iserv/ghc.mk
new file mode 100644
index 0000000000..4cae48299f
--- /dev/null
+++ b/iserv/ghc.mk
@@ -0,0 +1,67 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009-2012 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture
+# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying
+#
+# -----------------------------------------------------------------------------
+
+iserv_USES_CABAL = YES
+iserv_PACKAGE = iserv-bin
+
+ifeq "$(GhcDebugged)" "YES"
+iserv_stage2_MORE_HC_OPTS += -debug
+iserv_stage2_p_MORE_HC_OPTS += -debug
+iserv_stage2_dyn_MORE_HC_OPTS += -debug
+endif
+
+iserv_stage2_MORE_HC_OPTS += -threaded
+iserv_stage2_p_MORE_HC_OPTS += -threaded
+iserv_stage2_dyn_MORE_HC_OPTS += -threaded
+
+# Override the default way, because we want a specific version of this
+# program for each way. Note that it's important to do this even for
+# the vanilla version, otherwise we get a dynamic executable when
+# DYNAMIC_GHC_PROGRAMS=YES.
+iserv_stage2_PROGRAM_WAY = v
+iserv_stage2_p_PROGRAM_WAY = p
+iserv_stage2_dyn_PROGRAM_WAY = dyn
+
+iserv_stage2_PROGNAME = ghc-iserv
+iserv_stage2_p_PROGNAME = ghc-iserv-prof
+iserv_stage2_dyn_PROGNAME = ghc-iserv-dyn
+
+iserv_stage2_MORE_HC_OPTS += -no-hs-main
+iserv_stage2_p_MORE_HC_OPTS += -no-hs-main
+iserv_stage2_dyn_MORE_HC_OPTS += -no-hs-main
+
+iserv_stage2_INSTALL = YES
+iserv_stage2_p_INSTALL = YES
+iserv_stage2_dyn_INSTALL = YES
+
+# Install in $(libexec), not in $(bindir)
+iserv_stage2_TOPDIR = YES
+iserv_stage2_p_TOPDIR = YES
+iserv_stage2_dyn_TOPDIR = YES
+
+iserv_stage2_INSTALL_INPLACE = YES
+iserv_stage2_p_INSTALL_INPLACE = YES
+iserv_stage2_dyn_INSTALL_INPLACE = YES
+
+$(eval $(call build-prog,iserv,stage2,1))
+
+ifneq "$(findstring p, $(GhcLibWays))" ""
+$(eval $(call build-prog,iserv,stage2_p,1))
+endif
+
+ifneq "$(findstring dyn, $(GhcLibWays))" ""
+$(eval $(call build-prog,iserv,stage2_dyn,1))
+endif
+
+all_ghc_stage2 : $(iserv-stage2_INPLACE)
+all_ghc_stage2 : $(iserv-stage2_p_INPLACE)
+all_ghc_stage2 : $(iserv-stage2_dyn_INPLACE)
diff --git a/iserv/iserv-bin.cabal b/iserv/iserv-bin.cabal
new file mode 100644
index 0000000000..9dac158ebf
--- /dev/null
+++ b/iserv/iserv-bin.cabal
@@ -0,0 +1,26 @@
+Name: iserv-bin
+Version: 0.0
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: XXX
+Description:
+ XXX
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Executable iserv
+ Default-Language: Haskell2010
+ Main-Is: Main.hs
+ C-Sources: iservmain.c
+ Build-Depends: array >= 0.5 && < 0.6,
+ base >= 4 && < 5,
+ unix >= 2.7 && < 2.8,
+ binary >= 0.7 && < 0.9,
+ bytestring >= 0.10 && < 0.11,
+ containers >= 0.5 && < 0.6,
+ deepseq >= 1.4 && < 1.5,
+ ghci
diff --git a/iserv/iservmain.c b/iserv/iservmain.c
new file mode 100644
index 0000000000..f7eb5664c5
--- /dev/null
+++ b/iserv/iservmain.c
@@ -0,0 +1,16 @@
+#include "../rts/PosixSource.h"
+#include "Rts.h"
+
+#include "HsFFI.h"
+
+int main (int argc, char *argv[])
+{
+ RtsConfig conf = defaultRtsConfig;
+
+ // We never know what symbols GHC will look up in the future, so
+ // we must retain CAFs for running interpreted code.
+ conf.keep_cafs = 1;
+
+ extern StgClosure ZCMain_main_closure;
+ hs_main(argc, argv, &ZCMain_main_closure, conf);
+}
diff --git a/libraries/ghc-boot/GHC/LanguageExtensions.hs b/libraries/ghc-boot/GHC/LanguageExtensions.hs
index b108013f4b..39c1b11bf4 100644
--- a/libraries/ghc-boot/GHC/LanguageExtensions.hs
+++ b/libraries/ghc-boot/GHC/LanguageExtensions.hs
@@ -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
diff --git a/compiler/utils/Serialized.hs b/libraries/ghc-boot/GHC/Serialized.hs
index 41c1cea03f..39fa6a72f3 100644
--- a/compiler/utils/Serialized.hs
+++ b/libraries/ghc-boot/GHC/Serialized.hs
@@ -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:)))
-
diff --git a/libraries/ghc-boot/ghc-boot.cabal b/libraries/ghc-boot/ghc-boot.cabal
index 883bbaf795..4439153211 100644
--- a/libraries/ghc-boot/ghc-boot.cabal
+++ b/libraries/ghc-boot/ghc-boot.cabal
@@ -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
index 0000000000..026e3eafbd
--- /dev/null
+++ b/libraries/ghci/GHCi/CreateBCO.hs
@@ -0,0 +1,147 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RecordWildCards #-}
+
+--
+-- (c) The University of Glasgow 2002-2006
+--
+
+module GHCi.CreateBCO (createBCOs) where
+
+import GHCi.ResolvedBCO
+import GHCi.RemoteTypes
+import SizedSeq
+
+import System.IO (fixIO)
+import Control.Monad
+import Data.Array.Base
+import Foreign hiding (newArray)
+import GHC.Arr ( Array(..) )
+import GHC.Exts
+import GHC.IO
+-- import Debug.Trace
+
+createBCOs :: [ResolvedBCO] -> IO [HValueRef]
+createBCOs bcos = do
+ let n_bcos = length bcos
+ hvals <- fixIO $ \hvs -> do
+ let arr = listArray (0, n_bcos-1) hvs
+ mapM (createBCO arr) bcos
+ mapM mkHValueRef hvals
+
+createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
+createBCO arr bco
+ = do BCO bco# <- linkBCO' arr bco
+ -- Why do we need mkApUpd0 here? Otherwise top-level
+ -- interpreted CAFs don't get updated after evaluation. A
+ -- top-level BCO will evaluate itself and return its value
+ -- when entered, but it won't update itself. Wrapping the BCO
+ -- in an AP_UPD thunk will take care of the update for us.
+ --
+ -- Furthermore:
+ -- (a) An AP thunk *must* point directly to a BCO
+ -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
+ -- (c) An AP is always fully saturated, so we *can't* wrap
+ -- non-zero arity BCOs in an AP thunk.
+ --
+ if (resolvedBCOArity bco > 0)
+ then return (HValue (unsafeCoerce# bco#))
+ else case mkApUpd0# bco# of { (# final_bco #) ->
+ return (HValue final_bco) }
+
+
+linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
+linkBCO' arr ResolvedBCO{..} = do
+ let
+ ptrs = ssElts resolvedBCOPtrs
+ n_ptrs = sizeSS resolvedBCOPtrs
+
+ !(I# arity#) = resolvedBCOArity
+
+ !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
+
+ barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
+ insns_barr = barr resolvedBCOInstrs
+ bitmap_barr = barr resolvedBCOBitmap
+ literals_barr = barr resolvedBCOLits
+
+ PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
+ IO $ \s ->
+ case unsafeFreezeArray# marr s of { (# s, arr #) ->
+ case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
+ io s
+ }}
+
+
+-- we recursively link any sub-BCOs while making the ptrs array
+mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
+mkPtrsArray arr n_ptrs ptrs = do
+ marr <- newPtrsArray (fromIntegral n_ptrs)
+ let
+ fill (ResolvedBCORef n) i =
+ writePtrsArrayHValue i (arr ! n) marr -- must be lazy!
+ fill (ResolvedBCOPtr r) i = do
+ hv <- localHValueRef r
+ writePtrsArrayHValue i hv marr
+ fill (ResolvedBCOStaticPtr r) i = do
+ writePtrsArrayPtr i (fromRemotePtr r) marr
+ fill (ResolvedBCOPtrBCO bco) i = do
+ BCO bco# <- linkBCO' arr bco
+ writePtrsArrayBCO i bco# marr
+ fill (ResolvedBCOPtrLocal hv) i = do
+ writePtrsArrayHValue i hv marr
+ zipWithM_ fill ptrs [0..]
+ return marr
+
+data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)
+
+newPtrsArray :: Int -> IO PtrsArr
+newPtrsArray (I# i) = IO $ \s ->
+ case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)
+
+writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
+writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->
+ case writeArray# arr i hv s of s' -> (# s', () #)
+
+writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()
+writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->
+ case writeArrayAddr# arr i a# s of s' -> (# s', () #)
+
+-- This is rather delicate: convincing GHC to pass an Addr# as an Any but
+-- without making a thunk turns out to be surprisingly tricky.
+{-# NOINLINE writeArrayAddr# #-}
+writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
+writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s
+
+writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()
+writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
+ case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
+
+data BCO = BCO BCO#
+
+newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
+newBCO instrs lits ptrs arity bitmap = IO $ \s ->
+ case newBCO# instrs lits ptrs arity bitmap s of
+ (# s1, bco #) -> (# s1, BCO bco #)
+
+{- Note [BCO empty array]
+
+Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
+they are 2-word heap objects. So let's make a single empty array and
+share it between all BCOs.
+-}
+
+data EmptyArr = EmptyArr ByteArray#
+
+{-# NOINLINE emptyArr #-}
+emptyArr :: EmptyArr
+emptyArr = unsafeDupablePerformIO $ IO $ \s ->
+ case newByteArray# 0# s of { (# s, arr #) ->
+ case unsafeFreezeByteArray# arr s of { (# s, farr #) ->
+ (# s, EmptyArr farr #)
+ }}
diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc
new file mode 100644
index 0000000000..36619aeb5d
--- /dev/null
+++ b/libraries/ghci/GHCi/FFI.hsc
@@ -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
index 0000000000..d9d63146dd
--- /dev/null
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -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
index 0000000000..bdf29cbd73
--- /dev/null
+++ b/libraries/ghci/GHCi/Message.hs
@@ -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))
diff --git a/compiler/ghci/ObjLink.hs b/libraries/ghci/GHCi/ObjLink.hs
index b1cfe61da9..710cffd1a6 100644
--- a/compiler/ghci/ObjLink.hs
+++ b/libraries/ghci/GHCi/ObjLink.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
--
-- (c) The University of Glasgow 2002-2006
--
@@ -8,45 +10,33 @@
-- | 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 ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int
foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int
foreign import ccall unsafe "addLibrarySearchPath" c_addLibrarySearchPath :: CFilePath -> IO (Ptr ())
-foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr () -> IO Bool
foreign import ccall unsafe "findSystemLibrary" c_findSystemLibrary :: CFilePath -> IO CFilePath
+foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool
+
+-- -----------------------------------------------------------------------------
+-- Configuration
+
+#include "ghcautoconf.h"
+
+cLeadingUnderscore :: Bool
+#ifdef LEADING_UNDERSCORE
+cLeadingUnderscore = True
+#else
+cLeadingUnderscore = False
+#endif
+
+isWindowsHost :: Bool
+#if mingw32_HOST_OS
+isWindowsHost = True
+#else
+isWindowsHost = False
+#endif
diff --git a/libraries/ghci/GHCi/RemoteTypes.hs b/libraries/ghci/GHCi/RemoteTypes.hs
new file mode 100644
index 0000000000..920ce93fe6
--- /dev/null
+++ b/libraries/ghci/GHCi/RemoteTypes.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE CPP, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
+module GHCi.RemoteTypes
+ ( RemotePtr(..), toRemotePtr, fromRemotePtr
+ , HValue(..)
+ , HValueRef, mkHValueRef, localHValueRef, freeHValueRef
+ , ForeignHValue, mkForeignHValue, withForeignHValue
+ , unsafeForeignHValueToHValueRef, finalizeForeignHValue
+ ) where
+
+import Data.Word
+import Foreign hiding (newForeignPtr)
+import Foreign.Concurrent
+import Data.Binary
+import GHC.Exts
+import GHC.ForeignPtr
+
+-- -----------------------------------------------------------------------------
+-- RemotePtr
+
+-- Static pointers only; don't use this for heap-resident pointers.
+-- Instead use HValueRef.
+
+#include "MachDeps.h"
+#if SIZEOF_HSINT == 4
+newtype RemotePtr = RemotePtr Word32
+#elif SIZEOF_HSINT == 8
+newtype RemotePtr = RemotePtr Word64
+#endif
+
+toRemotePtr :: Ptr a -> RemotePtr
+toRemotePtr p = RemotePtr (fromIntegral (ptrToWordPtr p))
+
+fromRemotePtr :: RemotePtr -> Ptr a
+fromRemotePtr (RemotePtr p) = wordPtrToPtr (fromIntegral p)
+
+deriving instance Show RemotePtr
+deriving instance Binary RemotePtr
+
+-- -----------------------------------------------------------------------------
+-- HValueRef
+
+newtype HValue = HValue Any
+
+instance Show HValue where
+ show _ = "<HValue>"
+
+newtype HValueRef = HValueRef RemotePtr
+ deriving (Show, Binary)
+
+-- | Make a reference to a local HValue that we can send remotely.
+-- This reference will keep the value that it refers to alive until
+-- 'freeHValueRef' is called.
+mkHValueRef :: HValue -> IO HValueRef
+mkHValueRef (HValue hv) = do
+ sp <- newStablePtr hv
+ return $! HValueRef (toRemotePtr (castStablePtrToPtr sp))
+
+-- | Convert an HValueRef to an HValue. Should only be used if the HValue
+-- originated in this process.
+localHValueRef :: HValueRef -> IO HValue
+localHValueRef (HValueRef w) = do
+ p <- deRefStablePtr (castPtrToStablePtr (fromRemotePtr w))
+ return (HValue p)
+
+-- | Release an HValueRef that originated in this process
+freeHValueRef :: HValueRef -> IO ()
+freeHValueRef (HValueRef w) =
+ freeStablePtr (castPtrToStablePtr (fromRemotePtr w))
+
+-- | An HValueRef with a finalizer
+newtype ForeignHValue = ForeignHValue (ForeignPtr ())
+
+-- | Create a 'ForeignHValue' from an 'HValueRef'. The finalizer
+-- should arrange to call 'freeHValueRef' on the 'HValueRef'. (since
+-- this function needs to be called in the process that created the
+-- 'HValueRef', it cannot be called directly from the finalizer).
+mkForeignHValue :: HValueRef -> IO () -> IO ForeignHValue
+mkForeignHValue (HValueRef hvref) finalizer =
+ ForeignHValue <$> newForeignPtr (fromRemotePtr hvref) finalizer
+
+-- | Use a 'ForeignHValue'
+withForeignHValue :: ForeignHValue -> (HValueRef -> IO a) -> IO a
+withForeignHValue (ForeignHValue fp) f =
+ withForeignPtr fp (f . HValueRef . toRemotePtr)
+
+unsafeForeignHValueToHValueRef :: ForeignHValue -> HValueRef
+unsafeForeignHValueToHValueRef (ForeignHValue fp) =
+ HValueRef (toRemotePtr (unsafeForeignPtrToPtr fp))
+
+finalizeForeignHValue :: ForeignHValue -> IO ()
+finalizeForeignHValue (ForeignHValue fp) = finalizeForeignPtr fp
diff --git a/libraries/ghci/GHCi/ResolvedBCO.hs b/libraries/ghci/GHCi/ResolvedBCO.hs
new file mode 100644
index 0000000000..9234210418
--- /dev/null
+++ b/libraries/ghci/GHCi/ResolvedBCO.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving #-}
+module GHCi.ResolvedBCO
+ ( ResolvedBCO(..)
+ , ResolvedBCOPtr(..)
+ ) where
+
+import SizedSeq
+import GHCi.RemoteTypes
+
+import Data.Array.Unboxed
+import Data.Binary
+import GHC.Generics
+
+-- -----------------------------------------------------------------------------
+-- ResolvedBCO
+
+-- A ResolvedBCO is one in which all the Name references have been
+-- resolved to actual addresses or RemoteHValues.
+
+data ResolvedBCO
+ = ResolvedBCO {
+ resolvedBCOArity :: Int,
+ resolvedBCOInstrs :: UArray Int Word16, -- insns
+ resolvedBCOBitmap :: UArray Int Word, -- bitmap
+ resolvedBCOLits :: UArray Int Word, -- non-ptrs
+ resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ptrs
+ }
+ deriving (Generic, Show)
+
+instance Binary ResolvedBCO
+
+data ResolvedBCOPtr
+ = ResolvedBCORef Int
+ -- ^ reference to the Nth BCO in the current set
+ | ResolvedBCOPtr HValueRef
+ -- ^ reference to a previously created BCO
+ | ResolvedBCOStaticPtr RemotePtr
+ -- ^ reference to a static ptr
+ | ResolvedBCOPtrBCO ResolvedBCO
+ -- ^ a nested BCO
+ | ResolvedBCOPtrLocal HValue
+ -- ^ something local, cannot be serialized
+ deriving (Generic, Show)
+
+-- Manual Binary instance is needed because we cannot serialize
+-- ResolvedBCOPtrLocal. This will go away once we have support for
+-- remote breakpoints.
+instance Binary ResolvedBCOPtr where
+ put (ResolvedBCORef a) = putWord8 0 >> put a
+ put (ResolvedBCOPtr a) = putWord8 1 >> put a
+ put (ResolvedBCOStaticPtr a) = putWord8 2 >> put a
+ put (ResolvedBCOPtrBCO a) = putWord8 3 >> put a
+ put (ResolvedBCOPtrLocal _) =
+ error "Cannot serialize a local pointer. Use -fno-external-interpreter?"
+
+ get = do
+ w <- getWord8
+ case w of
+ 0 -> ResolvedBCORef <$> get
+ 1 -> ResolvedBCOPtr <$> get
+ 2 -> ResolvedBCOStaticPtr <$> get
+ _ -> ResolvedBCOPtrBCO <$> get
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
new file mode 100644
index 0000000000..69f82db689
--- /dev/null
+++ b/libraries/ghci/GHCi/Run.hs
@@ -0,0 +1,308 @@
+{-# LANGUAGE GADTs, RecordWildCards, UnboxedTuples, MagicHash,
+ ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+-- |
+-- Execute GHCi messages
+--
+module GHCi.Run
+ ( run, redirectInterrupts
+ , toSerializableException, fromSerializableException
+ ) where
+
+import GHCi.CreateBCO
+import GHCi.InfoTable
+import GHCi.FFI
+import GHCi.Message
+import GHCi.ObjLink
+import GHCi.RemoteTypes
+import GHCi.TH
+
+import Control.Concurrent
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Unsafe as B
+import GHC.Exts
+import Foreign
+import Foreign.C
+import GHC.Conc.Sync
+import GHC.IO hiding ( bracket )
+import System.Exit
+import System.Mem.Weak ( deRefWeak )
+import Unsafe.Coerce
+
+-- -----------------------------------------------------------------------------
+-- Implement messages
+
+run :: Message a -> IO a
+run m = case m of
+ InitLinker -> initObjLinker
+ LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str
+ LookupClosure str -> lookupClosure str
+ LoadDLL str -> loadDLL str
+ LoadArchive str -> loadArchive str
+ LoadObj str -> loadObj str
+ UnloadObj str -> unloadObj str
+ AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str
+ RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)
+ ResolveObjs -> resolveObjs
+ FindSystemLibrary str -> findSystemLibrary str
+ CreateBCOs bco -> createBCOs bco
+ FreeHValueRefs rs -> mapM_ freeHValueRef rs
+ EvalStmt opts r -> evalStmt opts r
+ ResumeStmt opts r -> resumeStmt opts r
+ AbandonStmt r -> abandonStmt r
+ EvalString r -> evalString r
+ EvalStringToString r s -> evalStringToString r s
+ EvalIO r -> evalIO r
+ MallocData bs -> mkString bs
+ PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
+ FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
+ MkConInfoTable ptrs nptrs tag desc ->
+ toRemotePtr <$> mkConInfoTable ptrs nptrs tag desc
+ StartTH -> startTH
+ _other -> error "GHCi.Run.run"
+
+evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
+evalStmt opts expr = do
+ io <- mkIO expr
+ sandboxIO opts $ do
+ rs <- unsafeCoerce io :: IO [HValue]
+ mapM mkHValueRef rs
+ where
+ mkIO (EvalThis href) = localHValueRef href
+ mkIO (EvalApp l r) = do
+ l' <- mkIO l
+ r' <- mkIO r
+ return ((unsafeCoerce l' :: HValue -> HValue) r')
+
+evalIO :: HValueRef -> IO (EvalResult ())
+evalIO r = do
+ io <- localHValueRef r
+ tryEval (unsafeCoerce io :: IO ())
+
+evalString :: HValueRef -> IO (EvalResult String)
+evalString r = do
+ io <- localHValueRef r
+ tryEval $ do
+ r <- unsafeCoerce io :: IO String
+ evaluate (force r)
+
+evalStringToString :: HValueRef -> String -> IO (EvalResult String)
+evalStringToString r str = do
+ io <- localHValueRef r
+ tryEval $ do
+ r <- (unsafeCoerce io :: String -> IO String) str
+ evaluate (force r)
+
+-- 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 :: EvalOpts -> IO a -> IO (EvalStatus a)
+sandboxIO opts io = do
+ -- We are running in uninterruptibleMask
+ breakMVar <- newEmptyMVar
+ statusMVar <- newEmptyMVar
+ withBreakAction opts breakMVar statusMVar $ do
+ let runIt = measureAlloc $ tryEval $ rethrow opts io
+ if useSandboxThread opts
+ then do
+ tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar
+ -- empty: can't block
+ redirectInterrupts tid $ unsafeUnmask $ 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
+
+-- 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 :: EvalOpts -> IO a -> IO a
+rethrow EvalOpts{..} io =
+ catch io $ \se -> do
+ -- If -fbreak-on-error, we break unconditionally,
+ -- but with care of not breaking twice
+ if breakOnError && not breakOnException
+ 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
+ throwIO se
+
+--
+-- 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 (EvalResult a) -> IO (EvalStatus a)
+measureAlloc io = do
+ setAllocationCounter maxBound
+ a <- io
+ ctr <- getAllocationCounter
+ let allocs = fromIntegral (maxBound::Int64) - fromIntegral ctr
+ return (EvalComplete allocs a)
+
+-- Exceptions can't be marshaled because they're dynamically typed, so
+-- everything becomes a String.
+tryEval :: IO a -> IO (EvalResult a)
+tryEval io = do
+ e <- try io
+ case e of
+ Left ex -> return (EvalException (toSerializableException ex))
+ Right a -> return (EvalSuccess a)
+
+toSerializableException :: SomeException -> SerializableException
+toSerializableException ex
+ | Just UserInterrupt <- fromException ex = EUserInterrupt
+ | Just (ec::ExitCode) <- fromException ex = (EExitCode ec)
+ | otherwise = EOtherException (show (ex :: SomeException))
+
+fromSerializableException :: SerializableException -> SomeException
+fromSerializableException EUserInterrupt = toException UserInterrupt
+fromSerializableException (EExitCode c) = toException c
+fromSerializableException (EOtherException str) = toException (ErrorCall str)
+
+-- 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 :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a
+withBreakAction opts breakMVar statusMVar act
+ = bracket setBreakAction resetBreakAction (\_ -> act)
+ where
+ setBreakAction = do
+ stablePtr <- newStablePtr onBreak
+ poke breakPointIOAction stablePtr
+ when (breakOnException opts) $ poke exceptionFlag 1
+ when (singleStep opts) $ 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
+ let resume = ResumeContext
+ { resumeBreakMVar = breakMVar
+ , resumeStatusMVar = statusMVar
+ , resumeThreadId = tid }
+ resume_r <- mkHValueRef (unsafeCoerce resume)
+ apStack_r <- mkHValueRef apStack
+ info_r <- mkHValueRef info
+ putMVar statusMVar (EvalBreak is_exception apStack_r info_r resume_r)
+ takeMVar breakMVar
+
+ resetBreakAction stablePtr = do
+ poke breakPointIOAction noBreakStablePtr
+ poke exceptionFlag 0
+ resetStepFlag
+ freeStablePtr stablePtr
+
+data ResumeContext a = ResumeContext
+ { resumeBreakMVar :: MVar ()
+ , resumeStatusMVar :: MVar (EvalStatus a)
+ , resumeThreadId :: ThreadId
+ }
+
+resumeStmt :: EvalOpts -> HValueRef -> IO (EvalStatus [HValueRef])
+resumeStmt opts hvref = do
+ ResumeContext{..} <- unsafeCoerce (localHValueRef hvref)
+ withBreakAction opts resumeBreakMVar resumeStatusMVar $
+ mask_ $ do
+ putMVar resumeBreakMVar () -- this awakens the stopped thread...
+ redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
+
+-- 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.
+abandonStmt :: HValueRef -> IO ()
+abandonStmt hvref = do
+ ResumeContext{..} <- unsafeCoerce (localHValueRef hvref)
+ killThread resumeThreadId
+ putMVar resumeBreakMVar ()
+ _ <- takeMVar resumeStatusMVar
+ return ()
+
+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
+
+foreign import ccall "&rts_breakpoint_io_action"
+ breakPointIOAction :: Ptr (StablePtr (Bool -> HValue -> HValue -> IO ()))
+
+noBreakStablePtr :: StablePtr (Bool -> HValue -> HValue -> IO ())
+noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
+
+noBreakAction :: Bool -> HValue -> HValue -> IO ()
+noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
+noBreakAction True _ _ = return () -- exception: just continue
+
+-- Malloc and copy the bytes. We don't have any way to monitor the
+-- lifetime of this memory, so it just leaks.
+mkString :: ByteString -> IO RemotePtr
+mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
+ ptr <- mallocBytes len
+ copyBytes ptr cstr len
+ return (toRemotePtr ptr)
diff --git a/libraries/ghci/GHCi/Signals.hs b/libraries/ghci/GHCi/Signals.hs
new file mode 100644
index 0000000000..9341b6ccab
--- /dev/null
+++ b/libraries/ghci/GHCi/Signals.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE CPP #-}
+module GHCi.Signals (installSignalHandlers) where
+
+import Control.Concurrent
+import Control.Exception
+import System.Mem.Weak ( deRefWeak )
+
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals
+#endif
+
+#if defined(mingw32_HOST_OS)
+import GHC.ConsoleHandler
+#endif
+
+-- | Install standard signal handlers for catching ^C, which just throw an
+-- exception in the target thread. The current target thread is the
+-- thread at the head of the list in the MVar passed to
+-- installSignalHandlers.
+installSignalHandlers :: IO ()
+installSignalHandlers = do
+ main_thread <- myThreadId
+ wtid <- mkWeakThreadId main_thread
+
+ let interrupt = do
+ r <- deRefWeak wtid
+ case r of
+ Nothing -> return ()
+ Just t -> throwTo t UserInterrupt
+
+#if !defined(mingw32_HOST_OS)
+ _ <- installHandler sigQUIT (Catch interrupt) Nothing
+ _ <- installHandler sigINT (Catch interrupt) Nothing
+#else
+ -- GHC 6.3+ has support for console events on Windows
+ -- NOTE: running GHCi under a bash shell for some reason requires
+ -- you to press Ctrl-Break rather than Ctrl-C to provoke
+ -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
+ -- why --SDM 17/12/2004
+ let sig_handler ControlC = interrupt
+ sig_handler Break = interrupt
+ sig_handler _ = return ()
+
+ _ <- installHandler (Catch sig_handler)
+#endif
+ return ()
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
new file mode 100644
index 0000000000..0121da9426
--- /dev/null
+++ b/libraries/ghci/GHCi/TH.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,
+ TupleSections, RecordWildCards, InstanceSigs #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+-- |
+-- Running TH splices
+--
+module GHCi.TH (startTH, finishTH, runTH, GHCiQException(..)) where
+
+import GHCi.Message
+import GHCi.RemoteTypes
+import GHC.Serialized
+
+import Control.Exception
+import Data.Binary
+import Data.Binary.Put
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Data
+import Data.Dynamic
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import GHC.Desugar
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
+import Unsafe.Coerce
+
+data QState = QState
+ { qsMap :: Map TypeRep Dynamic
+ -- ^ persistent data between splices in a module
+ , qsFinalizers :: [TH.Q ()]
+ -- ^ registered finalizers (in reverse order)
+ , qsLocation :: Maybe TH.Loc
+ -- ^ location for current splice, if any
+ , qsPipe :: Pipe
+ -- ^ pipe to communicate with GHC
+ }
+instance Show QState where show _ = "<QState>"
+
+initQState :: Pipe -> QState
+initQState p = QState M.empty [] Nothing p
+
+runModFinalizers :: GHCiQ ()
+runModFinalizers = go =<< getState
+ where
+ go s | (f:ff) <- qsFinalizers s = do
+ putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go
+ go _ = return ()
+
+newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
+
+data GHCiQException = GHCiQException QState String
+ deriving (Show, Typeable)
+
+instance Exception GHCiQException
+
+instance Functor GHCiQ where
+ fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s
+
+instance Applicative GHCiQ where
+ f <*> a = GHCiQ $ \s ->
+ do (f',s') <- runGHCiQ f s
+ (a',s'') <- runGHCiQ a s'
+ return (f' a', s'')
+ pure x = GHCiQ (\s -> return (x,s))
+
+instance Monad GHCiQ where
+ m >>= f = GHCiQ $ \s ->
+ do (m', s') <- runGHCiQ m s
+ (a, s'') <- runGHCiQ (f m') s'
+ return (a, s'')
+ return = pure
+ fail err = GHCiQ $ \s -> throwIO (GHCiQException s err)
+
+getState :: GHCiQ QState
+getState = GHCiQ $ \s -> return (s,s)
+
+putState :: QState -> GHCiQ ()
+putState s = GHCiQ $ \_ -> return ((),s)
+
+noLoc :: TH.Loc
+noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
+
+ghcCmd :: Binary a => Message (THResult a) -> GHCiQ a
+ghcCmd m = GHCiQ $ \s -> do
+ r <- remoteCall (qsPipe s) m
+ case r of
+ THException str -> throwIO (GHCiQException s str)
+ THComplete res -> return (res, s)
+
+instance TH.Quasi GHCiQ where
+ qNewName str = ghcCmd (NewName str)
+ qReport isError msg = ghcCmd (Report isError msg)
+ qRecover = undefined
+{-
+ qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> do
+ let r :: Bool -> IO ()
+ r b = do EndRecover' <- sendRequest (EndRecover b)
+ return ()
+ StartRecover' <- sendRequest StartRecover
+ (a s >>= \s' -> r False >> return s') `E.catch`
+ \(GHCiQException s' _ _) -> r True >> h s
+-}
+ qLookupName isType occ = ghcCmd (LookupName isType occ)
+ qReify name = ghcCmd (Reify name)
+ qReifyFixity name = ghcCmd (ReifyFixity name)
+ qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
+ qReifyRoles name = ghcCmd (ReifyRoles name)
+
+ -- To reify annotations, we send GHC the AnnLookup and also the TypeRep of the
+ -- thing we're looking for, to avoid needing to serialize irrelevant annotations.
+ qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]
+ qReifyAnnotations lookup =
+ map (deserializeWithData . B.unpack) <$> ghcCmd (ReifyAnnotations lookup typerep)
+ where typerep = typeOf (undefined :: a)
+
+ qReifyModule m = ghcCmd (ReifyModule m)
+ qLocation = fromMaybe noLoc . qsLocation <$> getState
+ qRunIO m = GHCiQ $ \s -> fmap (,s) m
+ qAddDependentFile file = ghcCmd (AddDependentFile file)
+ qAddTopDecls decls = ghcCmd (AddTopDecls decls)
+ qAddModFinalizer fin = GHCiQ $ \s ->
+ return ((), s { qsFinalizers = fin : qsFinalizers s })
+ qGetQ = GHCiQ $ \s ->
+ let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
+ lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
+ in return (lookup (qsMap s), s)
+ qPutQ k = GHCiQ $ \s ->
+ return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
+ qIsExtEnabled x = ghcCmd (IsExtEnabled x)
+ qExtsEnabled = ghcCmd ExtsEnabled
+
+startTH :: IO HValueRef
+startTH = do
+ r <- newIORef (initQState (error "startTH: no pipe"))
+ mkHValueRef (unsafeCoerce r)
+
+finishTH :: Pipe -> HValueRef -> IO ()
+finishTH pipe rstate = do
+ qstateref <- unsafeCoerce <$> localHValueRef rstate
+ qstate <- readIORef qstateref
+ _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }
+ freeHValueRef rstate
+ return ()
+
+runTH
+ :: Pipe -> HValueRef -> HValueRef
+ -> THResultType
+ -> Maybe TH.Loc
+ -> IO ByteString
+runTH pipe rstate rhv ty mb_loc = do
+ hv <- localHValueRef rhv
+ case ty of
+ THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)
+ THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)
+ THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)
+ THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])
+ THAnnWrapper -> do
+ hv <- unsafeCoerce <$> localHValueRef rhv
+ case hv :: AnnotationWrapper of
+ AnnotationWrapper thing ->
+ return $! LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
+
+runTHQ :: Binary a => Pipe -> HValueRef -> Maybe TH.Loc -> TH.Q a
+ -> IO ByteString
+runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
+ qstateref <- unsafeCoerce <$> localHValueRef rstate
+ qstate <- readIORef qstateref
+ let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
+ (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
+ writeIORef qstateref new_state
+ return $! LB.toStrict (runPut (put r))
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
new file mode 100644
index 0000000000..41187fdef9
--- /dev/null
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -0,0 +1,73 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- This module is full of orphans, unfortunately
+module GHCi.TH.Binary () where
+
+import Data.Binary
+import qualified Data.ByteString as B
+import Data.Typeable
+import GHC.Serialized
+import qualified Language.Haskell.TH as TH
+import qualified Language.Haskell.TH.Syntax as TH
+
+-- Put these in a separate module because they take ages to compile
+
+instance Binary TH.Loc
+instance Binary TH.Name
+instance Binary TH.ModName
+instance Binary TH.NameFlavour
+instance Binary TH.PkgName
+instance Binary TH.NameSpace
+instance Binary TH.Module
+instance Binary TH.Info
+instance Binary TH.Type
+instance Binary TH.TyLit
+instance Binary TH.TyVarBndr
+instance Binary TH.Role
+instance Binary TH.Lit
+instance Binary TH.Range
+instance Binary TH.Stmt
+instance Binary TH.Pat
+instance Binary TH.Exp
+instance Binary TH.Dec
+instance Binary TH.Guard
+instance Binary TH.Body
+instance Binary TH.Match
+instance Binary TH.Fixity
+instance Binary TH.TySynEqn
+instance Binary TH.FamFlavour
+instance Binary TH.FunDep
+instance Binary TH.AnnTarget
+instance Binary TH.RuleBndr
+instance Binary TH.Phases
+instance Binary TH.RuleMatch
+instance Binary TH.Inline
+instance Binary TH.Pragma
+instance Binary TH.Safety
+instance Binary TH.Callconv
+instance Binary TH.Foreign
+instance Binary TH.Strict
+instance Binary TH.FixityDirection
+instance Binary TH.OccName
+instance Binary TH.Con
+instance Binary TH.AnnLookup
+instance Binary TH.ModuleInfo
+instance Binary TH.Clause
+instance Binary TH.InjectivityAnn
+instance Binary TH.FamilyResultSig
+instance Binary TH.TypeFamilyHead
+
+-- We need Binary TypeRep for serializing annotations
+
+instance Binary TyCon where
+ put tc = put (tyConPackage tc) >> put (tyConModule tc) >> put (tyConName tc)
+ get = mkTyCon3 <$> get <*> get <*> get
+
+instance Binary TypeRep where
+ put type_rep = put (splitTyConApp type_rep)
+ get = do
+ (ty_con, child_type_reps) <- get
+ return (mkTyConApp ty_con child_type_reps)
+
+instance Binary Serialized where
+ put (Serialized tyrep wds) = put tyrep >> put (B.pack wds)
+ get = Serialized <$> get <*> (B.unpack <$> get)
diff --git a/libraries/ghci/GNUmakefile b/libraries/ghci/GNUmakefile
new file mode 100644
index 0000000000..ce6a24f19b
--- /dev/null
+++ b/libraries/ghci/GNUmakefile
@@ -0,0 +1,4 @@
+dir = libraries/ghci
+TOP = ../..
+include $(TOP)/mk/sub-makefile.mk
+FAST_MAKE_OPTS += stage=0
diff --git a/libraries/ghci/LICENSE b/libraries/ghci/LICENSE
new file mode 100644
index 0000000000..99fa52679d
--- /dev/null
+++ b/libraries/ghci/LICENSE
@@ -0,0 +1,31 @@
+The Glasgow Haskell Compiler License
+
+Copyright 2002, The University Court of the University of Glasgow.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
diff --git a/libraries/ghci/SizedSeq.hs b/libraries/ghci/SizedSeq.hs
new file mode 100644
index 0000000000..1c23fff2b7
--- /dev/null
+++ b/libraries/ghci/SizedSeq.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
+module SizedSeq
+ ( SizedSeq(..)
+ , emptySS
+ , addToSS
+ , addListToSS
+ , ssElts
+ , sizeSS
+ ) where
+
+import Data.Binary
+import Data.List
+import GHC.Generics
+
+data SizedSeq a = SizedSeq !Word [a]
+ deriving (Generic, Show)
+
+instance Functor SizedSeq where
+ fmap f (SizedSeq sz l) = SizedSeq sz (fmap f l)
+
+instance Binary a => Binary (SizedSeq 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
diff --git a/libraries/ghci/ghc.mk b/libraries/ghci/ghc.mk
new file mode 100644
index 0000000000..dc6a891bf3
--- /dev/null
+++ b/libraries/ghci/ghc.mk
@@ -0,0 +1,5 @@
+libraries/ghci_PACKAGE = ghci
+libraries/ghci_dist-install_GROUP = libraries
+$(if $(filter ghci,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/ghci,dist-boot,0)))
+$(if $(filter ghci,$(PACKAGES_STAGE1)),$(eval $(call build-package,libraries/ghci,dist-install,1)))
+$(if $(filter ghci,$(PACKAGES_STAGE2)),$(eval $(call build-package,libraries/ghci,dist-install,2)))
diff --git a/libraries/ghci/ghci.cabal b/libraries/ghci/ghci.cabal
new file mode 100644
index 0000000000..9e2f04599c
--- /dev/null
+++ b/libraries/ghci/ghci.cabal
@@ -0,0 +1,41 @@
+Name: ghci
+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
+
+Library
+ Default-Language: Haskell2010
+ Exposed-Modules: GHCi.Message,
+ GHCi.ResolvedBCO,
+ GHCi.RemoteTypes,
+ GHCi.ObjLink,
+ GHCi.CreateBCO,
+ GHCi.FFI,
+ GHCi.InfoTable,
+ GHCi.Run,
+ GHCi.Signals,
+ GHCi.TH,
+ GHCi.TH.Binary,
+ SizedSeq
+ Build-Depends: base >= 4 && < 5,
+ binary >= 0.7 && < 0.9,
+ bytestring >= 0.10 && < 0.11,
+ containers >= 0.5 && < 0.6,
+ deepseq >= 1.4 && < 1.5,
+ filepath >= 1.4 && < 1.5,
+ ghc-boot,
+ array >= 0.5 && < 0.6,
+ template-haskell >= 2.11 && < 2.12,
+ transformers >= 0.4 && < 0.6
+
+ if !os(windows)
+ Build-Depends: unix >= 2.7 && < 2.8
diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 3ad3bc6d5b..e1510db97f 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -1161,7 +1161,12 @@ run_BCO:
pap->fun = (StgClosure*)Sp[0];
// The function should be a BCO
- ASSERT(get_itbl(pap->fun)->type == BCO);
+ if (get_itbl(pap->fun)->type != BCO) {
+#ifdef DEBUG
+ printClosure(pap->fun);
+#endif
+ barf("bci_MKPAP");
+ }
for (i = 0; i < n_payload; i++)
pap->payload[i] = (StgClosure*)Sp[i+1];
diff --git a/rules/build-prog.mk b/rules/build-prog.mk
index 1a497078c5..8352d88412 100644
--- a/rules/build-prog.mk
+++ b/rules/build-prog.mk
@@ -48,7 +48,6 @@ endef
-
define build-prog-vars
# $1 = dir
# $2 = distdir
@@ -92,18 +91,27 @@ else
ifneq "$$($$($1_$2_PROGNAME)_INPLACE)" ""
$$(error $$($1_$2_PROGNAME)_INPLACE defined twice)
endif
+#
+# Where do we install the wrapper and the binary?
+# $$($1_$2_PROGNAME)_INPLACE The thing we run (script or binary)
+# $1_$2_INPLACE The binary
+#
ifeq "$$($1_$2_TOPDIR)" "YES"
-$$($1_$2_PROGNAME)_INPLACE = $$(INPLACE_TOPDIR)/$$($1_$2_PROG)
+$$($1_$2_PROGNAME)_INPLACE = $$(INPLACE_LIB)/bin/$$($1_$2_PROG)
+ifeq "$$($1_$2_WANT_INPLACE_WRAPPER)" "YES"
+$1_$2_INPLACE = $$(INPLACE_LIB)/bin/$$($1_$2_PROG).bin
else
-$$($1_$2_PROGNAME)_INPLACE = $$(INPLACE_BIN)/$$($1_$2_PROG)
+$1_$2_INPLACE = $$(INPLACE_LIB)/bin/$$($1_$2_PROG)
endif
-# Where do we install the inplace version?
+else
+$$($1_$2_PROGNAME)_INPLACE = $$(INPLACE_BIN)/$$($1_$2_PROG)
ifeq "$$($1_$2_WANT_INPLACE_WRAPPER)" "YES"
$1_$2_INPLACE = $$(INPLACE_LIB)/bin/$$($1_$2_PROG)
else
$1_$2_INPLACE = $$($$($1_$2_PROGNAME)_INPLACE)
endif
endif
+endif
endef
@@ -297,7 +305,7 @@ endif
ifeq "$$($1_$2_WANT_INSTALLED_WRAPPER)" "YES"
INSTALL_LIBEXECS += $1/$2/build/tmp/$$($1_$2_PROG)
else ifeq "$$($1_$2_TOPDIR)" "YES"
-INSTALL_TOPDIR_BINS += $1/$2/build/tmp/$$($1_$2_PROG)
+INSTALL_LIBEXECS += $1/$2/build/tmp/$$($1_$2_PROG)
else
INSTALL_BINS += $1/$2/build/tmp/$$($1_$2_PROG)
endif
diff --git a/rules/shell-wrapper.mk b/rules/shell-wrapper.mk
index 11eef67a83..f674c0dfc2 100644
--- a/rules/shell-wrapper.mk
+++ b/rules/shell-wrapper.mk
@@ -26,7 +26,7 @@ ifeq "$$($1_$2_WANT_INPLACE_WRAPPER)" "YES"
$1_$2_INPLACE_SHELL_WRAPPER_NAME = $$($1_$2_PROG)
ifeq "$$($1_$2_TOPDIR)" "YES"
-$1_$2_INPLACE_WRAPPER = $$(INPLACE_LIB)/$$($1_$2_INPLACE_SHELL_WRAPPER_NAME)
+$1_$2_INPLACE_WRAPPER = $$(INPLACE_LIB)/bin/$$($1_$2_INPLACE_SHELL_WRAPPER_NAME)
else
$1_$2_INPLACE_WRAPPER = $$(INPLACE_BIN)/$$($1_$2_INPLACE_SHELL_WRAPPER_NAME)
endif
diff --git a/testsuite/config/ghc b/testsuite/config/ghc
index fdb7250c10..dc00adbe79 100644
--- a/testsuite/config/ghc
+++ b/testsuite/config/ghc
@@ -29,7 +29,8 @@ config.other_ways = ['prof',
'threaded1_ls', 'threaded2_hT',
'llvm', 'debugllvm',
'profllvm', 'profoptllvm', 'profthreadedllvm',
- 'debug']
+ 'debug',
+ 'ghci-ext']
if (ghc_with_native_codegen == 1):
config.compile_ways.append('optasm')
@@ -110,6 +111,7 @@ config.way_flags = lambda name : {
'profllvm' : ['-prof', '-static', '-auto-all', '-fllvm'],
'profoptllvm' : ['-O', '-prof', '-static', '-auto-all', '-fllvm'],
'profthreadedllvm' : ['-O', '-prof', '-static', '-auto-all', '-threaded', '-fllvm'],
+ 'ghci-ext' : ['--interactive', '-v0', '-ignore-dot-ghci', '-fexternal-interpreter', '+RTS', '-I0.1', '-RTS'],
}
config.way_rts_flags = {
@@ -140,6 +142,7 @@ config.way_rts_flags = {
'profllvm' : ['-p'],
'profoptllvm' : ['-hc', '-p'],
'profthreadedllvm' : ['-p'],
+ 'ghci-ext' : [],
}
# Useful classes of ways that can be used with only_ways() and
diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py
index 60e5d465ac..c41bb8cb65 100644
--- a/testsuite/driver/testlib.py
+++ b/testsuite/driver/testlib.py
@@ -207,7 +207,7 @@ def _extra_ways( name, opts, ways ):
def only_compiler_types( _compiler_types ):
# Don't delete yet. The libraries unix, stm and hpc still call this function.
- return lambda _name, _opts: None
+ return lambda _name, _opts: None
# -----
@@ -949,25 +949,12 @@ def run_command( name, way, cmd ):
# -----------------------------------------------------------------------------
# GHCi tests
-def ghci_script_without_flag(flag):
- def apply(name, way, script):
- overrides = [f for f in getTestOpts().compiler_always_flags if f != flag]
- return ghci_script_override_default_flags(overrides)(name, way, script)
-
- return apply
-
-def ghci_script_override_default_flags(overrides):
- def apply(name, way, script):
- return ghci_script(name, way, script, overrides)
-
- return apply
-
def ghci_script( name, way, script, override_flags = None ):
# filter out -fforce-recomp from compiler_always_flags, because we're
# actually testing the recompilation behaviour in the GHCi tests.
flags = ' '.join(get_compiler_flags(override_flags, noforce=True))
- way_flags = ' '.join(config.way_flags(name)['ghci'])
+ way_flags = ' '.join(config.way_flags(name)[way])
# We pass HC and HC_OPTS as environment variables, so that the
# script can invoke the correct compiler by using ':! $HC $HC_OPTS'
@@ -1093,7 +1080,7 @@ def compile_and_run__( name, way, top_mod, extra_mods, extra_hc_opts ):
return result
extra_hc_opts = result['hc_opts']
- if way == 'ghci': # interpreted...
+ if way.startswith('ghci'): # interpreted...
return interpreter_run( name, way, extra_hc_opts, 0, top_mod )
else: # compiled...
force = 0
@@ -1174,7 +1161,7 @@ def checkStats(name, way, stats_file, range_fields):
display(' Actual ' + full_name + ' ' + field + ':', val, '')
if val != expected:
display(' Deviation ' + full_name + ' ' + field + ':', deviation, '%')
-
+
return result
# -----------------------------------------------------------------------------
@@ -2031,7 +2018,7 @@ def addTestFilesWrittenHelper(name, fn):
pass
else:
framework_fail(name, 'strace', "Can't understand strace line: " + line)
-
+
def checkForFilesWrittenProblems(file):
foundProblem = False
diff --git a/testsuite/tests/annotations/should_run/annrun01.hs b/testsuite/tests/annotations/should_run/annrun01.hs
index 6fd07252cc..0dbd44dd92 100644
--- a/testsuite/tests/annotations/should_run/annrun01.hs
+++ b/testsuite/tests/annotations/should_run/annrun01.hs
@@ -6,7 +6,7 @@ import GHC
import MonadUtils ( liftIO )
import DynFlags ( defaultFatalMessager, defaultFlushOut )
import Annotations ( AnnTarget(..), CoreAnnTarget )
-import Serialized ( deserializeWithData )
+import GHC.Serialized ( deserializeWithData )
import Panic
import Config
diff --git a/testsuite/tests/cabal/cabal04/Makefile b/testsuite/tests/cabal/cabal04/Makefile
index 9aaa25f404..6c43dde45d 100644
--- a/testsuite/tests/cabal/cabal04/Makefile
+++ b/testsuite/tests/cabal/cabal04/Makefile
@@ -14,7 +14,7 @@ cabal04:
$(MAKE) clean
'$(TEST_HC)' -v0 --make Setup
$(SETUP) clean
- $(SETUP) configure --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS))' $(VANILLA) $(PROF) $(DYN) --ghc-options='$(ghcThWayFlags)'
+ $(SETUP) configure --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS))' $(VANILLA) $(PROF) $(DYN)
$(SETUP) build 2> err
! grep -v "Creating library file" err
ifneq "$(CLEANUP)" ""
@@ -23,4 +23,3 @@ endif
clean :
$(RM) -r *.o *.hi dist Setup$(exeext) err
-
diff --git a/testsuite/tests/cabal/cabal04/all.T b/testsuite/tests/cabal/cabal04/all.T
index 53d90145ce..b2794a5e10 100644
--- a/testsuite/tests/cabal/cabal04/all.T
+++ b/testsuite/tests/cabal/cabal04/all.T
@@ -20,5 +20,5 @@ else:
test('cabal04',
normal,
- run_command,
+ run_command,
['$MAKE -s --no-print-directory cabal04 VANILLA=' + vanilla + ' PROF=' + prof + ' DYN=' + dyn + ' ' + cleanup])
diff --git a/testsuite/tests/ghc-api/T4891/T4891.hs b/testsuite/tests/ghc-api/T4891/T4891.hs
index 854bf62998..b2f8cc464d 100644
--- a/testsuite/tests/ghc-api/T4891/T4891.hs
+++ b/testsuite/tests/ghc-api/T4891/T4891.hs
@@ -35,17 +35,16 @@ doit = do
dflags' <- getSessionDynFlags
primPackages <- setSessionDynFlags dflags'
dflags <- getSessionDynFlags
- defaultCleanupHandler dflags $ do
- target <- guessTarget "X.hs" Nothing
- setTargets [target]
- load LoadAllTargets
+ target <- guessTarget "X.hs" Nothing
+ setTargets [target]
+ load LoadAllTargets
- () <- chaseConstructor (unsafeCoerce False)
- () <- chaseConstructor (unsafeCoerce [1,2,3])
- () <- chaseConstructor (unsafeCoerce (3 :-> 2))
- () <- chaseConstructor (unsafeCoerce (4 :->. 4))
- () <- chaseConstructor (unsafeCoerce (4 :->.+ 4))
- return ()
+ () <- chaseConstructor (unsafeCoerce False)
+ () <- chaseConstructor (unsafeCoerce [1,2,3])
+ () <- chaseConstructor (unsafeCoerce (3 :-> 2))
+ () <- chaseConstructor (unsafeCoerce (4 :->. 4))
+ () <- chaseConstructor (unsafeCoerce (4 :->.+ 4))
+ return ()
chaseConstructor :: (GhcMonad m) => HValue -> m ()
chaseConstructor !hv = do
diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr
index 16ba5ec004..58faa697c5 100644
--- a/testsuite/tests/ghci.debugger/scripts/break006.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr
@@ -10,7 +10,7 @@
instance Show Ordering -- Defined in ‘GHC.Show’
instance Show Integer -- Defined in ‘GHC.Show’
...plus 23 others
- ...plus 13 instance involving out-of-scope typess
+ ...plus 19 instance involving out-of-scope typess
(use -fprint-potential-instances to see them all)
• In a stmt of an interactive GHCi command: print it
@@ -25,6 +25,6 @@
instance Show Ordering -- Defined in ‘GHC.Show’
instance Show Integer -- Defined in ‘GHC.Show’
...plus 23 others
- ...plus 13 instance involving out-of-scope typess
+ ...plus 19 instance involving out-of-scope typess
(use -fprint-potential-instances to see them all)
• In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci.debugger/scripts/break011.script b/testsuite/tests/ghci.debugger/scripts/break011.script
index f9ca3fe393..e913a2f240 100644
--- a/testsuite/tests/ghci.debugger/scripts/break011.script
+++ b/testsuite/tests/ghci.debugger/scripts/break011.script
@@ -15,4 +15,7 @@ error "foo"
:force _exception
:show bindings
:force _result
+-- the exception is caught by the withProg/withArgs wrappers, hence 3 :continues
+:continue
+:continue
:continue
diff --git a/testsuite/tests/ghci.debugger/scripts/break011.stdout b/testsuite/tests/ghci.debugger/scripts/break011.stdout
index dee4d94360..ec0b3e9609 100644
--- a/testsuite/tests/ghci.debugger/scripts/break011.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break011.stdout
@@ -32,6 +32,18 @@ _exception :: SomeException = SomeException
*** Exception: foo
CallStack (from ImplicitParams):
error, called at ../Test7.hs:2:18 in main:Main
+Stopped at <exception thrown>
+_exception :: e = SomeException
+ (ErrorCallWithLocation
+ "foo"
+ "CallStack (from ImplicitParams):
+ error, called at ../Test7.hs:2:18 in main:Main")
+Stopped at <exception thrown>
+_exception :: e = SomeException
+ (ErrorCallWithLocation
+ "foo"
+ "CallStack (from ImplicitParams):
+ error, called at ../Test7.hs:2:18 in main:Main")
*** Exception: foo
CallStack (from ImplicitParams):
error, called at ../Test7.hs:2:18 in main:Main
diff --git a/testsuite/tests/ghci.debugger/scripts/break013.stdout b/testsuite/tests/ghci.debugger/scripts/break013.stdout
index 4c3d5f3d76..13d203f0b3 100644
--- a/testsuite/tests/ghci.debugger/scripts/break013.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break013.stdout
@@ -5,7 +5,7 @@ _result :: (Bool, Bool, ()) = _
a :: Bool = _
b :: Bool = _
c :: () = _
-c :: () = _
b :: Bool = _
+c :: () = _
a :: Bool = _
_result :: (Bool, Bool, ()) = _
diff --git a/testsuite/tests/ghci.debugger/scripts/break024.stdout b/testsuite/tests/ghci.debugger/scripts/break024.stdout
index dc3bd73425..548e7a4470 100644
--- a/testsuite/tests/ghci.debugger/scripts/break024.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/break024.stdout
@@ -10,7 +10,9 @@ _exception :: e = _
_exception = SomeException
(GHC.IO.Exception.IOError
Nothing GHC.IO.Exception.UserError [] "error" Nothing Nothing)
-*** Exception: user error (error)
+Stopped at <exception thrown>
+_exception :: e = SomeException
+ (GHC.IO.Exception.IOError Nothing GHC.IO.Exception.UserError ....)
Stopped at <exception thrown>
_exception :: e = _
_exception = SomeException
diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr
index fa53d94701..c1dc48bf21 100644
--- a/testsuite/tests/ghci.debugger/scripts/print019.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr
@@ -9,6 +9,6 @@
instance Show Ordering -- Defined in ‘GHC.Show’
instance Show TyCon -- Defined in ‘GHC.Show’
...plus 30 others
- ...plus two instance involving out-of-scope typess
+ ...plus 8 instance involving out-of-scope typess
(use -fprint-potential-instances to see them all)
• In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/ghci/prog001/prog001-ext.stdout b/testsuite/tests/ghci/prog001/prog001-ext.stdout
new file mode 100644
index 0000000000..eef24c2153
--- /dev/null
+++ b/testsuite/tests/ghci/prog001/prog001-ext.stdout
@@ -0,0 +1,4 @@
+"hello world84"
+"hello world84"
+"hello world84"
+44
diff --git a/testsuite/tests/ghci/prog001/prog001.T b/testsuite/tests/ghci/prog001/prog001.T
index 1ef3c0430c..af221e6fd9 100644
--- a/testsuite/tests/ghci/prog001/prog001.T
+++ b/testsuite/tests/ghci/prog001/prog001.T
@@ -1,5 +1,5 @@
test('prog001',
[extra_clean(['C.hs', 'D.hs', 'D.hi', 'D.o']),
- cmd_prefix('ghciWayFlags=' + config.ghci_way_flags)],
+ cmd_prefix('ghciWayFlags=' + config.ghci_way_flags),
+ unless(opsys('mingw32'),extra_ways(['ghci-ext']))],
ghci_script, ['prog001.script'])
-
diff --git a/testsuite/tests/ghci/scripts/T10110A.hs b/testsuite/tests/ghci/scripts/T10110A.hs
index 8482e7f673..ab64cfd016 100644
--- a/testsuite/tests/ghci/scripts/T10110A.hs
+++ b/testsuite/tests/ghci/scripts/T10110A.hs
@@ -1,4 +1,5 @@
module T10110A (a) where
+import Debug.Trace
{-# NOINLINE a #-}
a :: Int
a = 3
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 1a664d128d..5c25cf8bb0 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -3,9 +3,13 @@
test('ghci001', combined_output, ghci_script, ['ghci001.script'])
test('ghci002', combined_output, ghci_script, ['ghci002.script'])
test('ghci003', combined_output, ghci_script, ['ghci003.script'])
-test('ghci004', combined_output, ghci_script, ['ghci004.script'])
+test('ghci004', [ combined_output,
+ unless(opsys('mingw32'),extra_ways(['ghci-ext'])) ],
+ ghci_script, ['ghci004.script'])
test('ghci005', combined_output, ghci_script, ['ghci005.script'])
-test('ghci006', combined_output, ghci_script, ['ghci006.script'])
+test('ghci006', [ combined_output,
+ unless(opsys('mingw32'),extra_ways(['ghci-ext'])) ],
+ ghci_script, ['ghci006.script'])
test('ghci007', combined_output, ghci_script, ['ghci007.script'])
test('ghci008', combined_output, ghci_script, ['ghci008.script'])
test('ghci009', combined_output, ghci_script, ['ghci009.script'])
@@ -84,7 +88,7 @@ test('ghci056',
],
ghci_script, ['ghci056.script'])
-test('ghci057', normal, ghci_script_without_flag('-fno-warn-tabs'), ['ghci057.script'])
+test('ghci057', extra_hc_opts('-fwarn-tabs'), ghci_script, ['ghci057.script'])
test('T2452', normal, ghci_script, ['T2452.script'])
test('T2766', normal, ghci_script, ['T2766.script'])
@@ -192,7 +196,7 @@ test('T9181', normal, ghci_script, ['T9181.script'])
test('T9086b', normal, ghci_script, ['T9086b.script'])
test('T9140', combined_output, ghci_script, ['T9140.script'])
test('T9658', normal, ghci_script, ['T9658.script'])
-test('T9293', normal, ghci_script_without_flag('-fno-warn-tabs'), ['T9293.script'])
+test('T9293', extra_hc_opts('-fwarn-tabs'), ghci_script, ['T9293.script'])
test('T9762',
[ unless(have_dynamic(),skip)
, pre_cmd('$MAKE -s --no-print-directory T9762_prep')
diff --git a/testsuite/tests/profiling/should_run/scc003.prof.sample b/testsuite/tests/profiling/should_run/scc003.prof.sample
index e1d0b64464..69633d4c91 100644
--- a/testsuite/tests/profiling/should_run/scc003.prof.sample
+++ b/testsuite/tests/profiling/should_run/scc003.prof.sample
@@ -1,27 +1,35 @@
- Thu Apr 2 19:44 2015 Time and Allocation Profiling Report (Final)
+ Tue Dec 8 08:29 2015 Time and Allocation Profiling Report (Final)
- scc003 +RTS -p -RTS
+ scc003 +RTS -hc -p -RTS
- total time = 0.13 secs (132 ticks @ 1000 us, 1 processor)
- total alloc = 195,487,784 bytes (excludes profiling overheads)
+ total time = 0.04 secs (40 ticks @ 1000 us, 1 processor)
+ total alloc = 48,912 bytes (excludes profiling overheads)
-COST CENTRE MODULE %time %alloc
+COST CENTRE MODULE %time %alloc
-fib Main 100.0 100.0
+fib Main 100.0 0.0
+MAIN MAIN 0.0 1.8
+main Main 0.0 19.6
+CAF GHC.Conc.Signal 0.0 1.3
+CAF GHC.IO.Encoding 0.0 5.9
+CAF GHC.IO.Handle.FD 0.0 70.6
- individual inherited
-COST CENTRE MODULE no. entries %time %alloc %time %alloc
+ individual inherited
+COST CENTRE MODULE no. entries %time %alloc %time %alloc
-MAIN MAIN 99 0 0.0 0.0 100.0 100.0
- CAF Main 197 0 0.0 0.0 100.0 100.0
- main Main 198 1 0.0 0.0 100.0 100.0
- f Main 199 1 0.0 0.0 100.0 100.0
- f.\ Main 201 1 0.0 0.0 99.2 99.2
- fib Main 202 2692537 99.2 99.2 99.2 99.2
- fib Main 200 21891 0.8 0.8 0.8 0.8
- CAF GHC.Conc.Signal 179 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Encoding 163 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Encoding.Iconv 161 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Handle.FD 152 0 0.0 0.0 0.0 0.0
- CAF GHC.IO.Handle.Text 150 0 0.0 0.0 0.0 0.0
+MAIN MAIN 105 0 0.0 1.8 100.0 100.0
+ main Main 211 0 0.0 18.9 0.0 18.9
+ CAF GHC.IO.Handle.Text 140 0 0.0 0.2 0.0 0.2
+ CAF GHC.IO.Handle.FD 138 0 0.0 70.6 0.0 70.6
+ CAF GHC.IO.Encoding.Iconv 130 0 0.0 0.5 0.0 0.5
+ CAF GHC.IO.Encoding 128 0 0.0 5.9 0.0 5.9
+ CAF GHC.Conc.Signal 118 0 0.0 1.3 0.0 1.3
+ CAF Main 112 0 0.0 0.0 100.0 0.8
+ main Main 210 1 0.0 0.7 100.0 0.8
+ f Main 212 1 0.0 0.0 100.0 0.1
+ f.\ Main 216 1 0.0 0.0 100.0 0.0
+ fib Main 217 2692537 100.0 0.0 100.0 0.0
+ f.x' Main 213 1 0.0 0.0 0.0 0.0
+ f.(...) Main 214 1 0.0 0.0 0.0 0.0
+ fib Main 215 21891 0.0 0.0 0.0 0.0
diff --git a/testsuite/tests/rts/LinkerUnload.hs b/testsuite/tests/rts/LinkerUnload.hs
index 7e9d1dd38a..9d6b243256 100644
--- a/testsuite/tests/rts/LinkerUnload.hs
+++ b/testsuite/tests/rts/LinkerUnload.hs
@@ -16,5 +16,5 @@ loadPackages = do
let dflags' = dflags { hscTarget = HscNothing
, ghcLink = LinkInMemory }
pkgs <- setSessionDynFlags dflags'
- dflags <- getSessionDynFlags
- liftIO $ Linker.linkPackages dflags pkgs
+ hsc_env <- getSession
+ liftIO $ Linker.linkPackages hsc_env pkgs
diff --git a/testsuite/tests/rts/T2615.hs b/testsuite/tests/rts/T2615.hs
index 53c2d13ceb..6a81185e9e 100644
--- a/testsuite/tests/rts/T2615.hs
+++ b/testsuite/tests/rts/T2615.hs
@@ -1,4 +1,4 @@
-import ObjLink
+import GHCi.ObjLink
library_name = "libfoo_script_T2615.so" -- this is really a linker script
diff --git a/testsuite/tests/th/Makefile b/testsuite/tests/th/Makefile
index 5d2be1eb34..b759a81b67 100644
--- a/testsuite/tests/th/Makefile
+++ b/testsuite/tests/th/Makefile
@@ -20,6 +20,13 @@ TH_spliceE5_prof::
'$(TEST_HC)' $(TEST_HC_OPTS) $(HC_OPTS) --make -v0 TH_spliceE5_prof.hs -prof -auto-all -osuf p.o -o $@
./$@
+# With -fexternal-interpreter, we don't have to build the non-profiled
+# objects first.
+TH_spliceE5_prof_ext::
+ $(RM) TH_spliceE5_prof_ext*.o TH_spliceE5_prof_ext*.hi TH_spliceE5_prof_ext*.p.o
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(HC_OPTS) --make -v0 TH_spliceE5_prof_ext.hs -prof -auto-all -fexternal-interpreter -o $@
+ ./$@
+
.PHONY: TH_Depends
TH_Depends:
$(RM) TH_Depends_external.txt
diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr
index e4a9a47858..c44e5b9d9d 100644
--- a/testsuite/tests/th/TH_Roles2.stderr
+++ b/testsuite/tests/th/TH_Roles2.stderr
@@ -5,9 +5,10 @@ TYPE CONSTRUCTORS
Kind: forall k1. k1 -> *
COERCION AXIOMS
Dependent modules: []
-Dependent packages: [array-0.5.1.0, base-4.9.0.0, deepseq-1.4.2.0,
+Dependent packages: [array-0.5.1.0, base-4.9.0.0, binary-0.7.5.0,
+ bytestring-0.10.7.0, containers-0.5.6.3, deepseq-1.4.2.0,
ghc-boot-0.0.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0,
- pretty-1.1.2.0, template-haskell-2.11.0.0]
+ pretty-1.1.3.2, template-haskell-2.11.0.0]
==================== Typechecker ====================
TH_Roles2.$tcT
diff --git a/testsuite/tests/th/TH_finalizer.hs b/testsuite/tests/th/TH_finalizer.hs
new file mode 100644
index 0000000000..f59364edaf
--- /dev/null
+++ b/testsuite/tests/th/TH_finalizer.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module ShouldCompile where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+$( do
+ addModFinalizer (do b <- getQ; reportWarning (show (b::Maybe Bool)))
+ return [] )
+$( putQ True >> return [] )
diff --git a/testsuite/tests/th/TH_finalizer.stderr b/testsuite/tests/th/TH_finalizer.stderr
new file mode 100644
index 0000000000..e89d434adb
--- /dev/null
+++ b/testsuite/tests/th/TH_finalizer.stderr
@@ -0,0 +1,2 @@
+
+TH_finalizer.hs:1:1: warning: Just True
diff --git a/testsuite/tests/th/TH_spliceE5_prof_ext.hs b/testsuite/tests/th/TH_spliceE5_prof_ext.hs
new file mode 100644
index 0000000000..255b1c5b8d
--- /dev/null
+++ b/testsuite/tests/th/TH_spliceE5_prof_ext.hs
@@ -0,0 +1,14 @@
+module Main where
+
+import TH_spliceE5_prof_ext_Lib
+
+v1 = "foo"
+
+main = putStrLn $(expandVars ["v1","v2"])
+-- The splice expands to refer to both v1 and v2,
+-- and the test checks that we don't dependency-analyse
+-- the program so that one or the other isn't in scope
+-- to the type checker
+
+
+v2 = "bar"
diff --git a/testsuite/tests/th/TH_spliceE5_prof_ext.stdout b/testsuite/tests/th/TH_spliceE5_prof_ext.stdout
new file mode 100644
index 0000000000..323fae03f4
--- /dev/null
+++ b/testsuite/tests/th/TH_spliceE5_prof_ext.stdout
@@ -0,0 +1 @@
+foobar
diff --git a/testsuite/tests/th/TH_spliceE5_prof_ext_Lib.hs b/testsuite/tests/th/TH_spliceE5_prof_ext_Lib.hs
new file mode 100644
index 0000000000..eb598c03d7
--- /dev/null
+++ b/testsuite/tests/th/TH_spliceE5_prof_ext_Lib.hs
@@ -0,0 +1,8 @@
+module TH_spliceE5_prof_ext_Lib where
+
+import Language.Haskell.TH
+
+expandVars :: [String] -> Q Exp
+expandVars s = [| concat $(return (ListE (map f s))) |]
+ where
+ f x = VarE (mkName x)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index af8531c8b1..45ee2df13b 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -51,6 +51,14 @@ test('TH_spliceE5_prof',
run_command,
['$MAKE -s --no-print-directory TH_spliceE5_prof'])
+test('TH_spliceE5_prof_ext',
+ [req_profiling,
+ omit_ways(['ghci']),
+ extra_clean(['TH_spliceE5_prof_ext_Lib.hi',
+ 'TH_spliceE5_prof_ext_Lib.o'])],
+ run_command,
+ ['$MAKE -s --no-print-directory TH_spliceE5_prof_ext'])
+
test('TH_spliceD1',
extra_clean(['TH_spliceD1_Lib.hi', 'TH_spliceD1_Lib.o']),
multimod_compile_fail,
@@ -370,3 +378,5 @@ test('T10819',
multimod_compile,
['T10819.hs', '-v0 ' + config.ghc_th_way_flags])
test('T10820', normal, compile_and_run, ['-v0'])
+
+test('TH_finalizer', normal, compile, ['-v0'])
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index 7bbec3065d..551c68b838 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -38,7 +38,7 @@ import qualified Data.Map as M
--import UniqFM
--import Debug.Trace
--- search for definitions of things
+-- search for definitions of things
-- we do this by parsing the source and grabbing top-level definitions
-- We generate both CTAGS and ETAGS format tags files
@@ -118,10 +118,8 @@ main = do
_ <- setSessionDynFlags dflags2
--liftIO $ print (length pkgs)
- GHC.defaultCleanupHandler dflags2 $ do
-
- targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
- mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
+ targetsAtOneGo hsfiles (ctags_hdl,etags_hdl)
+ mapM_ (mapM (liftIO . hClose)) [ctags_hdl, etags_hdl]
----------------------------------------------
---------- ARGUMENT PROCESSING --------------