[Git][ghc/ghc][wip/T22194-flags] Make approximateWC a bit cleverer

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T22194-flags at Glasgow Haskell Compiler / GHC


Commits:
d82250e8 by Simon Peyton Jones at 2023-04-03T23:05:03+01:00
Make approximateWC a bit cleverer

See the long comment in !10123.  Submitting for CI.
I'll write a proper commit later if we like this.

- - - - -


1 changed file:

- compiler/GHC/Tc/Solver.hs


Changes:

=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -3157,30 +3157,36 @@ defaultTyVarTcS the_tv
 
 approximateWC :: Bool -> WantedConstraints -> Cts
 -- Second return value is the depleted wc
--- Third return value is YesFDsCombined <=> multiple constraints for the same fundep floated
 -- Postcondition: Wanted Cts
 -- See Note [ApproximateWC]
 -- See Note [floatKindEqualities vs approximateWC]
 approximateWC float_past_equalities wc
-  = float_wc emptyVarSet wc
+  = float_wc False emptyVarSet wc
   where
-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts
-    float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })
-      = filterBag (is_floatable trapping_tvs) simples `unionBags`
-        concatMapBag (float_implic trapping_tvs) implics
-    float_implic :: TcTyCoVarSet -> Implication -> Cts
-    float_implic trapping_tvs imp
-      | float_past_equalities || ic_given_eqs imp /= MaybeGivenEqs
-      = float_wc new_trapping_tvs (ic_wanted imp)
-      | otherwise   -- Take care with equalities
-      = emptyCts    -- See (1) under Note [ApproximateWC]
+    float_wc :: Bool           -- True <=> there are enclosing equalities
+             -> TcTyCoVarSet   -- Enclosing skolem binders
+             -> WantedConstraints -> Cts
+    float_wc encl_eqs trapping_tvs (WC { wc_simple = simples, wc_impl = implics })
+      = filterBag (is_floatable encl_eqs trapping_tvs) simples `unionBags`
+        concatMapBag (float_implic encl_eqs trapping_tvs) implics
+
+    float_implic :: Bool -> TcTyCoVarSet -> Implication -> Cts
+    float_implic encl_eqs trapping_tvs imp
+      = float_wc new_encl_eqs new_trapping_tvs (ic_wanted imp)
       where
         new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
-
-    is_floatable skol_tvs ct
-       | isGivenCt ct     = False
-       | insolubleEqCt ct = False
-       | otherwise        = tyCoVarsOfCt ct `disjointVarSet` skol_tvs
+        new_encl_eqs = encl_eqs || ic_given_eqs imp == MaybeGivenEqs
+
+    is_floatable encl_eqs skol_tvs ct
+       | isGivenCt ct                                = False
+       | insolubleEqCt ct                            = False
+       | tyCoVarsOfCt ct `intersectsVarSet` skol_tvs = False
+       | otherwise
+       = case classifyPredType (ctPred ct) of
+           EqPred {}     -> float_past_equalities || not encl_eqs
+           ClassPred {}  -> True
+           IrredPred {}  -> True
+           ForAllPred {} -> False
 
 {- Note [ApproximateWC]
 ~~~~~~~~~~~~~~~~~~~~~~~



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d82250e8ab66107ed004878948a09f1f7b960472
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/20230403/592139fc/attachment-0001.html>