[Git][ghc/ghc][wip/fabu/T24026-early-reject-type-failing-rules] compiler: Rejects RULES whose LHS immediately fails to type-check

[Fabricio Nascimento (@fabu)]

Fabricio Nascimento pushed to branch wip/fabu/T24026-early-reject-type-failing-rules at Glasgow Haskell Compiler / GHC


Commits:
fbcdad20 by Fabricio de Sousa Nascimento at 2024-06-12T12:48:34+09:00
compiler: Rejects RULES whose LHS immediately fails to type-check

Fixes GHC crashing on `decomposeRuleLhs` due to ignoring coercion values. This
happens when we have a RULE that does not type check, and enable
`-fdefer-type-errors`. We prevent this to happen by rejecting RULES with an
immediately LHS type error.

Fixes #24026

- - - - -


7 changed files:

- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Rule.hs
- + testsuite/tests/typecheck/T24026/T24026a.hs
- + testsuite/tests/typecheck/T24026/T24026a.stderr
- + testsuite/tests/typecheck/T24026/T24026b.hs
- + testsuite/tests/typecheck/T24026/T24026b.stderr
- + testsuite/tests/typecheck/T24026/all.T


Changes:

=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -1032,8 +1032,8 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
                   where
                     extra_tvs   = [ v | v <- extra_vars, isTyVar v ]
                 extra_dicts =
-                  [ mkLocalId (localiseName (idName d)) ManyTy (idType d)
-                  | d <- extra_vars, isDictId d ]
+                  [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)
+                    | d <- extra_vars, isEvVar d ]
                 extra_vars  =
                   [ v
                   | v <- exprsFreeVarsList args


=====================================
compiler/GHC/Tc/Gen/Rule.hs
=====================================
@@ -108,11 +108,12 @@ tcRules decls = mapM (wrapLocMA tcRuleDecls) decls
 tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)
 tcRuleDecls (HsRules { rds_ext = src
                      , rds_rules = decls })
-   = do { tc_decls <- mapM (wrapLocMA tcRule) decls
+   = do { tc_decls_list <- mapM (wrapLocMA tcRule) decls
+        ; let tc_decls = concatMap (\(L loc e) -> map (L loc) e) tc_decls_list
         ; return $ HsRules { rds_ext   = src
                            , rds_rules = tc_decls } }
 
-tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTc)
+tcRule :: RuleDecl GhcRn -> TcM ([RuleDecl GhcTc])
 tcRule (HsRule { rd_ext  = ext
                , rd_name = rname@(L _ name)
                , rd_act  = act
@@ -181,14 +182,20 @@ tcRule (HsRule { rd_ext  = ext
        ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
                                          lhs_evs rhs_wanted
        ; emitImplications (lhs_implic `unionBags` rhs_implic)
-       ; return $ HsRule { rd_ext = ext
+       -- This prevents GHC to crash downstream trying to apply a RULE that won't type check.
+       -- For example when we turn on `-fdefer-type-errors` on an invalid rule. See #24026.
+       ; if anyBag insolubleImplic lhs_implic
+        then
+          return []
+        else
+          return $ [HsRule { rd_ext = ext
                          , rd_name = rname
                          , rd_act = act
                          , rd_tyvs = ty_bndrs -- preserved for ppr-ing
                          , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)
                                          (qtkvs ++ tpl_ids)
                          , rd_lhs  = mkHsDictLet lhs_binds lhs'
-                         , rd_rhs  = mkHsDictLet rhs_binds rhs' } }
+                         , rd_rhs  = mkHsDictLet rhs_binds rhs' } ]}
 
 generateRuleConstraints :: FastString
                         -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]


=====================================
testsuite/tests/typecheck/T24026/T24026a.hs
=====================================
@@ -0,0 +1,6 @@
+module T24026a where
+
+{-# RULES "f" forall (x :: Bool). f x = 0 #-}
+
+f :: Int -> Int
+f x = 0


=====================================
testsuite/tests/typecheck/T24026/T24026a.stderr
=====================================
@@ -0,0 +1,9 @@
+T24026a.hs:3:11: warning: [GHC-95396] [-Winline-rule-shadowing (in -Wdefault)]
+    Rule "f" may never fire because ‘f’ might inline first
+    Suggested fix: Add an INLINE[n] or NOINLINE[n] pragma for ‘f’
+
+T24026a.hs:3:37: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]
+    • Couldn't match expected type ‘Int’ with actual type ‘Bool’
+    • In the first argument of ‘f’, namely ‘x’
+      In the expression: f x
+      When checking the rewrite rule "f"
\ No newline at end of file


=====================================
testsuite/tests/typecheck/T24026/T24026b.hs
=====================================
@@ -0,0 +1,6 @@
+module T24026b where
+
+{-# RULES "f" forall (x :: Bool). f x = 0 #-}
+
+f :: Int -> Int
+f x = 0


=====================================
testsuite/tests/typecheck/T24026/T24026b.stderr
=====================================
@@ -0,0 +1,5 @@
+T24026b.hs:3:37: error: [GHC-83865]
+    • Couldn't match expected type ‘Int’ with actual type ‘Bool’
+    • In the first argument of ‘f’, namely ‘x’
+      In the expression: f x
+      When checking the rewrite rule "f"
\ No newline at end of file


=====================================
testsuite/tests/typecheck/T24026/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T24026a', normal, compile, ['-dlint -fdefer-type-errors'])
+test('T24026b', normal, compile_fail, [''])
\ No newline at end of file



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbcdad20e1dffd012559332e21e793f4ccf61cc3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbcdad20e1dffd012559332e21e793f4ccf61cc3
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/20240611/de5a6aa5/attachment-0001.html>