Commit 37610105 authored by mnislaih's avatar mnislaih
Browse files

Breakpoint code instrumentation

Instrumentation gets activated by the '-fdebugging' dynflag.

All the instrumentation occurrs in the desugarer; it consists of inserting 'breakpoint' combinators at a number of places in the AST, namely: 
 - Binding sites
 - Do-notation statements 
These 'breakpoint' combinators will later be further desugared (at DsExpr) into ___Jump functions.
For more info about this and all the ghci.debugger see the page at the GHC wiki:

http://hackage.haskell.org/trac/ghc/wiki/GhciDebugger
parent 3a99fa88
......@@ -10,6 +10,7 @@ module Desugar ( deSugar, deSugarExpr ) where
#include "HsVersions.h"
import Breakpoints
import DynFlags
import StaticFlags
import HscTypes
......@@ -43,8 +44,9 @@ import Maybes
import FastString
import Util
import Coverage
import IOEnv
import Data.IORef
\end{code}
%************************************************************************
......@@ -81,9 +83,9 @@ deSugar hsc_env
-- Desugar the program
; let export_set = availsToNameSet exports
; let auto_scc = mkAutoScc mod export_set
; let noDbgSites = []
; mb_res <- case ghcMode dflags of
JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo))
JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites))
_ -> do (binds_cvr,ds_hpc_info)
<- if opt_Hpc
then addCoverageTicksToBinds dflags mod mod_loc binds
......@@ -95,10 +97,13 @@ deSugar hsc_env
local_bndrs = mkVarSet (map fst all_prs)
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info)
; dbgSites_var <- getBkptSitesDs
; dbgSites <- ioToIOEnv$ readIORef dbgSites_var
; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, dbgSites)
}
; case mb_res of {
Nothing -> return Nothing ;
Just (all_prs, ds_rules, ds_fords,ds_hpc_info) -> do
Just (all_prs, ds_rules, ds_fords,ds_hpc_info, dbgSites) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
......@@ -167,7 +172,8 @@ deSugar hsc_env
mg_rules = ds_rules,
mg_binds = ds_binds,
mg_foreign = ds_fords,
mg_hpc_info = ds_hpc_info }
mg_hpc_info = ds_hpc_info,
mg_dbg_sites = dbgSites }
; return (Just mod_guts)
}}}
......
......@@ -104,6 +104,79 @@ mkBreakpointExpr loc bkptFuncId = do
srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
instrumenting = idName bkptFuncId == breakpointAutoName
debug_enabled :: DsM Bool
debug_enabled = do
debugging <- doptDs Opt_Debugging
b_enabled <- breakpoints_enabled
return (debugging && b_enabled)
breakpoints_enabled :: DsM Bool
breakpoints_enabled = do
ghcMode <- getGhcModeDs
currentModule <- getModuleDs
ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
return ( not ignore_breakpoints
&& ghcMode == Interactive
&& currentModule /= iNTERACTIVE )
maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id)
--maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined
maybeInsertBreakpoint lhsexpr@(L loc _) ty = do
instrumenting <- isInstrumentationSpot lhsexpr
if instrumenting
then do L _ dynBkpt <- dynBreakpoint loc
-- return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr))
return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr)
else return lhsexpr
where l = L loc
dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr
dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do
coreExpr <- dsLExpr expr
instrumenting <- isInstrumentationSpot expr
if instrumenting
then do L _ dynBkpt<- dynBreakpoint loc
bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt)
return (bkptCore `App` coreExpr)
else return coreExpr
where l = L loc
isInstrumentationSpot (L loc e) = do
ghcmode <- getGhcModeDs
instrumenting <- debug_enabled
return$ instrumenting
&& isGoodSrcSpan loc -- Avoids 'derived' code
&& (not$ isRedundant e)
isRedundant HsLet {} = True
isRedundant HsDo {} = True
isRedundant HsCase {} = True
isRedundant _ = False
dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id)
dynBreakpoint loc | not (isGoodSrcSpan loc) =
pprPanic "dynBreakpoint" (ppr loc)
dynBreakpoint loc = do
let autoBreakpoint = mkGlobalId VanillaGlobal breakpointAutoName
breakpointAutoTy vanillaIdInfo
dflags <- getDOptsDs
ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc)
return$ L loc (HsVar autoBreakpoint)
where breakpointAutoTy = (ForAllTy alphaTyVar
(FunTy (TyVarTy alphaTyVar)
(TyVarTy alphaTyVar)))
-- Records a breakpoint site and returns the site number
recordBkpt :: SrcLoc -> DsM (Int)
--recordBkpt | trace "recordBkpt" False = undefined
recordBkpt loc = do
sites_var <- getBkptSitesDs
sites <- ioToIOEnv$ readIORef sites_var
let site = length sites + 1
let coords = (srcLocLine loc, srcLocCol loc)
ioToIOEnv$ writeIORef sites_var ((site, coords) : sites)
return site
mkJumpFunc :: Id -> DsM Id
mkJumpFunc bkptFuncId
| idName bkptFuncId == breakpointName
......@@ -129,5 +202,9 @@ mkJumpFunc bkptFuncId
(basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo
mkTupleType tys = mkTupleTy Boxed (length tys) tys
#else
maybeInsertBreakpoint expr _ = return expr
dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr
breakpoints_enabled = False
#endif
\end{code}
......@@ -291,7 +291,7 @@ dsExpr (HsCase discrim matches)
returnDs (scrungleMatch discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
= dsLExpr body `thenDs` \ body' ->
= dsAndThenMaybeInsertBreakpoint body `thenDs` \ body' ->
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
......@@ -593,10 +593,10 @@ dsDo :: [LStmt Id]
dsDo stmts body result_ty
= go (map unLoc stmts)
where
go [] = dsLExpr body
go [] = dsAndThenMaybeInsertBreakpoint body
go (ExprStmt rhs then_expr _ : stmts)
= do { rhs2 <- dsLExpr rhs
= do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
; then_expr2 <- dsExpr then_expr
; rest <- go stmts
; returnDs (mkApps then_expr2 [rhs2, rest]) }
......@@ -611,7 +611,7 @@ dsDo stmts body result_ty
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
result_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
; rhs' <- dsLExpr rhs
; rhs' <- dsAndThenMaybeInsertBreakpoint rhs
; bind_op' <- dsExpr bind_op
; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
......@@ -661,7 +661,7 @@ dsMDo tbl stmts body result_ty
; dsLocalBinds binds rest }
go (ExprStmt rhs _ rhs_ty : stmts)
= do { rhs2 <- dsLExpr rhs
= do { rhs2 <- dsAndThenMaybeInsertBreakpoint rhs
; rest <- go stmts
; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
......@@ -674,7 +674,7 @@ dsMDo tbl stmts body result_ty
; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
; match_code <- extractMatchResult match fail_expr
; rhs' <- dsLExpr rhs
; rhs' <- dsAndThenMaybeInsertBreakpoint rhs
; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
......
......@@ -20,6 +20,7 @@ import Type
import DsMonad
import DsUtils
import DsBreakpoint
import Unique
import PrelInfo
import TysWiredIn
......
......@@ -18,11 +18,12 @@ module DsMonad (
getModuleDs,
newUnique,
UniqSupply, newUniqueSupply,
getDOptsDs,
getDOptsDs, getGhcModeDs, doptDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
getBkptSitesDs,
-- Warnings
DsWarning, warnDs, failWithDs,
......@@ -55,6 +56,9 @@ import NameEnv
import OccName
import DynFlags
import ErrUtils
import Bag
import Breakpoints
import OccName
import Data.IORef
......@@ -132,8 +136,9 @@ data DsGblEnv = DsGblEnv {
ds_mod :: Module, -- For SCC profiling
ds_unqual :: PrintUnqualified,
ds_msgs :: IORef Messages, -- Warning messages
ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
ds_if_env :: (IfGblEnv, IfLclEnv), -- Used for looking up global,
-- possibly-imported things
ds_bkptSites :: IORef SiteMap -- Inserted Breakpoints sites
}
data DsLclEnv = DsLclEnv {
......@@ -256,6 +261,12 @@ the @SrcSpan@ being carried around.
getDOptsDs :: DsM DynFlags
getDOptsDs = getDOpts
doptDs :: DynFlag -> TcRnIf gbl lcl Bool
doptDs = doptM
getGhcModeDs :: DsM GhcMode
getGhcModeDs = getDOptsDs >>= return . ghcMode
getModuleDs :: DsM Module
getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
......@@ -316,4 +327,10 @@ dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
\end{code}
\begin{code}
getBkptSitesDs :: DsM (IORef SiteMap)
getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) }
\end{code}
......@@ -50,6 +50,7 @@ import Maybes
import SrcLoc
import Util
import DynFlags
import Breakpoints
import Control.Monad
import Data.List
......@@ -209,7 +210,8 @@ typecheckIface iface
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_exports = exports
, md_exports = exports
, md_dbg_sites = noDbgSites
}
}
\end{code}
......
......@@ -23,3 +23,9 @@ nullBkptHandler = BkptHandler {
type BkptLocation a = (a, SiteNumber)
type SiteNumber = Int
type SiteMap = [(SiteNumber, Coord)]
type Coord = (Int, Int)
noDbgSites :: SiteMap
noDbgSites = []
......@@ -200,6 +200,7 @@ data DynFlag
| Opt_SplitObjs
| Opt_StgStats
| Opt_HideAllPackages
| Opt_Debugging
| Opt_PrintBindResult
| Opt_Haddock
......@@ -1054,7 +1055,9 @@ fFlags = [
( "excess-precision", Opt_ExcessPrecision ),
( "asm-mangling", Opt_DoAsmMangling ),
( "print-bind-result", Opt_PrintBindResult ),
( "force-recomp", Opt_ForceRecomp )
( "force-recomp", Opt_ForceRecomp ),
( "hpc", Opt_Hpc ),
( "hpc-tracer", Opt_Hpc_Tracer )
]
......
......@@ -59,6 +59,9 @@ module GHC (
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
#if defined(GHCI)
modInfoBkptSites,
#endif
lookupGlobalName,
-- * Printing
......@@ -849,6 +852,9 @@ checkModule session@(Session ref) mod = do
md_exports details,
minf_rdr_env = Just rdr_env,
minf_instances = md_insts details
#ifdef GHCI
,minf_dbg_sites = noDbgSites
#endif
}
return (Just (CheckedModule {
parsedSource = parsed,
......@@ -1757,7 +1763,10 @@ data ModuleInfo = ModuleInfo {
minf_type_env :: TypeEnv,
minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [Instance]
minf_instances :: [Instance],
#ifdef GHCI
minf_dbg_sites :: [(SiteNumber,Coord)]
#endif
-- ToDo: this should really contain the ModIface too
}
-- We don't want HomeModInfo here, because a ModuleInfo applies
......@@ -1796,7 +1805,8 @@ getPackageModuleInfo hsc_env mdl = do
minf_type_env = mkTypeEnv tys,
minf_exports = names,
minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
minf_instances = error "getModuleInfo: instances for package module unimplemented"
minf_instances = error "getModuleInfo: instances for package module unimplemented",
minf_dbg_sites = noDbgSites
}))
#else
-- bogusly different for non-GHCI (ToDo)
......@@ -1813,6 +1823,9 @@ getHomeModuleInfo hsc_env mdl =
minf_exports = availsToNameSet (md_exports details),
minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details
#ifdef GHCI
,minf_dbg_sites = md_dbg_sites details
#endif
}))
-- | The list of top-level entities defined in a module
......@@ -1846,6 +1859,10 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
#ifdef GHCI
modInfoBkptSites = minf_dbg_sites
#endif
isDictonaryId :: Id -> Bool
isDictonaryId id
= case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau }
......
......@@ -76,6 +76,7 @@ import CodeGen ( codeGen )
import CmmParse ( parseCmmFile )
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
import Breakpoints ( noDbgSites )
import DynFlags
import ErrUtils
......@@ -685,6 +686,7 @@ hscFileCheck hsc_env mod_summary = do {
md_exports = tcg_exports tc_result,
md_insts = tcg_insts tc_result,
md_fam_insts = tcg_fam_insts tc_result,
md_dbg_sites = noDbgSites,
md_rules = [panic "no rules"] }
-- Rules are CoreRules, not the
-- RuleDecls we get out of the typechecker
......
......@@ -64,6 +64,7 @@ module HscTypes (
#include "HsVersions.h"
import Breakpoints ( SiteNumber, Coord, noDbgSites )
#ifdef GHCI
import ByteCodeAsm ( CompiledByteCode )
#endif
......@@ -454,14 +455,16 @@ data ModDetails
md_types :: !TypeEnv,
md_insts :: ![Instance], -- Dfun-ids for the instances in this module
md_fam_insts :: ![FamInst],
md_rules :: ![CoreRule] -- Domain may include Ids from other modules
md_rules :: ![CoreRule], -- Domain may include Ids from other modules
md_dbg_sites :: ![(SiteNumber, Coord)] -- Breakpoint sites inserted by the renamer
}
emptyModDetails = ModDetails { md_types = emptyTypeEnv,
md_exports = [],
md_insts = [],
md_rules = [],
md_fam_insts = [] }
md_fam_insts = [],
md_dbg_sites = noDbgSites}
-- A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
......@@ -490,7 +493,8 @@ data ModGuts
mg_rules :: ![CoreRule], -- Rules from this module
mg_binds :: ![CoreBind], -- Bindings for this module
mg_foreign :: !ForeignStubs,
mg_hpc_info :: !HpcInfo -- info about coverage tick boxes
mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes
mg_dbg_sites :: ![(SiteNumber, Coord)] -- Bkpts inserted by the renamer
}
-- The ModGuts takes on several slightly different forms:
......
......@@ -124,7 +124,8 @@ mkBootModDetails hsc_env (ModGuts { mg_module = mod
, mg_exports = exports
, mg_types = type_env
, mg_insts = insts
, mg_fam_insts = fam_insts })
, mg_fam_insts = fam_insts,
mg_dbg_sites = sites })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy [hoot] type env"
......@@ -138,7 +139,8 @@ mkBootModDetails hsc_env (ModGuts { mg_module = mod
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
, md_exports = exports })
, md_exports = exports
, md_dbg_sites = sites})
}
where
......@@ -241,7 +243,8 @@ tidyProgram hsc_env
mg_rules = imp_rules,
mg_dir_imps = dir_imps, mg_deps = deps,
mg_foreign = foreign_stubs,
mg_hpc_info = hpc_info })
mg_hpc_info = hpc_info,
mg_dbg_sites = sites })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy Core"
......@@ -299,7 +302,8 @@ tidyProgram hsc_env
md_rules = tidy_rules,
md_insts = tidy_insts,
md_fam_insts = fam_insts,
md_exports = exports })
md_exports = exports,
md_dbg_sites = sites })
}
lookup_dfun type_env dfun_id
......
......@@ -69,6 +69,7 @@ import NameSet
import TyCon
import SrcLoc
import HscTypes
import DsBreakpoint
import Outputable
#ifdef GHCI
......@@ -309,7 +310,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
mg_fix_env = emptyFixityEnv,
mg_deprecs = NoDeprecs,
mg_foreign = NoStubs,
mg_hpc_info = noHpcInfo
mg_hpc_info = noHpcInfo,
mg_dbg_sites = noDbgSites
} } ;
tcCoreDump mod_guts ;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment