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

Make -fhpc a dynamic flag

parent af4f9871
...@@ -35,7 +35,6 @@ import OldPprCmm () ...@@ -35,7 +35,6 @@ import OldPprCmm ()
import StgSyn import StgSyn
import PrelNames import PrelNames
import DynFlags import DynFlags
import StaticFlags
import HscTypes import HscTypes
import CostCentre import CostCentre
...@@ -101,7 +100,7 @@ mkModuleInit ...@@ -101,7 +100,7 @@ mkModuleInit
mkModuleInit dflags cost_centre_info this_mod hpc_info mkModuleInit dflags cost_centre_info this_mod hpc_info
= do { -- Allocate the static boolean that records if this = do { -- Allocate the static boolean that records if this
; whenC (opt_Hpc) $ ; whenC (dopt Opt_Hpc dflags) $
hpcTable this_mod hpc_info hpcTable this_mod hpc_info
; whenC (dopt Opt_SccProfilingOn dflags) $ do ; whenC (dopt Opt_SccProfilingOn dflags) $ do
......
...@@ -17,7 +17,7 @@ import Module ...@@ -17,7 +17,7 @@ import Module
import CmmUtils import CmmUtils
import StgCmmUtils import StgCmmUtils
import HscTypes import HscTypes
import StaticFlags import DynFlags
mkTickBox :: Module -> Int -> CmmAGraph mkTickBox :: Module -> Int -> CmmAGraph
mkTickBox mod n mkTickBox mod n
...@@ -35,9 +35,10 @@ initHpc :: Module -> HpcInfo -> FCode () ...@@ -35,9 +35,10 @@ initHpc :: Module -> HpcInfo -> FCode ()
initHpc _ (NoHpcInfo {}) initHpc _ (NoHpcInfo {})
= return () = return ()
initHpc this_mod (HpcInfo tickCount _hashNo) initHpc this_mod (HpcInfo tickCount _hashNo)
= whenC opt_Hpc $ = do dflags <- getDynFlags
do { emitDataLits (mkHpcTicksLabel this_mod) whenC (dopt Opt_Hpc dflags) $
[ (CmmInt 0 W64) do emitDataLits (mkHpcTicksLabel this_mod)
| _ <- take tickCount [0::Int ..] [ (CmmInt 0 W64)
] | _ <- take tickCount [0 :: Int ..]
} ]
...@@ -23,7 +23,6 @@ import VarSet ...@@ -23,7 +23,6 @@ import VarSet
import Data.List import Data.List
import FastString import FastString
import HscTypes import HscTypes
import StaticFlags
import TyCon import TyCon
import Unique import Unique
import BasicTypes import BasicTypes
...@@ -91,7 +90,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = ...@@ -91,7 +90,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
, this_mod = mod , this_mod = mod
, tickishType = case hscTarget dflags of , tickishType = case hscTarget dflags of
HscInterpreted -> Breakpoints HscInterpreted -> Breakpoints
_ | opt_Hpc -> HpcTicks _ | dopt Opt_Hpc dflags -> HpcTicks
| dopt Opt_SccProfilingOn dflags | dopt Opt_SccProfilingOn dflags
-> ProfNotes -> ProfNotes
| otherwise -> error "addTicksToBinds: No way to annotate!" | otherwise -> error "addTicksToBinds: No way to annotate!"
...@@ -146,7 +145,7 @@ mkModBreaks count entries = do ...@@ -146,7 +145,7 @@ mkModBreaks count entries = do
writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
writeMixEntries dflags mod count entries filename writeMixEntries dflags mod count entries filename
| not opt_Hpc = return 0 | not (dopt Opt_Hpc dflags) = return 0
| otherwise = do | otherwise = do
let let
hpc_dir = hpcDir dflags hpc_dir = hpcDir dflags
...@@ -184,7 +183,7 @@ data TickDensity ...@@ -184,7 +183,7 @@ data TickDensity
mkDensity :: DynFlags -> TickDensity mkDensity :: DynFlags -> TickDensity
mkDensity dflags mkDensity dflags
| opt_Hpc = TickForCoverage | dopt Opt_Hpc dflags = TickForCoverage
| HscInterpreted <- hscTarget dflags = TickForBreakPoints | HscInterpreted <- hscTarget dflags = TickForBreakPoints
| ProfAutoAll <- profAuto dflags = TickAllFunctions | ProfAutoAll <- profAuto dflags = TickAllFunctions
| ProfAutoTop <- profAuto dflags = TickTopFunctions | ProfAutoTop <- profAuto dflags = TickTopFunctions
......
...@@ -16,7 +16,6 @@ The Desugarer: turning HsSyn into Core. ...@@ -16,7 +16,6 @@ The Desugarer: turning HsSyn into Core.
module Desugar ( deSugar, deSugarExpr ) where module Desugar ( deSugar, deSugarExpr ) where
import DynFlags import DynFlags
import StaticFlags
import HscTypes import HscTypes
import HsSyn import HsSyn
import TcRnTypes import TcRnTypes
...@@ -109,7 +108,7 @@ deSugar hsc_env ...@@ -109,7 +108,7 @@ deSugar hsc_env
Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
_ -> do _ -> do
let want_ticks = opt_Hpc let want_ticks = dopt Opt_Hpc dflags
|| target == HscInterpreted || target == HscInterpreted
|| (dopt Opt_SccProfilingOn dflags || (dopt Opt_SccProfilingOn dflags
&& case profAuto dflags of && case profAuto dflags of
...@@ -130,7 +129,7 @@ deSugar hsc_env ...@@ -130,7 +129,7 @@ deSugar hsc_env
; ds_rules <- mapMaybeM dsRule rules ; ds_rules <- mapMaybeM dsRule rules
; ds_vects <- mapM dsVect vects ; ds_vects <- mapM dsVect vects
; let hpc_init ; let hpc_init
| opt_Hpc = hpcInitCode mod ds_hpc_info | dopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty | otherwise = empty
; return ( ds_ev_binds ; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs , foreign_prs `appOL` core_prs `appOL` spec_prs
......
...@@ -327,6 +327,7 @@ data DynFlag ...@@ -327,6 +327,7 @@ data DynFlag
| Opt_SccProfilingOn | Opt_SccProfilingOn
| Opt_Ticky | Opt_Ticky
| Opt_Static | Opt_Static
| Opt_Hpc
-- output style opts -- output style opts
| Opt_PprCaseAsLet | Opt_PprCaseAsLet
...@@ -2275,7 +2276,8 @@ fFlags = [ ...@@ -2275,7 +2276,8 @@ fFlags = [
( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ),
( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ),
( "prof-count-entries", Opt_ProfCountEntries, 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\>@ -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
......
...@@ -37,9 +37,6 @@ module StaticFlags ( ...@@ -37,9 +37,6 @@ module StaticFlags (
opt_SuppressTypeSignatures, opt_SuppressTypeSignatures,
opt_SuppressVarKinds, opt_SuppressVarKinds,
-- Hpc opts
opt_Hpc,
-- language opts -- language opts
opt_DictsStrict, opt_DictsStrict,
...@@ -219,10 +216,6 @@ opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") ...@@ -219,10 +216,6 @@ opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
opt_NoDebugOutput :: Bool opt_NoDebugOutput :: Bool
opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")
-- Hpc opts
opt_Hpc :: Bool
opt_Hpc = lookUp (fsLit "-fhpc")
-- language opts -- language opts
opt_DictsStrict :: Bool opt_DictsStrict :: Bool
opt_DictsStrict = lookUp (fsLit "-fdicts-strict") opt_DictsStrict = lookUp (fsLit "-fdicts-strict")
......
...@@ -57,7 +57,7 @@ module Lexer ( ...@@ -57,7 +57,7 @@ module Lexer (
extension, bangPatEnabled, datatypeContextsEnabled, extension, bangPatEnabled, datatypeContextsEnabled,
traditionalRecordSyntaxEnabled, traditionalRecordSyntaxEnabled,
typeLiteralsEnabled, typeLiteralsEnabled,
explicitNamespacesEnabled, sccProfilingOn, explicitNamespacesEnabled, sccProfilingOn, hpcEnabled,
addWarning, addWarning,
lexTokenStream lexTokenStream
) where ) where
...@@ -1851,6 +1851,8 @@ rawTokenStreamBit :: Int ...@@ -1851,6 +1851,8 @@ rawTokenStreamBit :: Int
rawTokenStreamBit = 20 -- producing a token stream with all comments included rawTokenStreamBit = 20 -- producing a token stream with all comments included
sccProfilingOnBit :: Int sccProfilingOnBit :: Int
sccProfilingOnBit = 21 sccProfilingOnBit = 21
hpcBit :: Int
hpcBit = 22
alternativeLayoutRuleBit :: Int alternativeLayoutRuleBit :: Int
alternativeLayoutRuleBit = 23 alternativeLayoutRuleBit = 23
relaxedLayoutBit :: Int relaxedLayoutBit :: Int
...@@ -1907,6 +1909,8 @@ rawTokenStreamEnabled :: Int -> Bool ...@@ -1907,6 +1909,8 @@ rawTokenStreamEnabled :: Int -> Bool
rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit
alternativeLayoutRule :: Int -> Bool alternativeLayoutRule :: Int -> Bool
alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit
hpcEnabled :: Int -> Bool
hpcEnabled flags = testBit flags hpcBit
relaxedLayout :: Int -> Bool relaxedLayout :: Int -> Bool
relaxedLayout flags = testBit flags relaxedLayoutBit relaxedLayout flags = testBit flags relaxedLayoutBit
nondecreasingIndentation :: Int -> Bool nondecreasingIndentation :: Int -> Bool
...@@ -1977,6 +1981,7 @@ mkPState flags buf loc = ...@@ -1977,6 +1981,7 @@ mkPState flags buf loc =
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. hpcBit `setBitIf` dopt Opt_Hpc flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
.|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. sccProfilingOnBit `setBitIf` dopt Opt_SccProfilingOn flags .|. sccProfilingOnBit `setBitIf` dopt Opt_SccProfilingOn flags
......
...@@ -53,7 +53,6 @@ import OccName ( varName, dataName, tcClsName, tvName ) ...@@ -53,7 +53,6 @@ import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName ) import DataCon ( DataCon, dataConName )
import SrcLoc import SrcLoc
import Module import Module
import StaticFlags ( opt_Hpc )
import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
import Class ( FunDep ) import Class ( FunDep )
import BasicTypes import BasicTypes
...@@ -1416,9 +1415,10 @@ exp10 :: { LHsExpr RdrName } ...@@ -1416,9 +1415,10 @@ exp10 :: { LHsExpr RdrName }
; return $ LL $ if on ; return $ LL $ if on
then HsSCC (unLoc $1) $2 then HsSCC (unLoc $1) $2
else HsPar $2 } } else HsPar $2 } }
| hpc_annot exp { LL $ if opt_Hpc | hpc_annot exp {% do { on <- extension hpcEnabled
then HsTickPragma (unLoc $1) $2 ; return $ LL $ if on
else HsPar $2 } then HsTickPragma (unLoc $1) $2
else HsPar $2 } }
| 'proc' aexp '->' exp | 'proc' aexp '->' exp
{% checkPattern $2 >>= \ p -> {% checkPattern $2 >>= \ p ->
......
...@@ -1847,7 +1847,7 @@ ...@@ -1847,7 +1847,7 @@
<row> <row>
<entry><option>-fhpc</option></entry> <entry><option>-fhpc</option></entry>
<entry>Turn on Haskell program coverage instrumentation</entry> <entry>Turn on Haskell program coverage instrumentation</entry>
<entry>static</entry> <entry>dynamic</entry>
<entry><option>-</option></entry> <entry><option>-</option></entry>
</row> </row>
<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