Commit 98b2c508 authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan

Support SCC pragmas in declaration context

Not having SCCs at the top level is becoming annoying real quick. For
simplest cases, it's possible to do this transformation:

    f x y = ...
    =>
    f = {-# SCC f #-} \x y -> ...

However, it doesn't work when there's a `where` clause:

    f x y = <t is in scope>
      where t = ...
    =>
    f = {-# SCC f #-} \x y -> <t is out of scope>
      where t = ...

Or when we have a "equation style" definition:

    f (C1 ...) = ...
    f (C2 ...) = ...
    f (C3 ...) = ...
    ...

(usual solution is to rename `f` to `f'` and define a new `f` with a
`SCC`)

This patch implements support for SCC annotations in declaration
contexts. This is now a valid program:

    f x y = ...
      where
        g z = ...
        {-# SCC g #-}
    {-# SCC f #-}

Test Plan: This passes slow validate (no new failures added).

Reviewers: goldfire, mpickering, austin, bgamari, simonmar

Reviewed By: bgamari, simonmar

Subscribers: simonmar, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2407
parent 0df3f4cd
......@@ -695,8 +695,7 @@ rep_sigs sigs = do locs_cores <- rep_sigs' sigs
rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
-- We silently ignore ones we don't recognise
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
return (concat sigs1) }
rep_sigs' = concatMapM rep_sig
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
......@@ -711,6 +710,7 @@ rep_sig (L loc (SpecSig nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec loc) tys
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
......
......@@ -796,6 +796,18 @@ data Sig name
| MinimalSig SourceText (LBooleanFormula (Located name))
-- Note [Pragma source text] in BasicTypes
-- | A "set cost centre" pragma for declarations
--
-- > {-# SCC funName #-}
--
-- or
--
-- > {-# SCC funName "cost_centre_name" #-}
| SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes
(Located name) -- Function name
(Maybe StringLiteral)
deriving instance (DataId name) => Data (Sig name)
......@@ -855,6 +867,7 @@ isPragLSig :: LSig name -> Bool
-- Identifies pragmas
isPragLSig (L _ (SpecSig {})) = True
isPragLSig (L _ (InlineSig {})) = True
isPragLSig (L _ (SCCFunSig {})) = True
isPragLSig _ = False
isInlineLSig :: LSig name -> Bool
......@@ -864,7 +877,11 @@ isInlineLSig _ = False
isMinimalLSig :: LSig name -> Bool
isMinimalLSig (L _ (MinimalSig {})) = True
isMinimalLSig _ = False
isMinimalLSig _ = False
isSCCFunSig :: LSig name -> Bool
isSCCFunSig (L _ (SCCFunSig {})) = True
isSCCFunSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = text "type signature"
......@@ -878,6 +895,7 @@ hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma"
hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma"
hsSigDoc (FixSig {}) = text "fixity declaration"
hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
hsSigDoc (SCCFunSig {}) = text "SCC pragma"
{-
Check if signatures overlap; this is used when checking for duplicate
......@@ -903,6 +921,10 @@ ppr_sig (SpecInstSig _ ty)
ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf)
ppr_sig (PatSynSig names sig_ty)
= text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
ppr_sig (SCCFunSig _ fn Nothing)
= pragBrackets (text "SCC" <+> ppr fn)
ppr_sig (SCCFunSig _ fn (Just str))
= pragBrackets (text "SCC" <+> ppr fn <+> ppr (sl_st str))
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
......
......@@ -835,7 +835,7 @@ topdecl :: { LHsDecl RdrName }
-- The $(..) form is one possible form of infixexp
-- but we treat an arbitrary expression just as if
-- it had a $(..) wrapped around it
| infixexp { sLL $1 $> $ mkSpliceDecl $1 }
| infixexp_top { sLL $1 $> $ mkSpliceDecl $1 }
-- Type classes
--
......@@ -1989,7 +1989,7 @@ decl_no_th :: { LHsDecl RdrName }
-- Turn it all into an expression so that
-- checkPattern can check that bangs are enabled
| infixexp opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
| infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
let { l = comb2 $1 $> };
case r of {
(FunBind n _ _ _ _) ->
......@@ -2029,7 +2029,7 @@ gdrh :: { LGRHS RdrName (LHsExpr RdrName) }
sigdecl :: { LHsDecl RdrName }
:
-- See Note [Declaration/signature overlap] for why we need infixexp here
infixexp '::' sigtypedoc
infixexp_top '::' sigtypedoc
{% do v <- checkValSigLhs $1
; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
; return (sLL $1 $> $ SigD $
......@@ -2056,6 +2056,16 @@ sigdecl :: { LHsDecl RdrName }
(snd $2)))))
((mo $1:fst $2) ++ [mc $4]) }
| '{-# SCC' qvar '#-}'
{% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing)))
[mo $1, mc $3] }
| '{-# SCC' qvar STRING '#-}'
{% do { scc <- getSCC $3
; let str_lit = StringLiteral (getSTRINGs $3) scc
; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just str_lit))))
[mo $1, mc $4] } }
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
{% ams (
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
......@@ -2121,14 +2131,18 @@ exp :: { LHsExpr RdrName }
| infixexp { $1 }
infixexp :: { LHsExpr RdrName }
: exp10 { $1 }
| infixexp qop exp10 {% ams (sLL $1 $>
(OpApp $1 $2 placeHolderFixity $3))
[mj AnnVal $2] }
: exp10 { $1 }
| infixexp qop exp10 {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
infixexp_top :: { LHsExpr RdrName }
: exp10_top { $1 }
| infixexp_top qop exp10_top
{% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
[mj AnnVal $2] }
exp10 :: { LHsExpr RdrName }
exp10_top :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp
{% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
[sLL $1 $> $ Match { m_ctxt = LambdaExpr
......@@ -2170,9 +2184,6 @@ exp10 :: { LHsExpr RdrName }
(mkHsDo MDoExpr (snd $ unLoc $2)))
(mj AnnMdo $1:(fst $ unLoc $2)) }
| scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ unLoc $1) }
| hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1)
(snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ fst $ unLoc $1) }
......@@ -2191,6 +2202,11 @@ exp10 :: { LHsExpr RdrName }
-- hdaume: core annotation
| fexp { $1 }
exp10 :: { LHsExpr RdrName }
: exp10_top { $1 }
| scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ unLoc $1) }
optSemi :: { ([Located a],Bool) }
: ';' { ([$1],True) }
| {- empty -} { ([],False) }
......
......@@ -933,6 +933,10 @@ renameSig ctxt sig@(PatSynSig vs ty)
ty_ctxt = GenericCtx (text "a pattern synonym signature for"
<+> ppr_sig_bndrs vs)
renameSig ctxt sig@(SCCFunSig st v s)
= do { new_v <- lookupSigOccRn ctxt sig v
; return (SCCFunSig st new_v s, emptyFVs) }
ppr_sig_bndrs :: [Located RdrName] -> SDoc
ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
......@@ -971,6 +975,9 @@ okHsSig ctxt (L _ sig)
(MinimalSig {}, ClsDeclCtxt {}) -> True
(MinimalSig {}, _) -> False
(SCCFunSig {}, HsBootCtxt {}) -> False
(SCCFunSig {}, _) -> True
-------------------
findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
-- Check for duplicates on RdrName version,
......@@ -989,6 +996,7 @@ findDupSigs sigs
expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns]
expand_sig sig@(ClassOpSig _ ns _) = [(n,sig) | n <- ns]
expand_sig sig@(PatSynSig ns _ ) = [(n,sig) | n <- ns]
expand_sig sig@(SCCFunSig _ n _) = [(n,sig)]
expand_sig _ = []
matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2
......@@ -997,6 +1005,7 @@ findDupSigs sigs
mtch (TypeSig {}) (TypeSig {}) = True
mtch (ClassOpSig d1 _ _) (ClassOpSig d2 _ _) = d1 == d2
mtch (PatSynSig _ _) (PatSynSig _ _) = True
mtch (SCCFunSig{}) (SCCFunSig{}) = True
mtch _ _ = False
-- Warn about multiple MINIMAL signatures
......
......@@ -18,7 +18,10 @@ import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
, tcPatSynBuilderBind )
import CoreSyn (Tickish (..))
import CostCentre (mkUserCC)
import DynFlags
import FastString
import HsSyn
import HscTypes( isHsBootOrSig )
import TcSigs
......@@ -57,6 +60,7 @@ import BasicTypes
import Outputable
import PrelNames( gHC_PRIM, ipClassName )
import TcValidity (checkValidType)
import Unique (getUnique)
import UniqFM
import qualified GHC.LanguageExtensions as LangExt
......@@ -659,11 +663,12 @@ tcPolyCheck prag_fn
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
; mod <- getModule
; let bind' = FunBind { fun_id = L nm_loc mono_id
, fun_matches = matches'
, fun_co_fn = co_fn
, bind_fvs = placeHolderNamesTc
, fun_tick = [] }
, fun_tick = funBindTicks nm_loc mono_id mod prag_sigs }
abs_bind = L loc $ AbsBindsSig
{ abs_sig_export = poly_id
......@@ -678,6 +683,22 @@ tcPolyCheck prag_fn
tcPolyCheck _prag_fn sig bind
= pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig Name] -> [Tickish TcId]
funBindTicks loc fun_id mod sigs
| (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
-- this can only be a singleton list, as duplicate pragmas are rejected
-- by the renamer
, let cc_str
| Just cc_str <- mb_cc_str
= sl_fs cc_str
| otherwise
= getOccFS (Var.varName fun_id)
cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
cc = mkUserCC cc_name mod loc (getUnique fun_id)
= [ProfNote cc True True]
| otherwise
= []
{- Note [Instantiate sig with fresh variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's vital to instantiate a type signature with fresh variables.
......
......@@ -490,6 +490,7 @@ mkPragEnv sigs binds
get_sig :: LSig Name -> Maybe (Name, LSig Name)
get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl))
get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl))
get_sig (L l (SCCFunSig st lnm@(L _ nm) str)) = Just (nm, L l $ SCCFunSig st lnm str)
get_sig _ = Nothing
add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function
......@@ -666,7 +667,7 @@ tcSpecPrags poly_id prag_sigs
where
spec_sigs = filter isSpecLSig prag_sigs
bad_sigs = filter is_bad_sig prag_sigs
is_bad_sig s = not (isSpecLSig s || isInlineLSig s)
is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)
warn_discarded_sigs
= addWarnTc NoReason
......
......@@ -13,6 +13,7 @@ Highlights
The highlights since the 8.0 branch are:
- TODO FIXME
- SCC annotations can now be used for declarations.
Full details
------------
......@@ -32,7 +33,10 @@ Compiler
- Old profiling flags ``-auto-all``, ``-auto``, and ``-caf-all`` are deprecated
and their usage provokes a compile-time warning.
- Support for adding cost centres to declarations is added. The same `SCC`
syntax can be used, in addition to a new form for specifying the cost centre
name. See :ref:`scc-pragma` for examples.
GHCi
~~~~
......
......@@ -199,7 +199,7 @@ to the compiler, it automatically inserts a cost centre annotation
around every binding not marked INLINE in your program, but you are
entirely free to add cost centre annotations yourself.
The syntax of a cost centre annotation is ::
The syntax of a cost centre annotation for expressions is ::
{-# SCC "name" #-} <expression>
......@@ -210,7 +210,24 @@ extends as far to the right as possible when parsing. (SCC stands for
"Set Cost Centre"). The double quotes can be omitted if ``name`` is a
Haskell identifier, for example: ::
{-# SCC my_function #-} <expression>
{-# SCC id #-} <expression>
Cost centre annotations can also appear in the top-level or in a
declaration context. In that case you need to pass a function name
defined in the same module or scope with the annotation. Example: ::
f x y = ...
where
g z = ...
{-# SCC g #-}
{-# SCC f #-}
If you want to give a cost centre different name than the function name,
you can pass a string to the annotation ::
f x y = ...
{-# SCC f "cost_centre_name" #-}
Here is an example of a program with a couple of SCCs: ::
......
......@@ -76,6 +76,7 @@ config.way_flags = {
'optllvm' : ['-O', '-fllvm'],
'debugllvm' : ['-fllvm', '-keep-llvm-files'],
'prof' : ['-prof', '-static', '-fprof-auto', '-fasm'],
'prof_no_auto' : ['-prof', '-static', '-fasm'],
'profasm' : ['-O', '-prof', '-static', '-fprof-auto'],
'profthreaded' : ['-O', '-prof', '-static', '-fprof-auto', '-threaded'],
'ghci' : ['--interactive', '-v0', '-ignore-dot-ghci', '-fno-ghci-history', '+RTS', '-I0.1', '-RTS'],
......@@ -111,6 +112,7 @@ config.way_rts_flags = {
'optllvm' : [],
'debugllvm' : [],
'prof' : ['-p'],
'prof_no_auto' : ['-p'],
'profasm' : ['-hc', '-p'], # test heap profiling too
'profthreaded' : ['-p'],
'ghci' : [],
......
......@@ -104,7 +104,7 @@ test('T11627a', [extra_ways(extra_prof_ways)], compile_and_run, [''])
test('T11627b', [ extra_run_opts('+RTS -i0 -RTS') # census after each GC
, extra_ways(extra_prof_ways)
, when(opsys('mingw32'),
expect_broken_for(12236, ['prof_hc_hb']))
expect_broken_for(12236, ['prof_hc_hb']))
]
, compile_and_run
, [''])
......@@ -112,3 +112,8 @@ test('T11627b', [ extra_run_opts('+RTS -i0 -RTS') # census after each GC
test('T11978a',
[only_ways(['profthreaded']), extra_run_opts('+RTS -hb -N10')],
compile_and_run, [''])
test('toplevel_scc_1',
[extra_ways(['prof_no_auto']), only_ways(['prof_no_auto'])],
compile_and_run,
[''])
module Main where
f1 :: Int -> Int
f1 = (+ 1)
f2 :: Int -> Int
f2 = f3 . f3 . f3
where
f3 :: Int -> Int
f3 = (* 123)
{-# SCC f3 "bar" #-}
{-# NOINLINE f3 #-}
main :: IO ()
main = readLn >>= print . f2 . f1
{-# NOINLINE f1 #-}
{-# NOINLINE f2 #-}
{-# SCC f1 #-}
{-# SCC f2 "foo" #-}
Tue Jul 19 08:36 2016 Time and Allocation Profiling Report (Final)
toplevel_scc_1 +RTS -p -RTS
total time = 0.00 secs (0 ticks @ 1000 us, 1 processor)
total alloc = 79,792 bytes (excludes profiling overheads)
COST CENTRE MODULE SRC %time %alloc
CAF GHC.Read <entire-module> 0.0 1.2
CAF GHC.IO.Handle.FD <entire-module> 0.0 64.9
CAF GHC.IO.Encoding <entire-module> 0.0 3.5
CAF Main <entire-module> 0.0 27.6
individual inherited
COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc
MAIN MAIN <built-in> 105 0 0.0 0.4 0.0 100.0
CAF Main <entire-module> 209 0 0.0 27.6 0.0 27.9
Main.f1 Main toplevel_scc_1.hs:4:1-2 212 1 0.0 0.0 0.0 0.0
Main.foo Main toplevel_scc_1.hs:7:1-2 210 1 0.0 0.2 0.0 0.3
Main.bar Main toplevel_scc_1.hs:10:5-6 211 1 0.0 0.1 0.0 0.1
CAF GHC.Conc.Signal <entire-module> 203 0 0.0 0.8 0.0 0.8
CAF GHC.IO.Encoding <entire-module> 193 0 0.0 3.5 0.0 3.5
CAF GHC.IO.Encoding.Iconv <entire-module> 191 0 0.0 0.3 0.0 0.3
CAF GHC.IO.Handle.FD <entire-module> 183 0 0.0 64.9 0.0 64.9
CAF GHC.IO.Handle.Text <entire-module> 181 0 0.0 0.1 0.0 0.1
CAF GHC.Read <entire-module> 171 0 0.0 1.2 0.0 1.2
CAF Text.Read.Lex <entire-module> 154 0 0.0 0.8 0.0 0.8
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