Commit c1681a73 authored by andy@galois.com's avatar andy@galois.com

Adding pushing of hpc translation status through hi files.

Now, if a single module *anywhere* on the module tree is built with
-fhpc, the binary will enable reading/writing of <bin>.tix.

Previously, you needed to compile Main to allow coverage to operate.

This changes the file format for .hi files; you will need to recompile every library.
parent 84ca819a
......@@ -57,7 +57,7 @@ hpcTable this_mod (HpcInfo hpc_tickCount _) = do
else packageIdString (modulePackageId this_mod) ++ "/" ++
module_name_str
hpcTable this_mod (NoHpcInfo) = error "TODO: impossible"
hpcTable this_mod (NoHpcInfo {}) = error "TODO: impossible"
initHpc :: Module -> HpcInfo -> Code
initHpc this_mod (HpcInfo tickCount hashNo)
......
......@@ -224,7 +224,7 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
, CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
rec_descent_init = if opt_SccProfilingOn || opt_Hpc
rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
then jump_to_init
else ret_code
......
......@@ -69,7 +69,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do
Just file -> file
Nothing -> panic "can not find the original file during hpc trans"
if "boot" `isSuffixOf` orig_file then return (binds, noHpcInfo, emptyModBreaks) else do
if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
let mod_name = moduleNameString (moduleName mod)
......
......@@ -78,7 +78,8 @@ deSugar hsc_env
tcg_fords = fords,
tcg_rules = rules,
tcg_insts = insts,
tcg_fam_insts = fam_insts })
tcg_fam_insts = fam_insts,
tcg_hpc = other_hpc_info })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Desugar"
......@@ -87,12 +88,15 @@ deSugar hsc_env
; let export_set = availsToNameSet exports
; let auto_scc = mkAutoScc mod export_set
; let target = hscTarget dflags
; let hpcInfo = emptyHpcInfo other_hpc_info
; mb_res <- case target of
HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
HscNothing -> return (Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
_ -> do (binds_cvr,ds_hpc_info, modBreaks)
<- if opt_Hpc || target == HscInterpreted
<- if (opt_Hpc
|| target == HscInterpreted)
&& (not (isHsBoot hsc_src))
then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
else return (binds, noHpcInfo, emptyModBreaks)
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds_cvr
; (ds_fords, foreign_prs) <- dsForeigns fords
......
......@@ -295,7 +295,8 @@ instance Binary ModIface where
mi_fam_insts = fam_insts,
mi_rules = rules,
mi_rule_vers = rule_vers,
mi_vect_info = vect_info }) = do
mi_vect_info = vect_info,
mi_hpc = hpc_info }) = do
put_ bh mod
put_ bh is_boot
put_ bh mod_vers
......@@ -313,6 +314,7 @@ instance Binary ModIface where
lazyPut bh rules
put_ bh rule_vers
put_ bh vect_info
put_ bh hpc_info
get bh = do
mod_name <- get bh
......@@ -332,6 +334,7 @@ instance Binary ModIface where
rules <- {-# SCC "bin_rules" #-} lazyGet bh
rule_vers <- get bh
vect_info <- get bh
hpc_info <- get bh
return (ModIface {
mi_module = mod_name,
mi_boot = is_boot,
......@@ -351,6 +354,7 @@ instance Binary ModIface where
mi_rules = rules,
mi_rule_vers = rule_vers,
mi_vect_info = vect_info,
mi_hpc = hpc_info,
-- And build the cached values
mi_dep_fn = mkIfaceDepCache deprecs,
mi_fix_fn = mkIfaceFixCache fixities,
......
......@@ -593,6 +593,7 @@ pprModIface iface
<+> ppr (mi_mod_vers iface) <+> pp_sub_vers
<+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty)
<+> (if mi_finsts iface then ptext SLIT("[family instance module]") else empty)
<+> (if mi_hpc iface then ptext SLIT("[hpc]") else empty)
<+> integer opt_HiVersion
<+> ptext SLIT("where")
, vcat (map pprExport (mi_exports iface))
......@@ -605,7 +606,7 @@ pprModIface iface
, vcat (map ppr (mi_rules iface))
, pprVectInfo (mi_vect_info iface)
, pprDeprecs (mi_deprecs iface)
]
]
where
pp_boot | mi_boot iface = ptext SLIT("[boot]")
| otherwise = empty
......
......@@ -244,7 +244,8 @@ mkIface hsc_env maybe_old_iface
mg_deps = deps,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_deprecs = src_deprecs})
mg_deprecs = src_deprecs,
mg_hpc_info = hpc_info })
(ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
......@@ -304,6 +305,7 @@ mkIface hsc_env maybe_old_iface
mi_finsts = False, -- Ditto
mi_decls = deliberatelyOmitted "decls",
mi_ver_fn = deliberatelyOmitted "ver_fn",
mi_hpc = isHpcUsed hpc_info,
-- And build the cached values
mi_dep_fn = mkIfaceDepCache deprecs,
......@@ -472,7 +474,8 @@ addVersionInfo ver_fn (Just old_iface@(ModIface {
-- If the usages havn't changed either, we don't need to write the interface file
no_other_changes = mi_usages new_iface == mi_usages old_iface &&
mi_deps new_iface == mi_deps old_iface
mi_deps new_iface == mi_deps old_iface &&
mi_hpc new_iface == mi_hpc old_iface
no_change_at_all = no_output_change && no_other_changes
pp_diffs = vcat [pp_change no_export_change "Export list"
......
......@@ -61,7 +61,7 @@ module HscTypes (
Linkable(..), isObjectLinkable,
Unlinked(..), CompiledByteCode,
isObject, nameOfObject, isInterpretable, byteCodeOfObject,
HpcInfo(..), noHpcInfo,
HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,
-- Breakpoints
ModBreaks (..), BreakIndex, emptyModBreaks,
......@@ -473,12 +473,14 @@ data ModIface
-- and are not put into the interface file
mi_dep_fn :: Name -> Maybe DeprecTxt, -- Cached lookup for mi_deprecs
mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities
mi_ver_fn :: OccName -> Maybe (OccName, Version)
mi_ver_fn :: OccName -> Maybe (OccName, Version),
-- Cached lookup for mi_decls
-- The Nothing in mi_ver_fn means that the thing
-- isn't in decls. It's useful to know that when
-- seeing if we are up to date wrt the old interface
-- The 'OccName' is the parent of the name, if it has one.
mi_hpc :: !AnyHpcUsage
-- True if this program uses Hpc at any point in the program.
}
-- Should be able to construct ModDetails from mi_decls in ModIface
......@@ -629,7 +631,8 @@ emptyModIface mod
mi_vect_info = noIfaceVectInfo,
mi_dep_fn = emptyIfaceDepCache,
mi_fix_fn = emptyIfaceFixCache,
mi_ver_fn = emptyIfaceVerCache
mi_ver_fn = emptyIfaceVerCache,
mi_hpc = False
}
\end{code}
......@@ -1255,14 +1258,26 @@ showModMsg target recomp mod_summary
%************************************************************************
\begin{code}
data HpcInfo = HpcInfo
data HpcInfo
= HpcInfo
{ hpcInfoTickCount :: Int
, hpcInfoHash :: Int
}
| NoHpcInfo
| NoHpcInfo
{ hpcUsed :: AnyHpcUsage -- is hpc used anywhere on the module tree?
}
-- This is used to mean there is no module-local hpc usage,
-- but one of my imports used hpc instrumentation.
type AnyHpcUsage = Bool
emptyHpcInfo :: AnyHpcUsage -> HpcInfo
emptyHpcInfo = NoHpcInfo
noHpcInfo :: HpcInfo
noHpcInfo = NoHpcInfo
isHpcUsed :: HpcInfo -> AnyHpcUsage
isHpcUsed (HpcInfo {}) = True
isHpcUsed (NoHpcInfo { hpcUsed = used }) = used
\end{code}
%************************************************************************
......
......@@ -57,7 +57,7 @@ import Monad ( when )
\begin{code}
rnImports :: [LImportDecl RdrName]
-> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails)
-> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage)
rnImports imports
-- PROCESS IMPORT DECLS
......@@ -75,18 +75,19 @@ rnImports imports
stuff1 <- mapM (rnImportDecl this_mod) (prel_imports ++ ordinary)
stuff2 <- mapM (rnImportDecl this_mod) source
let (decls, rdr_env, imp_avails) = combine (stuff1 ++ stuff2)
return (decls, rdr_env, imp_avails)
let (decls, rdr_env, imp_avails,hpc_usage) = combine (stuff1 ++ stuff2)
return (decls, rdr_env, imp_avails,hpc_usage)
where
combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails)]
-> ([LImportDecl Name], GlobalRdrEnv, ImportAvails)
combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails)
where plus (decl, gbl_env1, imp_avails1)
(decls, gbl_env2, imp_avails2)
combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage)]
-> ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage)
combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails,False)
where plus (decl, gbl_env1, imp_avails1,hpc_usage1)
(decls, gbl_env2, imp_avails2,hpc_usage2)
= (decl:decls,
gbl_env1 `plusGlobalRdrEnv` gbl_env2,
imp_avails1 `plusImportAvails` imp_avails2)
imp_avails1 `plusImportAvails` imp_avails2,
hpc_usage1 || hpc_usage2)
mkPrelImports :: Module -> Bool -> [LImportDecl RdrName] -> [LImportDecl RdrName]
-- Consruct the implicit declaration "import Prelude" (or not)
......@@ -119,7 +120,7 @@ mkPrelImports this_mod implicit_prelude import_decls
rnImportDecl :: Module
-> LImportDecl RdrName
-> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails)
-> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage)
rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot
qual_only as_mod imp_details))
......@@ -245,7 +246,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot
let new_imp_decl = L loc (ImportDecl loc_imp_mod_name want_boot
qual_only as_mod new_imp_details)
returnM (new_imp_decl, gbl_env, imports)
returnM (new_imp_decl, gbl_env, imports, mi_hpc iface)
)
warnRedundantSourceImport mod_name
......
......@@ -197,7 +197,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax
\begin{code}
tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv
tcRnImports hsc_env this_mod import_decls
= do { (rn_imports, rdr_env, imports) <- rnImports import_decls ;
= do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
; dep_mods = imp_dep_mods imports
......@@ -226,7 +226,8 @@ tcRnImports hsc_env this_mod import_decls
tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl),
tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
home_fam_insts
home_fam_insts,
tcg_hpc = hpc_info
}) $ do {
; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
......@@ -323,7 +324,7 @@ 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 = emptyHpcInfo False,
mg_modBreaks = emptyModBreaks,
mg_vect_info = noVectInfo
} } ;
......
......@@ -113,7 +113,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcg_dfun_n = dfun_n_var,
tcg_keep = keep_var,
tcg_doc = Nothing,
tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing
tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing,
tcg_hpc = False
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
......
......@@ -226,7 +226,8 @@ data TcGblEnv
tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports
tcg_doc :: Maybe (HsDoc Name), -- Maybe Haddock documentation
tcg_hmi :: HaddockModInfo Name -- Haddock module information
tcg_hmi :: HaddockModInfo Name, -- Haddock module information
tcg_hpc :: AnyHpcUsage -- True if any part of the prog uses hpc instrumentation.
}
type RecFieldEnv = NameEnv [Name] -- Maps a constructor name *in this module*
......
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