[Git][ghc/ghc][wip/scc-parsing] Meaning-preserving SCC annotations (#15730)
Vladislav Zavialov
gitlab at gitlab.haskell.org
Sat May 4 17:58:27 UTC 2019
Vladislav Zavialov pushed to branch wip/scc-parsing at Glasgow Haskell Compiler / GHC
Commits:
1ce224ee by Vladislav Zavialov at 2019-05-04T17:57:38Z
Meaning-preserving SCC annotations (#15730)
- - - - -
6 changed files:
- compiler/parser/Parser.y
- + testsuite/tests/parser/should_fail/T15730.hs
- + testsuite/tests/parser/should_fail/T15730.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/perf/compiler/T15164.hs
- testsuite/tests/profiling/should_run/prof-doc-last.hs
Changes:
=====================================
compiler/parser/Parser.y
=====================================
@@ -1064,7 +1064,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
@@ -2411,7 +2411,7 @@ decl_no_th :: { LHsDecl GhcPs }
_ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
return $! (sL l $ ValD noExt r) } }
- | infixexp_top opt_sig rhs {% runECP_P $1 >>= \ $1 ->
+ | infixexp opt_sig rhs {% runECP_P $1 >>= \ $1 ->
do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3;
let { l = comb2 $1 $> };
-- Depending upon what the pattern looks like we might get either
@@ -2457,7 +2457,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]
@@ -2581,57 +2581,54 @@ exp :: { ECP }
HsHigherOrderApp False)
[mu AnnRarrowtail $2] }
| infixexp { $1 }
+ | exp_ann exp {% runECP_P $2 >>= \ $2 -> fmap ecpFromExp $ $1 $2 }
infixexp :: { ECP }
- : exp10 { $1 }
- | infixexp qop exp10 { 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
-
-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 }
+ : infixexp_inner { $1 }
+ | infixexp_inner qop exp_ann exp10
+ {% runPV $2 >>= \ $2 ->
+ runECP_P $1 >>= \ $1 ->
+ runECP_P $4 >>= \ $4 ->
+ $3 $4 >>= \last ->
+ fmap ecpFromExp $
+ ams (sLL $1 last $ OpApp noExt $1 $2 last)
+ [mj AnnVal $2] }
+ -- AnnVal annotation for NPlusKPat, which discards the operator
+
+infixexp_inner :: { ECP }
+ : exp10 { $1 }
+ | infixexp_inner qop exp10
+ { 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
+
+exp_ann :: { LHsExpr GhcPs -> P (LHsExpr GhcPs) }
+ : scc_annot { \exp ->
+ ams (sLL $1 exp $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) exp)
+ (fst $ fst $ unLoc $1) }
+ | hpc_annot { \exp ->
+ ams (sLL $1 exp $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1)
+ (snd $ fst $ unLoc $1) (snd $ unLoc $1) exp)
+ (fst $ fst $ fst $ unLoc $1) }
+
+ | '{-# CORE' STRING '#-}' { \exp ->
+ ams (sLL $1 exp $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) exp)
+ [mo $1,mj AnnVal $2
+ ,mc $3] }
+ -- hdaume: core annotation
+
+exp10 :: { ECP }
: '-' fexp { ECP $
runECP_PV $2 >>= \ $2 ->
amms (mkHsNegAppPV (comb2 $1 $>) $2)
[mj AnnMinus $1] }
-
-
- | hpc_annot exp {% runECP_P $2 >>= \ $2 ->
- fmap ecpFromExp $
- ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1)
- (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
- (fst $ fst $ fst $ unLoc $1) }
-
- | '{-# CORE' STRING '#-}' exp {% runECP_P $4 >>= \ $4 ->
- fmap ecpFromExp $
- ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4)
- [mo $1,mj AnnVal $2
- ,mc $3] }
- -- hdaume: core annotation
| fexp { $1 }
-exp10 :: { ECP }
- : exp10_top { $1 }
- | scc_annot exp {% runECP_P $2 >>= \ $2 ->
- fmap ecpFromExp $
- ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
- (fst $ fst $ unLoc $1) }
-
optSemi :: { ([Located Token],Bool) }
: ';' { ([$1],True) }
| {- empty -} { ([],False) }
@@ -2900,7 +2897,7 @@ 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_inner qop {% runECP_P $1 >>= \ $1 ->
runPV $2 >>= \ $2 ->
return $ ecpFromExp $
sLL $1 $> $ SectionL noExt $1 $2 }
=====================================
testsuite/tests/parser/should_fail/T15730.hs
=====================================
@@ -0,0 +1,3 @@
+module T15730 where
+
+x = 1 / {-# SCC ann #-} 2 / 2
=====================================
testsuite/tests/parser/should_fail/T15730.stderr
=====================================
@@ -0,0 +1,2 @@
+
+T15730.hs:3:27: error: parse error on input ‘/’
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -161,3 +161,4 @@ test('patFail006', normal, compile_fail, [''])
test('patFail007', normal, compile_fail, [''])
test('patFail008', normal, compile_fail, [''])
test('patFail009', normal, compile_fail, [''])
+test('T15730', normal, compile_fail, [''])
=====================================
testsuite/tests/perf/compiler/T15164.hs
=====================================
@@ -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
=====================================
testsuite/tests/profiling/should_run/prof-doc-last.hs
=====================================
@@ -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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/1ce224eef79feb2fe0942a9bf9070bfeb8fd6e5e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/1ce224eef79feb2fe0942a9bf9070bfeb8fd6e5e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190504/a4a75ee7/attachment-0001.html>
More information about the ghc-commits
mailing list