From 376101055fb111ebd52b5ef1fb76e00334b44304 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 10 Dec 2006 20:49:34 +0000 Subject: [PATCH] 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 --- compiler/deSugar/Desugar.lhs | 16 +++++--- compiler/deSugar/DsBreakpoint.lhs | 77 +++++++++++++++++++++++++++++++++++++ compiler/deSugar/DsExpr.lhs | 12 +++--- compiler/deSugar/DsGRHSs.lhs | 1 + compiler/deSugar/DsMonad.lhs | 21 +++++++++- compiler/iface/TcIface.lhs | 4 +- compiler/main/Breakpoints.hs | 6 +++ compiler/main/DynFlags.hs | 5 ++- compiler/main/GHC.hs | 21 +++++++++- compiler/main/HscMain.lhs | 2 + compiler/main/HscTypes.lhs | 10 +++-- compiler/main/TidyPgm.lhs | 12 ++++-- compiler/typecheck/TcRnDriver.lhs | 4 +- 13 files changed, 166 insertions(+), 25 deletions(-) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index dd2ed6d..d16672c 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -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) }}} diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs index 1abfb0c..ed7a536 100644 --- a/compiler/deSugar/DsBreakpoint.lhs +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -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} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 554149c..8c75dc9 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -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]) } diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 93f4ead..12e0f0b 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -20,6 +20,7 @@ import Type import DsMonad import DsUtils +import DsBreakpoint import Unique import PrelInfo import TysWiredIn diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index cbe182e..8d11931 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -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} diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 4232195..58ec39a 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -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} diff --git a/compiler/main/Breakpoints.hs b/compiler/main/Breakpoints.hs index 8bb1716..14d9ea2 100644 --- a/compiler/main/Breakpoints.hs +++ b/compiler/main/Breakpoints.hs @@ -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 = [] diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1799033..a176a73 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 ) ] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c292cf0..cbe82c4 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 } diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 6c09b97..041ea15 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index a76ec5a..4155807 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -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: diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index a8dede8..6f44bca 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -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 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index a93133d..044b67d 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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 ; -- 1.7.10.4