Commit 02975c90 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix-up to d4d4bef2 'Improve the desugaring of RULES'

I'd forgotten the possiblity that desugaring could generate
dead dictionary bindings; easily fixed by calling occurAnalyseExpr
parent 03365889
......@@ -35,6 +35,7 @@ import HsSyn -- lots of things
import CoreSyn -- lots of things
import Literal ( Literal(MachStr) )
import CoreSubst
import OccurAnal ( occurAnalyseExpr )
import MkCore
import CoreUtils
import CoreArity ( etaExpand )
......@@ -627,7 +628,9 @@ decomposeRuleLhs orig_bndrs orig_lhs
, text "Orig lhs:" <+> ppr orig_lhs])
dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
, ptext (sLit "is not bound in RULE lhs")])
2 (ppr lhs2)
2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
, text "Orig lhs:" <+> ppr orig_lhs
, text "optimised lhs:" <+> ppr lhs2 ])
pp_bndr bndr
| isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)
| Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
......@@ -637,8 +640,11 @@ decomposeRuleLhs orig_bndrs orig_lhs
drop_dicts e
= wrap_lets needed bnds body
where
(bnds, body) = split_lets e
needed = orig_bndr_set `minusVarSet` exprFreeVars body
(bnds, body) = split_lets (occurAnalyseExpr e)
-- The occurAnalyseExpr drops dead bindings which is
-- crucial to ensure that every binding is used later;
-- which in turn makes wrap_lets work right
split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
split_lets e
......
T4398.hs:5:11: Warning:
Forall'd constraint ‘Ord a’ is not bound in RULE lhs f @ a x y
T4398.hs:5:11: Warning:
Forall'd constraint ‘Ord a’ is not bound in RULE lhs
Orig bndrs: [a, $dOrd, x, y]
Orig lhs: let {
$dEq :: Eq a
[LclId, Str=DmdType]
$dEq = GHC.Classes.$p1Ord @ a $dOrd } in
f @ a
((\ ($dOrd :: Ord a) ->
let {
$dEq :: Eq a
[LclId, Str=DmdType]
$dEq = GHC.Classes.$p1Ord @ a $dOrd } in
let {
$dEq :: Eq a
[LclId, Str=DmdType]
$dEq = GHC.Classes.$p1Ord @ a $dOrd } in
x)
$dOrd)
y
optimised lhs: f @ a x y
......@@ -95,7 +95,7 @@ test('EvalTest',
test('T3831', normal, compile, [''])
test('T4345', normal, compile, [''])
test('T4398', normal, compile, [''])
test('T4398', normal, compile, ['-dsuppress-uniques'])
test('T4903',
extra_clean(['T4903a.hi', 'T4903a.o']),
......
simpl016.hs:5:1: Warning:
Forall'd constraint ‘Num b’ is not bound in RULE lhs
delta' @ Int @ b $dEq
simpl016.hs:5:1: Warning:
Forall'd constraint ‘Num b’ is not bound in RULE lhs
Orig bndrs: [b, $dNum]
Orig lhs: let {
$dEq :: Eq Int
[LclId, Str=DmdType]
$dEq = GHC.Classes.$fEqInt } in
delta' @ Int @ b $dEq
optimised lhs: delta' @ Int @ b $dEq
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment