Commit 6be09e88 authored by Simon Marlow's avatar Simon Marlow

Enable stack traces with ghci -fexternal-interpreter -prof

Summary:
The main goal here is enable stack traces in GHCi.  After this change,
if you start GHCi like this:

  ghci -fexternal-interpreter -prof

(which requires packages to be built for profiling, but not GHC
itself) then the interpreter manages cost-centre stacks during
execution and can produce a stack trace on request.  Call locations
are available for all interpreted code, and any compiled code that was
built with the `-fprof-auto` familiy of flags.

There are a couple of ways to get a stack trace:

* `error`/`undefined` automatically get one attached
* `Debug.Trace.traceStack` can be used anywhere, and prints the current
  stack

Because the interpreter is running in a separate process, only the
interpreted code is running in profiled mode and the compiler itself
isn't slowed down by profiling.

The GHCi debugger still doesn't work with -fexternal-interpreter,
although this patch gets it a step closer.  Most of the functionality
of breakpoints is implemented, but the runtime value introspection is
still not supported.

Along the way I also did some refactoring and added type arguments to
the various remote pointer types in `GHCi.RemotePtr`, so there's
better type safety and documentation in the bridge code between GHC
and ghc-iserv.

Test Plan: validate

Reviewers: bgamari, ezyang, austin, hvr, goldfire, erikd

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1747

GHC Trac Issues: #11047, #11100
parent c78fedde
......@@ -10,6 +10,9 @@ module Coverage (addTicksToBinds, hpcInitCode) where
#ifdef GHCI
import qualified GHCi
import GHCi.RemoteTypes
import Data.Array
import ByteCodeTypes
import GHC.Stack.CCS
#endif
import Type
import HsSyn
......@@ -37,14 +40,14 @@ import Maybes
import CLabel
import Util
import Data.Array
import Data.Time
import Foreign.C
import System.Directory
import Trace.Hpc.Mix
import Trace.Hpc.Util
import BreakArray
import qualified Data.ByteString as B
import Data.Map (Map)
import qualified Data.Map as Map
......@@ -65,7 +68,7 @@ addTicksToBinds
-- hasn't set it), so we have to work from this set.
-> [TyCon] -- Type constructor in this module
-> LHsBinds Id
-> IO (LHsBinds Id, HpcInfo, ModBreaks)
-> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks)
addTicksToBinds hsc_env mod mod_loc exports tyCons binds
| let dflags = hsc_dflags hsc_env
......@@ -73,7 +76,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
Just orig_file <- ml_hs_file mod_loc = do
if "boot" `isSuffixOf` orig_file
then return (binds, emptyHpcInfo False, emptyModBreaks)
then return (binds, emptyHpcInfo False, Nothing)
else do
us <- mkSplitUniqSupply 'C' -- for cost centres
......@@ -93,7 +96,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
, density = mkDensity tickish dflags
, this_mod = mod
, tickishType = tickish
}
}
(binds',_,st') = unTM (addTickLHsBinds binds) env st
in (binds', st')
......@@ -113,9 +116,9 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
(pprLHsBinds binds1)
return (binds1, HpcInfo tickCount hashNo, modBreaks)
return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
| otherwise = return (binds, emptyHpcInfo False, emptyModBreaks)
| otherwise = return (binds, emptyHpcInfo False, Nothing)
guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
guessSourceFile binds orig_file =
......@@ -131,12 +134,13 @@ guessSourceFile binds orig_file =
mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
#ifndef GHCI
mkModBreaks _hsc_env _mod _count _entries = return emptyModBreaks
#else
mkModBreaks hsc_env mod count entries
| HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
breakArray <- newBreakArray (length entries)
#ifdef GHCI
breakArray <- GHCi.newBreakArray hsc_env (length entries)
ccs <- mkCCSArray hsc_env mod count entries
#endif
let
locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]
varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]
......@@ -146,31 +150,30 @@ mkModBreaks hsc_env mod count entries
, modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
, modBreaks_decls = declsTicks
#ifdef GHCI
, modBreaks_ccs = ccs
#endif
}
| otherwise = return emptyModBreaks
#ifdef GHCI
mkCCSArray
:: HscEnv -> Module -> Int -> [MixEntry_]
-> IO (Array BreakIndex RemotePtr {- CCostCentre -})
-> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
mkCCSArray hsc_env modul count entries = do
if interpreterProfiled (hsc_dflags hsc_env)
then do
let module_bs = fastStringToByteString (moduleNameFS (moduleName modul))
c_module <- GHCi.mallocData hsc_env module_bs
costcentres <- mapM (mkCostCentre hsc_env (toRemotePtr c_module)) entries
c_module <- GHCi.mallocData hsc_env (module_bs `B.snoc` 0)
-- NB. null-terminate the string
costcentres <-
mapM (mkCostCentre hsc_env (castRemotePtr c_module)) entries
return (listArray (0,count-1) costcentres)
else do
return (listArray (0,-1) [])
where
mkCostCentre
:: HscEnv
-> RemotePtr {- CChar -}
-> RemotePtr CChar
-> MixEntry_
-> IO (RemotePtr {- CCostCentre -})
-> IO (RemotePtr GHC.Stack.CCS.CostCentre)
mkCostCentre hsc_env@HscEnv{..} c_module (srcspan, decl_path, _, _) = do
let name = concat (intersperse "." decl_path)
src = showSDoc hsc_dflags (ppr srcspan)
......@@ -1010,9 +1013,7 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
coveragePasses :: DynFlags -> [TickishType]
coveragePasses dflags =
ifa (hscTarget dflags == HscInterpreted &&
not (gopt Opt_ExternalInterpreter dflags)) Breakpoints $
-- TODO: breakpoints don't work with -fexternal-interpreter yet
ifa (hscTarget dflags == HscInterpreted) Breakpoints $
ifa (gopt Opt_Hpc dflags) HpcTicks $
ifa (gopt Opt_SccProfilingOn dflags &&
profAuto dflags /= NoProfAuto) ProfNotes $
......
......@@ -302,7 +302,7 @@ deSugar hsc_env
<- if not (isHsBootOrSig hsc_src)
then addTicksToBinds hsc_env mod mod_loc
export_set (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
else return (binds, hpcInfo, Nothing)
; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
do { ds_ev_binds <- dsEvBinds ev_binds
......
......@@ -306,7 +306,6 @@ Library
TcIface
FlagChecker
Annotations
BreakArray
CmdLineParser
CodeOutput
Config
......
......@@ -454,7 +454,6 @@ compiler_stage2_dll0_MODULES = \
BasicTypes \
Binary \
BooleanFormula \
BreakArray \
BufWrite \
Class \
CmdLineParser \
......
......@@ -32,6 +32,7 @@ import DynFlags
import Outputable
import Platform
import Util
import Unique
-- From iserv
import SizedSeq
......@@ -86,11 +87,18 @@ bcoFreeNames bco
-- bytecode address in this BCO.
-- Top level assembler fn.
assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons = do
assembleBCOs
:: HscEnv -> [ProtoBCO Name] -> [TyCon] -> Maybe ModBreaks
-> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons modbreaks = do
itblenv <- mkITbls hsc_env tycons
bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
return (ByteCode bcos itblenv (concat (map protoBCOFFIs proto_bcos)))
return CompiledByteCode
{ bc_bcos = bcos
, bc_itbls = itblenv
, bc_ffis = concat (map protoBCOFFIs proto_bcos)
, bc_breaks = modbreaks
}
assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
......@@ -356,11 +364,11 @@ assembleI dflags i = case i of
RETURN_UBX rep -> emit (return_ubx rep) []
CCALL off m_addr i -> do np <- addr m_addr
emit bci_CCALL [SmallOp off, Op np, SmallOp i]
BRK_FUN array index info cc -> do p1 <- ptr (BCOPtrArray array)
p2 <- ptr (BCOPtrBreakInfo info)
np <- addr cc
emit bci_BRK_FUN [Op p1, SmallOp index,
Op p2, Op np]
BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray
q <- int (getKey uniq)
np <- addr cc
emit bci_BRK_FUN [Op p1, SmallOp index,
Op q, Op np]
where
literal (MachLabel fs (Just sz) _)
......@@ -474,14 +482,7 @@ mkLitI64 dflags ii
| otherwise
= panic "mkLitI64: Bad wORD_SIZE"
mkLitI i
= runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 i
i_arr <- castSTUArray arr
w0 <- readArray i_arr 0
return [w0 :: Word]
)
mkLitI i = [fromIntegral i :: Word]
iNTERP_STACK_CHECK_THRESH :: Int
iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
{-# LANGUAGE CPP, MagicHash #-}
{-# LANGUAGE CPP, MagicHash, RecordWildCards #-}
--
-- (c) The University of Glasgow 2002-2006
--
......@@ -44,6 +44,7 @@ import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW )
import SMRep
import Bitmap
import OrdList
import Maybes
import Data.List
import Foreign
......@@ -51,16 +52,17 @@ import Control.Monad
import Data.Char
import UniqSupply
import BreakArray
import Data.Maybe
import Module
import Control.Arrow ( second )
import Data.Array
import Data.Map (Map)
import Data.IntMap (IntMap)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified FiniteMap as Map
import Data.Ord
import GHC.Stack.CCS
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
......@@ -69,9 +71,9 @@ byteCodeGen :: HscEnv
-> Module
-> CoreProgram
-> [TyCon]
-> ModBreaks
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen hsc_env this_mod binds tycs modBreaks
byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
= do let dflags = hsc_dflags hsc_env
showPass dflags "ByteCodeGen"
......@@ -79,8 +81,9 @@ byteCodeGen hsc_env this_mod binds tycs modBreaks
| (bndr, rhs) <- flattenBinds binds]
us <- mkSplitUniqSupply 'y'
(BcM_State _hsc_env _us _this_mod _final_ctr ffis _, proto_bcos)
<- runBc hsc_env us this_mod modBreaks (mapM schemeTopBind flatBinds)
(BcM_State{..}, proto_bcos) <-
runBc hsc_env us this_mod mb_modBreaks $
mapM schemeTopBind flatBinds
when (notNull ffis)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
......@@ -89,12 +92,14 @@ byteCodeGen hsc_env this_mod binds tycs modBreaks
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
assembleBCOs hsc_env proto_bcos tycs
(case modBreaks of
Nothing -> Nothing
Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
-- Returns: (the root BCO for this expression,
-- a list of auxilary BCOs resulting from compiling closures)
-- Returns: the root BCO for this expression
coreExprToBCOs :: HscEnv
-> Module
-> CoreExpr
......@@ -111,8 +116,8 @@ coreExprToBCOs hsc_env this_mod expr
-- the uniques are needed to generate fresh variables when we introduce new
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
<- runBc hsc_env us this_mod emptyModBreaks $
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ , proto_bco)
<- runBc hsc_env us this_mod Nothing $
schemeTopBind (invented_id, simpleFreeVars expr)
when (notNull mallocd)
......@@ -331,22 +336,18 @@ schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeER_wrk d p rhs
| AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
= do code <- schemeE (fromIntegral d) 0 p newRhs
flag_arr <- getBreakArray
cc_arr <- getCCArray
this_mod <- getCurrentModule
this_mod <- moduleName <$> getCurrentModule
let idOffSets = getVarOffSets d p fvs
let breakInfo = BreakInfo
{ breakInfo_module = this_mod
, breakInfo_number = tick_no
, breakInfo_vars = idOffSets
, breakInfo_resty = exprType (deAnnotate' newRhs)
let breakInfo = CgBreakInfo
{ cgb_vars = idOffSets
, cgb_resty = exprType (deAnnotate' newRhs)
}
newBreakInfo tick_no breakInfo
dflags <- getDynFlags
let cc | interpreterProfiled dflags = cc_arr ! tick_no
| otherwise = toRemotePtr nullPtr
let breakInstr = case flag_arr of
BA arr# ->
BRK_FUN arr# (fromIntegral tick_no) breakInfo cc
let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
return $ breakInstr `consOL` code
| otherwise = schemeE (fromIntegral d) 0 p rhs
......@@ -1642,7 +1643,8 @@ data BcM_State
, nextlabel :: Word16 -- for generating local labels
, ffis :: [FFIInfo] -- ffi info blocks, to free later
-- Should be free()d when it is GCd
, modBreaks :: ModBreaks -- info about breakpoints
, modBreaks :: Maybe ModBreaks -- info about breakpoints
, breakInfo :: IntMap CgBreakInfo
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
......@@ -1652,10 +1654,10 @@ ioToBc io = BcM $ \st -> do
x <- io
return (st, x)
runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r
runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r
-> IO (BcM_State, r)
runBc hsc_env us this_mod modBreaks (BcM m)
= m (BcM_State hsc_env us this_mod 0 [] modBreaks)
= m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
......@@ -1695,7 +1697,7 @@ emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
= BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
recordFFIBc :: RemotePtr -> BcM ()
recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
recordFFIBc a
= BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
......@@ -1711,11 +1713,15 @@ getLabelsBc n
= BcM $ \st -> let ctr = nextlabel st
in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
getBreakArray :: BcM BreakArray
getBreakArray = BcM $ \st -> return (st, modBreaks_flags (modBreaks st))
getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
getCCArray = BcM $ \st ->
let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
return (st, modBreaks_ccs breaks)
getCCArray :: BcM (Array BreakIndex RemotePtr {- CCostCentre -})
getCCArray = BcM $ \st -> return (st, modBreaks_ccs (modBreaks st))
newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
newBreakInfo ix info = BcM $ \st ->
return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
newUnique :: BcM Unique
newUnique = BcM $
......
......@@ -14,11 +14,13 @@ module ByteCodeInstr (
import ByteCodeTypes
import GHCi.RemoteTypes
import GHCi.FFI (C_ffi_cif)
import StgCmmLayout ( ArgRep(..) )
import PprCore
import Outputable
import FastString
import Name
import Unique
import Id
import CoreSyn
import Literal
......@@ -27,8 +29,8 @@ import VarSet
import PrimOp
import SMRep
import GHC.Exts
import Data.Word
import GHC.Stack.CCS (CostCentre)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
......@@ -125,7 +127,7 @@ data BCInstr
-- For doing calls to C (via glue code generated by libffi)
| CCALL Word16 -- stack frame size
RemotePtr -- addr of the glue code
(RemotePtr C_ffi_cif) -- addr of the glue code
Word16 -- whether or not the call is interruptible
-- (XXX: inefficient, but I don't know
-- what the alignment constraints are.)
......@@ -140,7 +142,7 @@ data BCInstr
| RETURN_UBX ArgRep -- return an unlifted value, here's its rep
-- Breakpoints
| BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo RemotePtr
| BRK_FUN Word16 Unique (RemotePtr CostCentre)
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
......@@ -240,7 +242,7 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr RETURN = text "RETURN"
ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
ppr (BRK_FUN _breakArray index info _cc) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info <+> text "<cc>"
ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
-- -----------------------------------------------------------------------------
-- The stack use, in words, of each bytecode insn. These _must_ be
......
......@@ -11,7 +11,6 @@ module ByteCodeItbls ( mkITbls ) where
import ByteCodeTypes
import GHCi
import GHCi.RemoteTypes
import DynFlags
import HscTypes
import Name ( Name, getName )
......@@ -70,4 +69,4 @@ make_constr_itbls hsc_env cons =
descr = dataConIdentity dcon
r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really conNo descr)
return (getName dcon, ItblPtr (fromRemotePtr r))
return (getName dcon, ItblPtr r)
......@@ -22,6 +22,7 @@ module ByteCodeLink (
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.InfoTable
import GHCi.BreakArray
import SizedSeq
import GHCi
......@@ -60,15 +61,16 @@ extendClosureEnv cl_env pairs
-}
linkBCO
:: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> UnlinkedBCO
:: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO hsc_env ie ce bco_ix
linkBCO hsc_env ie ce bco_ix breakarray
(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)
ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)
return (ResolvedBCO arity insns bitmap
(listArray (0, fromIntegral (sizeSS lits0)-1) lits)
(addListToSS emptySS ptrs))
(listArray (0, fromIntegral (sizeSS lits0)-1) lits)
(addListToSS emptySS ptrs))
lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word
lookupLiteral _ _ (BCONPtrWord lit) = return lit
......@@ -79,7 +81,7 @@ 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
fromIntegral . ptrToWordPtr . fromRemotePtr <$> mallocData hsc_env bs
lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())
lookupStaticPtr hsc_env addr_of_label_string = do
......@@ -89,26 +91,26 @@ lookupStaticPtr hsc_env addr_of_label_string = do
Nothing -> linkFail "ByteCodeLink: can't find label"
(unpackFS addr_of_label_string)
lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr a)
lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
lookupIE hsc_env ie con_nm =
case lookupNameEnv ie con_nm of
Just (_, ItblPtr a) -> return (castPtr (conInfoPtr a))
Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr 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)
Just addr -> return 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)
Just addr -> return addr
Nothing -> linkFail "ByteCodeLink.lookupIE"
(unpackFS sym_to_find1 ++ " or " ++
unpackFS sym_to_find2)
lookupPrimOp :: HscEnv -> PrimOp -> IO RemotePtr
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)
......@@ -117,13 +119,14 @@ lookupPrimOp hsc_env primop = do
Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
resolvePtr
:: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> BCOPtr
:: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
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))
return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
| otherwise =
ASSERT2(isExternalName nm, ppr nm)
do let sym_to_find = nameToCLabel nm "closure"
......@@ -131,14 +134,12 @@ resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm)
case m of
Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
resolvePtr hsc_env _ _ _ (BCOPtrPrimOp op) =
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))
resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco
resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =
return (ResolvedBCOPtrBreakArray breakarray)
linkFail :: String -> String -> IO a
linkFail who what
......
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MagicHash, RecordWildCards #-}
--
-- (c) The University of Glasgow 2002-2006
--
......@@ -8,43 +8,55 @@ module ByteCodeTypes
( CompiledByteCode(..), FFIInfo(..)
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
, BreakInfo(..)
, CgBreakInfo(..)
, ModBreaks (..), BreakIndex, emptyModBreaks
, CCostCentre
) where
import FastString
import Id
import Module
import Name
import NameEnv
import Outputable
import PrimOp
import SizedSeq
import Type
import SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
import GHCi.FFI
import GHCi.InfoTable
import Foreign
import Data.Array
import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import GHC.Exts
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import GHC.Stack.CCS
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
data CompiledByteCode
= ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
ItblEnv -- A mapping from DataCons to their itbls
[FFIInfo] -- ffi blocks we allocated
data CompiledByteCode = CompiledByteCode
{ bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings
, bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls
, bc_ffis :: [FFIInfo] -- ffi blocks we allocated
, bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
-- creating breakpoints, for some reason)
}
-- ToDo: we're not tracking strings that we malloc'd
newtype FFIInfo = FFIInfo RemotePtr
newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
deriving Show
instance Outputable CompiledByteCode where
ppr (ByteCode bcos _ _) = ppr bcos
ppr CompiledByteCode{..} = ppr bc_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
newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) deriving Show
data UnlinkedBCO
= UnlinkedBCO {
......@@ -60,8 +72,7 @@ data BCOPtr
= BCOPtrName Name
| BCOPtrPrimOp PrimOp
| BCOPtrBCO UnlinkedBCO
| BCOPtrBreakInfo BreakInfo
| BCOPtrArray (MutableByteArray# RealWorld)
| BCOPtrBreakArray -- a pointer to this module's BreakArray
data BCONPtr
= BCONPtrWord Word
......@@ -69,12 +80,11 @@ data BCONPtr
| BCONPtrItbl Name
| BCONPtrStr ByteString
data BreakInfo
= BreakInfo
{ breakInfo_module :: Module
, breakInfo_number :: {-# UNPACK #-} !Int
, breakInfo_vars :: [(Id,Word16)]
, breakInfo_resty :: Type
-- | Information about a breakpoint that we know at code-generation time
data CgBreakInfo
= CgBreakInfo
{ cgb_vars :: [(Id,Word16)]
, cgb_resty :: Type
}
instance Outputable UnlinkedBCO where
......@@ -83,9 +93,46 @@ instance Outputable UnlinkedBCO where
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))
instance Outputable CgBreakInfo where
ppr info = text "CgBreakInfo" <+>
parens (ppr (cgb_vars info) <+>
ppr (cgb_resty info))
-- -----------------------------------------------------------------------------
-- Breakpoints
-- | Breakpoint index
type BreakIndex = Int
-- | C CostCentre type
data CCostCentre
-- | All the information about the breakpoints for a module
data ModBreaks
= ModBreaks
{ modBreaks_flags :: ForeignRef BreakArray
-- ^ The array of flags, one per breakpoint,
-- indicating which breakpoints are enabled.
, modBreaks_locs :: !(Array BreakIndex SrcSpan)
-- ^ An array giving the source span of each breakpoint.
, modBreaks_vars :: !(Array BreakIndex [OccName])
-- ^ An array giving the names of the free variables at each breakpoint.
, modBreaks_decls :: !(Array BreakIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
, modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre))
-- ^ Array pointing to cost centre for each breakpoint
, modBreaks_breakInfo :: IntMap CgBreakInfo
-- ^ info about each breakpoint from the bytecode generator
}
-- | Construct an empty ModBreaks
emptyModBreaks :: ModBreaks
emptyModBreaks = ModBreaks
{ modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
-- ToDo: can we avoid this?