Commit 84585e5e authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot

Meaning-preserving SCC annotations (#15730)

This patch implements GHC Proposal #176:
  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst

Before the change:

  1 /                    2 / 2 = 0.25
  1 / {-# SCC "name" #-} 2 / 2 = 1.0

After the change:

  1 /                    2 / 2 = 0.25
  1 / {-# SCC "name" #-} 2 / 2 = parse error
parent f03a41d4
......@@ -1080,7 +1080,7 @@ topdecl :: { LHsDecl GhcPs }
-- The $(..) form is one possible form of infixexp
-- but we treat an arbitrary expression just as if
-- it had a $(..) wrapped around it
| infixexp_top {% runECP_P $1 >>= \ $1 ->
| infixexp {% runECP_P $1 >>= \ $1 ->
return $ sLL $1 $> $ mkSpliceDecl $1 }
-- Type classes
......@@ -2430,7 +2430,7 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
| infixexp_top opt_sig rhs {% runECP_P $1 >>= \ $1 ->
| infixexp opt_sig rhs {% runECP_P $1 >>= \ $1 ->
do { (ann,r) <- checkValDef $1 (snd $2) $3;
let { l = comb2 $1 $> };
-- Depending upon what the pattern looks like we might get either
......@@ -2476,7 +2476,7 @@ gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
sigdecl :: { LHsDecl GhcPs }
:
-- See Note [Declaration/signature overlap] for why we need infixexp here
infixexp_top '::' sigtypedoc
infixexp '::' sigtypedoc
{% do { $1 <- runECP_P $1
; v <- checkValSigLhs $1
; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
......@@ -2571,7 +2571,8 @@ quasiquote :: { Located (HsSplice GhcPs) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { ECP }
: infixexp '::' sigtype { ECP $
: infixexp_no_prag '::' sigtype
{ ECP $
runECP_PV $1 >>= \ $1 ->
amms (mkHsTySigPV (comb2 $1 $>) $1 $3)
[mu AnnDcolon $2] }
......@@ -2600,10 +2601,35 @@ exp :: { ECP }
HsHigherOrderApp False)
[mu AnnRarrowtail $2] }
| infixexp { $1 }
| exp_prag(exp) { $1 } -- See Note [Pragmas and operator fixity]
infixexp :: { ECP }
: infixexp_no_prag { $1 }
| infixexp_no_prag qop exp_prag(last_exp10) -- See Note [Pragmas and operator fixity]
{ ECP $
superInfixOp $
$2 >>= \ $2 ->
runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
last_exp10 :: { ECP }
: exp10 { $1 }
| exp_prag(last_exp10) { $1 } -- See Note [Pragmas and operator fixity]
exp_prag(e) :: { ECP }
: prag_e e -- See Note [Pragmas and operator fixity]
{% runECP_P $2 >>= \ $2 ->
fmap ecpFromExp $
ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
(fst $ unLoc $1) }
infixexp_no_prag :: { ECP }
: exp10 { $1 }
| infixexp qop exp10 { ECP $
| infixexp_no_prag qop exp10
{ ECP $
superInfixOp $
$2 >>= \ $2 ->
runECP_PV $1 >>= \ $1 ->
......@@ -2612,49 +2638,75 @@ infixexp :: { ECP }
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
infixexp_top :: { ECP }
: exp10_top { $1 }
| infixexp_top qop exp10_top
{ ECP $
superInfixOp $
$2 >>= \ $2 ->
runECP_PV $1 >>= \ $1 ->
runECP_PV $3 >>= \ $3 ->
amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
[mj AnnVal $2] }
exp10_top :: { ECP }
exp10 :: { ECP }
: '-' fexp { ECP $
runECP_PV $2 >>= \ $2 ->
amms (mkHsNegAppPV (comb2 $1 $>) $2)
[mj AnnMinus $1] }
| exp_annot (prag_hpc) { $1 }
| exp_annot (prag_core) { $1 }
| fexp { $1 }
exp10 :: { ECP }
: exp10_top { $1 }
| exp_annot(prag_scc) { $1 }
optSemi :: { ([Located Token],Bool) }
: ';' { ([$1],True) }
| {- empty -} { ([],False) }
prag_scc :: { Located ([AddAnn], HsPragE GhcPs) }
: '{-# SCC' STRING '#-}' {% do scc <- getSCC $2
; return $ sLL $1 $>
([mo $1,mj AnnValStr $2,mc $3],
HsPragSCC noExtField
(getSCC_PRAGs $1)
(StringLiteral (getSTRINGs $2) scc)) }
| '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
HsPragSCC noExtField
(getSCC_PRAGs $1)
(StringLiteral NoSourceText (getVARID $2))) }
prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) }
: '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
{- Note [Pragmas and operator fixity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'prag_e' is an expression pragma, such as {-# SCC ... #-}, {-# CORE ... #-}, or
{-# GENERATED ... #-}.
It must be used with care, or else #15730 happens. Consider this infix
expression:
1 / 2 / 2
There are two ways to parse it:
1. (1 / 2) / 2 = 0.25
2. 1 / (2 / 2) = 1.0
Due to the fixity of the (/) operator (assuming it comes from Prelude),
option 1 is the correct parse. However, in the past GHC's parser used to get
confused by the SCC annotation when it occurred in the middle of an infix
expression:
1 / {-# SCC ann #-} 2 / 2 -- used to get parsed as option 2
There are several ways to address this issue, see GHC Proposal #176 for a
detailed exposition:
https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst
The accepted fix is to disallow pragmas that occur within infix expressions.
Infix expressions are assembled out of 'exp10', so 'exp10' must not accept
pragmas. Instead, we accept them in exactly two places:
* at the start of an expression or a parenthesized subexpression:
f = {-# SCC ann #-} 1 / 2 / 2 -- at the start of the expression
g = 5 + ({-# SCC ann #-} 1 / 2 / 2) -- at the start of a parenthesized subexpression
* immediately after the last operator:
f = 1 / 2 / {-# SCC ann #-} 2
In both cases, the parse does not depend on operator fixity. The second case
may sound unnecessary, but it's actually needed to support a common idiom:
f $ {-# SCC ann $-} ...
-}
prag_e :: { Located ([AddAnn], HsPragE GhcPs) }
: '{-# SCC' STRING '#-}' {% do scc <- getSCC $2
; return $ sLL $1 $>
([mo $1,mj AnnValStr $2,mc $3],
HsPragSCC noExtField
(getSCC_PRAGs $1)
(StringLiteral (getSTRINGs $2) scc)) }
| '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
HsPragSCC noExtField
(getSCC_PRAGs $1)
(StringLiteral NoSourceText (getVARID $2))) }
| '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
{ let getINT = fromInteger . il_value . getINTEGER in
sLL $1 $> $ ([mo $1,mj AnnVal $2
,mj AnnVal $3,mj AnnColon $4
......@@ -2668,19 +2720,11 @@ prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) }
(getINT $7, getINT $9))
((getINTEGERs $3, getINTEGERs $5),
(getINTEGERs $7, getINTEGERs $9) )) }
prag_core :: { Located ([AddAnn], HsPragE GhcPs) }
: '{-# CORE' STRING '#-}'
| '{-# CORE' STRING '#-}'
{ sLL $1 $> $
([mo $1,mj AnnVal $2,mc $3],
HsPragCore noExtField (getCORE_PRAGs $1) (getStringLiteral $2)) }
exp_annot(prag) :: { ECP }
: prag exp {% runECP_P $2 >>= \ $2 ->
fmap ecpFromExp $
ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
(fst $ unLoc $1) }
fexp :: { ECP }
: fexp aexp { ECP $
superFunArg $
......@@ -2912,7 +2956,8 @@ texp :: { ECP }
-- Then when converting expr to pattern we unravel it again
-- Meanwhile, the renamer checks that real sections appear
-- inside parens.
| infixexp qop {% runECP_P $1 >>= \ $1 ->
| infixexp_no_prag qop
{% runECP_P $1 >>= \ $1 ->
runPV $2 >>= \ $2 ->
return $ ecpFromExp $
sLL $1 $> $ SectionL noExtField $1 $2 }
......
......@@ -205,10 +205,22 @@ The syntax of a cost centre annotation for expressions is ::
where ``"name"`` is an arbitrary string, that will become the name of
your cost centre as it appears in the profiling output, and
``<expression>`` is any Haskell expression. An ``SCC`` annotation
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: ::
``<expression>`` is any Haskell expression. An ``SCC`` annotation extends as
far to the right as possible when parsing, having the same precedence as lambda
abstractions, let expressions, and conditionals. Additionally, an annotation
may not appear in a position where it would change the grouping of
subexpressions::
a = 1 / 2 / 2 -- accepted (a=0.25)
b = 1 / {-# SCC "name" #-} / 2 / 2 -- rejected (instead of b=1.0)
This restriction is required to maintain the property that inserting a pragma,
just like inserting a comment, does not have unintended effects on the
semantics of the program, in accordance with `GHC Proposal #176
<https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst>`__.
SCC stands for "Set Cost Centre". The double quotes can be omitted if ``name``
is a Haskell identifier, for example: ::
{-# SCC id #-} <expression>
......@@ -235,9 +247,9 @@ Here is an example of a program with a couple of SCCs: ::
main = do let xs = [1..1000000]
let ys = [1..2000000]
print $ {-# SCC last_xs #-} last xs
print $ {-# SCC last_init_xs #-} last $ init xs
print $ {-# SCC last_init_xs #-} last (init xs)
print $ {-# SCC last_ys #-} last ys
print $ {-# SCC last_init_ys #-} last $ init ys
print $ {-# SCC last_init_ys #-} last (init ys)
which gives this profile when run:
......
x = 1 / 2 / 2
a = {-# SCC ann #-} 1 / 2 / 2
b = 1 / 2 / {-# SCC ann #-} 2
main = print (x, a == x, b == x)
......@@ -162,3 +162,5 @@ test('proposal-229f',
omit_ways(['profasm', 'profthreaded'])
],
multimod_compile_and_run, ['proposal-229f.hs', ''])
test('T15730a', normal, compile_and_run, [''])
module T15730 where
x = 1 / {-# SCC ann #-} 2 / 2
T15730.hs:3:27: error: parse error on input ‘/’
module T15730b where
(.!) :: (a, a) -> Bool -> a
a .! True = fst a
a .! False = snd a
t :: Bool -> Integer
t x = (5,6) .! {-# SCC a1 #-} {-# SCC a2 #-} x :: Integer
T15730b.hs:8:48: error: parse error on input ‘::’
......@@ -163,3 +163,5 @@ test('patFail008', normal, compile_fail, [''])
test('patFail009', normal, compile_fail, [''])
test('T17162', normal, compile_fail, [''])
test('proposal-229c', normal, compile_fail, [''])
test('T15730', normal, compile_fail, [''])
test('T15730b', normal, compile_fail, [''])
......@@ -252,7 +252,7 @@ instance Rule f Primary => Rule f Factor where
-- ::= name
newtype FormalDesignator = MkFormalDesignator (NT Name)
instance Rule f Name => Rule f FormalDesignator where
get = trace "FormalDesignator" $ {-# SCC "get_FormalDesignator" #-} MkFormalDesignator <$> n93
get = trace "FormalDesignator" $ {-# SCC "get_FormalDesignator" #-} (MkFormalDesignator <$> n93)
-- formal_part
-- ::= formal_designator
......
......@@ -2,6 +2,6 @@ main :: IO ()
main = do let xs = [1..1000000]
let ys = [1..2000000]
print $ {-# SCC "last_xs" #-} last xs
print $ {-# SCC "last_init_xs" #-} last $ init xs
print $ {-# SCC "last_init_xs" #-} last (init xs)
print $ {-# SCC "last_ys" #-} last ys
print $ {-# SCC "last_init_ys" #-}last $ init ys
print $ {-# SCC "last_init_ys" #-} last (init ys)
......@@ -8,7 +8,7 @@
COST CENTRE MODULE SRC %time %alloc
main.ys Main prof-doc-last.hs:3:15-31 39.7 37.5
last_init_ys Main prof-doc-last.hs:7:45-58 23.1 29.2
last_init_ys Main prof-doc-last.hs:7:46-59 23.1 29.2
main.xs Main prof-doc-last.hs:2:15-31 23.1 18.7
last_init_xs Main prof-doc-last.hs:5:46-59 11.6 14.6
last_xs Main prof-doc-last.hs:4:41-47 1.7 0.0
......@@ -27,7 +27,7 @@ MAIN MAIN <built-in> 46
CAF GHC.IO.Encoding.Iconv <entire-module> 65 0 0.0 0.0 0.0 0.0
main Main prof-doc-last.hs:(2,1)-(7,58) 93 0 0.0 0.0 100.0 100.0
last_init_xs Main prof-doc-last.hs:5:46-59 96 1 11.6 14.6 11.6 14.6
last_init_ys Main prof-doc-last.hs:7:45-58 99 1 23.1 29.2 23.1 29.2
last_init_ys Main prof-doc-last.hs:7:46-59 99 1 23.1 29.2 23.1 29.2
last_xs Main prof-doc-last.hs:4:41-47 94 1 1.7 0.0 1.7 0.0
last_ys Main prof-doc-last.hs:6:41-47 97 1 0.8 0.0 0.8 0.0
main.xs Main prof-doc-last.hs:2:15-31 95 1 23.1 18.7 23.1 18.7
......
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