[Git][ghc/ghc][wip/T24984] Wibbles

[Simon Peyton Jones (@simonpj)]

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


Commits:
a42d4cae by Simon Peyton Jones at 2024-07-16T00:23:21+01:00
Wibbles

- - - - -


4 changed files:

- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Utils/Misc.hs


Changes:

=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -192,18 +192,12 @@ getEqPredRole :: PredType -> Role
 -- Precondition: the PredType is (s ~#N t) or (s ~#R t)
 getEqPredRole ty = eqRelRole (predTypeEqRel ty)
 
--- | Get the equality relation relevant for a pred type.
--- Precondition: the PredType is (s ~#N t) or (s ~#R t)
+-- | Get the equality relation relevant for a pred type
+-- Returns NomEq for dictionary predicates, etc
 predTypeEqRel :: HasDebugCallStack => PredType -> EqRel
 predTypeEqRel ty
-  = case splitTyConApp_maybe ty of
-     Just (tc, _) | tc `hasKey` eqReprPrimTyConKey
-                  -> ReprEq
-                  | otherwise
-                  -> assertPpr (tc `hasKey` eqPrimTyConKey) (ppr ty)
-                     NomEq
-     _ -> pprPanic "predTypeEqRel" (ppr ty)
-
+  | isReprEqPrimPred ty = ReprEq
+  | otherwise           = NomEq
 
 {-------------------------------------------
 Predicates on PredType


=====================================
compiler/GHC/Tc/Solver/InertSet.hs
=====================================
@@ -1554,8 +1554,8 @@ kickOutRewritableLHS ko_spec new_fr@(_, new_role)
 
     (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs
     (feqs_out,   feqs_in)   = partitionFunEqs   kick_out_eq funeqmap
-    (dicts_out,  dicts_in)  = partitionDicts    (kick_out_non_eq . CDictCan) dictmap
-    (irs_out,    irs_in)    = partitionBag      (kick_out_non_eq . CIrredCan) irreds
+    (dicts_out,  dicts_in)  = partitionDicts    kick_out_dict dictmap
+    (irs_out,    irs_in)    = partitionBag      kick_out_irred irreds
       -- Kick out even insolubles: See Note [Rewrite insolubles]
       -- Of course we must kick out irreducibles like (c a), in case
       -- we can rewrite 'c' to something more useful
@@ -1581,7 +1581,6 @@ kickOutRewritableLHS ko_spec new_fr@(_, new_role)
     lookOnlyUnderFamApps = True
 
     fr_tv_can_rewrite_ty :: UnderFam -> (TyVar -> Bool) -> EqRel -> Type -> Bool
-    -- UnderFam = True <=> look only under type-family applications
     fr_tv_can_rewrite_ty look_under_famapp_only check_tv role ty
       = anyRewritableTyVar role can_rewrite ty
       where
@@ -1591,7 +1590,6 @@ kickOutRewritableLHS ko_spec new_fr@(_, new_role)
              new_role `eqCanRewrite` old_role && check_tv tv
 
     fr_tf_can_rewrite_ty :: UnderFam -> TyCon -> [TcType] -> EqRel -> Type -> Bool
-    -- UnderFam = True <=> look only under type-family applications
     fr_tf_can_rewrite_ty look_under_famapp_only new_tf new_tf_args role ty
       = anyRewritableTyFamApp role can_rewrite ty
       where
@@ -1619,17 +1617,16 @@ kickOutRewritableLHS ko_spec new_fr@(_, new_role)
     -- Kick it out if the new CEqCan can rewrite the inert one
     -- See Note [kickOutRewritable]
     kick_out_dict (DictCt { di_tys = tys, di_ev = ev })
-      =  fr_may_rewrite fs
+      =  fr_may_rewrite (ctEvFlavour ev, NomEq)
       && any (fr_can_rewrite_ty lookEverywhere NomEq) tys
-      where
-        fs = (ctEvFlavour ev, NomEq)
 
     kick_out_irred :: IrredCt -> Bool
-    kick_out_irred (IrredCt }{ 
-      =  fr_may_rewrite fs
-      && any (fr_can_rewrite_ty lookEverywhere NomEq) tys
+    kick_out_irred (IrredCt { ir_ev = ev })
+      =  fr_may_rewrite (ctEvFlavour ev, eq_rel)
+      && fr_can_rewrite_ty lookEverywhere eq_rel pred
       where
-        fs = (ctEvFlavour ev, NomEq)
+       pred   = ctEvPred ev
+       eq_rel = predTypeEqRel pred
 
     -- Implements criteria K1-K3 in Note [Extending the inert equalities]
     kick_out_eq :: EqCt -> Bool


=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -225,7 +225,7 @@ data DictCt   -- e.g.  Num ty
 dictCtEvidence :: DictCt -> CtEvidence
 dictCtEvidence = di_ev
 
-dictCtPred :: DictCt -> CtEvidence
+dictCtPred :: DictCt -> TcPredType
 dictCtPred (DictCt { di_cls = cls, di_tys = tys }) = mkClassPred cls tys
 
 instance Outputable DictCt where
@@ -2048,9 +2048,7 @@ ctEvRewriteEqRel :: CtEvidence -> EqRel
 -- ^ Return the rewrite-role of an abitrary CtEvidence
 -- See Note [The rewrite-role of a constraint]
 -- We return ReprEq for (a ~R# b) and NomEq for all other preds
-ctEvRewriteEqRel ev
-  | isReprEqPrimPred (ctEvPred ev) = ReprEq
-  | otherwise                      = NomEq
+ctEvRewriteEqRel = predTypeEqRel . ctEvPred
 
 ctEvTerm :: CtEvidence -> EvTerm
 ctEvTerm ev = EvExpr (ctEvExpr ev)


=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -649,13 +649,12 @@ all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 -- True if the lists are the same length, and
 -- all corresponding elements satisfy the predicate
 all2 _ []     []     = True
-
 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 all2 _ _      _      = False
 
 any2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 -- True if any of the corresponding elements satisfy the predicate
--- Unlike `any2`, this ignores excess elements of the other list
+-- Unlike `all2`, this ignores excess elements of the other list
 any2 p (x:xs) (y:ys) = p x y || all2 p xs ys
 any2 _ _      _      = False
 



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

-- 
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a42d4cae4d583bd46aca73f876e0c6445c2834c4
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/20240715/046d821d/attachment-0001.html>