diff options
| author | Simon Marlow <marlowsd@gmail.com> | 2015-11-18 16:42:24 +0000 |
|---|---|---|
| committer | Simon Marlow <marlowsd@gmail.com> | 2015-12-17 09:39:52 +0000 |
| commit | 4905b83a2d448c65ccced385343d4e8124548a3b (patch) | |
| tree | 070cf9e48f6fce668cd01d888b8da8b3772d1f53 | |
| parent | 7221ad70daa363d77f60d96c3f6e1baa1d9bec81 (diff) | |
| download | haskell-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
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 @@ -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 -------------- |