[Git][ghc/ghc][wip/T25266] Wibbles related to the MR

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T25266 at Glasgow Haskell Compiler / GHC


Commits:
46564aa6 by Simon Peyton Jones at 2024-10-11T12:02:20+01:00
Wibbles related to the MR

- - - - -


1 changed file:

- compiler/GHC/Tc/Solver.hs


Changes:

=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -61,6 +61,7 @@ import GHC.Types.Error
 import GHC.Driver.DynFlags( DynFlags, xopt )
 import GHC.Utils.Panic
 import GHC.Utils.Outputable
+import GHC.Utils.Misc( filterOut )
 
 import GHC.Data.Bag
 
@@ -1469,19 +1470,17 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
              -- mono_tvs0 are all the type variables we can't quantify over
              mono_tvs0
                | isTopTcLevel tc_lvl
-                 -- At top level: we want to promote tyvars that are
+                 -- At top level: we want to promote only tyvars that are
                  --  (a) free in envt (already promoted)
                  --  (b) will be defaulted
                  --  (c) determined by (a) or (b)
                  -- mono_tvs0 deals with (a) or (b); closeWrtFunDeps deals with (c)
                = outerLevelTyVars tc_lvl (tyCoVarsOfTypes post_mr_quant)
-                 `unionVarSet` tyCoVarsOfTypes mr_no_quant
 
                | otherwise
                = outerLevelTyVars tc_lvl (tyCoVarsOfTypes post_mr_quant)
                      -- outerLevelTyVars are free in the envt, so can't quantify them
                  `unionVarSet` tyCoVarsOfTypes no_quant
-                 `unionVarSet` tyCoVarsOfTypes mr_no_quant
                  `unionVarSet` co_var_tvs
                      -- If we don't quantify over a constraint in no_quant, we
                      -- can either not-quantify its free vars (hoping that call
@@ -1500,9 +1499,9 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
              -- We need to know not to quantify over beta or gamma, because they
              -- are in the equality constraint with alpha. Actual test case:
              -- typecheck/should_compile/tc213
-             -- See Note [growThetaTyVars vs closeWrtFunDeps]
+             -- see Note [growThetaTyVars vs closeWrtFunDeps]
              mono_tvs1 = closeWrtFunDeps post_mr_quant $
-                         mono_tvs0 `unionVarSet` tyCoVarsOfTypes mr_no_quant
+                         (mono_tvs0 `unionVarSet` tyCoVarsOfTypes mr_no_quant)
 
              -- Finally, delete psig_qtvs
              -- If the user has explicitly asked for quantification, then that
@@ -1513,6 +1512,14 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
              -- in Step 2 of Note [Deciding quantification].
              mono_tvs = mono_tvs1 `delVarSetList` psig_qtvs
 
+             -- 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
+             newly_mono = mono_tvs `minusVarSet` mono_tvs0
+             final_quant
+               | isTopTcLevel tc_lvl = filterOut (predMentions newly_mono) post_mr_quant
+               | otherwise           = post_mr_quant
+
        -- Check if the Monomorphism Restriction has bitten
        ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $
          do { let mono_tvs_wo_mr = closeWrtFunDeps post_mr_quant mono_tvs0
@@ -1537,10 +1544,11 @@ decideAndPromoteTyVars infer_mode name_taus psigs wanted
            , text "post_mr_quant =" <+> ppr post_mr_quant
            , text "no_quant =" <+> ppr no_quant
            , text "mr_no_quant =" <+> ppr mr_no_quant
+           , text "final_quant =" <+> ppr final_quant
            , text "mono_tvs =" <+> ppr mono_tvs
            , text "co_vars =" <+> ppr co_vars ]
 
-       ; return (post_mr_quant, co_vars) }
+       ; return (final_quant, co_vars) }
 
 -------------------
 applyMR :: DynFlags -> InferMode -> [PredType]



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/46564aa68229130568ef932b0e140187de436191
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/20241011/fe5f1f2c/attachment-0001.html>