From c1681a73fa4ca4cf8758264ae387ac09a9e900d8 Mon Sep 17 00:00:00 2001 From: "andy@galois.com" Date: Tue, 17 Jul 2007 07:35:10 +0000 Subject: [PATCH] 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 .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. --- compiler/codeGen/CgHpc.hs | 2 +- compiler/codeGen/CodeGen.lhs | 2 +- compiler/deSugar/Coverage.lhs | 2 +- compiler/deSugar/Desugar.lhs | 12 ++++++++---- compiler/iface/BinIface.hs | 6 +++++- compiler/iface/LoadIface.lhs | 3 ++- compiler/iface/MkIface.lhs | 7 +++++-- compiler/main/HscTypes.lhs | 29 ++++++++++++++++++++++------- compiler/rename/RnNames.lhs | 23 ++++++++++++----------- compiler/typecheck/TcRnDriver.lhs | 7 ++++--- compiler/typecheck/TcRnMonad.lhs | 3 ++- compiler/typecheck/TcRnTypes.lhs | 3 ++- 12 files changed, 65 insertions(+), 34 deletions(-) diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index ed58daa..6da243b 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -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) diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 4c7f570..863d29e 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -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 diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 2d2cb2a..f2ad77c 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -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) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index e2b22ee..9a4c261 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index d852559..d79ec95 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -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, diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 6835fe6..5c7d816 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index de191de..564d3a4 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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" diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index a74b1b3..85cf73e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -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} %************************************************************************ diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 26fadbe..8b09f52 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -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 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 5e138b3..8468f87 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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 } } ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 3c1f510..f36be69 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -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, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index be37c16..4785a49 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -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* -- 1.7.10.4