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

Remote GHCi, -fexternal-interpreter

Summary:
(Apologies for the size of this patch, I couldn't make a smaller one
that was validate-clean and also made sense independently)

(Some of this code is derived from GHCJS.)

This commit adds support for running interpreted code (for GHCi and
TemplateHaskell) in a separate process.  The functionality is
experimental, so for now it is off by default and enabled by the flag
-fexternal-interpreter.

Reaosns we want this:

* compiling Template Haskell code with -prof does not require
  building the code without -prof first

* when GHC itself is profiled, it can interpret unprofiled code, and
  the same applies to dynamic linking.  We would no longer need to
  force -dynamic-too with TemplateHaskell, and we can load ordinary
  objects into a dynamically-linked GHCi (and vice versa).

* An unprofiled GHCi can load and run profiled code, which means it
  can use the stack-trace functionality provided by profiling without
  taking the performance hit on the compiler that profiling would
  entail.

Amongst other things; see
https://ghc.haskell.org/trac/ghc/wiki/RemoteGHCi for more details.

Notes on the implementation are in Note [Remote GHCi] in the new
module compiler/ghci/GHCi.hs.  It probably needs more documenting,
feel free to suggest things I could elaborate on.

Things that are not currently implemented for -fexternal-interpreter:

* The GHCi debugger
* :set prog, :set args in GHCi
* `recover` in Template Haskell
* Redirecting stdin/stdout for the external process

These are all doable, I just wanted to get to a working validate-clean
patch first.

I also haven't done any benchmarking yet.  I expect there to be slight hit
to link times for byte code and some penalty due to having to
serialize/deserialize TH syntax, but I don't expect it to be a serious
problem.  There's also lots of low-hanging fruit in the byte code
generator/linker that we could exploit to speed things up.

Test Plan:
* validate
* I've run parts of the test suite with
EXTRA_HC_OPTS=-fexternal-interpreter, notably tests/ghci and tests/th.
There are a few failures due to the things not currently implemented
(see above).

Reviewers: simonpj, goldfire, ezyang, austin, alanz, hvr, niteria, bgamari, gibiansky, luite

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1562
parent 7221ad70
......@@ -72,6 +72,7 @@ _darcs/
/ghc/stage1/
/ghc/stage2/
/ghc/stage3/
/iserv/stage2*/
# -----------------------------------------------------------------------------
# specific generated files
......
......@@ -467,7 +467,7 @@ AC_DEFUN([FP_SETTINGS],
SettingsPerlCommand='$topdir/../perl/perl.exe'
SettingsDllWrapCommand="\$topdir/../${mingw_bin_prefix}dllwrap.exe"
SettingsWindresCommand="\$topdir/../${mingw_bin_prefix}windres.exe"
SettingsTouchCommand='$topdir/touchy.exe'
SettingsTouchCommand='$topdir/bin/touchy.exe'
else
SettingsCCompilerCommand="$WhatGccIsCalled"
SettingsHaskellCPPCommand="$HaskellCPPCmd"
......
......@@ -86,8 +86,6 @@ module BasicTypes(
FractionalLit(..), negateFractionalLit, integralFractionalLit,
HValue(..),
SourceText,
IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit
......@@ -99,7 +97,6 @@ import SrcLoc ( Located,unLoc )
import StaticFlags( opt_PprStyle_Debug )
import Data.Data hiding (Fixity)
import Data.Function (on)
import GHC.Exts (Any)
{-
************************************************************************
......@@ -1165,8 +1162,6 @@ instance Ord FractionalLit where
instance Outputable FractionalLit where
ppr = text . fl_text
newtype HValue = HValue Any
{-
************************************************************************
* *
......
......@@ -106,13 +106,13 @@ data Literal
(Maybe Int)
FunctionOrData
-- ^ A label literal. Parameters:
--
-- 1) The name of the symbol mentioned in the declaration
--
-- 2) The size (in bytes) of the arguments
-- the label expects. Only applicable with
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
--
-- 1) The name of the symbol mentioned in the declaration
--
-- 2) The size (in bytes) of the arguments
-- the label expects. Only applicable with
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
| LitInteger Integer Type -- ^ Integer literals
-- See Note [Integer literals]
......
......@@ -278,15 +278,16 @@ mkStringExprFS str
| all safeChar chars
= do unpack_id <- lookupId unpackCStringName
return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str))))
return (App (Var unpack_id) lit)
| otherwise
= do unpack_id <- lookupId unpackCStringUtf8Name
return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str))))
= do unpack_utf8_id <- lookupId unpackCStringUtf8Name
return (App (Var unpack_utf8_id) lit)
where
chars = unpackFS str
safeChar c = ord c >= 1 && ord c <= 0x7F
lit = Lit (MachStr (fastStringToByteString str))
{-
************************************************************************
......
......@@ -981,7 +981,9 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
coveragePasses :: DynFlags -> [TickishType]
coveragePasses dflags =
ifa (hscTarget dflags == HscInterpreted) Breakpoints $
ifa (hscTarget dflags == HscInterpreted &&
not (gopt Opt_ExternalInterpreter dflags)) Breakpoints $
-- TODO: breakpoints don't work with -fexternal-interpreter yet
ifa (gopt Opt_Hpc dflags) HpcTicks $
ifa (gopt Opt_SccProfilingOn dflags &&
profAuto dflags /= NoProfAuto) ProfNotes $
......
......@@ -64,6 +64,9 @@ Library
else
Build-Depends: unix
if flag(ghci)
Build-Depends: ghci
GHC-Options: -Wall -fno-warn-name-shadowing
if flag(ghci)
......@@ -467,7 +470,6 @@ Library
Pair
Panic
Pretty
Serialized
State
Stream
StringBuffer
......@@ -578,6 +580,7 @@ Library
if flag(ghci)
Exposed-Modules:
Convert
ByteCodeTypes
ByteCodeAsm
ByteCodeGen
ByteCodeInstr
......@@ -586,6 +589,6 @@ Library
Debugger
LibFFI
Linker
ObjLink
RtClosureInspect
DebuggerUtils
GHCi
......@@ -580,7 +580,6 @@ compiler_stage2_dll0_MODULES = \
PrimOp \
RdrName \
Rules \
Serialized \
SrcLoc \
StaticFlags \
StringBuffer \
......@@ -609,49 +608,8 @@ ifeq "$(GhcWithInterpreter)" "YES"
# These files are reacheable from DynFlags
# only by GHCi-enabled code (see #9552)
compiler_stage2_dll0_MODULES += \
Bitmap \
BlockId \
ByteCodeAsm \
ByteCodeInstr \
ByteCodeItbls \
CLabel \
Cmm \
CmmCallConv \
CmmExpr \
CmmInfo \
CmmMachOp \
CmmNode \
CmmSwitch \
CmmUtils \
CodeGen.Platform \
CodeGen.Platform.ARM \
CodeGen.Platform.ARM64 \
CodeGen.Platform.NoRegs \
CodeGen.Platform.PPC \
CodeGen.Platform.PPC_Darwin \
CodeGen.Platform.SPARC \
CodeGen.Platform.X86 \
CodeGen.Platform.X86_64 \
Hoopl \
Hoopl.Dataflow \
InteractiveEvalTypes \
MkGraph \
PprCmm \
PprCmmDecl \
PprCmmExpr \
Reg \
RegClass \
SMRep \
StgCmmArgRep \
StgCmmClosure \
StgCmmEnv \
StgCmmLayout \
StgCmmMonad \
StgCmmProf \
StgCmmTicky \
StgCmmUtils \
StgSyn \
Stream
ByteCodeTypes \
InteractiveEvalTypes
endif
compiler_stage2_dll0_HS_OBJS = \
......@@ -769,4 +727,3 @@ ghc/stage1/package-data.mk : compiler/stage1/inplace-pkg-config-munged
endif
endif
......@@ -8,8 +8,7 @@
module ByteCodeAsm (
assembleBCOs, assembleBCO,
CompiledByteCode(..),
UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames,
bcoFreeNames,
SizedSeq, sizeSS, ssElts,
iNTERP_STACK_CHECK_THRESH
) where
......@@ -18,12 +17,13 @@ module ByteCodeAsm (
import ByteCodeInstr
import ByteCodeItbls
import ByteCodeTypes
import HscTypes
import Name
import NameSet
import Literal
import TyCon
import PrimOp
import FastString
import StgCmmLayout ( ArgRep(..) )
import SMRep
......@@ -32,6 +32,9 @@ import Outputable
import Platform
import Util
-- From iserv
import SizedSeq
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
#endif
......@@ -47,6 +50,7 @@ import Data.Array.Base ( UArray(..) )
import Data.Array.Unsafe( castSTUArray )
import qualified Data.ByteString as B
import Foreign
import Data.Char ( ord )
import Data.List
......@@ -54,44 +58,12 @@ import Data.Map (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
-- -----------------------------------------------------------------------------
-- Unlinked BCOs
-- CompiledByteCode represents the result of byte-code
-- compiling a bunch of functions and data types
data CompiledByteCode
= ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
ItblEnv -- A mapping from DataCons to their itbls
instance Outputable CompiledByteCode where
ppr (ByteCode bcos _) = ppr bcos
data UnlinkedBCO
= UnlinkedBCO {
unlinkedBCOName :: Name,
unlinkedBCOArity :: Int,
unlinkedBCOInstrs :: ByteArray#, -- insns
unlinkedBCOBitmap :: ByteArray#, -- bitmap
unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs
unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs
}
data BCOPtr
= BCOPtrName Name
| BCOPtrPrimOp PrimOp
| BCOPtrBCO UnlinkedBCO
| BCOPtrBreakInfo BreakInfo
| BCOPtrArray (MutableByteArray# RealWorld)
data BCONPtr
= BCONPtrWord Word
| BCONPtrLbl FastString
| BCONPtrItbl Name
-- | Finds external references. Remember to remove the names
-- defined by this group of BCOs themselves
bcoFreeNames :: UnlinkedBCO -> NameSet
......@@ -105,12 +77,6 @@ bcoFreeNames bco
map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
)
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
= sep [text "BCO", ppr nm, text "with",
ppr (sizeSS lits), text "lits",
ppr (sizeSS ptrs), text "ptrs" ]
-- -----------------------------------------------------------------------------
-- The bytecode assembler
......@@ -122,11 +88,11 @@ instance Outputable UnlinkedBCO where
-- bytecode address in this BCO.
-- Top level assembler fn.
assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs dflags proto_bcos tycons
= do itblenv <- mkITbls dflags tycons
bcos <- mapM (assembleBCO dflags) proto_bcos
return (ByteCode bcos itblenv)
assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons = do
itblenv <- mkITbls hsc_env tycons
bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
return (ByteCode bcos itblenv (concat (map protoBCOFFIs proto_bcos)))
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
......@@ -161,15 +127,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
ASSERT(n_insns == sizeSS final_insns) return ()
let asm_insns = ssElts final_insns
barr a = case a of UArray _lo _hi _n b -> b
insns_arr = Array.listArray (0, n_insns - 1) asm_insns
!insns_barr = barr insns_arr
insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
bitmap_arr = mkBitmapArray bsize bitmap
!bitmap_barr = barr bitmap_arr
ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
......@@ -191,23 +151,6 @@ type AsmState = (SizedSeq Word16,
SizedSeq BCONPtr,
SizedSeq BCOPtr)
data SizedSeq a = SizedSeq !Word [a]
emptySS :: SizedSeq a
emptySS = SizedSeq 0 []
addToSS :: SizedSeq a -> a -> SizedSeq a
addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)
addListToSS :: SizedSeq a -> [a] -> SizedSeq a
addListToSS (SizedSeq n r_xs) xs
= SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)
ssElts :: SizedSeq a -> [a]
ssElts (SizedSeq _ r_xs) = reverse r_xs
sizeSS :: SizedSeq a -> Word
sizeSS (SizedSeq n _) = n
data Operand
= Op Word
| SmallOp Word16
......@@ -365,9 +308,7 @@ assembleI dflags i = case i of
-> do let ul_bco = assembleBCO dflags proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p]
PUSH_UBX (Left lit) nws -> do np <- literal lit
emit bci_PUSH_UBX [Op np, SmallOp nws]
PUSH_UBX (Right aa) nws -> do np <- addr aa
PUSH_UBX lit nws -> do np <- literal lit
emit bci_PUSH_UBX [Op np, SmallOp nws]
PUSH_APPLY_N -> emit bci_PUSH_APPLY_N []
......@@ -437,7 +378,9 @@ assembleI dflags i = case i of
literal (MachChar c) = int (ord c)
literal (MachInt64 ii) = int64 (fromIntegral ii)
literal (MachWord64 ii) = int64 (fromIntegral ii)
literal other = pprPanic "ByteCodeAsm.literal" (ppr other)
literal (MachStr bs) = lit [BCONPtrStr (bs `B.snoc` 0)]
-- MachStr requires a zero-terminator when emitted
literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger"
litlabel fs = lit [BCONPtrLbl fs]
addr = words . mkLitPtr
......
This diff is collapsed.
......@@ -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
......
This diff is collapsed.
This diff is collapsed.
{-# 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))
......@@ -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]
......
......@@ -4,8 +4,8 @@ module DebuggerUtils (
dataConInfoPtrToName,
) where
import GHCi.InfoTable
import CmmInfo ( stdInfoTableSizeB )
import ByteCodeItbls
import DynFlags
import FastString
import TcRnTypes
......
This diff is collapsed.
This diff is collapsed.
......@@ -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)
......
......@@ -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
......@@ -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)