Adding pushing of hpc translation status through hi files.
authorandy@galois.com <unknown>
Tue, 17 Jul 2007 07:35:10 +0000 (07:35 +0000)
committerandy@galois.com <unknown>
Tue, 17 Jul 2007 07:35:10 +0000 (07:35 +0000)
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.

12 files changed:
compiler/codeGen/CgHpc.hs
compiler/codeGen/CodeGen.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/iface/BinIface.hs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/main/HscTypes.lhs
compiler/rename/RnNames.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs

index ed58daa..6da243b 100644 (file)
@@ -57,7 +57,7 @@ hpcTable this_mod (HpcInfo hpc_tickCount _) = do
                      else packageIdString (modulePackageId this_mod) ++ "/" ++
                           module_name_str
 
                      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)
 
 initHpc :: Module -> HpcInfo -> Code
 initHpc this_mod (HpcInfo tickCount hashNo)
index 4c7f570..863d29e 100644 (file)
@@ -224,7 +224,7 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe
                       , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
 
 
                       , 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
 
                       then jump_to_init
                       else ret_code
 
index 2d2cb2a..f2ad77c 100644 (file)
@@ -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"
 
                    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)
 
 
   let mod_name = moduleNameString (moduleName mod)
 
index e2b22ee..9a4c261 100644 (file)
@@ -78,7 +78,8 @@ deSugar hsc_env
                            tcg_fords        = fords,
                            tcg_rules        = rules,
                            tcg_insts        = insts,
                            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"
 
   = 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 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
        ; mb_res <- case target of
-                    HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
+                    HscNothing -> return (Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
                      _        -> do (binds_cvr,ds_hpc_info, modBreaks) 
                      _        -> 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 
                                                  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
                                     initDs hsc_env mod rdr_env type_env $ do
                                        { core_prs <- dsTopLHsBinds auto_scc binds_cvr
                                        ; (ds_fords, foreign_prs) <- dsForeigns fords
index d852559..d79ec95 100644 (file)
@@ -295,7 +295,8 @@ instance Binary ModIface where
                 mi_fam_insts = fam_insts,
                 mi_rules     = rules,
                 mi_rule_vers = rule_vers,
                 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
        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
        lazyPut bh rules
        put_ bh rule_vers
         put_ bh vect_info
+       put_ bh hpc_info
 
    get bh = do
        mod_name  <- get bh
 
    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
        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,
        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_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,
                        -- And build the cached values
                 mi_dep_fn    = mkIfaceDepCache deprecs,
                 mi_fix_fn    = mkIfaceFixCache fixities,
index 6835fe6..5c7d816 100644 (file)
@@ -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)
                <+> 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))
                <+> 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)
        , 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
   where
     pp_boot | mi_boot iface = ptext SLIT("[boot]")
            | otherwise     = empty
index de191de..564d3a4 100644 (file)
@@ -244,7 +244,8 @@ mkIface hsc_env maybe_old_iface
                      mg_deps      = deps,
                      mg_rdr_env   = rdr_env,
                      mg_fix_env   = fix_env,
                      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,
        (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_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,
 
                        -- 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 && 
 
        -- 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" 
     no_change_at_all = no_output_change && no_other_changes
  
     pp_diffs = vcat [pp_change no_export_change "Export list" 
index a74b1b3..85cf73e 100644 (file)
@@ -61,7 +61,7 @@ module HscTypes (
        Linkable(..), isObjectLinkable,
        Unlinked(..), CompiledByteCode,
        isObject, nameOfObject, isInterpretable, byteCodeOfObject,
        Linkable(..), isObjectLinkable,
        Unlinked(..), CompiledByteCode,
        isObject, nameOfObject, isInterpretable, byteCodeOfObject,
-        HpcInfo(..), noHpcInfo,
+        HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,
 
         -- Breakpoints
         ModBreaks (..), BreakIndex, emptyModBreaks,
 
         -- 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
                -- 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.
                         -- 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
      }
 
 -- 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_vect_info = noIfaceVectInfo,
               mi_dep_fn = emptyIfaceDepCache,
               mi_fix_fn = emptyIfaceFixCache,
-              mi_ver_fn = emptyIfaceVerCache
+              mi_ver_fn = emptyIfaceVerCache,
+              mi_hpc    = False
     }          
 \end{code}
 
     }          
 \end{code}
 
@@ -1255,14 +1258,26 @@ showModMsg target recomp mod_summary
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-data HpcInfo = HpcInfo 
+data HpcInfo 
+  = HpcInfo 
      { hpcInfoTickCount :: Int 
      , hpcInfoHash      :: Int  
      }
      { 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
index 26fadbe..8b09f52 100644 (file)
@@ -57,7 +57,7 @@ import Monad          ( when )
 
 \begin{code}
 rnImports :: [LImportDecl RdrName]
 
 \begin{code}
 rnImports :: [LImportDecl RdrName]
-           -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails)
+           -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage)
 
 rnImports imports
          -- PROCESS IMPORT DECLS
 
 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
 
          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
 
     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,
                 = (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)
 
 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
 
 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))
 
 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)
 
     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
     )
 
 warnRedundantSourceImport mod_name
index 5e138b3..8468f87 100644 (file)
@@ -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
 \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
 
        ; 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) 
               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))
            }) $ 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_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
                    } } ;
                                 mg_modBreaks = emptyModBreaks,
                                 mg_vect_info = noVectInfo
                    } } ;
index 3c1f510..f36be69 100644 (file)
@@ -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_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,
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
index be37c16..4785a49 100644 (file)
@@ -226,7 +226,8 @@ data TcGblEnv
        tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
 
        tcg_doc :: Maybe (HsDoc Name), -- Maybe Haddock documentation
        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*
     }
 
 type RecFieldEnv = NameEnv [Name]      -- Maps a constructor name *in this module*