[Git][ghc/ghc][wip/T25266] Wibbles to solver and MR
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Oct 14 15:36:34 UTC 2024
Simon Peyton Jones pushed to branch wip/T25266 at Glasgow Haskell Compiler / GHC
Commits:
423febc9 by Simon Peyton Jones at 2024-10-14T16:36:19+01:00
Wibbles to solver and MR
- - - - -
3 changed files:
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Solver.hs
- testsuite/tests/typecheck/should_compile/T13785.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -773,6 +773,7 @@ checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool
checkMonomorphismRestriction mbis lbinds
= do { mr_on <- xoptM LangExt.MonomorphismRestriction
; let mr_applies = mr_on && any (restricted . unLoc) lbinds
+ ; when mr_applies $ traceTc "cmr" (ppr lbinds $$ vcat (map (ppr . mbi_sig) mbis))
; when mr_applies $ mapM_ checkOverloadedSig mbis
; return mr_applies }
where
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1469,19 +1469,35 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
++ tau_tys ++ post_mr_quant)
co_var_tvs = closeOverKinds co_vars
+ -- outer_tvs are belong to some outer level,
+ -- so we definitely can't quantify over them
+ outer_tvs = outerLevelTyVars tc_lvl $
+ tyCoVarsOfTypes can_quant `unionVarSet` tyCoVarsOfTypes no_quant
+
+ mono_tvs_ignoring_mr
+ | isTopTcLevel tc_lvl = outer_tvs
+ | otherwise = outer_tvs
+ `unionVarSet` tyCoVarsOfTypes no_quant
+ `unionVarSet` co_var_tvs
+
+ mono_tvs_accounting_for_mr
+ = mono_tvs_ignoring_mr `unionVarSet` tyCoVarsOfTypes mr_no_quant
+
+{-
-- mono_tvs0 are all the type variables we can't quantify over
mono_tvs0
| isTopTcLevel tc_lvl
-- At top level: we want to promote only tyvars that are
- -- (a) free in envt (already promoted)
- -- (b) will be defaulted
+ -- (a) free in envt (outer_tvs)
+ -- (b) will be defaulted (mr_no_quant)
-- (c) determined by (a) or (b)
-- mono_tvs0 deals with (a) or (b); closeWrtFunDeps deals with (c)
- = outerLevelTyVars tc_lvl (tyCoVarsOfTypes post_mr_quant)
+ = outer_tvs
+ `unionVarSet` tyCoVarsOfTypes mr_no_quant
| otherwise
- = outerLevelTyVars tc_lvl (tyCoVarsOfTypes post_mr_quant)
- -- outerLevelTyVars are free in the envt, so can't quantify them
+ = outer_tvs
+ `unionVarSet` tyCoVarsOfTypes mr_no_quant
`unionVarSet` tyCoVarsOfTypes no_quant
`unionVarSet` co_var_tvs
-- If we don't quantify over a constraint in no_quant, we
@@ -1489,9 +1505,22 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
-- sites will fix them) or just ignore it for the purposes
-- of mono_tvs0 (leaving behind a perhaps insoluble residual
-- constraint)
+-}
+
+ add_determined tvs = closeWrtFunDeps post_mr_quant tvs
+ `delVarSetList` psig_qtvs
+ -- Finally, delete psig_qtvs
+ -- If the user has explicitly asked for quantification, then that
+ -- request "wins" over the MR.
+ --
+ -- What if a psig variable is also free in the environment
+ -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation
+ -- in Step 2 of Note [Deciding quantification].
+
+
- -- Next, use closeWrtFunDeps to find any other variables that are determined
- -- by mono_tvs0 + mr_no_quant, by functional dependencies or equalities.
+ -- Next, use closeWrtFunDeps to find any other variables that are
+ -- determined by mono_tvs0, by functional dependencies or equalities.
-- Example
-- f x y = ...
-- where z = x 3
@@ -1502,21 +1531,18 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
-- are in the equality constraint with alpha. Actual test case:
-- typecheck/should_compile/tc213
-- see Note [growThetaTyVars vs closeWrtFunDeps]
- mono_tvs1 = closeWrtFunDeps post_mr_quant $
- (mono_tvs0 `unionVarSet` tyCoVarsOfTypes mr_no_quant)
-
- -- Finally, delete psig_qtvs
- -- If the user has explicitly asked for quantification, then that
- -- request "wins" over the MR.
- --
- -- What if a psig variable is also free in the environment
- -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation
- -- in Step 2 of Note [Deciding quantification].
- mono_tvs = mono_tvs1 `delVarSetList` psig_qtvs
+ mono_tvs_with_mr = add_determined mono_tvs_accounting_for_mr
+ mono_tvs_without_mr = add_determined mono_tvs_ignoring_mr
-- Do not quantify over any constraint mentioning a "newly-mono" tyvar
- -- The "newly-mono" tyvars are the ones not free in the envt
- -- nor forced to be promoted by the MR; but are deternmined by them
+ -- The "newly-mono" tyvars are the ones not free in the envt, nor
+ -- forced to be promoted by the MR; but are determined (via fundeps) by them
+ -- Example: class C a b | a -> b
+ -- [W] C Int beta[1], tau = beta[1]->Int
+ -- We promote beta[1] to beta[0] since it is determined by fundep,
+ -- but we do not want to generate f :: (C Int beta[0]) => beta[0] -> Int
+ -- Rather, we generate f :: beta[0] -> Int, but leave [W] C Int beta[0]
+ -- in the residual constraints, which will probably cause a type errors
newly_mono = mono_tvs `minusVarSet` mono_tvs0
final_quant
| isTopTcLevel tc_lvl = filterOut (predMentions newly_mono) post_mr_quant
@@ -1525,11 +1551,8 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
-- Check if the Monomorphism Restriction has bitten
; warn_mr <- woptM Opt_WarnMonomorphism
; when (warn_mr && case infer_mode of { ApplyMR -> True; _ -> False}) $
- do { let mono_tvs_wo_mr = closeWrtFunDeps post_mr_quant mono_tvs0
- `delVarSetList` psig_qtvs
-
- ; diagnosticTc (not (mono_tvs `subVarSet` mono_tvs_wo_mr)) $
- TcRnMonomorphicBindings (map fst name_taus) }
+ diagnosticTc (not (mono_tvs `subVarSet` mono_tvs_wo_mr)) $
+ TcRnMonomorphicBindings (map fst name_taus)
-- If there is a variable in mono_tvs, but not in mono_tvs_wo_mr
-- then the MR has "bitten" and reduced polymorphism.
=====================================
testsuite/tests/typecheck/should_compile/T13785.hs
=====================================
@@ -2,15 +2,20 @@
{-# OPTIONS_GHC -Wmonomorphism-restriction #-}
module Bug where
-class Monad m => C m where
- c :: (m Char, m Char)
+class Monad x => C x where
+ c :: (x Char, x Char)
foo :: forall m. C m => m Char
-foo = bar >> baz >> bar2
+foo = bar >> baz >> bar1 >> bar2
where
-- Should not get MR warning
bar, baz :: m Char
- (bar, baz) = c
+ (bar, baz) = (c :: m Char, m Char)
+
+ -- Should not get MR warning
+ (bar1, baz1) = (c :: (m Char, m Char))
-- Should get MR warning
+ -- Natural type for the "whole binding": forall x. C x => (x Char, x Char)
+ -- MR makes it less polymorphic => warning.
(bar2, baz2) = c
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/423febc9d474cf3786f2491e9b9143c2e250ba4b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/423febc9d474cf3786f2491e9b9143c2e250ba4b
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/20241014/d4536060/attachment-0001.html>
More information about the ghc-commits
mailing list