Commit 7b11baa6 authored by ian@well-typed.com's avatar ian@well-typed.com

Make -fhpc a dynamic flag

parent af4f9871
......@@ -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
......
......@@ -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 ..]
]
......@@ -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
......
......@@ -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
......
......@@ -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\>@
......
......@@ -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")
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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>
......
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