Meaning-preserving SCC annotations (#15730)
authorVladislav Zavialov <vlad.z.4096@gmail.com>
Tue, 12 Nov 2019 07:56:57 +0000 (10:56 +0300)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Thu, 5 Dec 2019 21:07:44 +0000 (16:07 -0500)
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

13 files changed:
compiler/parser/Parser.y
docs/users_guide/profiling.rst
testsuite/tests/parser/should_compile/T15730a.hs [new file with mode: 0644]
testsuite/tests/parser/should_compile/T15730a.stdout [new file with mode: 0644]
testsuite/tests/parser/should_compile/all.T
testsuite/tests/parser/should_fail/T15730.hs [new file with mode: 0644]
testsuite/tests/parser/should_fail/T15730.stderr [new file with mode: 0644]
testsuite/tests/parser/should_fail/T15730b.hs [new file with mode: 0644]
testsuite/tests/parser/should_fail/T15730b.stderr [new file with mode: 0644]
testsuite/tests/parser/should_fail/all.T
testsuite/tests/perf/compiler/T15164.hs
testsuite/tests/profiling/should_run/prof-doc-last.hs
testsuite/tests/profiling/should_run/prof-doc-last.prof.sample

index 0076a01..4272da7 100644 (file)
@@ -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 }
index b6db42a..c1d4d7d 100644 (file)
@@ -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:
 
diff --git a/testsuite/tests/parser/should_compile/T15730a.hs b/testsuite/tests/parser/should_compile/T15730a.hs
new file mode 100644 (file)
index 0000000..5f1c458
--- /dev/null
@@ -0,0 +1,5 @@
+x = 1 / 2 / 2
+a = {-# SCC ann #-} 1 / 2 / 2
+b = 1 / 2 / {-# SCC ann #-} 2
+
+main = print (x, a == x, b == x)
diff --git a/testsuite/tests/parser/should_compile/T15730a.stdout b/testsuite/tests/parser/should_compile/T15730a.stdout
new file mode 100644 (file)
index 0000000..f8528ac
--- /dev/null
@@ -0,0 +1 @@
+(0.25,True,True)
index 91aae13..85a7c3c 100644 (file)
@@ -162,3 +162,5 @@ test('proposal-229f',
        omit_ways(['profasm', 'profthreaded'])
      ],
      multimod_compile_and_run, ['proposal-229f.hs', ''])
+
+test('T15730a', normal, compile_and_run, [''])
diff --git a/testsuite/tests/parser/should_fail/T15730.hs b/testsuite/tests/parser/should_fail/T15730.hs
new file mode 100644 (file)
index 0000000..98c7689
--- /dev/null
@@ -0,0 +1,3 @@
+module T15730 where
+
+x = 1 / {-# SCC ann #-} 2 / 2
diff --git a/testsuite/tests/parser/should_fail/T15730.stderr b/testsuite/tests/parser/should_fail/T15730.stderr
new file mode 100644 (file)
index 0000000..32b5b33
--- /dev/null
@@ -0,0 +1,2 @@
+
+T15730.hs:3:27: error: parse error on input ‘/’
diff --git a/testsuite/tests/parser/should_fail/T15730b.hs b/testsuite/tests/parser/should_fail/T15730b.hs
new file mode 100644 (file)
index 0000000..01fa6e2
--- /dev/null
@@ -0,0 +1,8 @@
+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
diff --git a/testsuite/tests/parser/should_fail/T15730b.stderr b/testsuite/tests/parser/should_fail/T15730b.stderr
new file mode 100644 (file)
index 0000000..5794dc0
--- /dev/null
@@ -0,0 +1,2 @@
+
+T15730b.hs:8:48: error: parse error on input ‘::’
index c4a7a4f..e0000f0 100644 (file)
@@ -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, [''])
index 0f29623..1b67c90 100644 (file)
@@ -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
index f5073fd..d74997d 100644 (file)
@@ -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)
index 371fad4..f67863d 100644 (file)
@@ -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