[Git][ghc/ghc][wip/t22695] Only store Name in FunRhs rather than Id with knot-tied fields
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Tue Jan 3 12:36:27 UTC 2023
Matthew Pickering pushed to branch wip/t22695 at Glasgow Haskell Compiler / GHC
Commits:
e9821db3 by Matthew Pickering at 2023-01-03T12:36:05+00:00
Only store Name in FunRhs rather than Id with knot-tied fields
The Note [fixM for rhs_ty in tcMonoBinds] explains that certain fields of the Id created
here are knot-tied and can't be referenced inside the scope of the fixM.
The modification to `FunRhs` ensures that we
can't accidentally force the knot-tied fields of the `Id`. The `Name` is
just used for error messages and printing.
The result is that when `-dppr-debug` was enabled the compiler would
hang because the debug printing of the Id would try and print fields
which were not populated yet.
Fixes #22695
- - - - -
10 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- + testsuite/tests/ghci/scripts/T22695.script
- + testsuite/tests/ghci/scripts/T22695.stderr
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2002,7 +2002,7 @@ matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
matchSeparator PatSyn = panic "unused"
-pprMatchContext :: (Outputable (IdP p), UnXRec p)
+pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
pprMatchContext ctxt
| want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
@@ -2013,10 +2013,10 @@ pprMatchContext ctxt
want_an (ArrowMatchCtxt KappaExpr) = True
want_an _ = False
-pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)
+pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for"
- <+> quotes (ppr (unXRec @p fun))
+ <+> quotes (ppr (unXRec @(NoGhcTc p) fun))
pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant
<+> text "alternative"
@@ -2032,10 +2032,10 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
$$ pprAStmtContext ctxt
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
-pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p)
+pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsMatchContext p -> SDoc
pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for"
- <+> quotes (ppr (unXRec @p fun))
+ <+> quotes (ppr (unXRec @(NoGhcTc p) fun))
pprMatchContextNouns PatBindGuards = text "pattern binding guards"
pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c
pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in"
@@ -2056,7 +2056,7 @@ pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_varia
pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'
-----------------
-pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)
+pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
=> HsStmtContext p -> SDoc
pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour
pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -863,7 +863,7 @@ mkSimpleGeneratedFunBind loc fun pats expr
emptyLocalBinds]
-- | Make a prefix, non-strict function 'HsMatchContext'
-mkPrefixFunRhs :: LIdP p -> HsMatchContext p
+mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict }
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -957,7 +957,7 @@ instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where
name' :: LocatedN Name
name' = case hiePass @p of
HieRn -> name
- HieTc -> fmap varName name
+ HieTc -> name
toHie (StmtCtxt a) = toHie a
toHie _ = pure []
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -127,12 +127,7 @@ tcMatchesFun fun_id matches exp_ty
herald = ExpectedFunTyMatches (NameThing fun_name) matches
ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True
-- But that's wrong for f :: Int -> forall a. blah
- what = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }
- -- Careful: this fun_id could be an unfilled
- -- thunk from fixM in tcMonoBinds, so we're
- -- not allowed to look at it, except for
- -- idName.
- -- See Note [fixM for rhs_ty in tcMonoBinds]
+ what = FunRhs { mc_fun = idName <$> fun_id, mc_fixity = Prefix, mc_strictness = strictness }
match_ctxt = MC { mc_what = what, mc_body = tcBody }
strictness
| [L _ match] <- unLoc $ mg_alts matches
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -838,7 +838,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
args body]
, mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated
}
- match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []
+ match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) []
(mkHsLams (rr_tv:res_tv:univ_tvs)
req_dicts body')
(EmptyLocalBinds noExtField)
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -1533,7 +1533,7 @@ data HsMatchContext p
= FunRhs
-- ^ A pattern matching on an argument of a
-- function binding
- { mc_fun :: LIdP p -- ^ function binder of @f@
+ { mc_fun :: LIdP (NoGhcTc p) -- ^ function binder of @f@
, mc_fixity :: LexicalFixity -- ^ fixing of @f@
, mc_strictness :: SrcStrictness -- ^ was @f@ banged?
-- See Note [FunBind vs PatBind]
=====================================
testsuite/tests/ghci/scripts/T22695.script
=====================================
@@ -0,0 +1 @@
+test x | Just <- x = x
=====================================
testsuite/tests/ghci/scripts/T22695.stderr
=====================================
@@ -0,0 +1,8 @@
+
+<interactive>:1:10: error:
+ • The constructor ‘Just’ should have 1 argument, but has been given none
+ • In the pattern: Just
+ In a stmt of a pattern guard for
+ an equation for ‘test’:
+ Just <- x
+ In an equation for ‘test’: test x | Just <- x = x
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -370,3 +370,4 @@ test('T21110', [extra_files(['T21110A.hs'])], ghci_script,
test('T17830', [filter_stdout_lines(r'======.*')], ghci_script, ['T17830.script'])
test('T21294a', normal, ghci_script, ['T21294a.script'])
test('T21507', normal, ghci_script, ['T21507.script'])
+test('T22695', normal, ghci_script, ['T22695.script'])
=====================================
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
=====================================
@@ -1560,7 +1560,7 @@
(FunRhs
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 })
- {Var: main})
+ {Name: main})
(Prefix)
(NoSrcStrict))
[]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9821db3c8b484473a2debfb874e105bca96ea49
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e9821db3c8b484473a2debfb874e105bca96ea49
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/20230103/d39f47d2/attachment-0001.html>
More information about the ghc-commits
mailing list