[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