Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
7b11baa6
Commit
7b11baa6
authored
Sep 03, 2012
by
ian@well-typed.com
Browse files
Make -fhpc a dynamic flag
parent
af4f9871
Changes
9
Hide whitespace changes
Inline
Side-by-side
compiler/codeGen/CodeGen.lhs
View file @
7b11baa6
...
...
@@ -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 (
d
opt
Opt_Hpc dflags
) $
hpcTable this_mod hpc_info
; whenC (dopt Opt_SccProfilingOn dflags) $ do
...
...
compiler/codeGen/StgCmmHpc.hs
View file @
7b11baa6
...
...
@@ -17,7 +17,7 @@ import Module
import
CmmUtils
import
StgCmmUtils
import
HscTypes
import
Static
Flags
import
Dyn
Flags
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
View file @
7b11baa6
...
...
@@ -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
_ |
o
pt_Hpc
-> HpcTicks
_ |
dopt O
pt_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
(d
opt
Opt_Hpc dflags)
= return 0
| otherwise = do
let
hpc_dir = hpcDir dflags
...
...
@@ -184,7 +183,7 @@ data TickDensity
mkDensity :: DynFlags -> TickDensity
mkDensity dflags
|
o
pt_Hpc
= TickForCoverage
|
dopt O
pt_Hpc
dflags
= TickForCoverage
| HscInterpreted <- hscTarget dflags = TickForBreakPoints
| ProfAutoAll <- profAuto dflags = TickAllFunctions
| ProfAutoTop <- profAuto dflags = TickTopFunctions
...
...
compiler/deSugar/Desugar.lhs
View file @
7b11baa6
...
...
@@ -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 =
d
opt
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
|
o
pt_Hpc
= hpcInitCode mod ds_hpc_info
|
dopt O
pt_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
View file @
7b11baa6
...
...
@@ -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
View file @
7b11baa6
...
...
@@ -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
View file @
7b11baa6
...
...
@@ -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
View file @
7b11baa6
...
...
@@ -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
View file @
7b11baa6
...
...
@@ -1847,7 +1847,7 @@
<row>
<entry><option>
-fhpc
</option></entry>
<entry>
Turn on Haskell program coverage instrumentation
</entry>
<entry>
stat
ic
</entry>
<entry>
dynam
ic
</entry>
<entry><option>
-
</option></entry>
</row>
<row>
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment