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
#include "HsVersions.h"
+import Breakpoints
import DynFlags
import StaticFlags
import HscTypes
import FastString
import Util
import Coverage
-
+import IOEnv
import Data.IORef
+
\end{code}
%************************************************************************
-- 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
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
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)
}}}
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
(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}
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)
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]) }
; 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]) }
; 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]) }
; 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]) }
import DsMonad
import DsUtils
+import DsBreakpoint
import Unique
import PrelInfo
import TysWiredIn
getModuleDs,
newUnique,
UniqSupply, newUniqueSupply,
- getDOptsDs,
+ getDOptsDs, getGhcModeDs, doptDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
+ getBkptSitesDs,
-- Warnings
DsWarning, warnDs, failWithDs,
import OccName
import DynFlags
import ErrUtils
+import Bag
+import Breakpoints
+import OccName
import Data.IORef
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 {
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) }
= 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}
import SrcLoc
import Util
import DynFlags
+import Breakpoints
import Control.Monad
import Data.List
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
- , md_exports = exports
+ , md_exports = exports
+ , md_dbg_sites = noDbgSites
}
}
\end{code}
\r
type BkptLocation a = (a, SiteNumber)\r
type SiteNumber = Int\r
+\r
+type SiteMap = [(SiteNumber, Coord)]\r
+type Coord = (Int, Int)\r
+\r
+noDbgSites :: SiteMap\r
+noDbgSites = []\r
| Opt_SplitObjs
| Opt_StgStats
| Opt_HideAllPackages
+ | Opt_Debugging
| Opt_PrintBindResult
| Opt_Haddock
( "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 )
]
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
+#if defined(GHCI)
+ modInfoBkptSites,
+#endif
lookupGlobalName,
-- * Printing
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,
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
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)
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
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 }
import CmmParse ( parseCmmFile )
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
+import Breakpoints ( noDbgSites )
import DynFlags
import ErrUtils
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
#include "HsVersions.h"
+import Breakpoints ( SiteNumber, Coord, noDbgSites )
#ifdef GHCI
import ByteCodeAsm ( CompiledByteCode )
#endif
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
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:
, 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"
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
- , md_exports = exports })
+ , md_exports = exports
+ , md_dbg_sites = sites})
}
where
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"
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
import TyCon
import SrcLoc
import HscTypes
+import DsBreakpoint
import Outputable
#ifdef GHCI
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 ;
projects / ghc-hetmet.git / commitdiff