Skip to content
Snippets Groups Projects
Commit fbcdad20 authored by Fabricio de Sousa Nascimento's avatar Fabricio de Sousa Nascimento
Browse files

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
parent f3017dd3
No related branches found
No related tags found
No related merge requests found
Pipeline #96565 canceled
......@@ -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
......
......@@ -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]
......
module T24026a where
{-# RULES "f" forall (x :: Bool). f x = 0 #-}
f :: Int -> Int
f x = 0
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
module T24026b where
{-# RULES "f" forall (x :: Bool). f x = 0 #-}
f :: Int -> Int
f x = 0
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
test('T24026a', normal, compile, ['-dlint -fdefer-type-errors'])
test('T24026b', normal, compile_fail, [''])
\ No newline at end of file
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment