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.

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)

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
 

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)
 

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

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,

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

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" 

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}
 
 %************************************************************************

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

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
 		    } } ;

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,

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*