Commit 6d4bd8f7 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

A somewhat subtle (FC-related) bug concerning the monomorphism restriction

parent 2026e951
...@@ -1066,8 +1066,6 @@ tcSimplifyRestricted -- Used for restricted binding groups ...@@ -1066,8 +1066,6 @@ tcSimplifyRestricted -- Used for restricted binding groups
tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- Zonk everything in sight -- Zonk everything in sight
= mappM zonkInst wanteds `thenM` \ wanteds' -> = mappM zonkInst wanteds `thenM` \ wanteds' ->
zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
tcGetGlobalTyVars `thenM` \ gbl_tvs' ->
-- 'reduceMe': Reduce as far as we can. Don't stop at -- 'reduceMe': Reduce as far as we can. Don't stop at
-- dicts; the idea is to get rid of as many type -- dicts; the idea is to get rid of as many type
...@@ -1076,25 +1074,30 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds ...@@ -1076,25 +1074,30 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- immediately, with no constraint on s. -- immediately, with no constraint on s.
-- --
-- BUT do no improvement! See Plan D above -- BUT do no improvement! See Plan D above
-- HOWEVER, some unification may take place, if we instantiate
-- a method Inst with an equality constraint
reduceContextWithoutImprovement reduceContextWithoutImprovement
doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) -> doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over -- Next, figure out the tyvars we will quantify over
zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
tcGetGlobalTyVars `thenM` \ gbl_tvs' ->
mappM zonkInst constrained_dicts `thenM` \ constrained_dicts' ->
let let
constrained_tvs = tyVarsOfInsts constrained_dicts constrained_tvs' = tyVarsOfInsts constrained_dicts'
qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs') qtvs' = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs')
`minusVarSet` constrained_tvs `minusVarSet` constrained_tvs'
in in
traceTc (text "tcSimplifyRestricted" <+> vcat [ traceTc (text "tcSimplifyRestricted" <+> vcat [
pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts, pprInsts wanteds, pprInsts _frees, pprInsts constrained_dicts',
ppr _binds, ppr _binds,
ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_` ppr constrained_tvs', ppr tau_tvs', ppr qtvs' ]) `thenM_`
-- The first step may have squashed more methods than -- The first step may have squashed more methods than
-- necessary, so try again, this time more gently, knowing the exact -- necessary, so try again, this time more gently, knowing the exact
-- set of type variables to quantify over. -- set of type variables to quantify over.
-- --
-- We quantify only over constraints that are captured by qtvs; -- We quantify only over constraints that are captured by qtvs';
-- these will just be a subset of non-dicts. This in contrast -- these will just be a subset of non-dicts. This in contrast
-- to normal inference (using isFreeWhenInferring) in which we quantify over -- to normal inference (using isFreeWhenInferring) in which we quantify over
-- all *non-inheritable* constraints too. This implements choice -- all *non-inheritable* constraints too. This implements choice
...@@ -1108,7 +1111,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds ...@@ -1108,7 +1111,7 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- expose implicit parameters to the test that follows -- expose implicit parameters to the test that follows
let let
is_nested_group = isNotTopLevel top_lvl is_nested_group = isNotTopLevel top_lvl
try_me inst | isFreeWrtTyVars qtvs inst, try_me inst | isFreeWrtTyVars qtvs' inst,
(is_nested_group || isDict inst) = Free (is_nested_group || isDict inst) = Free
| otherwise = ReduceMe AddSCs | otherwise = ReduceMe AddSCs
in in
...@@ -1119,14 +1122,14 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds ...@@ -1119,14 +1122,14 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-- See "Notes on implicit parameters, Question 4: top level" -- See "Notes on implicit parameters, Question 4: top level"
if is_nested_group then if is_nested_group then
extendLIEs frees `thenM_` extendLIEs frees `thenM_`
returnM (varSetElems qtvs, binds) returnM (varSetElems qtvs', binds)
else else
let let
(non_ips, bad_ips) = partition isClassDict frees (non_ips, bad_ips) = partition isClassDict frees
in in
addTopIPErrs bndrs bad_ips `thenM_` addTopIPErrs bndrs bad_ips `thenM_`
extendLIEs non_ips `thenM_` extendLIEs non_ips `thenM_`
returnM (varSetElems qtvs, binds) returnM (varSetElems qtvs', binds)
\end{code} \end{code}
......
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