Make -fhpc a dynamic flag

compiler/codeGen/CodeGen.lhs

@@ -35,7 +35,6 @@ import OldPprCmm ()
 import StgSyn
 import PrelNames
 import DynFlags
-import StaticFlags
 
 import HscTypes
 import CostCentre
@@ -101,7 +100,7 @@ mkModuleInit
 
 mkModuleInit dflags cost_centre_info this_mod hpc_info
   = do  { -- Allocate the static boolean that records if this
-        ; whenC (opt_Hpc) $
+        ; whenC (dopt Opt_Hpc dflags) $
               hpcTable this_mod hpc_info
 
         ; whenC (dopt Opt_SccProfilingOn dflags) $ do

compiler/codeGen/StgCmmHpc.hs

@@ -17,7 +17,7 @@ import Module
 import CmmUtils
 import StgCmmUtils
 import HscTypes
-import StaticFlags
+import DynFlags
 
 mkTickBox :: Module -> Int -> CmmAGraph
 mkTickBox mod n 
@@ -35,9 +35,10 @@ initHpc :: Module -> HpcInfo -> FCode ()
 initHpc _ (NoHpcInfo {})
   = return ()
 initHpc this_mod (HpcInfo tickCount _hashNo)
-  = whenC opt_Hpc $
-    do  { emitDataLits (mkHpcTicksLabel this_mod)
-                       [ (CmmInt 0 W64)
-                       | _ <- take tickCount [0::Int ..]
-                       ]
-       }
+  = do dflags <- getDynFlags
+       whenC (dopt Opt_Hpc dflags) $
+           do emitDataLits (mkHpcTicksLabel this_mod)
+                           [ (CmmInt 0 W64)
+                           | _ <- take tickCount [0 :: Int ..]
+                           ]
+

compiler/deSugar/Coverage.lhs

@@ -23,7 +23,6 @@ import VarSet
 import Data.List
 import FastString
 import HscTypes
-import StaticFlags
 import TyCon
 import Unique
 import BasicTypes
@@ -91,7 +90,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
                       , this_mod     = mod
                       , tickishType  = case hscTarget dflags of
                           HscInterpreted          -> Breakpoints
-                          _ | opt_Hpc             -> HpcTicks
+                          _ | dopt Opt_Hpc dflags -> HpcTicks
                             | dopt Opt_SccProfilingOn dflags
                                                   -> ProfNotes
                             | otherwise           -> error "addTicksToBinds: No way to annotate!"
@@ -146,7 +145,7 @@ mkModBreaks count entries = do
 
 writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
 writeMixEntries dflags mod count entries filename
-  | not opt_Hpc = return 0
+  | not (dopt Opt_Hpc dflags) = return 0
   | otherwise   = do
         let
             hpc_dir = hpcDir dflags
@@ -184,7 +183,7 @@ data TickDensity
 
 mkDensity :: DynFlags -> TickDensity
 mkDensity dflags
-  | opt_Hpc                              = TickForCoverage
+  | dopt Opt_Hpc dflags                  = TickForCoverage
   | HscInterpreted  <- hscTarget dflags  = TickForBreakPoints
   | ProfAutoAll     <- profAuto dflags   = TickAllFunctions
   | ProfAutoTop     <- profAuto dflags   = TickTopFunctions

compiler/deSugar/Desugar.lhs

@@ -16,7 +16,6 @@ The Desugarer: turning HsSyn into Core.
 module Desugar ( deSugar, deSugarExpr ) where
 
 import DynFlags
-import StaticFlags
 import HscTypes
 import HsSyn
 import TcRnTypes
@@ -109,7 +108,7 @@ deSugar hsc_env
                                Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
                    _        -> do
 
-                     let want_ticks = opt_Hpc
+                     let want_ticks = dopt Opt_Hpc dflags
                                    || target == HscInterpreted
                                    || (dopt Opt_SccProfilingOn dflags
                                        && case profAuto dflags of
@@ -130,7 +129,7 @@ deSugar hsc_env
                           ; ds_rules <- mapMaybeM dsRule rules
                           ; ds_vects <- mapM dsVect vects
                           ; let hpc_init
-                                  | opt_Hpc   = hpcInitCode mod ds_hpc_info
+                                  | dopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs

compiler/main/DynFlags.hs

@@ -327,6 +327,7 @@ data DynFlag
    | Opt_SccProfilingOn
    | Opt_Ticky
    | Opt_Static
+   | Opt_Hpc
 
    -- output style opts
    | Opt_PprCaseAsLet
@@ -2275,7 +2276,8 @@ fFlags = [
   ( "building-cabal-package",           Opt_BuildingCabalPackage, nop ),
   ( "implicit-import-qualified",        Opt_ImplicitImportQualified, nop ),
   ( "prof-count-entries",               Opt_ProfCountEntries, nop ),
-  ( "prof-cafs",                        Opt_AutoSccsOnIndividualCafs, nop )
+  ( "prof-cafs",                        Opt_AutoSccsOnIndividualCafs, nop ),
+  ( "hpc",                              Opt_Hpc, nop )
   ]
 
 -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@

compiler/main/StaticFlags.hs

@@ -37,9 +37,6 @@ module StaticFlags (
 	opt_SuppressTypeSignatures,
         opt_SuppressVarKinds,
 
-        -- Hpc opts
-	opt_Hpc,
-
 	-- language opts
 	opt_DictsStrict,
 
@@ -219,10 +216,6 @@ opt_PprStyle_Debug              = lookUp  (fsLit "-dppr-debug")
 opt_NoDebugOutput   :: Bool
 opt_NoDebugOutput               = lookUp  (fsLit "-dno-debug-output")
 
--- Hpc opts
-opt_Hpc :: Bool
-opt_Hpc				= lookUp (fsLit "-fhpc")
-
 -- language opts
 opt_DictsStrict :: Bool
 opt_DictsStrict			= lookUp  (fsLit "-fdicts-strict")

compiler/parser/Lexer.x

@@ -57,7 +57,7 @@ module Lexer (
    extension, bangPatEnabled, datatypeContextsEnabled,
    traditionalRecordSyntaxEnabled,
    typeLiteralsEnabled,
-   explicitNamespacesEnabled, sccProfilingOn,
+   explicitNamespacesEnabled, sccProfilingOn, hpcEnabled,
    addWarning,
    lexTokenStream
   ) where
@@ -1851,6 +1851,8 @@ rawTokenStreamBit :: Int
 rawTokenStreamBit = 20 -- producing a token stream with all comments included
 sccProfilingOnBit :: Int
 sccProfilingOnBit = 21
+hpcBit :: Int
+hpcBit = 22
 alternativeLayoutRuleBit :: Int
 alternativeLayoutRuleBit = 23
 relaxedLayoutBit :: Int
@@ -1907,6 +1909,8 @@ rawTokenStreamEnabled :: Int -> Bool
 rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit
 alternativeLayoutRule :: Int -> Bool
 alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit
+hpcEnabled :: Int -> Bool
+hpcEnabled flags = testBit flags hpcBit
 relaxedLayout :: Int -> Bool
 relaxedLayout flags = testBit flags relaxedLayoutBit
 nondecreasingIndentation :: Int -> Bool
@@ -1977,6 +1981,7 @@ mkPState flags buf loc =
                .|. transformComprehensionsBit  `setBitIf` xopt Opt_TransformListComp        flags
                .|. transformComprehensionsBit  `setBitIf` xopt Opt_MonadComprehensions      flags
                .|. rawTokenStreamBit           `setBitIf` dopt Opt_KeepRawTokenStream       flags
+               .|. hpcBit                      `setBitIf` dopt Opt_Hpc                      flags
                .|. alternativeLayoutRuleBit    `setBitIf` xopt Opt_AlternativeLayoutRule    flags
                .|. relaxedLayoutBit            `setBitIf` xopt Opt_RelaxedLayout            flags
                .|. sccProfilingOnBit           `setBitIf` dopt Opt_SccProfilingOn           flags

compiler/parser/Parser.y.pp

@@ -53,7 +53,6 @@ import OccName          ( varName, dataName, tcClsName, tvName )
 import DataCon          ( DataCon, dataConName )
 import SrcLoc
 import Module
-import StaticFlags      ( opt_Hpc )
 import Kind             ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
 import Class            ( FunDep )
 import BasicTypes
@@ -1416,9 +1415,10 @@ exp10 :: { LHsExpr RdrName }
                                           ; return $ LL $ if on
                                                           then HsSCC (unLoc $1) $2
                                                           else HsPar $2 } }
-        | hpc_annot exp                         { LL $ if opt_Hpc
-                                                        then HsTickPragma (unLoc $1) $2
-                                                        else HsPar $2 }
+        | hpc_annot exp                         {% do { on <- extension hpcEnabled
+                                                      ; return $ LL $ if on
+                                                                      then HsTickPragma (unLoc $1) $2
+                                                                      else HsPar $2 } }
 
         | 'proc' aexp '->' exp  
                         {% checkPattern $2 >>= \ p -> 

docs/users_guide/flags.xml

@@ -1847,7 +1847,7 @@
           <row>
             <entry><option>-fhpc</option></entry>
             <entry>Turn on Haskell program coverage instrumentation</entry>
-            <entry>static</entry>
+            <entry>dynamic</entry>
             <entry><option>-</option></entry>
           </row>
           <row>