summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc/Solver
diff options
context:
space:
mode:
authorRichard Eisenberg <rae@richarde.dev>2020-11-25 15:22:16 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-12-01 19:57:41 -0500
commit8bb52d9186655134e3e06b4dc003e060379f5417 (patch)
treecf62438a5f5b3587fe666d72d77561201253306a /compiler/GHC/Tc/Solver
parent0dd45d0adbade7eaae973b09b4d0ff1acb1479b8 (diff)
downloadhaskell-8bb52d9186655134e3e06b4dc003e060379f5417.tar.gz
Remove flattening variables
This patch redesigns the flattener to simplify type family applications directly instead of using flattening meta-variables and skolems. The key new innovation is the CanEqLHS type and the new CEqCan constraint (Ct). A CanEqLHS is either a type variable or exactly-saturated type family application; either can now be rewritten using a CEqCan constraint in the inert set. Because the flattener no longer reduces all type family applications to variables, there was some performance degradation if a lengthy type family application is now flattened over and over (not making progress). To compensate, this patch contains some extra optimizations in the flattener, leading to a number of performance improvements. Close #18875. Close #18910. There are many extra parts of the compiler that had to be affected in writing this patch: * The family-application cache (formerly the flat-cache) sometimes stores coercions built from Given inerts. When these inerts get kicked out, we must kick out from the cache as well. (This was, I believe, true previously, but somehow never caused trouble.) Kicking out from the cache requires adding a filterTM function to TrieMap. * This patch obviates the need to distinguish "blocking" coercion holes from non-blocking ones (which, previously, arose from CFunEqCans). There is thus some simplification around coercion holes. * Extra commentary throughout parts of the code I read through, to preserve the knowledge I gained while working. * A change in the pure unifier around unifying skolems with other types. Unifying a skolem now leads to SurelyApart, not MaybeApart, as documented in Note [Binding when looking up instances] in GHC.Core.InstEnv. * Some more use of MCoercion where appropriate. * Previously, class-instance lookup automatically noticed that e.g. C Int was a "unifier" to a target [W] C (F Bool), because the F Bool was flattened to a variable. Now, a little more care must be taken around checking for unifying instances. * Previously, tcSplitTyConApp_maybe would split (Eq a => a). This is silly, because (=>) is not a tycon in Haskell. Fixed now, but there are some knock-on changes in e.g. TrieMap code and in the canonicaliser. * New function anyFreeVarsOf{Type,Co} to check whether a free variable satisfies a certain predicate. * Type synonyms now remember whether or not they are "forgetful"; a forgetful synonym drops at least one argument. This is useful when flattening; see flattenView. * The pattern-match completeness checker invokes the solver. This invocation might need to look through newtypes when checking representational equality. Thus, the desugarer needs to keep track of the in-scope variables to know what newtype constructors are in scope. I bet this bug was around before but never noticed. * Extra-constraints wildcards are no longer simplified before printing. See Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver. * Whether or not there are Given equalities has become slightly subtler. See the new HasGivenEqs datatype. * Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical explains a significant new wrinkle in the new approach. * See Note [What might match later?] in GHC.Tc.Solver.Interact, which explains the fix to #18910. * The inert_count field of InertCans wasn't actually used, so I removed it. Though I (Richard) did the implementation, Simon PJ was very involved in design and review. This updates the Haddock submodule to avoid #18932 by adding a type signature. ------------------------- Metric Decrease: T12227 T5030 T9872a T9872b T9872c Metric Increase: T9872d -------------------------
Diffstat (limited to 'compiler/GHC/Tc/Solver')
-rw-r--r--compiler/GHC/Tc/Solver/Canonical.hs1163
-rw-r--r--compiler/GHC/Tc/Solver/Flatten.hs1496
-rw-r--r--compiler/GHC/Tc/Solver/Interact.hs723
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs1465
4 files changed, 1981 insertions, 2866 deletions
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index 7068d3176d..60300b70f4 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE MultiWayIf #-}
module GHC.Tc.Solver.Canonical(
canonicalize,
unifyDerived,
- makeSuperClasses, maybeSym,
+ makeSuperClasses,
StopOrContinue(..), stopWith, continueWith,
solveCallStack -- For GHC.Tc.Solver
) where
@@ -16,7 +17,7 @@ import GHC.Prelude
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.Unify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) )
+import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Tc.Solver.Flatten
@@ -28,15 +29,17 @@ import GHC.Core.TyCon
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking
import GHC.Core.Coercion
+import GHC.Core.Coercion.Axiom
import GHC.Core
import GHC.Types.Id( mkTemplateLocals )
import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
import GHC.Types.Var
import GHC.Types.Var.Env( mkInScopeSet )
-import GHC.Types.Var.Set( delVarSetList )
+import GHC.Types.Var.Set( delVarSetList, anyVarSet )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Builtin.Types ( anyTypeOfKind )
import GHC.Driver.Session( DynFlags )
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
@@ -47,7 +50,7 @@ import GHC.Utils.Misc
import GHC.Data.Bag
import GHC.Utils.Monad
import Control.Monad
-import Data.Maybe ( isJust )
+import Data.Maybe ( isJust, isNothing )
import Data.List ( zip4 )
import GHC.Types.Basic
@@ -89,53 +92,46 @@ last time through, so we can skip the classification step.
canonicalize :: Ct -> TcS (StopOrContinue Ct)
canonicalize (CNonCanonical { cc_ev = ev })
= {-# SCC "canNC" #-}
- case classifyPredType pred of
- ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
- canClassNC ev cls tys
- EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
- canEqNC ev eq_rel ty1 ty2
- IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred)
- canIrred OtherCIS ev
- ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred)
- canForAllNC ev tvs th p
- where
- pred = ctEvPred ev
+ canNC ev
canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
= canForAll ev pend_sc
-canonicalize (CIrredCan { cc_ev = ev, cc_status = status })
- | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)
- = -- For insolubles (all of which are equalities, do /not/ flatten the arguments
+canonicalize (CIrredCan { cc_ev = ev })
+ = canNC ev
+ -- Instead of flattening the evidence before classifying, it's possible we
+ -- can make progress without the flatten. Try this first.
+ -- For insolubles (all of which are equalities), do /not/ flatten the arguments
-- In #14350 doing so led entire-unnecessary and ridiculously large
-- type function expansion. Instead, canEqNC just applies
-- the substitution to the predicate, and may do decomposition;
-- e.g. a ~ [a], where [G] a ~ [Int], can decompose
- canEqNC ev eq_rel ty1 ty2
-
- | otherwise
- = canIrred status ev
canonicalize (CDictCan { cc_ev = ev, cc_class = cls
, cc_tyargs = xis, cc_pend_sc = pend_sc })
= {-# SCC "canClass" #-}
canClass ev cls xis pend_sc
-canonicalize (CTyEqCan { cc_ev = ev
- , cc_tyvar = tv
- , cc_rhs = xi
- , cc_eq_rel = eq_rel })
+canonicalize (CEqCan { cc_ev = ev
+ , cc_lhs = lhs
+ , cc_rhs = rhs
+ , cc_eq_rel = eq_rel })
= {-# SCC "canEqLeafTyVarEq" #-}
- canEqNC ev eq_rel (mkTyVarTy tv) xi
- -- NB: Don't use canEqTyVar because that expects flattened types,
- -- and tv and xi may not be flat w.r.t. an updated inert set
+ canEqNC ev eq_rel (canEqLHSType lhs) rhs
-canonicalize (CFunEqCan { cc_ev = ev
- , cc_fun = fn
- , cc_tyargs = xis1
- , cc_fsk = fsk })
- = {-# SCC "canEqLeafFunEq" #-}
- canCFunEqCan ev fn xis1 fsk
+canNC :: CtEvidence -> TcS (StopOrContinue Ct)
+canNC ev =
+ case classifyPredType pred of
+ ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
+ canClassNC ev cls tys
+ EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
+ canEqNC ev eq_rel ty1 ty2
+ IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred)
+ canIrred ev
+ ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred)
+ canForAllNC ev tvs th p
+ where
+ pred = ctEvPred ev
{-
************************************************************************
@@ -206,8 +202,7 @@ canClass :: CtEvidence
canClass ev cls tys pend_sc
= -- all classes do *nominal* matching
ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
- do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys
- ; MASSERT( isTcReflCo _kind_co )
+ do { (xis, cos) <- flattenArgsNom ev cls_tc tys
; let co = mkTcTyConAppCo Nominal cls_tc cos
xi = mkClassPred cls xis
mk_ct new_ev = CDictCan { cc_ev = new_ev
@@ -701,24 +696,27 @@ See also Note [Evidence for quantified constraints] in GHC.Core.Predicate.
************************************************************************
-}
-canIrred :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct)
+canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
-- Precondition: ty not a tuple and no other evidence form
-canIrred status ev
+canIrred ev
= do { let pred = ctEvPred ev
; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
- ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred
+ ; (xi,co) <- flatten ev pred -- co :: xi ~ pred
; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
do { -- Re-classify, in case flattening has improved its shape
- -- Code is like the CNonCanonical case of canonicalize, except
+ -- Code is like the canNC, except
-- that the IrredPred branch stops work
; case classifyPredType (ctEvPred new_ev) of
ClassPred cls tys -> canClassNC new_ev cls tys
EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2
- ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred)
+ ForAllPred tvs th p -> -- this is highly suspect; Quick Look
+ -- should never leave a meta-var filled
+ -- in with a polytype. This is #18987.
+ do traceTcS "canEvNC:forall" (ppr pred)
canForAllNC ev tvs th p
IrredPred {} -> continueWith $
- mkIrredCt status new_ev } }
+ mkIrredCt OtherCIS new_ev } }
{- *********************************************************************
* *
@@ -817,11 +815,8 @@ canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
-- We have a constraint (forall as. blah => C tys)
canForAll ev pend_sc
= do { -- First rewrite it to apply the current substitution
- -- Do not bother with type-family reductions; we can't
- -- do them under a forall anyway (c.f. Flatten.flatten_one
- -- on a forall type)
let pred = ctEvPred ev
- ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
+ ; (xi,co) <- flatten ev pred -- co :: xi ~ pred
; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
do { -- Now decompose into its pieces and solve it
@@ -988,19 +983,12 @@ can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-- Then, get rid of casts
can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
- | not (isTyVarTy ty2) -- See (3) in Note [Equalities with incompatible kinds]
+ | isNothing (canEqLHS_maybe ty2) -- See (3) in Note [Equalities with incompatible kinds]
= canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
- | not (isTyVarTy ty1) -- See (3) in Note [Equalities with incompatible kinds]
+ | isNothing (canEqLHS_maybe ty1) -- See (3) in Note [Equalities with incompatible kinds]
= canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
--- NB: pattern match on True: we want only flat types sent to canEqTyVar.
--- See also Note [No top-level newtypes on RHS of representational equalities]
-can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2
- = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2
-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2
- = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1
-
----------------------
-- Otherwise try to decompose
----------------------
@@ -1014,8 +1002,8 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
-- Decompose FunTy: (s -> t) and (c => t)
-- NB: don't decompose (Int -> blah) ~ (Show a => blah)
can_eq_nc' _flat _rdr_env _envs ev eq_rel
- (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _
- (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _
+ (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1
+ (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2
| af1 == af2 -- Don't decompose (Int -> blah) ~ (Show a => blah)
, Just ty1a_rep <- getRuntimeRep_maybe ty1a -- getRutimeRep_maybe:
, Just ty1b_rep <- getRuntimeRep_maybe ty1b -- see Note [Decomposing FunTy]
@@ -1026,11 +1014,14 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel
[am2, ty2a_rep, ty2b_rep, ty2a, ty2b]
-- Decompose type constructor applications
--- NB: e have expanded type synonyms already
-can_eq_nc' _flat _rdr_env _envs ev eq_rel
- (TyConApp tc1 tys1) _
- (TyConApp tc2 tys2) _
- | not (isTypeFamilyTyCon tc1)
+-- NB: we have expanded type synonyms already
+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _
+ | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1
+ , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2
+ -- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better
+ -- error messages rather than decomposing into AppTys;
+ -- hence no direct match on TyConApp
+ , not (isTypeFamilyTyCon tc1)
, not (isTypeFamilyTyCon tc2)
= canTyConApp ev eq_rel tc1 tys1 tc2 tys2
@@ -1041,22 +1032,51 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel
= can_eq_nc_forall ev eq_rel s1 s2
-- See Note [Canonicalising type applications] about why we require flat types
-can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _
- | NomEq <- eq_rel
+-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families
+-- NB: Only decompose AppTy for nominal equality. See Note [Decomposing equality]
+can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _
+ | Just (t1, s1) <- tcSplitAppTy_maybe ty1
, Just (t2, s2) <- tcSplitAppTy_maybe ty2
= can_eq_app ev t1 s1 t2 s2
-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _
- | NomEq <- eq_rel
- , Just (t1, s1) <- tcSplitAppTy_maybe ty1
- = can_eq_app ev t1 s1 t2 s2
+
+-------------------
+-- Can't decompose.
+-------------------
-- No similarity in type structure detected. Flatten and try again.
can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
- = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1
- ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2
+ = do { (xi1, co1) <- flatten ev ps_ty1
+ ; (xi2, co2) <- flatten ev ps_ty2
; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
+----------------------------
+-- Look for a canonical LHS. See Note [Canonical LHS].
+-- Only flat types end up below here.
+----------------------------
+
+-- NB: pattern match on True: we want only flat types sent to canEqLHS
+-- This means we've rewritten any variables and reduced any type family redexes
+-- See also Note [No top-level newtypes on RHS of representational equalities]
+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+ | Just can_eq_lhs1 <- canEqLHS_maybe ty1
+ = canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2
+
+ | Just can_eq_lhs2 <- canEqLHS_maybe ty2
+ = canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1
+
+ -- If the type is TyConApp tc1 args1, then args1 really can't be less
+ -- than tyConArity tc1. It could be *more* than tyConArity, but then we
+ -- should have handled the case as an AppTy. That case only fires if
+ -- *both* sides of the equality are AppTy-like... but if one side is
+ -- AppTy-like and the other isn't (and it also isn't a variable or
+ -- saturated type family application, both of which are handled by
+ -- can_eq_nc'), we're in a failure mode and can just fall through.
+
+----------------------------
+-- Fall-through. Give up.
+----------------------------
+
-- We've flattened and the types don't match. Give up.
can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
= do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
@@ -1461,7 +1481,7 @@ can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2
-- AppTys only decompose for nominal equality, so this case just leads
-- to an irreducible constraint; see typecheck/should_compile/T10494
--- See Note [Decomposing equality], note {4}
+-- See Note [Decomposing AppTy at representational role]
can_eq_app ev s1 t1 s2 t2
| CtDerived {} <- ev
= do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]
@@ -1615,7 +1635,7 @@ In this Note, "decomposition" refers to taking the constraint
where that notation indicates a list of new constraints, where the
new constraints may have different flavours and different roles.
-The key property to consider is injectivity. When decomposing a Given the
+The key property to consider is injectivity. When decomposing a Given, the
decomposition is sound if and only if T is injective in all of its type
arguments. When decomposing a Wanted, the decomposition is sound (assuming the
correct roles in the produced equality constraints), but it may be a guess --
@@ -1633,56 +1653,53 @@ Pursuing the details requires exploring three axes:
* Role: Nominal vs. Representational
* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable
-(So a type variable isn't a TyCon, but it's convenient to put the AppTy case
+(A type variable isn't a TyCon, of course, but it's convenient to put the AppTy case
in the same table.)
Right away, we can say that Derived behaves just as Wanted for the purposes
of decomposition. The difference between Derived and Wanted is the handling of
evidence. Since decomposition in these cases isn't a matter of soundness but of
-guessing, we want the same behavior regardless of evidence.
+guessing, we want the same behaviour regardless of evidence.
Here is a table (discussion following) detailing where decomposition of
(T s1 ... sn) ~r (T t1 .. tn)
is allowed. The first four lines (Data types ... type family) refer
-to TyConApps with various TyCons T; the last line is for AppTy, where
-there is presumably a type variable at the head, so it's actually
- (s s1 ... sn) ~r (t t1 .. tn)
+to TyConApps with various TyCons T; the last line is for AppTy, covering
+both where there is a type variable at the head and the case for an over-
+saturated type family.
-NOMINAL GIVEN WANTED
+NOMINAL GIVEN WANTED WHERE
-Datatype YES YES
-Newtype YES YES
-Data family YES YES
-Type family YES, in injective args{1} YES, in injective args{1}
-Type variable YES YES
+Datatype YES YES canTyConApp
+Newtype YES YES canTyConApp
+Data family YES YES canTyConApp
+Type family NO{1} YES, in injective args{1} canEqCanLHS2
+AppTy YES YES can_eq_app
-REPRESENTATIONAL GIVEN WANTED
+REPRESENTATIONAL GIVEN WANTED
-Datatype YES YES
-Newtype NO{2} MAYBE{2}
-Data family NO{3} MAYBE{3}
-Type family NO NO
-Type variable NO{4} NO{4}
+Datatype YES YES canTyConApp
+Newtype NO{2} MAYBE{2} canTyConApp(can_decompose)
+Data family NO{3} MAYBE{3} canTyConApp(can_decompose)
+Type family NO NO canEqCanLHS2
+AppTy NO{4} NO{4} can_eq_nc'
{1}: Type families can be injective in some, but not all, of their arguments,
so we want to do partial decomposition. This is quite different than the way
other decomposition is done, where the decomposed equalities replace the original
-one. We thus proceed much like we do with superclasses: emitting new Givens
-when "decomposing" a partially-injective type family Given and new Deriveds
-when "decomposing" a partially-injective type family Wanted. (As of the time of
-writing, 13 June 2015, the implementation of injective type families has not
-been merged, but it should be soon. Please delete this parenthetical if the
-implementation is indeed merged.)
+one. We thus proceed much like we do with superclasses, emitting new Deriveds
+when "decomposing" a partially-injective type family Wanted. Injective type
+families have no corresponding evidence of their injectivity, so we cannot
+decompose an injective-type-family Given.
{2}: See Note [Decomposing newtypes at representational role]
{3}: Because of the possibility of newtype instances, we must treat
-data families like newtypes. See also Note [Decomposing newtypes at
-representational role]. See #10534 and test case
-typecheck/should_fail/T10534.
+data families like newtypes. See also
+Note [Decomposing newtypes at representational role]. See #10534 and
+test case typecheck/should_fail/T10534.
-{4}: Because type variables can stand in for newtypes, we conservatively do not
-decompose AppTys over representational equality.
+{4}: See Note [Decomposing AppTy at representational role]
In the implementation of can_eq_nc and friends, we don't directly pattern
match using lines like in the tables above, as those tables don't cover
@@ -1752,6 +1769,68 @@ Conclusion:
* Decompose [W] N s ~R N t iff there no given constraint that could
later solve it.
+Note [Decomposing AppTy at representational role]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never decompose AppTy at a representational role. For Givens, doing
+so is simply unsound: the LRCo coercion former requires a nominal-roled
+arguments. (See (1) for an example of why.) For Wanteds, decomposing
+would be sound, but it would be a guess, and a non-confluent one at that.
+
+Here is an example:
+
+ [G] g1 :: a ~R b
+ [W] w1 :: Maybe b ~R alpha a
+ [W] w2 :: alpha ~ Maybe
+
+Suppose we see w1 before w2. If we were to decompose, we would decompose
+this to become
+
+ [W] w3 :: Maybe ~R alpha
+ [W] w4 :: b ~ a
+
+Note that w4 is *nominal*. A nominal role here is necessary because AppCo
+requires a nominal role on its second argument. (See (2) for an example of
+why.) If we decomposed w1 to w3,w4, we would then get stuck, because w4
+is insoluble. On the other hand, if we see w2 first, setting alpha := Maybe,
+all is well, as we can decompose Maybe b ~R Maybe a into b ~R a.
+
+Another example:
+
+ newtype Phant x = MkPhant Int
+
+ [W] w1 :: Phant Int ~R alpha Bool
+ [W] w2 :: alpha ~ Phant
+
+If we see w1 first, decomposing would be disastrous, as we would then try
+to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become
+
+ [W] w1' :: Phant Int ~R Phant Bool
+
+which can then (assuming MkPhant is in scope) be simplified to Int ~R Int,
+and all will be well. See also Note [Unwrap newtypes first].
+
+Bottom line: never decompose AppTy with representational roles.
+
+(1) Decomposing a Given AppTy over a representational role is simply
+unsound. For example, if we have co1 :: Phant Int ~R a Bool (for
+the newtype Phant, above), then we surely don't want any relationship
+between Int and Bool, lest we also have co2 :: Phant ~ a around.
+
+(2) The role on the AppCo coercion is a conservative choice, because we don't
+know the role signature of the function. For example, let's assume we could
+have a representational role on the second argument of AppCo. Then, consider
+
+ data G a where -- G will have a nominal role, as G is a GADT
+ MkG :: G Int
+ newtype Age = MkAge Int
+
+ co1 :: G ~R a -- by assumption
+ co2 :: Age ~R Int -- by newtype axiom
+ co3 = AppCo co1 co2 :: G Age ~R a Int -- by our broken AppCo
+
+and now co3 can be used to cast MkG to have type G Age, in violation of
+the way GADTs are supposed to work (which is to use nominal equality).
+
-}
canDecomposableTyConAppOK :: CtEvidence -> EqRel
@@ -1820,8 +1899,8 @@ canEqFailure :: CtEvidence -> EqRel
canEqFailure ev NomEq ty1 ty2
= canEqHardFailure ev ty1 ty2
canEqFailure ev ReprEq ty1 ty2
- = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1
- ; (xi2, co2) <- flatten FM_FlattenAll ev ty2
+ = do { (xi1, co1) <- flatten ev ty1
+ ; (xi2, co2) <- flatten ev ty2
-- We must flatten the types before putting them in the
-- inert set, so that we are sure to kick them out when
-- new equalities become available
@@ -1836,8 +1915,8 @@ canEqHardFailure :: CtEvidence
-- See Note [Make sure that insolubles are fully rewritten]
canEqHardFailure ev ty1 ty2
= do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)
- ; (s1, co1) <- flatten FM_SubstOnly ev ty1
- ; (s2, co2) <- flatten FM_SubstOnly ev ty2
+ ; (s1, co1) <- flatten ev ty1
+ ; (s2, co2) <- flatten ev ty2
; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
; continueWith (mkIrredCt InsolubleCIS new_ev) }
@@ -1858,10 +1937,7 @@ unifyWanted etc to short-cut that work.
Note [Canonicalising type applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given (s1 t1) ~ ty2, how should we proceed?
-The simple things is to see if ty2 is of form (s2 t2), and
-decompose. By this time s1 and s2 can't be saturated type
-function applications, because those have been dealt with
-by an earlier equation in can_eq_nc, so it is always sound to
+The simple thing is to see if ty2 is of form (s2 t2), and
decompose.
However, over-eager decomposition gives bad error messages
@@ -1921,9 +1997,9 @@ Suppose we're in this situation:
where
newtype Id a = Id a
-We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened
+We want to make sure canEqCanLHS sees [W] a ~R a, after b is flattened
and the Id newtype is unwrapped. This is assured by requiring only flat
-types in canEqTyVar *and* having the newtype-unwrapping check above
+types in canEqCanLHS *and* having the newtype-unwrapping check above
the tyvar check in can_eq_nc.
Note [Occurs check error]
@@ -1942,104 +2018,83 @@ isInsolubleOccursCheck does.
See also #10715, which induced this addition.
-Note [canCFunEqCan]
-~~~~~~~~~~~~~~~~~~~
-Flattening the arguments to a type family can change the kind of the type
-family application. As an easy example, consider (Any k) where (k ~ Type)
-is in the inert set. The original (Any k :: k) becomes (Any Type :: Type).
-The problem here is that the fsk in the CFunEqCan will have the old kind.
-
-The solution is to come up with a new fsk/fmv of the right kind. For
-givens, this is easy: just introduce a new fsk and update the flat-cache
-with the new one. For wanteds, we want to solve the old one if favor of
-the new one, so we use dischargeFmv. This also kicks out constraints
-from the inert set; this behavior is correct, as the kind-change may
-allow more constraints to be solved.
-
-We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case
-if we really need to. Of course `flattenArgsNom` should return `Refl`
-whenever possible, but #15577 was an infinite loop because even
-though the coercion was homo-kinded, `kind_co` was not `Refl`, so we
-made a new (identical) CFunEqCan, and then the entire process repeated.
--}
+Note [Put touchable variables on the left]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticket #10009, a very nasty example:
-canCFunEqCan :: CtEvidence
- -> TyCon -> [TcType] -- LHS
- -> TcTyVar -- RHS
- -> TcS (StopOrContinue Ct)
--- ^ Canonicalise a CFunEqCan. We know that
--- the arg types are already flat,
--- and the RHS is a fsk, which we must *not* substitute.
--- So just substitute in the LHS
-canCFunEqCan ev fn tys fsk
- = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys
- -- cos :: tys' ~ tys
-
- ; let lhs_co = mkTcTyConAppCo Nominal fn cos
- -- :: F tys' ~ F tys
- new_lhs = mkTyConApp fn tys'
-
- flav = ctEvFlavour ev
- ; (ev', fsk')
- <- if isTcReflexiveCo kind_co -- See Note [canCFunEqCan]
- then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs)
- ; let fsk_ty = mkTyVarTy fsk
- ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
- lhs_co (mkTcNomReflCo fsk_ty)
- ; return (ev', fsk) }
- else do { traceTcS "canCFunEqCan: non-refl" $
- vcat [ text "Kind co:" <+> ppr kind_co
- , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk)
- , text "LHS:" <+> hang (ppr (mkTyConApp fn tys))
- 2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys)))
- , text "New LHS" <+> hang (ppr new_lhs)
- 2 (dcolon <+> ppr (tcTypeKind new_lhs)) ]
- ; (ev', new_co, new_fsk)
- <- newFlattenSkolem flav (ctEvLoc ev) fn tys'
- ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co
- -- sym lhs_co :: F tys ~ F tys'
- -- new_co :: F tys' ~ new_fsk
- -- co :: F tys ~ (new_fsk |> kind_co)
- co = mkTcSymCo lhs_co `mkTcTransCo`
- mkTcCoherenceRightCo Nominal
- (mkTyVarTy new_fsk)
- kind_co
- new_co
-
- ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev)
- ; dischargeFunEq ev fsk co xi
- ; return (ev', new_fsk) }
-
- ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev')
- ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn
- , cc_tyargs = tys', cc_fsk = fsk' }) }
+ f :: (UnF (F b) ~ b) => F b -> ()
+
+ g :: forall a. (UnF (F a) ~ a) => a -> ()
+ g _ = f (undefined :: F a)
+
+For g we get [G] g1 : UnF (F a) ~ a
+ [WD] w1 : UnF (F beta) ~ beta
+ [WD] w2 : F a ~ F beta
+
+g1 is canonical (CEqCan). It is oriented as above because a is not touchable.
+See canEqTyVarFunEq.
+
+w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key
+here.
+
+w2 is canonical. But which way should it be oriented? As written, we'll be
+stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is
+a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS
+of w2. We'll thus lose.
+
+But if w2 is swapped around, to
+
+ [D] w3 : F beta ~ F a
+
+then (after emitting shadow Deriveds, etc. See GHC.Tc.Solver.Monad
+Note [The improvement story and derived shadows]) we'll kick w1 out of the inert
+set (it mentions the LHS of w3). We then rewrite w1 to
+
+ [D] w4 : UnF (F a) ~ beta
+
+and then, using g1, to
+
+ [D] w5 : a ~ beta
+
+at which point we can unify and go on to glory. (This rewriting actually
+happens all at once, in the call to flatten during canonicalisation.)
+
+But what about the new LHS makes it better? It mentions a variable (beta)
+that can appear in a Wanted -- a touchable metavariable never appears
+in a Given. On the other hand, the original LHS mentioned only variables
+that appear in Givens. We thus choose to put variables that can appear
+in Wanteds on the left.
+
+Ticket #12526 is another good example of this in action.
+
+-}
---------------------
-canEqTyVar :: CtEvidence -- ev :: lhs ~ rhs
- -> EqRel -> SwapFlag
- -> TcTyVar -- tv1
- -> TcType -- lhs: pretty lhs, already flat
- -> TcType -> TcType -- rhs: already flat
- -> TcS (StopOrContinue Ct)
-canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2
+canEqCanLHS :: CtEvidence -- ev :: lhs ~ rhs
+ -> EqRel -> SwapFlag
+ -> CanEqLHS -- lhs (or, if swapped, rhs)
+ -> TcType -- lhs: pretty lhs, already flat
+ -> TcType -> TcType -- rhs: already flat
+ -> TcS (StopOrContinue Ct)
+canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
| k1 `tcEqType` k2
- = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2
+ = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
| otherwise
- = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2
+ = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2
where
- k1 = tyVarKind tv1
+ k1 = canEqLHSKind lhs1
k2 = tcTypeKind xi2
-canEqTyVarHetero :: CtEvidence -- :: (tv1 :: ki1) ~ (xi2 :: ki2)
- -> EqRel -> SwapFlag
- -> TcTyVar -> TcType -- tv1, pretty tv1
- -> TcKind -- ki1
- -> TcType -> TcType -- xi2, pretty xi2 :: ki2
- -> TcKind -- ki2
- -> TcS (StopOrContinue Ct)
-canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
+canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2)
+ -> EqRel -> SwapFlag
+ -> CanEqLHS -> TcType -- xi1, pretty xi1
+ -> TcKind -- ki1
+ -> TcType -> TcType -- xi2, pretty xi2 :: ki2
+ -> TcKind -- ki2
+ -> TcS (StopOrContinue Ct)
+canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
-- See Note [Equalities with incompatible kinds]
= do { kind_co <- emit_kind_co -- :: ki2 ~N ki1
@@ -2050,15 +2105,14 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
rhs_co = mkTcGReflLeftCo role xi2 kind_co
-- rhs_co :: (xi2 |> kind_co) ~ xi2
- lhs' = mkTyVarTy tv1 -- same as old lhs
- lhs_co = mkTcReflCo role lhs'
+ lhs_co = mkTcReflCo role xi1
; traceTcS "Hetero equality gives rise to kind equality"
(ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ])
- ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co
+ ; type_ev <- rewriteEqEvidence ev swapped xi1 rhs' lhs_co rhs_co
-- rewriteEqEvidence carries out the swap, so we're NotSwapped any more
- ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }
+ ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 rhs' ps_rhs' }
where
emit_kind_co :: TcS CoercionN
emit_kind_co
@@ -2071,9 +2125,10 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
| otherwise
= unifyWanted kind_loc Nominal ki2 ki1
+ xi1 = canEqLHSType lhs1
loc = ctev_loc ev
role = eqRelRole eq_rel
- kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc
+ kind_loc = mkKindLoc xi1 xi2 loc
kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1
maybe_sym = case swapped of
@@ -2082,104 +2137,236 @@ canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2
NotSwapped -> mkTcSymCo
-- guaranteed that tcTypeKind lhs == tcTypeKind rhs
-canEqTyVarHomo :: CtEvidence
- -> EqRel -> SwapFlag
- -> TcTyVar -- lhs: tv1
- -> TcType -- pretty lhs, flat
- -> TcType -> TcType -- rhs, flat
- -> TcS (StopOrContinue Ct)
-canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _
- | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2
- , tv1 == tv2
- = canEqReflexive ev eq_rel (mkTyVarTy tv1)
- -- we don't need to check co because it must be reflexive
-
- -- this guarantees (TyEq:TV)
- | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2
- , swapOverTyVars (isGiven ev) tv1 tv2
- = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
- ; let role = eqRelRole eq_rel
- sym_co2 = mkTcSymCo co2
- ty1 = mkTyVarTy tv1
- new_lhs = ty1 `mkCastTy` sym_co2
- lhs_co = mkTcGReflLeftCo role ty1 sym_co2
+canEqCanLHSHomo :: CtEvidence
+ -> EqRel -> SwapFlag
+ -> CanEqLHS -- lhs (or, if swapped, rhs)
+ -> TcType -- pretty lhs
+ -> TcType -> TcType -- rhs, pretty rhs
+ -> TcS (StopOrContinue Ct)
+canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
+ | (xi2', mco) <- split_cast_ty xi2
+ , Just lhs2 <- canEqLHS_maybe xi2'
+ = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkTcSymMCo mco) mco
- new_rhs = mkTyVarTy tv2
- rhs_co = mkTcGReflRightCo role new_rhs co2
+ | otherwise
+ = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2
- ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+ where
+ split_cast_ty (CastTy ty co) = (ty, MCo co)
+ split_cast_ty other = (other, MRefl)
+
+-- This function deals with the case that both LHS and RHS are potential
+-- CanEqLHSs.
+canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco)
+ -- or, if swapped: (rhs |> mco) ~ lhs
+ -> EqRel -> SwapFlag
+ -> CanEqLHS -- lhs (or, if swapped, rhs)
+ -> TcType -- pretty lhs
+ -> CanEqLHS -- rhs
+ -> TcType -- pretty rhs
+ -> MCoercion -- :: kind(rhs) ~N kind(lhs)
+ -> TcS (StopOrContinue Ct)
+canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
+ | lhs1 `eqCanEqLHS` lhs2
+ -- It must be the case that mco is reflexive
+ = canEqReflexive ev eq_rel (canEqLHSType lhs1)
+ | TyVarLHS tv1 <- lhs1
+ , TyVarLHS tv2 <- lhs2
+ , swapOverTyVars (isGiven ev) tv1 tv2
+ = do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
+ ; new_ev <- do_swap
+ ; canEqCanLHSFinish new_ev eq_rel IsSwapped (TyVarLHS tv2)
+ (ps_xi1 `mkCastTyMCo` sym_mco) }
+
+ | TyVarLHS tv1 <- lhs1
+ , TyFamLHS fun_tc2 fun_args2 <- lhs2
+ = canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
+
+ | TyFamLHS fun_tc1 fun_args1 <- lhs1
+ , TyVarLHS tv2 <- lhs2
+ = do { new_ev <- do_swap
+ ; canEqTyVarFunEq new_ev eq_rel IsSwapped tv2 ps_xi2
+ fun_tc1 fun_args1 ps_xi1 sym_mco }
+
+ | TyFamLHS fun_tc1 fun_args1 <- lhs1
+ , TyFamLHS fun_tc2 fun_args2 <- lhs2
+ = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2)
+
+ -- emit derived equalities for injective type families
+ ; let inj_eqns :: [TypeEqn] -- TypeEqn = Pair Type
+ inj_eqns
+ | ReprEq <- eq_rel = [] -- injectivity applies only for nom. eqs.
+ | fun_tc1 /= fun_tc2 = [] -- if the families don't match, stop.
+
+ | Injective inj <- tyConInjectivityInfo fun_tc1
+ = [ Pair arg1 arg2
+ | (arg1, arg2, True) <- zip3 fun_args1 fun_args2 inj ]
+
+ -- built-in synonym families don't have an entry point
+ -- for this use case. So, we just use sfInteractInert
+ -- and pass two equal RHSs. We *could* add another entry
+ -- point, but then there would be a burden to make
+ -- sure the new entry point and existing ones were
+ -- internally consistent. This is slightly distasteful,
+ -- but it works well in practice and localises the
+ -- problem.
+ | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1
+ = let ki1 = canEqLHSKind lhs1
+ ki2 | MRefl <- mco
+ = ki1 -- just a small optimisation
+ | otherwise
+ = canEqLHSKind lhs2
+
+ fake_rhs1 = anyTypeOfKind ki1
+ fake_rhs2 = anyTypeOfKind ki2
+ in
+ sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2
+
+ | otherwise -- ordinary, non-injective type family
+ = []
+
+ ; unless (isGiven ev) $
+ mapM_ (unifyDerived (ctEvLoc ev) Nominal) inj_eqns
+
+ ; tclvl <- getTcLevel
; dflags <- getDynFlags
- ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) }
+ ; let tvs1 = tyCoVarsOfTypes fun_args1
+ tvs2 = tyCoVarsOfTypes fun_args2
+
+ swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&
+ -- swap 'em: Note [Put touchable variables on the left]
+ not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1)
+ -- this check is just to avoid unfruitful swapping
+
+ -- If we have F a ~ F (F a), we want to swap.
+ swap_for_occurs
+ | MTVU_OK () <- checkTyFamEq dflags fun_tc2 fun_args2
+ (mkTyConApp fun_tc1 fun_args1)
+ , MTVU_Occurs <- checkTyFamEq dflags fun_tc1 fun_args1
+ (mkTyConApp fun_tc2 fun_args2)
+ = True
+
+ | otherwise
+ = False
+
+ ; if swap_for_rewriting || swap_for_occurs
+ then do { new_ev <- do_swap
+ ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) }
+ else finish_without_swapping }
+
+ -- that's all the special cases. Now we just figure out which non-special case
+ -- to continue to.
+ | otherwise
+ = finish_without_swapping
-canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2
- = do { dflags <- getDynFlags
- ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 }
-
--- The RHS here is either not a casted tyvar, or it's a tyvar but we want
--- to rewrite the LHS to the RHS (as per swapOverTyVars)
-canEqTyVar2 :: DynFlags
- -> CtEvidence -- lhs ~ rhs (or, if swapped, orhs ~ olhs)
- -> EqRel
- -> SwapFlag
- -> TcTyVar -- lhs = tv, flat
- -> TcType -- rhs, flat
- -> TcS (StopOrContinue Ct)
--- LHS is an inert type variable,
--- and RHS is fully rewritten, but with type synonyms
+ where
+ sym_mco = mkTcSymMCo mco
+
+ do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco
+ finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco)
+
+
+-- This function handles the case where one side is a tyvar and the other is
+-- a type family application. Which to put on the left?
+-- If we can unify the variable, put it on the left, as this may be our only
+-- shot to unify.
+-- Otherwise, put the function on the left, because it's generally better to
+-- rewrite away function calls. This makes types smaller. And it seems necessary:
+-- [W] F alpha ~ alpha
+-- [W] F alpha ~ beta
+-- [W] G alpha beta ~ Int ( where we have type instance G a a = a )
+-- If we end up with a stuck alpha ~ F alpha, we won't be able to solve this.
+-- Test case: indexed-types/should_compile/CEqCanOccursCheck
+-- It would probably work to always put the variable on the left, but we think
+-- it would be less efficient.
+canEqTyVarFunEq :: CtEvidence -- :: lhs ~ (rhs |> mco)
+ -- or (rhs |> mco) ~ lhs if swapped
+ -> EqRel -> SwapFlag
+ -> TyVar -> TcType -- lhs, pretty lhs
+ -> TyCon -> [Xi] -> TcType -- rhs fun, rhs args, pretty rhs
+ -> MCoercion -- :: kind(rhs) ~N kind(lhs)
+ -> TcS (StopOrContinue Ct)
+canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
+ = do { tclvl <- getTcLevel
+ ; dflags <- getDynFlags
+ ; if | isTouchableMetaTyVar tclvl tv1
+ , MTVU_OK _ <- checkTyVarEq dflags YesTypeFamilies tv1 (ps_xi2 `mkCastTyMCo` mco)
+ -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1)
+ (ps_xi2 `mkCastTyMCo` mco)
+ | otherwise
+ -> do { new_ev <- rewriteCastedEquality ev eq_rel swapped
+ (mkTyVarTy tv1) (mkTyConApp fun_tc2 fun_args2)
+ mco
+ ; canEqCanLHSFinish new_ev eq_rel IsSwapped
+ (TyFamLHS fun_tc2 fun_args2)
+ (ps_xi1 `mkCastTyMCo` sym_mco) } }
+ where
+ sym_mco = mkTcSymMCo mco
+
+-- The RHS here is either not CanEqLHS, or it's one that we
+-- want to rewrite the LHS to (as per e.g. swapOverTyVars)
+canEqCanLHSFinish :: CtEvidence
+ -> EqRel -> SwapFlag
+ -> CanEqLHS -- lhs (or, if swapped, rhs)
+ -> TcType -- rhs, pretty rhs
+ -> TcS (StopOrContinue Ct)
+canEqCanLHSFinish ev eq_rel swapped lhs rhs
+-- RHS is fully rewritten, but with type synonyms
-- preserved as much as possible
-- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K)
--- the "flat" requirement guarantees (TyEq:AFF)
-- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo
-canEqTyVar2 dflags ev eq_rel swapped tv1 rhs
- -- this next line checks also for coercion holes; see
- -- Note [Equalities with incompatible kinds]
- | MTVU_OK rhs' <- mtvu -- No occurs check
+
+ = do { dflags <- getDynFlags
+ ; new_ev <- rewriteEqEvidence ev swapped lhs_ty rhs rewrite_co1 rewrite_co2
+
-- Must do the occurs check even on tyvar/tyvar
-- equalities, in case have x ~ (y :: ..x...)
-- #12593
-- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H)
- = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2
- ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1
- , cc_rhs = rhs', cc_eq_rel = eq_rel }) }
+ -- this next line checks also for coercion holes (TyEq:H); see
+ -- Note [Equalities with incompatible kinds]
+ ; case canEqOK dflags eq_rel lhs rhs of
+ CanEqOK ->
+ do { traceTcS "canEqOK" (ppr lhs $$ ppr rhs)
+ ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs
+ , cc_rhs = rhs, cc_eq_rel = eq_rel }) }
+ -- it is possible that cc_rhs mentions the LHS if the LHS is a type
+ -- family. This will cause later flattening to potentially loop, but
+ -- that will be caught by the depth counter. The other option is an
+ -- occurs-check for a function application, which seems awkward.
+
+ CanEqNotOK status
+ -- See Note [Type variable cycles in Givens]
+ | OtherCIS <- status
+ , Given <- ctEvFlavour ev
+ , TyVarLHS lhs_tv <- lhs
+ , not (isCycleBreakerTyVar lhs_tv) -- See Detail (7) of Note
+ , NomEq <- eq_rel
+ -> do { traceTcS "canEqCanLHSFinish breaking a cycle" (ppr lhs $$ ppr rhs)
+ ; new_rhs <- breakTyVarCycle (ctEvLoc ev) rhs
+ ; traceTcS "new RHS:" (ppr new_rhs)
+ ; let new_pred = mkPrimEqPred (mkTyVarTy lhs_tv) new_rhs
+ new_new_ev = new_ev { ctev_pred = new_pred }
+ -- See Detail (6) of Note [Type variable cycles in Givens]
+
+ ; if anyRewritableTyVar True NomEq (\ _ tv -> tv == lhs_tv) new_rhs
+ then do { traceTcS "Note [Type variable cycles in Givens] Detail (1)"
+ (ppr new_new_ev)
+ ; continueWith (mkIrredCt status new_ev) }
+ else continueWith (CEqCan { cc_ev = new_new_ev, cc_lhs = lhs
+ , cc_rhs = new_rhs, cc_eq_rel = eq_rel }) }
- | otherwise -- For some reason (occurs check, or forall) we can't unify
-- We must not use it for further rewriting!
- = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs $$ ppr mtvu)
- ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2
- ; let status | isInsolubleOccursCheck eq_rel tv1 rhs
- = InsolubleCIS
- -- If we have a ~ [a], it is not canonical, and in particular
- -- we don't want to rewrite existing inerts with it, otherwise
- -- we'd risk divergence in the constraint solver
-
- | MTVU_HoleBlocker <- mtvu
- = BlockedCIS
- -- This is the case detailed in
- -- Note [Equalities with incompatible kinds]
-
- | otherwise
- = OtherCIS
- -- A representational equality with an occurs-check problem isn't
- -- insoluble! For example:
- -- a ~R b a
- -- We might learn that b is the newtype Id.
- -- But, the occurs-check certainly prevents the equality from being
- -- canonical, and we might loop if we were to use it in rewriting.
-
- ; continueWith (mkIrredCt status new_ev) }
+ | otherwise
+ -> do { traceTcS "canEqCanLHSFinish can't make a canonical" (ppr lhs $$ ppr rhs)
+ ; continueWith (mkIrredCt status new_ev) } }
where
- mtvu = metaTyVarUpdateOK dflags tv1 rhs
- -- Despite the name of the function, tv1 may not be a
- -- unification variable; we are really checking that this
- -- equality is ok to be used to rewrite others, i.e. that
- -- it satisfies the conditions for CTyEqCan
-
role = eqRelRole eq_rel
- lhs = mkTyVarTy tv1
+ lhs_ty = canEqLHSType lhs
- rewrite_co1 = mkTcReflCo role lhs
+ rewrite_co1 = mkTcReflCo role lhs_ty
rewrite_co2 = mkTcReflCo role rhs
-- | Solve a reflexive equality constraint
@@ -2192,6 +2379,96 @@ canEqReflexive ev eq_rel ty
mkTcReflCo (eqRelRole eq_rel) ty)
; stopWith ev "Solved by reflexivity" }
+rewriteCastedEquality :: CtEvidence -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs
+ -> EqRel -> SwapFlag
+ -> TcType -- lhs
+ -> TcType -- rhs
+ -> MCoercion -- mco
+ -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs
+ -- result is independent of SwapFlag
+rewriteCastedEquality ev eq_rel swapped lhs rhs mco
+ = rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+ where
+ new_lhs = lhs `mkCastTyMCo` sym_mco
+ lhs_co = mkTcGReflLeftMCo role lhs sym_mco
+
+ new_rhs = rhs
+ rhs_co = mkTcGReflRightMCo role rhs mco
+
+ sym_mco = mkTcSymMCo mco
+ role = eqRelRole eq_rel
+
+---------------------------------------------
+-- | Result of checking whether a RHS is suitable for pairing
+-- with a CanEqLHS in a CEqCan.
+data CanEqOK
+ = CanEqOK -- RHS is good
+ | CanEqNotOK CtIrredStatus -- don't proceed; explains why
+
+instance Outputable CanEqOK where
+ ppr CanEqOK = text "CanEqOK"
+ ppr (CanEqNotOK status) = text "CanEqNotOK" <+> ppr status
+
+-- | This function establishes most of the invariants needed to make
+-- a CEqCan.
+--
+-- TyEq:OC: Checked here.
+-- TyEq:F: Checked here.
+-- TyEq:K: assumed; ASSERTed here (that is, kind(lhs) = kind(rhs))
+-- TyEq:N: assumed; ASSERTed here (if eq_rel is R, rhs is not a newtype)
+-- TyEq:TV: not checked (this is hard to check)
+-- TyEq:H: Checked here.
+canEqOK :: DynFlags -> EqRel -> CanEqLHS -> Xi -> CanEqOK
+canEqOK dflags eq_rel lhs rhs
+ = ASSERT( good_rhs )
+ case checkTypeEq dflags YesTypeFamilies lhs rhs of
+ MTVU_OK () -> CanEqOK
+ MTVU_Bad -> CanEqNotOK OtherCIS
+ -- Violation of TyEq:F
+
+ MTVU_HoleBlocker -> CanEqNotOK (BlockedCIS holes)
+ where holes = coercionHolesOfType rhs
+ -- This is the case detailed in
+ -- Note [Equalities with incompatible kinds]
+ -- Violation of TyEq:H
+
+ -- These are both a violation of TyEq:OC, but we
+ -- want to differentiate for better production of
+ -- error messages
+ MTVU_Occurs | TyVarLHS tv <- lhs
+ , isInsolubleOccursCheck eq_rel tv rhs -> CanEqNotOK InsolubleCIS
+ -- If we have a ~ [a], it is not canonical, and in particular
+ -- we don't want to rewrite existing inerts with it, otherwise
+ -- we'd risk divergence in the constraint solver
+
+ -- NB: no occCheckExpand here; see Note [Flattening synonyms]
+ -- in GHC.Tc.Solver.Flatten
+
+ | otherwise -> CanEqNotOK OtherCIS
+ -- A representational equality with an occurs-check problem isn't
+ -- insoluble! For example:
+ -- a ~R b a
+ -- We might learn that b is the newtype Id.
+ -- But, the occurs-check certainly prevents the equality from being
+ -- canonical, and we might loop if we were to use it in rewriting.
+
+ -- This case also include type family occurs-check errors, which
+ -- are not generally insoluble
+
+ where
+ good_rhs = kinds_match && not bad_newtype
+
+ lhs_kind = canEqLHSKind lhs
+ rhs_kind = tcTypeKind rhs
+
+ kinds_match = lhs_kind `tcEqType` rhs_kind
+
+ bad_newtype | ReprEq <- eq_rel
+ , Just tc <- tyConAppTyCon_maybe rhs
+ = isNewTyCon tc
+ | otherwise
+ = False
+
{- Note [Equalities with incompatible kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What do we do when we have an equality
@@ -2213,8 +2490,17 @@ where
noDerived G = G
noDerived _ = W
-For Wanted/Derived, the [X] constraint is "blocked" (not CTyEqCan, is CIrred)
-until the k1~k2 constraint solved: Wrinkle (2).
+For reasons described in Wrinkle (2) below, we want the [X] constraint to be "blocked";
+that is, it should be put aside, and not used to rewrite any other constraint,
+until the kind-equality on which it depends (namely 'co' above) is solved.
+To achieve this
+* The [X] constraint is a CIrredCan
+* With a cc_status of BlockedCIS bchs
+* Where 'bchs' is the set of "blocking coercion holes". The blocking coercion
+ holes are the free coercion holes of [X]'s type
+* When all the blocking coercion holes in the CIrredCan are filled (solved),
+ we convert [X] to a CNonCanonical and put it in the work list.
+All this is described in more detail in Wrinkle (2).
Wrinkles:
@@ -2232,39 +2518,59 @@ Wrinkles:
in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for
tales of destruction.
- So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have
- any coercion holes. This is checked in metaTyVarUpdateOK. We also
- must be sure to kick out any constraints that mention coercion holes
- when those holes get filled in.
-
- (2a) We don't want to do this for CoercionHoles that witness
- CFunEqCans (that are produced by the flattener), as these will disappear
- once we unflatten. So we remember in the CoercionHole structure
- whether the presence of the hole should block substitution or not.
- A bit gross, this.
-
- (2b) We must now absolutely make sure to kick out any constraints that
- mention a newly-filled-in coercion hole. This is done in
- kickOutAfterFillingCoercionHole.
+ So, we have an invariant on CEqCan (TyEq:H) that the RHS does not have
+ any coercion holes. This is checked in checkTypeEq. Any equalities that
+ have such an RHS are turned into CIrredCans with a BlockedCIS status. We also
+ must be sure to kick out any such CIrredCan constraints that mention coercion holes
+ when those holes get filled in, so that the unification step can now proceed.
+
+ (2a) We must now kick out any constraints that mention a newly-filled-in
+ coercion hole, but only if there are no more remaining coercion
+ holes. This is done in kickOutAfterFillingCoercionHole. The extra
+ check that there are no more remaining holes avoids needless work
+ when rewriting evidence (which fills coercion holes) and aids
+ efficiency.
+
+ Moreover, kicking out when there are remaining unfilled holes can
+ cause a loop in the solver in this case:
+ [W] w1 :: (ty1 :: F a) ~ (ty2 :: s)
+ After canonicalisation, we discover that this equality is heterogeneous.
+ So we emit
+ [W] co_abc :: F a ~ s
+ and preserve the original as
+ [W] w2 :: (ty1 |> co_abc) ~ ty2 (blocked on co_abc)
+ Then, co_abc comes becomes the work item. It gets swapped in
+ canEqCanLHS2 and then back again in canEqTyVarFunEq. We thus get
+ co_abc := sym co_abd, and then co_abd := sym co_abe, with
+ [W] co_abe :: F a ~ s
+ This process has filled in co_abc. Suppose w2 were kicked out.
+ When it gets processed,
+ would get this whole chain going again. The solution is to
+ kick out a blocked constraint only when the result of filling
+ in the blocking coercion involves no further blocking coercions.
+ Alternatively, we could be careful not to do unnecessary swaps during
+ canonicalisation, but that seems hard to do, in general.
(3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the
algorithm detailed here, producing [W] co :: k2 ~ k1, and adding
[W] (a :: k1) ~ ((rhs |> co) :: k1) to the irreducibles. Some time
later, we solve co, and fill in co's coercion hole. This kicks out
- the irreducible as described in (2b).
+ the irreducible as described in (2a).
But now, during canonicalization, we see the cast
- and remove it, in canEqCast. By the time we get into canEqTyVar, the equality
+ and remove it, in canEqCast. By the time we get into canEqCanLHS, the equality
is heterogeneous again, and the process repeats.
To avoid this, we don't strip casts off a type if the other type
- in the equality is a tyvar. And this is an improvement regardless:
+ in the equality is a CanEqLHS (the scenario above can happen with a
+ type family, too. testcase: typecheck/should_compile/T13822).
+ And this is an improvement regardless:
because tyvars can, generally, unify with casted types, there's no
reason to go through the work of stripping off the cast when the
cast appears opposite a tyvar. This is implemented in the cast case
of can_eq_nc'.
- (4) Reporting an error for a constraint that is blocked only because
- of wrinkle (2) is hard: what would we say to users? And we don't
+ (4) Reporting an error for a constraint that is blocked with status BlockedCIS
+ is hard: what would we say to users? And we don't
really need to report, because if a constraint is blocked, then
there is unsolved wanted blocking it; that unsolved wanted will
be reported. We thus push such errors to the bottom of the queue
@@ -2328,7 +2634,211 @@ However, if we encounter an equality constraint with a type synonym
application on one side and a variable on the other side, we should
NOT (necessarily) expand the type synonym, since for the purpose of
good error messages we want to leave type synonyms unexpanded as much
-as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqTyVar.
+as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS.
+
+Note [Type variable cycles in Givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this situation (from indexed-types/should_compile/GivenLoop):
+
+ instance C (Maybe b)
+ [G] a ~ Maybe (F a)
+ [W] C a
+
+In order to solve the Wanted, we must use the Given to rewrite `a` to
+Maybe (F a). But note that the Given has an occurs-check failure, and
+so we can't straightforwardly add the Given to the inert set.
+
+The key idea is to replace the (F a) in the RHS of the Given with a
+fresh variable, which we'll call a CycleBreakerTv, or cbv. Then, emit
+a new Given to connect cbv with F a. So our situation becomes
+
+ instance C (Maybe b)
+ [G] a ~ Maybe cbv
+ [G] F a ~ cbv
+ [W] C a
+
+Note the orientation of the second Given. The type family ends up
+on the left; see commentary on canEqTyVarFunEq, which decides how to
+orient such cases. No special treatment for CycleBreakerTvs is
+necessary. This scenario is now easily soluble, by using the first
+Given to rewrite the Wanted, which can now be solved.
+
+(The first Given actually also rewrites the second one. This causes
+no trouble.)
+
+More generally, we detect this scenario by the following characteristics:
+ - a Given CEqCan constraint
+ - with a tyvar on its LHS
+ - with a soluble occurs-check failure
+ - and a nominal equality
+
+Having identified the scenario, we wish to replace all type family
+applications on the RHS with fresh metavariables (with MetaInfo
+CycleBreakerTv). This is done in breakTyVarCycle. These metavariables are
+untouchable, but we also emit Givens relating the fresh variables to the type
+family applications they replace.
+
+Of course, we don't want our fresh variables leaking into e.g. error messages.
+So we fill in the metavariables with their original type family applications
+after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds).
+This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in
+InertSet, which contains the pairings invented in breakTyVarCycle.
+
+That is:
+
+We transform
+ [G] g : a ~ ...(F a)...
+to
+ [G] (Refl a) : F a ~ cbv -- CEqCan
+ [G] g : a ~ ...cbv... -- CEqCan
+
+Note that
+* `cbv` is a fresh cycle breaker variable.
+* `cbv` is a is a meta-tyvar, but it is completely untouchable.
+* We track the cycle-breaker variables in inert_cycle_breakers in InertSet
+* We eventually fill in the cycle-breakers, with `cbv := F a`.
+ No one else fills in cycle-breakers!
+* In inert_cycle_breakers, we remember the (cbv, F a) pair; that is, we
+ remember the /original/ type. The [G] F a ~ cbv constraint may be rewritten
+ by other givens (eg if we have another [G] a ~ (b,c), but at the end we
+ still fill in with cbv := F a
+* This fill-in is done when solving is complete, by restoreTyVarCycles
+ in nestImplicTcS and runTcSWithEvBinds.
+* The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is
+ ultimately going to happen.
+
+There are drawbacks of this approach:
+
+ 1. We apply this trick only for Givens, never for Wanted or Derived.
+ It wouldn't make sense for Wanted, because Wanted never rewrite.
+ But it's conceivable that a Derived would benefit from this all.
+ I doubt it would ever happen, though, so I'm holding off.
+
+ 2. We don't use this trick for representational equalities, as there
+ is no concrete use case where it is helpful (unlike for nominal
+ equalities). Furthermore, because function applications can be
+ CanEqLHSs, but newtype applications cannot, the disparities between
+ the cases are enough that it would be effortful to expand the idea
+ to representational equalities. A quick attempt, with
+
+ data family N a b
+
+ f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b
+ f = coerce
+
+ failed with "Could not match 'b' with 'b'." Further work is held off
+ until when we have a concrete incentive to explore this dark corner.
+
+Details:
+
+ (1) We don't look under foralls, at all, when substituting away type family
+ applications, because doing so can never be fruitful. Recall that we
+ are in a case like [G] a ~ forall b. ... a .... Until we have a type
+ family that can pull the body out from a forall, this will always be
+ insoluble. Note also that the forall cannot be in an argument to a
+ type family, or that outer type family application would already have
+ been substituted away.
+
+ However, we still must check to make sure that breakTyVarCycle actually
+ succeeds in getting rid of all occurrences of the offending variable.
+ If one is hidden under a forall, this won't be true. So we perform
+ an additional check after performing the substitution.
+
+ Skipping this check causes typecheck/should_fail/GivenForallLoop to loop.
+
+ (2) Our goal here is to avoid loops in rewriting. We can thus skip looking
+ in coercions, as we don't rewrite in coercions.
+ (There is no worry about unifying a meta-variable here: this Note is
+ only about Givens.)
+
+ (3) As we're substituting, we can build ill-kinded
+ types. For example, if we have Proxy (F a) b, where (b :: F a), then
+ replacing this with Proxy cbv b is ill-kinded. However, we will later
+ set cbv := F a, and so the zonked type will be well-kinded again.
+ The temporary ill-kinded type hurts no one, and avoiding this would
+ be quite painfully difficult.
+
+ Specifically, this detail does not contravene the Purely Kinded Type Invariant
+ (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType).
+ The PKTI says that we can call typeKind on any type, without failure.
+ It would be violated if we, say, replaced a kind (a -> b) with a kind c,
+ because an arrow kind might be consulted in piResultTys. Here, we are
+ replacing one opaque type like (F a b c) with another, cbv (opaque in
+ that we never assume anything about its structure, like that it has a
+ result type or a RuntimeRep argument).
+
+ (4) The evidence for the produced Givens is all just reflexive, because
+ we will eventually set the cycle-breaker variable to be the type family,
+ and then, after the zonk, all will be well.
+
+ (5) The approach here is inefficient. For instance, we could choose to
+ affect only type family applications that mention the offending variable:
+ in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore,
+ we could try to detect cases like a ~ (F a, F a) and use the same
+ tyvar to replace F a. (Cf.
+ Note [Flattening type-family applications when matching instances]
+ in GHC.Core.Unify, which
+ goes to this extra effort.) There may be other opportunities for
+ improvement. However, this is really a very small corner case, always
+ tickled by a user-written Given. The investment to craft a clever,
+ performant solution seems unworthwhile.
+
+ (6) We often get the predicate associated with a constraint from its
+ evidence. We thus must not only make sure the generated CEqCan's
+ fields have the updated RHS type, but we must also update the
+ evidence itself. As in Detail (4), we don't need to change the
+ evidence term (as in e.g. rewriteEqEvidence) because the cycle
+ breaker variables are all zonked away by the time we examine the
+ evidence. That is, we must set the ctev_pred of the ctEvidence.
+ This is implemented in canEqCanLHSFinish, with a reference to
+ this detail.
+
+ (7) We don't wish to apply this magic to CycleBreakerTvs themselves.
+ Consider this, from typecheck/should_compile/ContextStack2:
+
+ type instance TF (a, b) = (TF a, TF b)
+ t :: (a ~ TF (a, Int)) => ...
+
+ [G] a ~ TF (a, Int)
+
+ The RHS reduces, so we get
+
+ [G] a ~ (TF a, TF Int)
+
+ We then break cycles, to get
+
+ [G] g1 :: a ~ (cbv1, cbv2)
+ [G] g2 :: TF a ~ cbv1
+ [G] g3 :: TF Int ~ cbv2
+
+ g1 gets added to the inert set, as written. But then g2 becomes
+ the work item. g1 rewrites g2 to become
+
+ [G] TF (cbv1, cbv2) ~ cbv1
+
+ which then uses the type instance to become
+
+ [G] (TF cbv1, TF cbv2) ~ cbv1
+
+ which looks remarkably like the Given we started with. If left
+ unchecked, this will end up breaking cycles again, looping ad
+ infinitum (and resulting in a context-stack reduction error,
+ not an outright loop). The solution is easy: don't break cycles
+ if the var is already a CycleBreakerTv. Instead, we mark this
+ final Given as a CIrredCan with an OtherCIS status (it's not
+ insoluble).
+
+ NB: When filling in CycleBreakerTvs, we fill them in with what
+ they originally stood for (e.g. cbv1 := TF a, cbv2 := TF Int),
+ not what may be in a rewritten constraint.
+
+ Not breaking cycles fursther makes sense, because
+ we only want to break cycles for user-written loopy Givens, and
+ a CycleBreakerTv certainly isn't user-written.
+
+NB: This same situation (an equality like b ~ Maybe (F b)) can arise with
+Wanteds, but we have no concrete case incentivising special treatment. It
+would just be a CIrredCan.
-}
@@ -2479,26 +2989,22 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
| CtGiven { ctev_evar = old_evar } <- old_ev
= do { let new_tm = evCoercion (lhs_co
- `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)
+ `mkTcTransCo` maybeTcSymCo swapped (mkTcCoVarCo old_evar)
`mkTcTransCo` mkTcSymCo rhs_co)
; newGivenEvVar loc' (new_pred, new_tm) }
| CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev
- = case dest of
- HoleDest hole ->
- do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc'
- (ctEvRole old_ev) nlhs nrhs
- -- The "_SI" variant ensures that we make a new Wanted
- -- with the same shadow-info as the existing one (#16735)
- ; let co = maybeSym swapped $
- mkSymCo lhs_co
- `mkTransCo` hole_co
- `mkTransCo` rhs_co
- ; setWantedEq dest co
- ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
- ; return new_ev }
-
- _ -> panic "rewriteEqEvidence"
+ = do { (new_ev, hole_co) <- newWantedEq_SI si loc'
+ (ctEvRole old_ev) nlhs nrhs
+ -- The "_SI" variant ensures that we make a new Wanted
+ -- with the same shadow-info as the existing one (#16735)
+ ; let co = maybeTcSymCo swapped $
+ mkSymCo lhs_co
+ `mkTransCo` hole_co
+ `mkTransCo` rhs_co
+ ; setWantedEq dest co
+ ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
+ ; return new_ev }
#if __GLASGOW_HASKELL__ <= 810
| otherwise
@@ -2513,7 +3019,14 @@ rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
loc = ctEvLoc old_ev
loc' = bumpCtLocDepth loc
-{- Note [unifyWanted and unifyDerived]
+{-
+************************************************************************
+* *
+ Unification
+* *
+************************************************************************
+
+Note [unifyWanted and unifyDerived]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When decomposing equalities we often create new wanted constraints for
(s ~ t). But what if s=t? Then it'd be faster to return Refl right away.
@@ -2619,7 +3132,3 @@ unify_derived loc role orig_ty1 orig_ty2
| ty1 `tcEqType` ty2 = return ()
-- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
| otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2
-
-maybeSym :: SwapFlag -> TcCoercion -> TcCoercion
-maybeSym IsSwapped co = mkTcSymCo co
-maybeSym NotSwapped co = co
diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs
index 22c92cff80..c94dc21f2a 100644
--- a/compiler/GHC/Tc/Solver/Flatten.hs
+++ b/compiler/GHC/Tc/Solver/Flatten.hs
@@ -5,18 +5,14 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.Solver.Flatten(
- FlattenMode(..),
flatten, flattenKind, flattenArgsNom,
- rewriteTyVar, flattenType,
-
- unflattenWanteds
+ flattenType
) where
#include "HsVersions.h"
import GHC.Prelude
-import GHC.Tc.Types
import GHC.Core.TyCo.Ppr ( pprTyVar )
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
@@ -29,468 +25,35 @@ import GHC.Core.Coercion
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
+import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Tc.Solver.Monad as TcS
-import GHC.Types.Basic( SwapFlag(..) )
import GHC.Utils.Misc
-import GHC.Data.Bag
+import GHC.Data.Maybe
import Control.Monad
import GHC.Utils.Monad ( zipWith3M )
-import Data.Foldable ( foldrM )
+import Data.List.NonEmpty ( NonEmpty(..) )
import Control.Arrow ( first )
{-
-Note [The flattening story]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* A CFunEqCan is either of form
- [G] <F xis> : F xis ~ fsk -- fsk is a FlatSkolTv
- [W] x : F xis ~ fmv -- fmv is a FlatMetaTv
- where
- x is the witness variable
- xis are function-free
- fsk/fmv is a flatten skolem;
- it is always untouchable (level 0)
-
-* CFunEqCans can have any flavour: [G], [W], [WD] or [D]
-
-* KEY INSIGHTS:
-
- - A given flatten-skolem, fsk, is known a-priori to be equal to
- F xis (the LHS), with <F xis> evidence. The fsk is still a
- unification variable, but it is "owned" by its CFunEqCan, and
- is filled in (unflattened) only by unflattenGivens.
-
- - A unification flatten-skolem, fmv, stands for the as-yet-unknown
- type to which (F xis) will eventually reduce. It is filled in
-
-
- - All fsk/fmv variables are "untouchable". To make it simple to test,
- we simply give them TcLevel=0. This means that in a CTyVarEq, say,
- fmv ~ Int
- we NEVER unify fmv.
-
- - A unification flatten-skolem, fmv, ONLY gets unified when either
- a) The CFunEqCan takes a step, using an axiom
- b) By unflattenWanteds
- They are never unified in any other form of equality.
- For example [W] ffmv ~ Int is stuck; it does not unify with fmv.
-
-* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan.
- That would destroy the invariant about the shape of a CFunEqCan,
- and it would risk wanted/wanted interactions. The only way we
- learn information about fsk is when the CFunEqCan takes a step.
-
- However we *do* substitute in the LHS of a CFunEqCan (else it
- would never get to fire!)
-
-* Unflattening:
- - We unflatten Givens when leaving their scope (see unflattenGivens)
- - We unflatten Wanteds at the end of each attempt to simplify the
- wanteds; see unflattenWanteds, called from solveSimpleWanteds.
-
-* Ownership of fsk/fmv. Each canonical [G], [W], or [WD]
- CFunEqCan x : F xis ~ fsk/fmv
- "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv.
- Why? We make a fresh fsk/fmv when the constraint is born;
- and we never rewrite the RHS of a CFunEqCan.
-
- In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W],
- but does not "own" it. If we reduce a [D] F Int ~ fmv, where
- say type instance F Int = ty, then we don't discharge fmv := ty.
- Rather we simply generate [D] fmv ~ ty (in GHC.Tc.Solver.Interact.reduce_top_fun_eq,
- and dischargeFmv)
-
-* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2
- then xis1 /= xis2
- i.e. at most one CFunEqCan with a particular LHS
-
-* Flattening a type (F xis):
- - If we are flattening in a Wanted/Derived constraint
- then create new [W] x : F xis ~ fmv
- else create new [G] x : F xis ~ fsk
- with fresh evidence variable x and flatten-skolem fsk/fmv
-
- - Add it to the work list
-
- - Replace (F xis) with fsk/fmv in the type you are flattening
-
- - You can also add the CFunEqCan to the "flat cache", which
- simply keeps track of all the function applications you
- have flattened.
-
- - If (F xis) is in the cache already, just
- use its fsk/fmv and evidence x, and emit nothing.
-
- - No need to substitute in the flat-cache. It's not the end
- of the world if we start with, say (F alpha ~ fmv1) and
- (F Int ~ fmv2) and then find alpha := Int. Athat will
- simply give rise to fmv1 := fmv2 via [Interacting rule] below
-
-* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv
- - Flatten xis (to substitute any tyvars; there are already no functions)
- cos :: xis ~ flat_xis
- - New wanted x2 :: F flat_xis ~ fsk/fmv
- - Add new wanted to flat cache
- - Discharge x = F cos ; x2
-
-* [Interacting rule]
- (inert) [W] x1 : F tys ~ fmv1
- (work item) [W] x2 : F tys ~ fmv2
- Just solve one from the other:
- x2 := x1
- fmv2 := fmv1
- This just unites the two fsks into one.
- Always solve given from wanted if poss.
-
-* For top-level reductions, see Note [Top-level reductions for type functions]
- in GHC.Tc.Solver.Interact
-
-
-Why given-fsks, alone, doesn't work
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Could we get away with only flatten meta-tyvars, with no flatten-skolems? No.
-
- [W] w : alpha ~ [F alpha Int]
-
----> flatten
- w = ...w'...
- [W] w' : alpha ~ [fsk]
- [G] <F alpha Int> : F alpha Int ~ fsk
-
---> unify (no occurs check)
- alpha := [fsk]
-
-But since fsk = F alpha Int, this is really an occurs check error. If
-that is all we know about alpha, we will succeed in constraint
-solving, producing a program with an infinite type.
-
-Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk)
-using axiom, zonking would not see it, so (x::alpha) sitting in the
-tree will get zonked to an infinite type. (Zonking always only does
-refl stuff.)
-
-Why flatten-meta-vars, alone doesn't work
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Look at Simple13, with unification-fmvs only
-
- [G] g : a ~ [F a]
-
----> Flatten given
- g' = g;[x]
- [G] g' : a ~ [fmv]
- [W] x : F a ~ fmv
-
---> subst a in x
- g' = g;[x]
- x = F g' ; x2
- [W] x2 : F [fmv] ~ fmv
-
-And now we have an evidence cycle between g' and x!
-
-If we used a given instead (ie current story)
-
- [G] g : a ~ [F a]
-
----> Flatten given
- g' = g;[x]
- [G] g' : a ~ [fsk]
- [G] <F a> : F a ~ fsk
-
----> Substitute for a
- [G] g' : a ~ [fsk]
- [G] F (sym g'); <F a> : F [fsk] ~ fsk
-
-
-Why is it right to treat fmv's differently to ordinary unification vars?
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- f :: forall a. a -> a -> Bool
- g :: F Int -> F Int -> Bool
-
-Consider
- f (x:Int) (y:Bool)
-This gives alpha~Int, alpha~Bool. There is an inconsistency,
-but really only one error. SherLoc may tell you which location
-is most likely, based on other occurrences of alpha.
-
-Consider
- g (x:Int) (y:Bool)
-Here we get (F Int ~ Int, F Int ~ Bool), which flattens to
- (fmv ~ Int, fmv ~ Bool)
-But there are really TWO separate errors.
-
- ** We must not complain about Int~Bool. **
-
-Moreover these two errors could arise in entirely unrelated parts of
-the code. (In the alpha case, there must be *some* connection (eg
-v:alpha in common envt).)
-
-Note [Unflattening can force the solver to iterate]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Look at #10340:
- type family Any :: * -- No instances
- get :: MonadState s m => m s
- instance MonadState s (State s) where ...
-
- foo :: State Any Any
- foo = get
-
-For 'foo' we instantiate 'get' at types mm ss
- [WD] MonadState ss mm, [WD] mm ss ~ State Any Any
-Flatten, and decompose
- [WD] MonadState ss mm, [WD] Any ~ fmv
- [WD] mm ~ State fmv, [WD] fmv ~ ss
-Unify mm := State fmv:
- [WD] MonadState ss (State fmv)
- [WD] Any ~ fmv, [WD] fmv ~ ss
-Now we are stuck; the instance does not match!! So unflatten:
- fmv := Any
- ss := Any (*)
- [WD] MonadState Any (State Any)
-
-The unification (*) represents progress, so we must do a second
-round of solving; this time it succeeds. This is done by the 'go'
-loop in solveSimpleWanteds.
-
-This story does not feel right but it's the best I can do; and the
-iteration only happens in pretty obscure circumstances.
-
-
-************************************************************************
-* *
-* Examples
- Here is a long series of examples I had to work through
-* *
-************************************************************************
-
-Simple20
-~~~~~~~~
-axiom F [a] = [F a]
-
- [G] F [a] ~ a
--->
- [G] fsk ~ a
- [G] [F a] ~ fsk (nc)
--->
- [G] F a ~ fsk2
- [G] fsk ~ [fsk2]
- [G] fsk ~ a
--->
- [G] F a ~ fsk2
- [G] a ~ [fsk2]
- [G] fsk ~ a
-
-----------------------------------------
-indexed-types/should_compile/T44984
-
- [W] H (F Bool) ~ H alpha
- [W] alpha ~ F Bool
--->
- F Bool ~ fmv0
- H fmv0 ~ fmv1
- H alpha ~ fmv2
-
- fmv1 ~ fmv2
- fmv0 ~ alpha
-
-flatten
-~~~~~~~
- fmv0 := F Bool
- fmv1 := H (F Bool)
- fmv2 := H alpha
- alpha := F Bool
-plus
- fmv1 ~ fmv2
-
-But these two are equal under the above assumptions.
-Solve by Refl.
-
-
---- under plan B, namely solve fmv1:=fmv2 eagerly ---
- [W] H (F Bool) ~ H alpha
- [W] alpha ~ F Bool
--->
- F Bool ~ fmv0
- H fmv0 ~ fmv1
- H alpha ~ fmv2
-
- fmv1 ~ fmv2
- fmv0 ~ alpha
--->
- F Bool ~ fmv0
- H fmv0 ~ fmv1
- H alpha ~ fmv2 fmv2 := fmv1
-
- fmv0 ~ alpha
-
-flatten
- fmv0 := F Bool
- fmv1 := H fmv0 = H (F Bool)
- retain H alpha ~ fmv2
- because fmv2 has been filled
- alpha := F Bool
-
-
-----------------------------
-indexed-types/should_failt/T4179
-
-after solving
- [W] fmv_1 ~ fmv_2
- [W] A3 (FCon x) ~ fmv_1 (CFunEqCan)
- [W] A3 (x (aoa -> fmv_2)) ~ fmv_2 (CFunEqCan)
-
-----------------------------------------
-indexed-types/should_fail/T7729a
-
-a) [W] BasePrimMonad (Rand m) ~ m1
-b) [W] tt m1 ~ BasePrimMonad (Rand m)
-
----> process (b) first
- BasePrimMonad (Ramd m) ~ fmv_atH
- fmv_atH ~ tt m1
-
----> now process (a)
- m1 ~ s_atH ~ tt m1 -- An obscure occurs check
-
-
-----------------------------------------
-typecheck/TcTypeNatSimple
-
-Original constraint
- [W] x + y ~ x + alpha (non-canonical)
-==>
- [W] x + y ~ fmv1 (CFunEqCan)
- [W] x + alpha ~ fmv2 (CFuneqCan)
- [W] fmv1 ~ fmv2 (CTyEqCan)
-
-(sigh)
-
-----------------------------------------
-indexed-types/should_fail/GADTwrong1
-
- [G] Const a ~ ()
-==> flatten
- [G] fsk ~ ()
- work item: Const a ~ fsk
-==> fire top rule
- [G] fsk ~ ()
- work item fsk ~ ()
-
-Surely the work item should rewrite to () ~ ()? Well, maybe not;
-it'a very special case. More generally, our givens look like
-F a ~ Int, where (F a) is not reducible.
-
-
-----------------------------------------
-indexed_types/should_fail/T8227:
-
-Why using a different can-rewrite rule in CFunEqCan heads
-does not work.
-
-Assuming NOT rewriting wanteds with wanteds
-
- Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk
- [W] fmv_aBk ~ fsk_aBh
-
- [G] Scalar fsk_aBg ~ fsk_aBh
- [G] V a ~ f_aBg
-
- Worklist includes [W] Scalar fmv_aBi ~ fmv_aBk
- fmv_aBi, fmv_aBk are flatten unification variables
-
- Work item: [W] V fsk_aBh ~ fmv_aBi
-
-Note that the inert wanteds are cyclic, because we do not rewrite
-wanteds with wanteds.
-
-
-Then we go into a loop when normalise the work-item, because we
-use rewriteOrSame on the argument of V.
-
-Conclusion: Don't make canRewrite context specific; instead use
-[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable.
-
-
-----------------------------------------
-
-Here is a somewhat similar case:
-
- type family G a :: *
-
- blah :: (G a ~ Bool, Eq (G a)) => a -> a
- blah = error "urk"
-
- foo x = blah x
-
-For foo we get
- [W] Eq (G a), G a ~ Bool
-Flattening
- [W] G a ~ fmv, Eq fmv, fmv ~ Bool
-We can't simplify away the Eq Bool unless we substitute for fmv.
-Maybe that doesn't matter: we would still be left with unsolved
-G a ~ Bool.
-
---------------------------
-#9318 has a very simple program leading to
-
- [W] F Int ~ Int
- [W] F Int ~ Bool
-
-We don't want to get "Error Int~Bool". But if fmv's can rewrite
-wanteds, we will
-
- [W] fmv ~ Int
- [W] fmv ~ Bool
---->
- [W] Int ~ Bool
-
-
************************************************************************
* *
* FlattenEnv & FlatM
* The flattening environment & monad
* *
************************************************************************
-
-}
-type FlatWorkListRef = TcRef [Ct] -- See Note [The flattening work list]
-
data FlattenEnv
- = FE { fe_mode :: !FlattenMode
- , fe_loc :: CtLoc -- See Note [Flattener CtLoc]
- -- unbanged because it's bogus in rewriteTyVar
+ = FE { fe_loc :: !CtLoc -- See Note [Flattener CtLoc]
, fe_flavour :: !CtFlavour
, fe_eq_rel :: !EqRel -- See Note [Flattener EqRels]
- , fe_work :: !FlatWorkListRef } -- See Note [The flattening work list]
-
-data FlattenMode -- Postcondition for all three: inert wrt the type substitution
- = FM_FlattenAll -- Postcondition: function-free
- | FM_SubstOnly -- See Note [Flattening under a forall]
-
--- | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening]
--- -- Postcondition:
--- -- * tyvar is only mentioned in result under a rigid path
--- -- e.g. [a] is ok, but F a won't happen
--- -- * If flat_top is True, top level is not a function application
--- -- (but under type constructors is ok e.g. [F a])
-
-instance Outputable FlattenMode where
- ppr FM_FlattenAll = text "FM_FlattenAll"
- ppr FM_SubstOnly = text "FM_SubstOnly"
-
-eqFlattenMode :: FlattenMode -> FlattenMode -> Bool
-eqFlattenMode FM_FlattenAll FM_FlattenAll = True
-eqFlattenMode FM_SubstOnly FM_SubstOnly = True
--- FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2
-eqFlattenMode _ _ = False
-
--- | The 'FlatM' monad is a wrapper around 'TcS' with the following
--- extra capabilities: (1) it offers access to a 'FlattenEnv';
--- and (2) it maintains the flattening worklist.
--- See Note [The flattening work list].
+ }
+
+-- | The 'FlatM' monad is a wrapper around 'TcS' with a 'FlattenEnv'
newtype FlatM a
= FlatM { runFlatM :: FlattenEnv -> TcS a }
deriving (Functor)
@@ -504,45 +67,27 @@ instance Applicative FlatM where
pure x = FlatM $ const (pure x)
(<*>) = ap
+instance HasDynFlags FlatM where
+ getDynFlags = liftTcS getDynFlags
+
liftTcS :: TcS a -> FlatM a
liftTcS thing_inside
= FlatM $ const thing_inside
-emitFlatWork :: Ct -> FlatM ()
--- See Note [The flattening work list]
-emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)
-
-- convenient wrapper when you have a CtEvidence describing
-- the flattening operation
-runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a
-runFlattenCtEv mode ev
- = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
-
--- Run thing_inside (which does flattening), and put all
--- the work it generates onto the main work list
--- See Note [The flattening work list]
-runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a
-runFlatten mode loc flav eq_rel thing_inside
- = do { flat_ref <- newTcRef []
- ; let fmode = FE { fe_mode = mode
- , fe_loc = bumpCtLocDepth loc
- -- See Note [Flatten when discharging CFunEqCan]
- , fe_flavour = flav
- , fe_eq_rel = eq_rel
- , fe_work = flat_ref }
- ; res <- runFlatM thing_inside fmode
- ; new_flats <- readTcRef flat_ref
- ; updWorkListTcS (add_flats new_flats)
- ; return res }
+runFlattenCtEv :: CtEvidence -> FlatM a -> TcS a
+runFlattenCtEv ev
+ = runFlatten (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
+
+-- Run thing_inside (which does the flattening)
+runFlatten :: CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a
+runFlatten loc flav eq_rel thing_inside
+ = runFlatM thing_inside fmode
where
- add_flats new_flats wl
- = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }
-
- add_funeqs [] wl = wl
- add_funeqs (f:fs) wl = add_funeqs fs (f:wl)
- -- add_funeqs fs ws = reverse fs ++ ws
- -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4]
- -- = [f3,f2,f1,w1,w2,w3,w4]
+ fmode = FE { fe_loc = loc
+ , fe_flavour = flav
+ , fe_eq_rel = eq_rel }
traceFlat :: String -> SDoc -> FlatM ()
traceFlat herald doc = liftTcS $ traceTcS herald doc
@@ -567,9 +112,6 @@ getFlavourRole
; eq_rel <- getEqRel
; return (flavour, eq_rel) }
-getMode :: FlatM FlattenMode
-getMode = getFlatEnvField fe_mode
-
getLoc :: FlatM CtLoc
getLoc = getFlatEnvField fe_loc
@@ -585,14 +127,7 @@ setEqRel new_eq_rel thing_inside
if new_eq_rel == fe_eq_rel env
then runFlatM thing_inside env
else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel })
-
--- | Change the 'FlattenMode' in a 'FlattenEnv'.
-setMode :: FlattenMode -> FlatM a -> FlatM a
-setMode new_mode thing_inside
- = FlatM $ \env ->
- if new_mode `eqFlattenMode` fe_mode env
- then runFlatM thing_inside env
- else runFlatM thing_inside (env { fe_mode = new_mode })
+{-# INLINE setEqRel #-}
-- | Make sure that flattening actually produces a coercion (in other
-- words, make sure our flavour is not Derived)
@@ -616,55 +151,6 @@ bumpDepth (FlatM thing_inside)
; thing_inside env' }
{-
-Note [The flattening work list]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The "flattening work list", held in the fe_work field of FlattenEnv,
-is a list of CFunEqCans generated during flattening. The key idea
-is this. Consider flattening (Eq (F (G Int) (H Bool)):
- * The flattener recursively calls itself on sub-terms before building
- the main term, so it will encounter the terms in order
- G Int
- H Bool
- F (G Int) (H Bool)
- flattening to sub-goals
- w1: G Int ~ fuv0
- w2: H Bool ~ fuv1
- w3: F fuv0 fuv1 ~ fuv2
-
- * Processing w3 first is BAD, because we can't reduce i t,so it'll
- get put into the inert set, and later kicked out when w1, w2 are
- solved. In #9872 this led to inert sets containing hundreds
- of suspended calls.
-
- * So we want to process w1, w2 first.
-
- * So you might think that we should just use a FIFO deque for the work-list,
- so that putting adding goals in order w1,w2,w3 would mean we processed
- w1 first.
-
- * BUT suppose we have 'type instance G Int = H Char'. Then processing
- w1 leads to a new goal
- w4: H Char ~ fuv0
- We do NOT want to put that on the far end of a deque! Instead we want
- to put it at the *front* of the work-list so that we continue to work
- on it.
-
-So the work-list structure is this:
-
- * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on
- top (extendWorkListFunEq), and take new work from the top
- (selectWorkItem).
-
- * When flattening, emitFlatWork pushes new flattening goals (like
- w1,w2,w3) onto the flattening work list, fe_work, another
- push-down stack.
-
- * When we finish flattening, we *reverse* the fe_work stack
- onto the wl_funeqs stack (which brings w1 to the top).
-
-The function runFlatten initialises the fe_work stack, and reverses
-it onto wl_fun_eqs at the end.
-
Note [Flattener EqRels]
~~~~~~~~~~~~~~~~~~~~~~~
When flattening, we need to know which equality relation -- nominal
@@ -693,32 +179,6 @@ will be essentially impossible. So, the official recommendation if a
stack limit is hit is to disable the check entirely. Otherwise, there
will be baffling, unpredictable errors.
-Note [Lazy flattening]
-~~~~~~~~~~~~~~~~~~~~~~
-The idea of FM_Avoid mode is to flatten less aggressively. If we have
- a ~ [F Int]
-there seems to be no great merit in lifting out (F Int). But if it was
- a ~ [G a Int]
-then we *do* want to lift it out, in case (G a Int) reduces to Bool, say,
-which gets rid of the occurs-check problem. (For the flat_top Bool, see
-comments above and at call sites.)
-
-HOWEVER, the lazy flattening actually seems to make type inference go
-*slower*, not faster. perf/compiler/T3064 is a case in point; it gets
-*dramatically* worse with FM_Avoid. I think it may be because
-floating the types out means we normalise them, and that often makes
-them smaller and perhaps allows more re-use of previously solved
-goals. But to be honest I'm not absolutely certain, so I am leaving
-FM_Avoid in the code base. What I'm removing is the unique place
-where it is *used*, namely in GHC.Tc.Solver.Canonical.canEqTyVar.
-
-See also Note [Conservative unification check] in GHC.Tc.Utils.Unify, which gives
-other examples where lazy flattening caused problems.
-
-Bottom line: FM_Avoid is unused for now (Nov 14).
-Note: T5321Fun got faster when I disabled FM_Avoid
- T5837 did too, but it's pathological anyway
-
Note [Phantoms in the flattener]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
@@ -730,8 +190,8 @@ is really irrelevant -- it will be ignored when solving for representational
equality later on. So, we omit flattening `ty` entirely. This may
violate the expectation of "xi"s for a bit, but the canonicaliser will
soon throw out the phantoms when decomposing a TyConApp. (Or, the
-canonicaliser will emit an insoluble, in which case the unflattened version
-yields a better error message anyway.)
+canonicaliser will emit an insoluble, in which case we get
+a better error message anyway.)
Note [No derived kind equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -751,52 +211,19 @@ changes the flavour from Derived just for this purpose.
* flattening work gets put into the work list *
* *
*********************************************************************
-
-Note [rewriteTyVar]
-~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have an injective function F and
- inert_funeqs: F t1 ~ fsk1
- F t2 ~ fsk2
- inert_eqs: fsk1 ~ [a]
- a ~ Int
- fsk2 ~ [Int]
-
-We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the
-[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans
-when trying to find derived equalities arising from injectivity.
-}
-- | See Note [Flattening].
-- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty
--- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll',
--- then 'xi' is almost function-free (Note [Almost function-free]
--- in "GHC.Tc.Types").
-flatten :: FlattenMode -> CtEvidence -> TcType
+-- where r is the role in @ev@.
+flatten :: CtEvidence -> TcType
-> TcS (Xi, TcCoercion)
-flatten mode ev ty
- = do { traceTcS "flatten {" (ppr mode <+> ppr ty)
- ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty)
+flatten ev ty
+ = do { traceTcS "flatten {" (ppr ty)
+ ; (ty', co) <- runFlattenCtEv ev (flatten_one ty)
; traceTcS "flatten }" (ppr ty')
; return (ty', co) }
--- Apply the inert set as an *inert generalised substitution* to
--- a variable, zonking along the way.
--- See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad.
--- Equivalently, this flattens the variable with respect to NomEq
--- in a Derived constraint. (Why Derived? Because Derived allows the
--- most about of rewriting.) Returns no coercion, because we're
--- using Derived constraints.
--- See Note [rewriteTyVar]
-rewriteTyVar :: TcTyVar -> TcS TcType
-rewriteTyVar tv
- = do { traceTcS "rewriteTyVar {" (ppr tv)
- ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $
- flattenTyVar tv
- ; traceTcS "rewriteTyVar }" (ppr ty)
- ; return ty }
- where
- fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv)
-
-- specialized to flattening kinds: never Derived, always Nominal
-- See Note [No derived kind equalities]
-- See Note [Flattening]
@@ -806,28 +233,29 @@ flattenKind loc flav ty
; let flav' = case flav of
Derived -> Wanted WDeriv -- the WDeriv/WOnly choice matters not
_ -> flav
- ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty)
+ ; (ty', co) <- runFlatten loc flav' NomEq (flatten_one ty)
; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic
; return (ty', co) }
-- See Note [Flattening]
-flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)
+flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion])
-- Externally-callable, hence runFlatten
-- Flatten a vector of types all at once; in fact they are
-- always the arguments of type family or class, so
-- ctEvFlavour ev = Nominal
-- and we want to flatten all at nominal role
-- The kind passed in is the kind of the type family or class, call it T
--- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys))
+-- The kind of T args must be constant (i.e. not depend on the args)
--
-- For Derived constraints the returned coercion may be undefined
-- because flattening may use a Derived equality ([D] a ~ ty)
flattenArgsNom ev tc tys
= do { traceTcS "flatten_args {" (vcat (map ppr tys))
; (tys', cos, kind_co)
- <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys)
+ <- runFlattenCtEv ev (flatten_args_tc tc Nothing tys)
+ ; MASSERT( isReflMCo kind_co )
; traceTcS "flatten }" (vcat (map ppr tys'))
- ; return (tys', cos, kind_co) }
+ ; return (tys', cos) }
-- | Flatten a type w.r.t. nominal equality. This is useful to rewrite
-- a type w.r.t. any givens. It does not do type-family reduction. This
@@ -835,8 +263,7 @@ flattenArgsNom ev tc tys
-- only givens.
flattenType :: CtLoc -> TcType -> TcS TcType
flattenType loc ty
- -- More info about FM_SubstOnly in Note [Holes] in GHC.Tc.Types.Constraint
- = do { (xi, _) <- runFlatten FM_SubstOnly loc Given NomEq $
+ = do { (xi, _) <- runFlatten loc Given NomEq $
flatten_one ty
-- use Given flavor so that it is rewritten
-- only w.r.t. Givens, never Wanteds/Deriveds
@@ -854,35 +281,31 @@ flattenType loc ty
~~~~~~~~~~~~~~~~~~~~
flatten ty ==> (xi, co)
where
- xi has no type functions, unless they appear under ForAlls
+ xi has no reducible type functions
has no skolems that are mapped in the inert set
has no filled-in metavariables
co :: xi ~ ty
Key invariants:
- (F0) co :: xi ~ zonk(ty)
+ (F0) co :: xi ~ zonk(ty') where zonk(ty') ~ zonk(ty)
(F1) tcTypeKind(xi) succeeds and returns a fully zonked kind
(F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))
-Note that it is flatten's job to flatten *every type function it sees*.
-flatten is only called on *arguments* to type functions, by canEqGiven.
+Note that it is flatten's job to try to reduce *every type function it sees*.
Flattening also:
* zonks, removing any metavariables, and
* applies the substitution embodied in the inert set
-The result of flattening is *almost function-free*. See
-Note [Almost function-free] in GHC.Tc.Utils.
-
Because flattening zonks and the returned coercion ("co" above) is also
zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,
we can rely on this fact:
- (F0) co :: xi ~ zonk(ty)
+ (F0) co :: xi ~ zonk(ty'), where zonk(ty') ~ zonk(ty)
Note that the left-hand type of co is *always* precisely xi. The right-hand
type may or may not be ty, however: if ty has unzonked filled-in metavariables,
-then the right-hand type of co will be the zonked version of ty.
+then the right-hand type of co will be the zonk-equal to ty.
It is for this reason that we
occasionally have to explicitly zonk, when (co :: xi ~ ty) is important
even before we zonk the whole program. For example, see the FTRNotFollowed
@@ -890,7 +313,7 @@ case in flattenTyVar.
Why have these invariants on flattening? Because we sometimes use tcTypeKind
during canonicalisation, and we want this kind to be zonked (e.g., see
-GHC.Tc.Solver.Canonical.canEqTyVar).
+GHC.Tc.Solver.Canonical.canEqCanLHS).
Flattening is always homogeneous. That is, the kind of the result of flattening is
always the same as the kind of the input, modulo zonking. More formally:
@@ -903,26 +326,12 @@ Recall that in comments we use alpha[flat = ty] to represent a
flattening skolem variable alpha which has been generated to stand in
for ty.
------ Example of flattening a constraint: ------
- flatten (List (F (G Int))) ==> (xi, cc)
- where
- xi = List alpha
- cc = { G Int ~ beta[flat = G Int],
- F beta ~ alpha[flat = F beta] }
-Here
- * alpha and beta are 'flattening skolem variables'.
- * All the constraints in cc are 'given', and all their coercion terms
- are the identity.
-
-NB: Flattening Skolems only occur in canonical constraints, which
-are never zonked, so we don't need to worry about zonking doing
-accidental unflattening.
-
Note that we prefer to leave type synonyms unexpanded when possible,
so when the flattener encounters one, it first asks whether its
-transitive expansion contains any type function applications. If so,
+transitive expansion contains any type function applications or is
+forgetful -- that is, omits one or more type variables in its RHS. If so,
it expands the synonym and proceeds; if not, it simply returns the
-unexpanded synonym.
+unexpanded synonym. See also Note [Flattening synonyms].
Note [flatten_args performance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -955,33 +364,34 @@ If we need to make this yet more performant, a possible way forward is to
duplicate the flattener code for the nominal case, and make that case
faster. This doesn't seem quite worth it, yet.
-Note [flatten_exact_fam_app_fully performance]
+Note [flatten_exact_fam_app performance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The refactor of GRefl seems to cause performance trouble for T9872x:
-the allocation of flatten_exact_fam_app_fully_performance
-increased. See note [Generalized reflexive coercion] in
-GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the
-current state.
-
-The explicit pattern match in homogenise_result helps with T9872a, b, c.
-
-Still, it increases the expected allocation of T9872d by ~2%.
-
-TODO: a step-by-step replay of the refactor to analyze the performance.
-
+Once we've got a flat rhs, we extend the famapp-cache to record
+the result. Doing so can save lots of work when the same redex shows up more
+than once. Note that we record the link from the redex all the way to its
+*final* value, not just the single step reduction.
+
+If we can reduce the family application right away (the first call
+to try_to_reduce), we do *not* add to the cache. There are two possibilities
+here: 1) we just read the result from the cache, or 2) we used one type
+family instance. In either case, recording the result in the cache doesn't
+save much effort the next time around. And adding to the cache here is
+actually disastrous: it more than doubles the allocations for T9872a. So
+we skip adding to the cache here.
-}
{-# INLINE flatten_args_tc #-}
flatten_args_tc
:: TyCon -- T
- -> [Role] -- Role r
+ -> Maybe [Role] -- Nothing: ambient role is Nominal; all args are Nominal
+ -- Otherwise: no assumptions; use roles provided
-> [Type] -- Arg types [t1,..,tn]
-> FlatM ( [Xi] -- List of flattened args [x1,..,xn]
-- 1-1 corresp with [t1,..,tn]
, [Coercion] -- List of arg coercions [co1,..,con]
-- 1-1 corresp with [t1,..,tn]
-- coi :: xi ~r ti
- , CoercionN) -- Result coercion, rco
+ , MCoercionN) -- Result coercion, rco
-- rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))
flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet
-- NB: TyCon kinds are always closed
@@ -999,8 +409,9 @@ flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet
flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are
-- named.
-> Kind -> TcTyCoVarSet -- function kind; kind's free vars
- -> [Role] -> [Type] -- these are in 1-to-1 correspondence
- -> FlatM ([Xi], [Coercion], CoercionN)
+ -> Maybe [Role] -> [Type] -- these are in 1-to-1 correspondence
+ -- Nothing: use all Nominal
+ -> FlatM ([Xi], [Coercion], MCoercionN)
-- Coercions :: Xi ~ Type, at roles given
-- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)
-- That is, the third coercion relates the kind of some function (whose kind is
@@ -1012,15 +423,12 @@ flatten_args orig_binders
any_named_bndrs
orig_inner_ki
orig_fvs
- orig_roles
+ orig_m_roles
orig_tys
- = if any_named_bndrs
- then flatten_args_slow orig_binders
- orig_inner_ki
- orig_fvs
- orig_roles
- orig_tys
- else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
+ = case (orig_m_roles, any_named_bndrs) of
+ (Nothing, False) -> flatten_args_fast orig_tys
+ _ -> flatten_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys
+ where orig_roles = fromMaybe (repeat Nominal) orig_m_roles
{-# INLINE flatten_args_fast #-}
-- | fast path flatten_args, in which none of the binders are named and
@@ -1028,75 +436,30 @@ flatten_args orig_binders
-- There are many bang patterns in here. It's been observed that they
-- greatly improve performance of an optimized build.
-- The T9872 test cases are good witnesses of this fact.
-flatten_args_fast :: [TyCoBinder]
- -> Kind
- -> [Role]
- -> [Type]
- -> FlatM ([Xi], [Coercion], CoercionN)
-flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
- = fmap finish (iterate orig_tys orig_roles orig_binders)
+flatten_args_fast :: [Type]
+ -> FlatM ([Xi], [Coercion], MCoercionN)
+flatten_args_fast orig_tys
+ = fmap finish (iterate orig_tys)
where
iterate :: [Type]
- -> [Role]
- -> [TyCoBinder]
- -> FlatM ([Xi], [Coercion], [TyCoBinder])
- iterate (ty:tys) (role:roles) (_:binders) = do
- (xi, co) <- go role ty
- (xis, cos, binders) <- iterate tys roles binders
- pure (xi : xis, co : cos, binders)
- iterate [] _ binders = pure ([], [], binders)
- iterate _ _ _ = pprPanic
- "flatten_args wandered into deeper water than usual" (vcat [])
- -- This debug information is commented out because leaving it in
- -- causes a ~2% increase in allocations in T9872{a,c,d}.
- {-
- (vcat [ppr orig_binders,
- ppr orig_inner_ki,
- ppr (take 10 orig_roles), -- often infinite!
- ppr orig_tys])
- -}
-
- {-# INLINE go #-}
- go :: Role
- -> Type
- -> FlatM (Xi, Coercion)
- go role ty
- = case role of
- -- In the slow path we bind the Xi and Coercion from the recursive
- -- call and then use it such
- --
- -- let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder)
- -- casted_xi = xi `mkCastTy` kind_co
- -- casted_co = xi |> kind_co ~r xi ; co
- --
- -- but this isn't necessary:
- -- mkTcSymCo (Refl a b) = Refl a b,
- -- mkCastTy x (Refl _ _) = x
- -- mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co
- --
- -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since
- -- we've already established that they're all anonymous.
- Nominal -> setEqRel NomEq $ flatten_one ty
- Representational -> setEqRel ReprEq $ flatten_one ty
- Phantom -> -- See Note [Phantoms in the flattener]
- do { ty <- liftTcS $ zonkTcType ty
- ; return (ty, mkReflCo Phantom ty) }
-
+ -> FlatM ([Xi], [Coercion])
+ iterate (ty:tys) = do
+ (xi, co) <- flatten_one ty
+ (xis, cos) <- iterate tys
+ pure (xi : xis, co : cos)
+ iterate [] = pure ([], [])
{-# INLINE finish #-}
- finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN)
- finish (xis, cos, binders) = (xis, cos, kind_co)
- where
- final_kind = mkPiTys binders orig_inner_ki
- kind_co = mkNomReflCo final_kind
+ finish :: ([Xi], [Coercion]) -> ([Xi], [Coercion], MCoercionN)
+ finish (xis, cos) = (xis, cos, MRefl)
{-# INLINE flatten_args_slow #-}
-- | Slow path, compared to flatten_args_fast, because this one must track
-- a lifting context.
flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet
-> [Role] -> [Type]
- -> FlatM ([Xi], [Coercion], CoercionN)
+ -> FlatM ([Xi], [Coercion], MCoercionN)
flatten_args_slow binders inner_ki fvs roles tys
-- Arguments used dependently must be flattened with proper coercions, but
-- we're not guaranteed to get a proper coercion when flattening with the
@@ -1143,6 +506,10 @@ flatten_one :: TcType -> FlatM (Xi, Coercion)
-- Postcondition: Coercion :: Xi ~ TcType
-- The role on the result coercion matches the EqRel in the FlattenEnv
+flatten_one ty
+ | Just ty' <- flattenView ty -- See Note [Flattening synonyms]
+ = flatten_one ty'
+
flatten_one xi@(LitTy {})
= do { role <- getRole
; return (xi, mkReflCo role xi) }
@@ -1154,19 +521,7 @@ flatten_one (AppTy ty1 ty2)
= flatten_app_tys ty1 [ty2]
flatten_one (TyConApp tc tys)
- -- Expand type synonyms that mention type families
- -- on the RHS; see Note [Flattening synonyms]
- | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
- , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
- = do { mode <- getMode
- ; case mode of
- FM_FlattenAll | not (isFamFreeTyCon tc)
- -> flatten_one expanded_ty
- _ -> flatten_ty_con_app tc tys }
-
- -- Otherwise, it's a type function application, and we have to
- -- flatten it away as well, and generate a new given equality constraint
- -- between the application and a newly generated flattening skolem variable.
+ -- If it's a type family application, try to reduce it
| isTypeFamilyTyCon tc
= flatten_fam_app tc tys
@@ -1174,11 +529,6 @@ flatten_one (TyConApp tc tys)
-- * data family application
-- we just recursively flatten the arguments.
| otherwise
--- FM_Avoid stuff commented out; see Note [Lazy flattening]
--- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid
--- FE { fe_mode = FM_Avoid tv _ }
--- -> fmode { fe_mode = FM_Avoid tv False }
--- _ -> fmode
= flatten_ty_con_app tc tys
flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
@@ -1198,14 +548,12 @@ flatten_one ty@(ForAllTy {})
-- applications inside the forall involve the bound type variables.
= do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty
tvs = binderVars bndrs
- ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho
- -- Substitute only under a forall
- -- See Note [Flattening under a forall]
+ ; (rho', co) <- flatten_one rho
; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }
flatten_one (CastTy ty g)
= do { (xi, co) <- flatten_one ty
- ; (g', _) <- flatten_co g
+ ; (g', _) <- flatten_co g
; role <- getRole
; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') }
-- It makes a /big/ difference to call castCoercionKind1 not
@@ -1279,7 +627,9 @@ flatten_app_ty_args fun_xi fun_co arg_tys
flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
flatten_ty_con_app tc tys
= do { role <- getRole
- ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys
+ ; let m_roles | Nominal <- role = Nothing
+ | otherwise = Just $ tyConRolesX role tc
+ ; (xis, cos, kind_co) <- flatten_args_tc tc m_roles tys
; let tyconapp_xi = mkTyConApp tc xis
tyconapp_co = mkTyConAppCo role tc cos
; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }
@@ -1288,15 +638,12 @@ flatten_ty_con_app tc tys
homogenise_result :: Xi -- a flattened type
-> Coercion -- :: xi ~r original ty
-> Role -- r
- -> CoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)
+ -> MCoercionN -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)
-> (Xi, Coercion) -- (xi |> kind_co, (xi |> kind_co)
-- ~r original ty)
-homogenise_result xi co r kind_co
- -- the explicit pattern match here improves the performance of T9872a, b, c by
- -- ~2%
- | isGReflCo kind_co = (xi `mkCastTy` kind_co, co)
- | otherwise = (xi `mkCastTy` kind_co
- , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co)
+homogenise_result xi co _ MRefl = (xi, co)
+homogenise_result xi co r mco@(MCo kind_co)
+ = (xi `mkCastTy` kind_co, (mkSymCo $ GRefl r xi mco) `mkTransCo` co)
{-# INLINE homogenise_result #-}
-- Flatten a vector (list of arguments).
@@ -1304,7 +651,7 @@ flatten_vector :: Kind -- of the function being applied to these arguments
-> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the
-- args have?
-> [Type] -- the args to flatten
- -> FlatM ([Xi], [Coercion], CoercionN)
+ -> FlatM ([Xi], [Coercion], MCoercionN)
flatten_vector ki roles tys
= do { eq_rel <- getEqRel
; case eq_rel of
@@ -1312,17 +659,17 @@ flatten_vector ki roles tys
any_named_bndrs
inner_ki
fvs
- (repeat Nominal)
+ Nothing
tys
ReprEq -> flatten_args bndrs
any_named_bndrs
inner_ki
fvs
- roles
+ (Just roles)
tys
}
where
- (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki
+ (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki -- "RAE" fix
fvs = tyCoVarsOfType ki
{-# INLINE flatten_vector #-}
@@ -1333,251 +680,215 @@ Not expanding synonyms aggressively improves error messages, and
keeps types smaller. But we need to take care.
Suppose
- type T a = a -> a
-and we want to flatten the type (T (F a)). Then we can safely flatten
-the (F a) to a skolem, and return (T fsk). We don't need to expand the
-synonym. This works because TcTyConAppCo can deal with synonyms
-(unlike TyConAppCo), see Note [TcCoercions] in GHC.Tc.Types.Evidence.
+ type Syn a = Int
+ type instance F Bool = Syn (F Bool)
+ [G] F Bool ~ Syn (F Bool)
-But (#8979) for
- type T a = (F a, a) where F is a type function
-we must expand the synonym in (say) T Int, to expose the type function
-to the flattener.
+If we don't expand the synonym, we'll get a spurious occurs-check
+failure. This is normally what occCheckExpand takes care of, but
+the LHS is a type family application, and occCheckExpand (already
+complex enough as it is) does not know how to expand to avoid
+a type family application.
+In addition, expanding the forgetful synonym like this
+will generally yield a *smaller* type. To wit, if we spot
+S ( ... F tys ... ), where S is forgetful, we don't want to bother
+doing hard work simplifying (F tys). We thus expand forgetful
+synonyms, but not others.
-Note [Flattening under a forall]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Under a forall, we
- (a) MUST apply the inert substitution
- (b) MUST NOT flatten type family applications
-Hence FMSubstOnly.
+isForgetfulSynTyCon returns True more often than it needs to, so
+we err on the side of more expansion.
-For (a) consider c ~ a, a ~ T (forall b. (b, [c]))
-If we don't apply the c~a substitution to the second constraint
-we won't see the occurs-check error.
-
-For (b) consider (a ~ forall b. F a b), we don't want to flatten
-to (a ~ forall b.fsk, F a b ~ fsk)
-because now the 'b' has escaped its scope. We'd have to flatten to
- (a ~ forall b. fsk b, forall b. F a b ~ fsk b)
-and we have not begun to think about how to make that work!
+We also, of course, must expand type synonyms that mention type families,
+so those families can get reduced.
************************************************************************
* *
Flattening a type-family application
* *
************************************************************************
+
+Note [How to normalise a family application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given an exactly saturated family application, how should we normalise it?
+This Note spells out the algorithm and its reasoning.
+
+STEP 1. Try the famapp-cache. If we get a cache hit, jump to FINISH.
+
+STEP 2. Try top-level instances. Note that we haven't simplified the arguments
+ yet. Example:
+ type instance F (Maybe a) = Int
+ target: F (Maybe (G Bool))
+ Instead of first trying to simplify (G Bool), we use the instance first. This
+ avoids the work of simplifying G Bool.
+
+ If an instance is found, jump to FINISH.
+
+STEP 3. Flatten all arguments. This might expose more information so that we
+ can use a top-level instance.
+
+ Continue to the next step.
+
+STEP 4. Try the inerts. Note that we try the inerts *after* flattening the
+ arguments, because the inerts will have flattened LHSs.
+
+ If an inert is found, jump to FINISH.
+
+STEP 5. Try the famapp-cache again. Now that we've revealed more information
+ in the arguments, the cache might be helpful.
+
+ If we get a cache hit, jump to FINISH.
+
+STEP 6. Try top-level instances, which might trigger now that we know more
+ about the argumnents.
+
+ If an instance is found, jump to FINISH.
+
+STEP 7. No progress to be made. Return what we have. (Do not do FINISH.)
+
+FINISH 1. We've made a reduction, but the new type may still have more
+ work to do. So flatten the new type.
+
+FINISH 2. Add the result to the famapp-cache, connecting the type we started
+ with to the one we ended with.
+
+Because STEP 1/2 and STEP 5/6 happen the same way, they are abstracted into
+try_to_reduce.
+
+FINISH is naturally implemented in `finish`. But, Note [flatten_exact_fam_app performance]
+tells us that we should not add to the famapp-cache after STEP 1/2. So `finish`
+is inlined in that case, and only FINISH 1 is performed.
+
-}
flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
-- flatten_fam_app can be over-saturated
- -- flatten_exact_fam_app is exactly saturated
- -- flatten_exact_fam_app_fully lifts out the application to top level
+ -- flatten_exact_fam_app lifts out the application to top level
-- Postcondition: Coercion :: Xi ~ F tys
flatten_fam_app tc tys -- Can be over-saturated
= ASSERT2( tys `lengthAtLeast` tyConArity tc
, ppr tc $$ ppr (tyConArity tc) $$ ppr tys)
- do { mode <- getMode
- ; case mode of
- { FM_SubstOnly -> flatten_ty_con_app tc tys
- ; FM_FlattenAll ->
-
-- Type functions are saturated
-- The type function might be *over* saturated
-- in which case the remaining arguments should
-- be dealt with by AppTys
do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys
- ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1
+ ; (xi1, co1) <- flatten_exact_fam_app tc tys1
-- co1 :: xi1 ~ F tys1
- ; flatten_app_ty_args xi1 co1 tys_rest } } }
+ ; flatten_app_ty_args xi1 co1 tys_rest }
-- the [TcType] exactly saturate the TyCon
--- See note [flatten_exact_fam_app_fully performance]
-flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
-flatten_exact_fam_app_fully tc tys
- -- See Note [Reduce type family applications eagerly]
- -- the following tcTypeKind should never be evaluated, as it's just used in
- -- casting, and casts by refl are dropped
- = do { mOut <- try_to_reduce_nocache tc tys
- ; case mOut of
- Just out -> pure out
- Nothing -> do
- { -- First, flatten the arguments
- ; (xis, cos, kind_co)
- <- setEqRel NomEq $ -- just do this once, instead of for
- -- each arg
- flatten_args_tc tc (repeat Nominal) tys
- -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)
- ; eq_rel <- getEqRel
- ; cur_flav <- getFlavour
- ; let role = eqRelRole eq_rel
- ret_co = mkTyConAppCo role tc cos
- -- ret_co :: F xis ~ F tys; might be heterogeneous
-
- -- Now, look in the cache
- ; mb_ct <- liftTcS $ lookupFlatCache tc xis
- ; case mb_ct of
- Just (co, rhs_ty, flav) -- co :: F xis ~ fsk
- -- flav is [G] or [WD]
- -- See Note [Type family equations] in GHC.Tc.Solver.Monad
- | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav
- -> -- Usable hit in the flat-cache
- do { traceFlat "flatten/flat-cache hit" $
- (ppr tc <+> ppr xis $$ ppr rhs_ty)
- ; (fsk_xi, fsk_co) <- flatten_one rhs_ty
- -- The fsk may already have been unified, so
- -- flatten it
- -- fsk_co :: fsk_xi ~ fsk
- ; let xi = fsk_xi `mkCastTy` kind_co
- co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co
- `mkTransCo`
- maybeTcSubCo eq_rel (mkSymCo co)
- `mkTransCo` ret_co
- ; return (xi, co')
- }
- -- :: fsk_xi ~ F xis
-
- -- Try to reduce the family application right now
- -- See Note [Reduce type family applications eagerly]
- _ -> do { mOut <- try_to_reduce tc
- xis
- kind_co
- (`mkTransCo` ret_co)
- ; case mOut of
- Just out -> pure out
- Nothing -> do
- { loc <- getLoc
- ; (ev, co, fsk) <- liftTcS $
- newFlattenSkolem cur_flav loc tc xis
-
- -- The new constraint (F xis ~ fsk) is not
- -- necessarily inert (e.g. the LHS may be a
- -- redex) so we must put it in the work list
- ; let ct = CFunEqCan { cc_ev = ev
- , cc_fun = tc
- , cc_tyargs = xis
- , cc_fsk = fsk }
- ; emitFlatWork ct
-
- ; traceFlat "flatten/flat-cache miss" $
- (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)
-
- -- NB: fsk's kind is already flattened because
- -- the xis are flattened
- ; let fsk_ty = mkTyVarTy fsk
- xi = fsk_ty `mkCastTy` kind_co
- co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co))
- `mkTransCo` ret_co
- ; return (xi, co')
- }
- }
- }
- }
-
+-- See Note [How to normalise a family application]
+flatten_exact_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
+flatten_exact_fam_app tc tys
+ = do { checkStackDepth (mkTyConApp tc tys)
+
+ -- STEP 1/2. Try to reduce without reducing arguments first.
+ ; result1 <- try_to_reduce tc tys
+ ; case result1 of
+ -- Don't use the cache;
+ -- See Note [flatten_exact_fam_app performance]
+ { Just (co, xi) -> finish False (xi, co)
+ ; Nothing ->
+
+ -- That didn't work. So reduce the arguments, in STEP 3.
+ do { eq_rel <- getEqRel
+ -- checking eq_rel == NomEq saves ~0.5% in T9872a
+ ; (xis, cos, kind_co) <- if eq_rel == NomEq
+ then flatten_args_tc tc Nothing tys
+ else setEqRel NomEq $
+ flatten_args_tc tc Nothing tys
+ -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)
+
+ ; let role = eqRelRole eq_rel
+ args_co = mkTyConAppCo role tc cos
+ -- args_co :: F xis ~r F tys
+
+ homogenise :: TcType -> TcCoercion -> (TcType, TcCoercion)
+ -- in (xi', co') = homogenise xi co
+ -- assume co :: xi ~r F xis, co is homogeneous
+ -- then xi' :: tcTypeKind(F tys)
+ -- and co' :: xi' ~r F tys, which is homogeneous
+ homogenise xi co = homogenise_result xi (co `mkTcTransCo` args_co) role kind_co
+
+ -- STEP 4: try the inerts
+ ; result2 <- liftTcS $ lookupFamAppInert tc xis
+ ; flavour <- getFlavour
+ ; case result2 of
+ { Just (co, xi, fr@(_, inert_eq_rel))
+ -- co :: F xis ~ir xi
+
+ | fr `eqCanRewriteFR` (flavour, eq_rel) ->
+ do { traceFlat "rewrite family application with inert"
+ (ppr tc <+> ppr xis $$ ppr xi)
+ ; finish True (homogenise xi downgraded_co) }
+ -- this will sometimes duplicate an inert in the cache,
+ -- but avoiding doing so had no impact on performance, and
+ -- it seems easier not to weed out that special case
+ where
+ inert_role = eqRelRole inert_eq_rel
+ role = eqRelRole eq_rel
+ downgraded_co = tcDowngradeRole role inert_role (mkTcSymCo co)
+ -- downgraded_co :: xi ~r F xis
+
+ ; _ ->
+
+ -- inert didn't work. Try to reduce again, in STEP 5/6.
+ do { result3 <- try_to_reduce tc xis
+ ; case result3 of
+ Just (co, xi) -> finish True (homogenise xi co)
+ Nothing -> -- we have made no progress at all: STEP 7.
+ return (homogenise reduced (mkTcReflCo role reduced))
+ where
+ reduced = mkTyConApp tc xis }}}}}
where
+ -- call this if the above attempts made progress.
+ -- This recursively flattens the result and then adds to the cache
+ finish :: Bool -- add to the cache?
+ -> (Xi, Coercion) -> FlatM (Xi, Coercion)
+ finish use_cache (xi, co)
+ = do { -- flatten the result: FINISH 1
+ (fully, fully_co) <- bumpDepth $ flatten_one xi
+ ; let final_co = fully_co `mkTcTransCo` co
+ ; eq_rel <- getEqRel
+ ; flavour <- getFlavour
+
+ -- extend the cache: FINISH 2
+ ; when (use_cache && eq_rel == NomEq && flavour /= Derived) $
+ -- the cache only wants Nominal eqs
+ -- and Wanteds can rewrite Deriveds; the cache
+ -- has only Givens
+ liftTcS $ extendFamAppCache tc tys (final_co, fully)
+ ; return (fully, final_co) }
+ {-# INLINE finish #-}
- -- try_to_reduce and try_to_reduce_nocache (below) could be unified into
- -- a more general definition, but it was observed that separating them
- -- gives better performance (lower allocation numbers in T9872x).
-
- try_to_reduce :: TyCon -- F, family tycon
- -> [Type] -- args, not necessarily flattened
- -> CoercionN -- kind_co :: tcTypeKind(F args) ~N
- -- tcTypeKind(F orig_args)
- -- where
- -- orig_args is what was passed to the outer
- -- function
- -> ( Coercion -- :: (xi |> kind_co) ~ F args
- -> Coercion ) -- what to return from outer function
- -> FlatM (Maybe (Xi, Coercion))
- try_to_reduce tc tys kind_co update_co
- = do { checkStackDepth (mkTyConApp tc tys)
- ; mb_match <- liftTcS $ matchFam tc tys
- ; case mb_match of
- -- NB: norm_co will always be homogeneous. All type families
- -- are homogeneous.
- Just (norm_co, norm_ty)
- -> do { traceFlat "Eager T.F. reduction success" $
- vcat [ ppr tc, ppr tys, ppr norm_ty
- , ppr norm_co <+> dcolon
- <+> ppr (coercionKind norm_co)
- ]
- ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty
- ; eq_rel <- getEqRel
- ; let co = maybeTcSubCo eq_rel norm_co
- `mkTransCo` mkSymCo final_co
- ; flavour <- getFlavour
- -- NB: only extend cache with nominal equalities
- ; when (eq_rel == NomEq) $
- liftTcS $
- extendFlatCache tc tys ( co, xi, flavour )
- ; let role = eqRelRole eq_rel
- xi' = xi `mkCastTy` kind_co
- co' = update_co $
- mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
- ; return $ Just (xi', co') }
- Nothing -> pure Nothing }
-
- try_to_reduce_nocache :: TyCon -- F, family tycon
- -> [Type] -- args, not necessarily flattened
- -> FlatM (Maybe (Xi, Coercion))
- try_to_reduce_nocache tc tys
- = do { checkStackDepth (mkTyConApp tc tys)
- ; mb_match <- liftTcS $ matchFam tc tys
- ; case mb_match of
- -- NB: norm_co will always be homogeneous. All type families
- -- are homogeneous.
- Just (norm_co, norm_ty)
- -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty
- ; eq_rel <- getEqRel
- ; let co = mkSymCo (maybeTcSubCo eq_rel norm_co
- `mkTransCo` mkSymCo final_co)
- ; return $ Just (xi, co) }
- Nothing -> pure Nothing }
-
-{- Note [Reduce type family applications eagerly]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we come across a type-family application like (Append (Cons x Nil) t),
-then, rather than flattening to a skolem etc, we may as well just reduce
-it on the spot to (Cons x t). This saves a lot of intermediate steps.
-Examples that are helped are tests T9872, and T5321Fun.
-
-Performance testing indicates that it's best to try this *twice*, once
-before flattening arguments and once after flattening arguments.
-Adding the extra reduction attempt before flattening arguments cut
-the allocation amounts for the T9872{a,b,c} tests by half.
-
-An example of where the early reduction appears helpful:
-
- type family Last x where
- Last '[x] = x
- Last (h ': t) = Last t
-
- workitem: (x ~ Last '[1,2,3,4,5,6])
-
-Flattening the argument never gets us anywhere, but trying to flatten
-it at every step is quadratic in the length of the list. Reducing more
-eagerly makes simplifying the right-hand type linear in its length.
-
-Testing also indicated that the early reduction should *not* use the
-flat-cache, but that the later reduction *should*. (Although the
-effect was not large.) Hence the Bool argument to try_to_reduce. To
-me (SLPJ) this seems odd; I get that eager reduction usually succeeds;
-and if don't use the cache for eager reduction, we will miss most of
-the opportunities for using it at all. More exploration would be good
-here.
-
-At the end, once we've got a flat rhs, we extend the flatten-cache to record
-the result. Doing so can save lots of work when the same redex shows up more
-than once. Note that we record the link from the redex all the way to its
-*final* value, not just the single step reduction. Interestingly, using the
-flat-cache for the first reduction resulted in an increase in allocations
-of about 3% for the four T9872x tests. However, using the flat-cache in
-the later reduction is a similar gain. I (Richard E) don't currently (Dec '14)
-have any knowledge as to *why* these facts are true.
+-- Returned coercion is output ~r input, where r is the role in the FlatM monad
+-- See Note [How to normalise a family application]
+try_to_reduce :: TyCon -> [TcType] -> FlatM (Maybe (TcCoercion, TcType))
+try_to_reduce tc tys
+ = do { result <- liftTcS $ firstJustsM [ lookupFamAppCache tc tys -- STEP 5
+ , matchFam tc tys ] -- STEP 6
+ ; downgrade result }
+ where
+ -- The result above is always Nominal. We might want a Representational
+ -- coercion; this downgrades (and prints, out of convenience).
+ downgrade :: Maybe (TcCoercionN, TcType) -> FlatM (Maybe (TcCoercion, TcType))
+ downgrade Nothing = return Nothing
+ downgrade result@(Just (co, xi))
+ = do { traceFlat "Eager T.F. reduction success" $
+ vcat [ ppr tc, ppr tys, ppr xi
+ , ppr co <+> dcolon <+> ppr (coercionKind co)
+ ]
+ ; eq_rel <- getEqRel
+ -- manually doing it this way avoids allocation in the vastly
+ -- common NomEq case
+ ; case eq_rel of
+ NomEq -> return result
+ ReprEq -> return (Just (mkSubCo co, xi)) }
+{-
************************************************************************
* *
Flattening a type variable
@@ -1636,17 +947,15 @@ flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult
flatten_tyvar2 tv fr@(_, eq_rel)
= do { ieqs <- liftTcS $ getInertEqs
- ; mode <- getMode
; case lookupDVarEnv ieqs tv of
- Just (ct:_) -- If the first doesn't work,
- -- the subsequent ones won't either
- | CTyEqCan { cc_ev = ctev, cc_tyvar = tv
- , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
+ Just (EqualCtList (ct :| _)) -- If the first doesn't work,
+ -- the subsequent ones won't either
+ | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv
+ , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
, let ct_fr = (ctEvFlavour ctev, ct_eq_rel)
, ct_fr `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR
-> do { traceFlat "Following inert tyvar"
- (ppr mode <+>
- ppr tv <+>
+ (ppr tv <+>
equals <+>
ppr rhs_ty $$ ppr ctev)
; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)
@@ -1688,239 +997,14 @@ only if (a) the work item can rewrite the inert AND
This is significantly harder to think about. It can save a LOT of work
in occurs-check cases, but we don't care about them much. #5837
-is an example; all the constraints here are Givens
-
- [G] a ~ TF (a,Int)
- -->
- work TF (a,Int) ~ fsk
- inert fsk ~ a
-
- --->
- work fsk ~ (TF a, TF Int)
- inert fsk ~ a
-
- --->
- work a ~ (TF a, TF Int)
- inert fsk ~ a
-
- ---> (attempting to flatten (TF a) so that it does not mention a
- work TF a ~ fsk2
- inert a ~ (fsk2, TF Int)
- inert fsk ~ (fsk2, TF Int)
-
- ---> (substitute for a)
- work TF (fsk2, TF Int) ~ fsk2
- inert a ~ (fsk2, TF Int)
- inert fsk ~ (fsk2, TF Int)
-
- ---> (top-level reduction, re-orient)
- work fsk2 ~ (TF fsk2, TF Int)
- inert a ~ (fsk2, TF Int)
- inert fsk ~ (fsk2, TF Int)
-
- ---> (attempt to flatten (TF fsk2) to get rid of fsk2
- work TF fsk2 ~ fsk3
- work fsk2 ~ (fsk3, TF Int)
- inert a ~ (fsk2, TF Int)
- inert fsk ~ (fsk2, TF Int)
+is an example, but it causes trouble only with the old (pre-Fall 2020)
+flattening story. It is unclear if there is any gain w.r.t. to
+the new story.
- --->
- work TF fsk2 ~ fsk3
- inert fsk2 ~ (fsk3, TF Int)
- inert a ~ ((fsk3, TF Int), TF Int)
- inert fsk ~ ((fsk3, TF Int), TF Int)
-
-Because the incoming given rewrites all the inert givens, we get more and
-more duplication in the inert set. But this really only happens in pathological
-casee, so we don't care.
-
-
-************************************************************************
-* *
- Unflattening
-* *
-************************************************************************
-
-An unflattening example:
- [W] F a ~ alpha
-flattens to
- [W] F a ~ fmv (CFunEqCan)
- [W] fmv ~ alpha (CTyEqCan)
-We must solve both!
-}
-unflattenWanteds :: Cts -> Cts -> TcS Cts
-unflattenWanteds tv_eqs funeqs
- = do { tclvl <- getTcLevel
-
- ; traceTcS "Unflattening" $ braces $
- vcat [ text "Funeqs =" <+> pprCts funeqs
- , text "Tv eqs =" <+> pprCts tv_eqs ]
-
- -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check
- -- Occurs check: consider [W] alpha ~ [F alpha]
- -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]
- -- ==> (unify) [W] F [fmv] ~ fmv
- -- See Note [Unflatten using funeqs first]
- ; funeqs <- foldrM unflatten_funeq emptyCts funeqs
- ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
-
- -- Step 2: unify the tv_eqs, if possible
- ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs
- ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)
-
- -- Step 3: fill any remaining fmvs with fresh unification variables
- ; funeqs <- mapBagM finalise_funeq funeqs
- ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)
-
- -- Step 4: remove any tv_eqs that look like ty ~ ty
- ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs
-
- ; let all_flat = tv_eqs `andCts` funeqs
- ; traceTcS "Unflattening done" $ braces (pprCts all_flat)
-
- ; return all_flat }
- where
- ----------------
- unflatten_funeq :: Ct -> Cts -> TcS Cts
- unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis
- , cc_fsk = fmv, cc_ev = ev }) rest
- = do { -- fmv should be an un-filled flatten meta-tv;
- -- we now fix its final value by filling it, being careful
- -- to observe the occurs check. Zonking will eliminate it
- -- altogether in due course
- rhs' <- zonkTcType (mkTyConApp tc xis)
- ; case occCheckExpand [fmv] rhs' of
- Just rhs'' -- Normal case: fill the tyvar
- -> do { setReflEvidence ev NomEq rhs''
- ; unflattenFmv fmv rhs''
- ; return rest }
-
- Nothing -> -- Occurs check
- return (ct `consCts` rest) }
-
- unflatten_funeq other_ct _
- = pprPanic "unflatten_funeq" (ppr other_ct)
-
- ----------------
- finalise_funeq :: Ct -> TcS Ct
- finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev })
- = do { demoteUnfilledFmv fmv
- ; return (mkNonCanonical ev) }
- finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct)
-
- ----------------
- unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts
- unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv
- , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
-
- | NomEq <- eq_rel -- See Note [Do not unify representational equalities]
- -- in GHC.Tc.Solver.Interact
- , isFmvTyVar tv -- Previously these fmvs were untouchable,
- -- but now they are touchable
- -- NB: unlike unflattenFmv, filling a fmv here /does/
- -- bump the unification count; it is "improvement"
- -- Note [Unflattening can force the solver to iterate]
- = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct )
- -- CTyEqCan invariant (TyEq:K) should ensure this is true
- do { is_filled <- isFilledMetaTyVar tv
- ; elim <- case is_filled of
- False -> do { traceTcS "unflatten_eq 2" (ppr ct)
- ; tryFill ev tv rhs }
- True -> do { traceTcS "unflatten_eq 3" (ppr ct)
- ; try_fill_rhs ev tclvl tv rhs }
- ; if elim
- then do { setReflEvidence ev eq_rel (mkTyVarTy tv)
- ; return rest }
- else return (ct `consCts` rest) }
-
- | otherwise
- = return (ct `consCts` rest)
-
- unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct)
-
- ----------------
- try_fill_rhs ev tclvl lhs_tv rhs
- -- Constraint is lhs_tv ~ rhs_tv,
- -- and lhs_tv is filled, so try RHS
- | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs
- -- co :: kind(rhs_tv) ~ kind(lhs_tv)
- , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv
- && not (isTyVarTyVar rhs_tv))
- -- LHS is a filled fmv, and so is a type
- -- family application, which a TyVarTv should
- -- not unify with
- = do { is_filled <- isFilledMetaTyVar rhs_tv
- ; if is_filled then return False
- else tryFill ev rhs_tv
- (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) }
-
- | otherwise
- = return False
-
- ----------------
- finalise_eq :: Ct -> Cts -> TcS Cts
- finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv
- , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
- | isFmvTyVar tv
- = do { ty1 <- zonkTcTyVar tv
- ; rhs' <- zonkTcType rhs
- ; if ty1 `tcEqType` rhs'
- then do { setReflEvidence ev eq_rel rhs'
- ; return rest }
- else return (mkNonCanonical ev `consCts` rest) }
-
- | otherwise
- = return (mkNonCanonical ev `consCts` rest)
-
- finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)
-
-tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool
--- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv
--- If tv does not appear in 'rhs', it set tv := rhs,
--- binds the evidence (which should be a CtWanted) to Refl<rhs>
--- and return True. Otherwise returns False
-tryFill ev tv rhs
- = ASSERT2( not (isGiven ev), ppr ev )
- do { rhs' <- zonkTcType rhs
- ; case () of
- _ | Just tv' <- tcGetTyVar_maybe rhs'
- , tv == tv' -- tv == rhs
- -> return True
-
- _ | Just rhs'' <- occCheckExpand [tv] rhs'
- -> do { -- Fill the tyvar
- unifyTyVar tv rhs''
- ; return True }
-
- _ | otherwise -- Occurs check
- -> return False
- }
-
-setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()
-setReflEvidence ev eq_rel rhs
- = setEvBindIfWanted ev (evCoercion refl_co)
- where
- refl_co = mkTcReflCo (eqRelRole eq_rel) rhs
-
-{-
-Note [Unflatten using funeqs first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- [W] G a ~ Int
- [W] F (G a) ~ G a
-
-do not want to end up with
- [W] F Int ~ Int
-because that might actually hold! Better to end up with the two above
-unsolved constraints. The flat form will be
-
- G a ~ fmv1 (CFunEqCan)
- F fmv1 ~ fmv2 (CFunEqCan)
- fmv1 ~ Int (CTyEqCan)
- fmv1 ~ fmv2 (CTyEqCan)
-
-Flatten using the fun-eqs first.
--}
+--------------------------------------
+-- Utilities
-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at
-- least one named binder.
@@ -1946,6 +1030,6 @@ ty_con_binders_ty_binders' = foldr go ([], False)
go (Bndr tv (NamedTCB vis)) (bndrs, _)
= (Named (Bndr tv vis) : bndrs, True)
go (Bndr tv (AnonTCB af)) (bndrs, n)
- = (Anon af (unrestricted (tyVarKind tv)) : bndrs, n)
+ = (Anon af (tymult (tyVarKind tv)) : bndrs, n)
{-# INLINE go #-}
{-# INLINE ty_con_binders_ty_binders' #-}
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
index baa132c2b6..49d4ad20ab 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ b/compiler/GHC/Tc/Solver/Interact.hs
@@ -11,14 +11,12 @@ module GHC.Tc.Solver.Interact (
#include "HsVersions.h"
import GHC.Prelude
-import GHC.Types.Basic ( SwapFlag(..), isSwapped,
+import GHC.Types.Basic ( SwapFlag(..),
infinity, IntWithInf, intGtLimit )
import GHC.Tc.Solver.Canonical
-import GHC.Tc.Solver.Flatten
-import GHC.Tc.Utils.Unify ( canSolveByUnification )
+import GHC.Tc.Utils.Unify( canSolveByUnification )
import GHC.Types.Var.Set
import GHC.Core.Type as Type
-import GHC.Core.Coercion ( BlockSubstFlag(..) )
import GHC.Core.InstEnv ( DFunInstType )
import GHC.Types.Var
@@ -57,6 +55,7 @@ import GHC.Types.Unique( hasKey )
import GHC.Driver.Session
import GHC.Utils.Misc
import qualified GHC.LanguageExtensions as LangExt
+import Data.List.NonEmpty ( NonEmpty(..) )
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
@@ -90,50 +89,6 @@ Note [Basic Simplifier Plan]
If in Step 1 no such element exists, we have exceeded our context-stack
depth and will simply fail.
-
-Note [Unflatten after solving the simple wanteds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We unflatten after solving the wc_simples of an implication, and before attempting
-to float. This means that
-
- * The fsk/fmv flatten-skolems only survive during solveSimples. We don't
- need to worry about them across successive passes over the constraint tree.
- (E.g. we don't need the old ic_fsk field of an implication.
-
- * When floating an equality outwards, we don't need to worry about floating its
- associated flattening constraints.
-
- * Another tricky case becomes easy: #4935
- type instance F True a b = a
- type instance F False a b = b
-
- [w] F c a b ~ gamma
- (c ~ True) => a ~ gamma
- (c ~ False) => b ~ gamma
-
- Obviously this is soluble with gamma := F c a b, and unflattening
- will do exactly that after solving the simple constraints and before
- attempting the implications. Before, when we were not unflattening,
- we had to push Wanted funeqs in as new givens. Yuk!
-
- Another example that becomes easy: indexed_types/should_fail/T7786
- [W] BuriedUnder sub k Empty ~ fsk
- [W] Intersect fsk inv ~ s
- [w] xxx[1] ~ s
- [W] forall[2] . (xxx[1] ~ Empty)
- => Intersect (BuriedUnder sub k Empty) inv ~ Empty
-
-Note [Running plugins on unflattened wanteds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is an annoying mismatch between solveSimpleGivens and
-solveSimpleWanteds, because the latter needs to fiddle with the inert
-set, unflatten and zonk the wanteds. It passes the zonked wanteds
-to runTcPluginsWanteds, which produces a replacement set of wanteds,
-some additional insolubles and a flag indicating whether to go round
-the loop again. If so, prepareInertsForImplications is used to remove
-the previous wanteds (which will still be in the inert set). Note
-that prepareInertsForImplications will discard the insolubles, so we
-must keep track of them separately.
-}
solveSimpleGivens :: [Ct] -> TcS ()
@@ -177,48 +132,36 @@ solveSimpleWanteds simples
| otherwise
= do { -- Solve
- (unif_count, wc1) <- solve_simple_wanteds wc
+ wc1 <- solve_simple_wanteds wc
-- Run plugins
; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
- -- See Note [Running plugins on unflattened wanteds]
- ; if unif_count == 0 && not rerun_plugin
- then return (n, wc2) -- Done
- else do { traceTcS "solveSimple going round again:" $
- ppr unif_count $$ ppr rerun_plugin
- ; go (n+1) limit wc2 } } -- Loop
+ ; if rerun_plugin
+ then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)
+ ; go (n+1) limit wc2 } -- Loop
+ else return (n, wc2) } -- Done
-solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)
+solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints
-- Try solving these constraints
-- Affects the unification state (of course) but not the inert set
-- The result is not necessarily zonked
solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes })
= nestTcS $
do { solveSimples simples1
- ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts
- ; (unif_count, unflattened_eqs) <- reportUnifications $
- unflattenWanteds tv_eqs fun_eqs
- -- See Note [Unflatten after solving the simple wanteds]
- ; return ( unif_count
- , WC { wc_simple = others `andCts` unflattened_eqs
- , wc_impl = implics1 `unionBags` implics2
- , wc_holes = holes }) }
+ ; (implics2, unsolved) <- getUnsolvedInerts
+ ; return (WC { wc_simple = unsolved
+ , wc_impl = implics1 `unionBags` implics2
+ , wc_holes = holes }) }
{- Note [The solveSimpleWanteds loop]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Solving a bunch of simple constraints is done in a loop,
(the 'go' loop of 'solveSimpleWanteds'):
- 1. Try to solve them; unflattening may lead to improvement that
- was not exploitable during solving
+ 1. Try to solve them
2. Try the plugin
- 3. If step 1 did improvement during unflattening; or if the plugin
- wants to run again, go back to step 1
-
-Non-obviously, improvement can also take place during
-the unflattening that takes place in step (1). See GHC.Tc.Solver.Flatten,
-See Note [Unflattening can force the solver to iterate]
+ 3. If the plugin wants to run again, go back to step 1
-}
-- The main solver loop implements Note [Basic Simplifier Plan]
@@ -481,15 +424,16 @@ or, equivalently,
-- Interaction result of WorkItem <~> Ct
interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)
--- Precondition: if the workitem is a CTyEqCan then it will not be able to
--- react with anything at this stage.
+-- Precondition: if the workitem is a CEqCan then it will not be able to
+-- react with anything at this stage (except, maybe, via a type family
+-- dependency)
interactWithInertsStage wi
= do { inerts <- getTcSInerts
+ ; lvl <- getTcLevel
; let ics = inert_cans inerts
; case wi of
- CTyEqCan {} -> interactTyVarEq ics wi
- CFunEqCan {} -> interactFunEq ics wi
+ CEqCan {} -> interactEq lvl ics wi
CIrredCan {} -> interactIrred ics wi
CDictCan {} -> interactDict ics wi
_ -> pprPanic "interactWithInerts" (ppr wi) }
@@ -1127,6 +1071,8 @@ shortCutSolver dflags ev_w ev_i
; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
; loc' <- lift $ checkInstanceOK loc what pred
+ ; lift $ checkReductionDepth loc' pred
+
; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds
-- Emit work for subgoals but use our local cache
@@ -1298,113 +1244,63 @@ I can think of two ways to fix this:
**********************************************************************
-}
-interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
--- Try interacting the work item with the inert set
-interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc
- , cc_tyargs = args, cc_fsk = fsk })
- | Just inert_ct@(CFunEqCan { cc_ev = ev_i
- , cc_fsk = fsk_i })
- <- findFunEq (inert_funeqs inerts) tc args
- , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev
- = do { traceTcS "reactFunEq (rewrite inert item):" $
- vcat [ text "work_item =" <+> ppr work_item
- , text "inertItem=" <+> ppr ev_i
- , text "(swap_flag, upgrade)" <+> ppr pr ]
- ; if isSwapped swap_flag
- then do { -- Rewrite inert using work-item
- let work_item' | upgrade_flag = upgradeWanted work_item
- | otherwise = work_item
- ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item'
- -- Do the updInertFunEqs before the reactFunEq, so that
- -- we don't kick out the inertItem as well as consuming it!
- ; reactFunEq ev fsk ev_i fsk_i
- ; stopWith ev "Work item rewrites inert" }
- else do { -- Rewrite work-item using inert
- ; when upgrade_flag $
- updInertFunEqs $ \ feqs -> insertFunEq feqs tc args
- (upgradeWanted inert_ct)
- ; reactFunEq ev_i fsk_i ev fsk
- ; stopWith ev "Inert rewrites work item" } }
-
- | otherwise -- Try improvement
- = do { improveLocalFunEqs ev inerts tc args fsk
- ; continueWith work_item }
-
-interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item)
-
-upgradeWanted :: Ct -> Ct
--- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2
--- so upgrade the [W] to [WD] before putting it in the inert set
-upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) }
- where
- upgrade_ev ev = ASSERT2( isWanted ev, ppr ct )
- ev { ctev_nosh = WDeriv }
-
-improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar
+improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType
-> TcS ()
-- Generate derived improvement equalities, by comparing
-- the current work item with inert CFunEqs
-- E.g. x + y ~ z, x + y' ~ z => [D] y ~ y'
--
-- See Note [FunDep and implicit parameter reactions]
-improveLocalFunEqs work_ev inerts fam_tc args fsk
- | isGiven work_ev -- See Note [No FunEq improvement for Givens]
- || not (isImprovable work_ev)
- = return ()
-
- | otherwise
- = do { eqns <- improvement_eqns
- ; if not (null eqns)
- then do { traceTcS "interactFunEq improvements: " $
- vcat [ text "Eqns:" <+> ppr eqns
+-- Precondition: isImprovable work_ev
+improveLocalFunEqs work_ev inerts fam_tc args rhs
+ = ASSERT( isImprovable work_ev )
+ unless (null improvement_eqns) $
+ do { traceTcS "interactFunEq improvements: " $
+ vcat [ text "Eqns:" <+> ppr improvement_eqns
, text "Candidates:" <+> ppr funeqs_for_tc
, text "Inert eqs:" <+> ppr (inert_eqs inerts) ]
- ; emitFunDepDeriveds eqns }
- else return () }
-
+ ; emitFunDepDeriveds improvement_eqns }
where
funeqs = inert_funeqs inerts
- funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc
+ funeqs_for_tc = [ funeq_ct | EqualCtList (funeq_ct :| _)
+ <- findFunEqsByTyCon funeqs fam_tc
+ , NomEq == ctEqRel funeq_ct ]
+ -- representational equalities don't interact
+ -- with type family dependencies
work_loc = ctEvLoc work_ev
work_pred = ctEvPred work_ev
fam_inj_info = tyConInjectivityInfo fam_tc
--------------------
- improvement_eqns :: TcS [FunDepEqn CtLoc]
+ improvement_eqns :: [FunDepEqn CtLoc]
improvement_eqns
| Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
= -- Try built-in families, notably for arithmethic
- do { rhs <- rewriteTyVar fsk
- ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc }
+ concatMap (do_one_built_in ops rhs) funeqs_for_tc
| Injective injective_args <- fam_inj_info
= -- Try improvement from type families with injectivity annotations
- do { rhs <- rewriteTyVar fsk
- ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc }
+ concatMap (do_one_injective injective_args rhs) funeqs_for_tc
| otherwise
- = return []
+ = []
--------------------
- do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })
- = do { inert_rhs <- rewriteTyVar ifsk
- ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) }
+ do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev })
+ = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs)
do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)
--------------------
-- See Note [Type inference for type families with injectivity]
- do_one_injective inj_args rhs (CFunEqCan { cc_tyargs = inert_args
- , cc_fsk = ifsk, cc_ev = inert_ev })
+ do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args
+ , cc_rhs = irhs, cc_ev = inert_ev })
| isImprovable inert_ev
- = do { inert_rhs <- rewriteTyVar ifsk
- ; return $ if rhs `tcEqType` inert_rhs
- then mk_fd_eqns inert_ev $
- [ Pair arg iarg
- | (arg, iarg, True) <- zip3 args inert_args inj_args ]
- else [] }
+ , rhs `tcEqType` irhs
+ = mk_fd_eqns inert_ev $ [ Pair arg iarg
+ | (arg, iarg, True) <- zip3 args inert_args inj_args ]
| otherwise
- = return []
+ = []
do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)
@@ -1421,26 +1317,13 @@ improveLocalFunEqs work_ev inerts fam_tc args fsk
loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
ctl_depth work_loc }
--------------
-reactFunEq :: CtEvidence -> TcTyVar -- From this :: F args1 ~ fsk1
- -> CtEvidence -> TcTyVar -- Solve this :: F args2 ~ fsk2
- -> TcS ()
-reactFunEq from_this fsk1 solve_this fsk2
- = do { traceTcS "reactFunEq"
- (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2])
- ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)
- ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$
- ppr solve_this $$ ppr fsk2) }
-
{- Note [Type inference for type families with injectivity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have a type family with an injectivity annotation:
type family F a b = r | r -> b
-Then if we have two CFunEqCan constraints for F with the same RHS
- F s1 t1 ~ rhs
- F s2 t2 ~ rhs
-then we can use the injectivity to get a new Derived constraint on
+Then if we have an equality like F s1 t1 ~ F s2 t2,
+we can use the injectivity to get a new Derived constraint on
the injective argument
[D] t1 ~ t2
@@ -1467,8 +1350,20 @@ We could go further and offer evidence from decomposing injective type-function
applications, but that would require new evidence forms, and an extension to
FC, so we don't do that right now (Dec 14).
-See also Note [Injective type families] in GHC.Core.TyCon
+We generate these Deriveds in three places, depending on how we notice the
+injectivity.
+
+1. When we have a [W/D] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
+described in Note [Decomposing equality] in GHC.Tc.Solver.Canonical.
+
+2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
+constraints rewrites the other, as they have different LHSs. This is done
+in improveLocalFunEqs, called during the interactWithInertsStage.
+
+3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
+This is done in improve_top_fun_eqs, called from the top-level reactions stage.
+See also Note [Injective type families] in GHC.Core.TyCon
Note [Cache-caused loops]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1501,85 +1396,34 @@ which did not really made a 'step' towards proving some goal. Solved's are
just an optimization so we don't lose anything in terms of completeness of
solving.
-
-Note [Efficient Orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we are interacting two FunEqCans with the same LHS:
- (inert) ci :: (F ty ~ xi_i)
- (work) cw :: (F ty ~ xi_w)
-We prefer to keep the inert (else we pass the work item on down
-the pipeline, which is a bit silly). If we keep the inert, we
-will (a) discharge 'cw'
- (b) produce a new equality work-item (xi_w ~ xi_i)
-Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):
- new_work :: xi_w ~ xi_i
- cw := ci ; sym new_work
-Why? Consider the simplest case when xi1 is a type variable. If
-we generate xi1~xi2, processing that constraint will kick out 'ci'.
-If we generate xi2~xi1, there is less chance of that happening.
-Of course it can and should still happen if xi1=a, xi1=Int, say.
-But we want to avoid it happening needlessly.
-
-Similarly, if we *can't* keep the inert item (because inert is Wanted,
-and work is Given, say), we prefer to orient the new equality (xi_i ~
-xi_w).
-
-Note [Carefully solve the right CFunEqCan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- ---- OLD COMMENT, NOW NOT NEEDED
- ---- because we now allow multiple
- ---- wanted FunEqs with the same head
-Consider the constraints
- c1 :: F Int ~ a -- Arising from an application line 5
- c2 :: F Int ~ Bool -- Arising from an application line 10
-Suppose that 'a' is a unification variable, arising only from
-flattening. So there is no error on line 5; it's just a flattening
-variable. But there is (or might be) an error on line 10.
-
-Two ways to combine them, leaving either (Plan A)
- c1 :: F Int ~ a -- Arising from an application line 5
- c3 :: a ~ Bool -- Arising from an application line 10
-or (Plan B)
- c2 :: F Int ~ Bool -- Arising from an application line 10
- c4 :: a ~ Bool -- Arising from an application line 5
-
-Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error
-on the *totally innocent* line 5. An example is test SimpleFail16
-where the expected/actual message comes out backwards if we use
-the wrong plan.
-
-The second is the right thing to do. Hence the isMetaTyVarTy
-test when solving pairwise CFunEqCan.
-
-
**********************************************************************
* *
- interactTyVarEq
+ interactEq
* *
**********************************************************************
-}
-inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole
+inertsCanDischarge :: InertCans -> CanEqLHS -> TcType -> CtFlavourRole
-> Maybe ( CtEvidence -- The evidence for the inert
, SwapFlag -- Whether we need mkSymCo
, Bool) -- True <=> keep a [D] version
-- of the [WD] constraint
-inertsCanDischarge inerts tv rhs fr
- | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
- , cc_eq_rel = eq_rel }
- <- findTyEqs inerts tv
+inertsCanDischarge inerts lhs rhs fr
+ | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+ , cc_eq_rel = eq_rel }
+ <- findEq inerts lhs
, (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
, rhs_i `tcEqType` rhs ]
= -- Inert: a ~ ty
-- Work item: a ~ ty
Just (ev_i, NotSwapped, keep_deriv ev_i)
- | Just tv_rhs <- getTyVar_maybe rhs
- , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
- , cc_eq_rel = eq_rel }
- <- findTyEqs inerts tv_rhs
+ | Just rhs_lhs <- canEqLHS_maybe rhs
+ , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+ , cc_eq_rel = eq_rel }
+ <- findEq inerts rhs_lhs
, (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
- , rhs_i `tcEqType` mkTyVarTy tv ]
+ , rhs_i `tcEqType` canEqLHSType lhs ]
= -- Inert: a ~ b
-- Work item: b ~ a
Just (ev_i, IsSwapped, keep_deriv ev_i)
@@ -1595,16 +1439,15 @@ inertsCanDischarge inerts tv rhs fr
| otherwise
= False -- Work item is fully discharged
-interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
--- CTyEqCans are always consumed, so always returns Stop
-interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
- , cc_rhs = rhs
- , cc_ev = ev
- , cc_eq_rel = eq_rel })
+interactEq :: TcLevel -> InertCans -> Ct -> TcS (StopOrContinue Ct)
+interactEq tclvl inerts workItem@(CEqCan { cc_lhs = lhs
+ , cc_rhs = rhs
+ , cc_ev = ev
+ , cc_eq_rel = eq_rel })
| Just (ev_i, swapped, keep_deriv)
- <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel)
+ <- inertsCanDischarge inerts lhs rhs (ctEvFlavour ev, eq_rel)
= do { setEvBindIfWanted ev $
- evCoercion (maybeSym swapped $
+ evCoercion (maybeTcSymCo swapped $
tcDowngradeRole (eqRelRole eq_rel)
(ctEvRole ev_i)
(ctEvCoercion ev_i))
@@ -1622,19 +1465,22 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
= do { traceTcS "Not unifying representational equality" (ppr workItem)
; continueWith workItem }
- | isGiven ev -- See Note [Touchables and givens]
- = continueWith workItem
+ -- try improvement, if possible
+ | TyFamLHS fam_tc fam_args <- lhs
+ , isImprovable ev
+ = do { improveLocalFunEqs ev inerts fam_tc fam_args rhs
+ ; continueWith workItem }
- | otherwise
- = do { tclvl <- getTcLevel
- ; if canSolveByUnification tclvl tv rhs
- then do { solveByUnification ev tv rhs
- ; n_kicked <- kickOutAfterUnification tv
- ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
+ | TyVarLHS tv <- lhs
+ , canSolveByUnification tclvl tv rhs
+ = do { solveByUnification ev tv rhs
+ ; n_kicked <- kickOutAfterUnification tv
+ ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
- else continueWith workItem }
+ | otherwise
+ = continueWith workItem
-interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
+interactEq _ _ wi = pprPanic "interactEq" (ppr wi)
solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()
-- Solve with the identity coercion
@@ -1645,7 +1491,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()
-- workItem = the new Given constraint
--
-- NB: No need for an occurs check here, because solveByUnification always
--- arises from a CTyEqCan, a *canonical* constraint. Its invariant (TyEq:OC)
+-- arises from a CEqCan, a *canonical* constraint. Its invariant (TyEq:OC)
-- says that in (a ~ xi), the type variable a does not appear in xi.
-- See GHC.Tc.Types.Constraint.Ct invariants.
--
@@ -1694,7 +1540,7 @@ where
and we want to get alpha := N b.
See also #15144, which was caused by unifying a representational
-equality (in the unflattener).
+equality.
************************************************************************
@@ -1822,9 +1668,8 @@ topReactionsStage work_item
; case work_item of
CDictCan {} -> do { inerts <- getTcSInerts
; doTopReactDict inerts work_item }
- CFunEqCan {} -> doTopReactFunEq work_item
+ CEqCan {} -> doTopReactEq work_item
CIrredCan {} -> doTopReactOther work_item
- CTyEqCan {} -> doTopReactOther work_item
_ -> -- Any other work item does not react with any top-level equations
continueWith work_item }
@@ -1832,7 +1677,7 @@ topReactionsStage work_item
--------------------
doTopReactOther :: Ct -> TcS (StopOrContinue Ct)
-- Try local quantified constraints for
--- CTyEqCan e.g. (a ~# ty)
+-- CEqCan e.g. (lhs ~# ty)
-- and CIrredCan e.g. (c a)
--
-- Why equalities? See GHC.Tc.Solver.Canonical
@@ -1889,126 +1734,24 @@ See
* Note [Evidence for quantified constraints] in GHC.Core.Predicate
* Note [Equality superclasses in quantified constraints]
in GHC.Tc.Solver.Canonical
-
-Note [Flatten when discharging CFunEqCan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have the following scenario (#16512):
-
-type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where
- LV (a ': as) b = a -> LV as b
-
-[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan)
-[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan)
-[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan)
-
-We start with w1. Because LV is injective, we wish to see if the RHS of the
-equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an
-fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs.
-That performs the match, but it allows a type family application (such as the
-LV in the RHS of the equation) to match with anything. (See "Injective type
-families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which
-means we can improve as0 (and b, but that's not interesting here). However,
-because the RHS of w1 can't see through fmv2 (we have no way of looking up a
-LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough),
-we invent a new unification variable here. We thus get (as0 := a : as1).
-Rewriting:
-
-[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1
-[WD] w2 :: fmv1 ~ (a -> fmv2)
-[WD] w3 :: LV (a : as1) b ~ fmv2
-
-We can now reduce both CFunEqCans, using the equation for LV. We get
-
-[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b)
-
-Now we decompose (and flatten) to
-
-[WD] w4 :: LV as1 (a -> b) ~ fmv3
-[WD] w5 :: fmv3 ~ (a -> fmv1)
-[WD] w6 :: LV as1 b ~ fmv4
-
-which is exactly where we started. These goals really are insoluble, but
-we would prefer not to loop. We thus need to find a way to bump the reduction
-depth, so that we can detect the loop and abort.
-
-The key observation is that we are performing a reduction. We thus wish
-to bump the level when discharging a CFunEqCan. Where does this bumped
-level go, though? It can't just go on the reduct, as that's a type. Instead,
-it must go on any CFunEqCans produced after flattening. We thus flatten
-when discharging, making sure that the level is bumped in the new
-fun-eqs. The flattening happens in reduce_top_fun_eq and the level
-is bumped when setting up the FlatM monad in GHC.Tc.Solver.Flatten.runFlatten.
-(This bumping will happen for call sites other than this one, but that
-makes sense -- any constraints emitted by the flattener are offshoots
-the work item and should have a higher level. We don't have any test
-cases that require the bumping in this other cases, but it's convenient
-and causes no harm to bump at every flatten.)
-
-Test case: typecheck/should_fail/T16512a
-
-}
--------------------
-doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)
-doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
- , cc_tyargs = args, cc_fsk = fsk })
-
- | fsk `elemVarSet` tyCoVarsOfTypes args
- = no_reduction -- See Note [FunEq occurs-check principle]
-
- | otherwise -- Note [Reduction for Derived CFunEqCans]
- = do { match_res <- matchFam fam_tc args
- -- Look up in top-level instances, or built-in axiom
- -- See Note [MATCHING-SYNONYMS]
- ; case match_res of
- Nothing -> no_reduction
- Just match_info -> reduce_top_fun_eq old_ev fsk match_info }
- where
- no_reduction
- = do { improveTopFunEqs old_ev fam_tc args fsk
- ; continueWith work_item }
-
-doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)
-
-reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType)
- -> TcS (StopOrContinue Ct)
--- We have found an applicable top-level axiom: use it to reduce
--- Precondition: fsk is not free in rhs_ty
--- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev
-reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)
- | not (isDerived old_ev) -- Precondition of shortCutReduction
- , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty
- , isTypeFamilyTyCon tc
- , tc_args `lengthIs` tyConArity tc -- Short-cut
- = -- RHS is another type-family application
- -- Try shortcut; see Note [Top-level reductions for type functions]
- do { shortCutReduction old_ev fsk ax_co tc tc_args
- ; stopWith old_ev "Fun/Top (shortcut)" }
-
- | otherwise
- = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)
- , ppr old_ev $$ ppr rhs_ty )
- -- Guaranteed by Note [FunEq occurs-check principle]
- do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty
- -- flatten_co :: rhs_xi ~ rhs_ty
- -- See Note [Flatten when discharging CFunEqCan]
- ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co
- ; dischargeFunEq old_ev fsk total_co rhs_xi
- ; traceTcS "doTopReactFunEq" $
- vcat [ text "old_ev:" <+> ppr old_ev
- , nest 2 (text ":=") <+> ppr ax_co ]
- ; stopWith old_ev "Fun/Top" }
-
-improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()
+doTopReactEq :: Ct -> TcS (StopOrContinue Ct)
+doTopReactEq work_item@(CEqCan { cc_ev = old_ev, cc_lhs = TyFamLHS fam_tc args
+ , cc_rhs = rhs })
+ = do { improveTopFunEqs old_ev fam_tc args rhs
+ ; doTopReactOther work_item }
+doTopReactEq work_item = doTopReactOther work_item
+
+improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS ()
-- See Note [FunDep and implicit parameter reactions]
-improveTopFunEqs ev fam_tc args fsk
- | isGiven ev -- See Note [No FunEq improvement for Givens]
- || not (isImprovable ev)
+improveTopFunEqs ev fam_tc args rhs
+ | not (isImprovable ev)
= return ()
| otherwise
= do { fam_envs <- getFamInstEnvs
- ; rhs <- rewriteTyVar fsk
; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs
; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs
, ppr eqns ])
@@ -2090,127 +1833,7 @@ improve_top_fun_eqs fam_envs fam_tc args rhs_ty
_ -> True
, (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }
-
-shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
- -> TyCon -> [TcType] -> TcS ()
--- See Note [Top-level reductions for type functions]
--- Previously, we flattened the tc_args here, but there's no need to do so.
--- And, if we did, this function would have all the complication of
--- GHC.Tc.Solver.Canonical.canCFunEqCan. See Note [canCFunEqCan]
-shortCutReduction old_ev fsk ax_co fam_tc tc_args
- = ASSERT( ctEvEqRel old_ev == NomEq)
- -- ax_co :: F args ~ G tc_args
- -- old_ev :: F args ~ fsk
- do { new_ev <- case ctEvFlavour old_ev of
- Given -> newGivenEvVar deeper_loc
- ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
- , evCoercion (mkTcSymCo ax_co
- `mkTcTransCo` ctEvCoercion old_ev) )
-
- Wanted {} ->
- -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst
- do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal
- (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
- ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co
- ; return new_ev }
-
- Derived -> pprPanic "shortCutReduction" (ppr old_ev)
-
- ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc
- , cc_tyargs = tc_args, cc_fsk = fsk }
- ; updWorkListTcS (extendWorkListFunEq new_ct) }
- where
- deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
-
-{- Note [Top-level reductions for type functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-c.f. Note [The flattening story] in GHC.Tc.Solver.Flatten
-
-Suppose we have a CFunEqCan F tys ~ fmv/fsk, and a matching axiom.
-Here is what we do, in four cases:
-
-* Wanteds: general firing rule
- (work item) [W] x : F tys ~ fmv
- instantiate axiom: ax_co : F tys ~ rhs
-
- Then:
- Discharge fmv := rhs
- Discharge x := ax_co ; sym x2
- This is *the* way that fmv's get unified; even though they are
- "untouchable".
-
- NB: Given Note [FunEq occurs-check principle], fmv does not appear
- in tys, and hence does not appear in the instantiated RHS. So
- the unification can't make an infinite type.
-
-* Wanteds: short cut firing rule
- Applies when the RHS of the axiom is another type-function application
- (work item) [W] x : F tys ~ fmv
- instantiate axiom: ax_co : F tys ~ G rhs_tys
-
- It would be a waste to create yet another fmv for (G rhs_tys).
- Instead (shortCutReduction):
- - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)
- - Add G rhs_xis ~ fmv to flat cache (note: the same old fmv)
- - New canonical wanted [W] x2 : G rhs_xis ~ fmv (CFunEqCan)
- - Discharge x := ax_co ; G cos ; x2
-
-* Givens: general firing rule
- (work item) [G] g : F tys ~ fsk
- instantiate axiom: ax_co : F tys ~ rhs
-
- Now add non-canonical given (since rhs is not flat)
- [G] (sym g ; ax_co) : fsk ~ rhs (Non-canonical)
-
-* Givens: short cut firing rule
- Applies when the RHS of the axiom is another type-function application
- (work item) [G] g : F tys ~ fsk
- instantiate axiom: ax_co : F tys ~ G rhs_tys
-
- It would be a waste to create yet another fsk for (G rhs_tys).
- Instead (shortCutReduction):
- - Flatten rhs_tys: flat_cos : tys ~ flat_tys
- - Add new Canonical given
- [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk (CFunEqCan)
-
-Note [FunEq occurs-check principle]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-I have spent a lot of time finding a good way to deal with
-CFunEqCan constraints like
- F (fuv, a) ~ fuv
-where flatten-skolem occurs on the LHS. Now in principle we
-might may progress by doing a reduction, but in practice its
-hard to find examples where it is useful, and easy to find examples
-where we fall into an infinite reduction loop. A rule that works
-very well is this:
-
- *** FunEq occurs-check principle ***
-
- Do not reduce a CFunEqCan
- F tys ~ fsk
- if fsk appears free in tys
- Instead we treat it as stuck.
-
-Examples:
-
-* #5837 has [G] a ~ TF (a,Int), with an instance
- type instance TF (a,b) = (TF a, TF b)
- This readily loops when solving givens. But with the FunEq occurs
- check principle, it rapidly gets stuck which is fine.
-
-* #12444 is a good example, explained in comment:2. We have
- type instance F (Succ x) = Succ (F x)
- [W] alpha ~ Succ (F alpha)
- If we allow the reduction to happen, we get an infinite loop
-
-Note [Cached solved FunEqs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When trying to solve, say (FunExpensive big-type ~ ty), it's important
-to see if we have reduced (FunExpensive big-type) before, lest we
-simply repeat it. Hence the lookup in inert_solved_funeqs. Moreover
-we must use `funEqCanDischarge` because both uses might (say) be Wanteds,
-and we *still* want to save the re-computation.
-
+{-
Note [MATCHING-SYNONYMS]
~~~~~~~~~~~~~~~~~~~~~~~~
When trying to match a dictionary (D tau) to a top-level instance, or a
@@ -2254,68 +1877,6 @@ kinds much match too; so it's easier to let the normal machinery
handle it. Instead we are careful to orient the new derived
equality with the template on the left. Delicate, but it works.
-Note [No FunEq improvement for Givens]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't do improvements (injectivity etc) for Givens. Why?
-
-* It generates Derived constraints on skolems, which don't do us
- much good, except perhaps identify inaccessible branches.
- (They'd be perfectly valid though.)
-
-* For type-nat stuff the derived constraints include type families;
- e.g. (a < b), (b < c) ==> a < c If we generate a Derived for this,
- we'll generate a Derived/Wanted CFunEqCan; and, since the same
- InertCans (after solving Givens) are used for each iteration, that
- massively confused the unflattening step (GHC.Tc.Solver.Flatten.unflatten).
-
- In fact it led to some infinite loops:
- indexed-types/should_compile/T10806
- indexed-types/should_compile/T10507
- polykinds/T10742
-
-Note [Reduction for Derived CFunEqCans]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You may wonder if it's important to use top-level instances to
-simplify [D] CFunEqCan's. But it is. Here's an example (T10226).
-
- type instance F Int = Int
- type instance FInv Int = Int
-
-Suppose we have to solve
- [WD] FInv (F alpha) ~ alpha
- [WD] F alpha ~ Int
-
- --> flatten
- [WD] F alpha ~ fuv0
- [WD] FInv fuv0 ~ fuv1 -- (A)
- [WD] fuv1 ~ alpha
- [WD] fuv0 ~ Int -- (B)
-
- --> Rewwrite (A) with (B), splitting it
- [WD] F alpha ~ fuv0
- [W] FInv fuv0 ~ fuv1
- [D] FInv Int ~ fuv1 -- (C)
- [WD] fuv1 ~ alpha
- [WD] fuv0 ~ Int
-
- --> Reduce (C) with top-level instance
- **** This is the key step ***
- [WD] F alpha ~ fuv0
- [W] FInv fuv0 ~ fuv1
- [D] fuv1 ~ Int -- (D)
- [WD] fuv1 ~ alpha -- (E)
- [WD] fuv0 ~ Int
-
- --> Rewrite (D) with (E)
- [WD] F alpha ~ fuv0
- [W] FInv fuv0 ~ fuv1
- [D] alpha ~ Int -- (F)
- [WD] fuv1 ~ alpha
- [WD] fuv0 ~ Int
-
- --> unify (F) alpha := Int, and that solves it
-
-Another example is indexed-types/should_compile/T10634
-}
{- *******************************************************************
@@ -2379,47 +1940,48 @@ chooseInstance work_item
, cir_mk_ev = mk_ev })
= do { traceTcS "doTopReact/found instance for" $ ppr ev
; deeper_loc <- checkInstanceOK loc what pred
- ; if isDerived ev then finish_derived deeper_loc theta
- else finish_wanted deeper_loc theta mk_ev }
+ ; if isDerived ev
+ then -- Use type-class instances for Deriveds, in the hope
+ -- of generating some improvements
+ -- C.f. Example 3 of Note [The improvement story]
+ -- It's easy because no evidence is involved
+ do { dflags <- getDynFlags
+ ; unless (subGoalDepthExceeded dflags (ctLocDepth deeper_loc)) $
+ emitNewDeriveds deeper_loc theta
+ -- If we have a runaway Derived, let's not issue a
+ -- "reduction stack overflow" error, which is not particularly
+ -- friendly. Instead, just drop the Derived.
+ ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))
+ ; stopWith ev "Dict/Top (solved derived)" }
+
+ else -- wanted
+ do { checkReductionDepth deeper_loc pred
+ ; evb <- getTcEvBindsVar
+ ; if isCoEvBindsVar evb
+ then continueWith work_item
+ -- See Note [Instances in no-evidence implications]
+
+ else
+ do { evc_vars <- mapM (newWanted deeper_loc) theta
+ ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))
+ ; emitWorkNC (freshGoals evc_vars)
+ ; stopWith ev "Dict/Top (solved wanted)" }}}
where
ev = ctEvidence work_item
pred = ctEvPred ev
loc = ctEvLoc ev
- finish_wanted :: CtLoc -> [TcPredType]
- -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct)
- -- Precondition: evidence term matches the predicate workItem
- finish_wanted loc theta mk_ev
- = do { evb <- getTcEvBindsVar
- ; if isCoEvBindsVar evb
- then -- See Note [Instances in no-evidence implications]
- continueWith work_item
- else
- do { evc_vars <- mapM (newWanted loc) theta
- ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))
- ; emitWorkNC (freshGoals evc_vars)
- ; stopWith ev "Dict/Top (solved wanted)" } }
-
- finish_derived loc theta
- = -- Use type-class instances for Deriveds, in the hope
- -- of generating some improvements
- -- C.f. Example 3 of Note [The improvement story]
- -- It's easy because no evidence is involved
- do { emitNewDeriveds loc theta
- ; traceTcS "finish_derived" (ppr (ctl_depth loc))
- ; stopWith ev "Dict/Top (solved derived)" }
-
chooseInstance work_item lookup_res
= pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)
checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
-- Check that it's OK to use this insstance:
-- (a) the use is well staged in the Template Haskell sense
--- (b) we have not recursed too deep
-- Returns the CtLoc to used for sub-goals
+-- Probably also want to call checkReductionDepth, but this function
+-- does not do so to enable special handling for Deriveds in chooseInstance
checkInstanceOK loc what pred
= do { checkWellStagedDFun loc what pred
- ; checkReductionDepth deeper_loc pred
; return deeper_loc }
where
deeper_loc = zap_origin (bumpCtLocDepth loc)
@@ -2460,7 +2022,7 @@ matchClassInst dflags inerts clas tys loc
-- First check whether there is an in-scope Given that could
-- match this constraint. In that case, do not use any instance
-- whether top level, or local quantified constraints.
--- ee Note [Instance and Given overlap]
+-- See Note [Instance and Given overlap]
| not (xopt LangExt.IncoherentInstances dflags)
, not (naturallyCoherentClass clas)
, let matchable_givens = matchableGivens loc pred inerts
@@ -2533,7 +2095,7 @@ The partial solution is that:
The end effect is that, much as we do for overlapping instances, we
delay choosing a class instance if there is a possibility of another
instance OR a given to match our constraint later on. This fixes
-#4981 and #5002.
+tickets #4981 and #5002.
Other notes:
@@ -2543,12 +2105,7 @@ Other notes:
- natural numbers
- Typeable
-* Flatten-skolems: we do not treat a flatten-skolem as unifiable
- for this purpose.
- E.g. f :: Eq (F a) => [a] -> [a]
- f xs = ....(xs==xs).....
- Here we get [W] Eq [a], and we don't want to refrain from solving
- it because of the given (Eq (F a)) constraint!
+* See also Note [What might match later?] in GHC.Tc.Solver.Monad.
* The given-overlap problem is arguably not easy to appear in practice
due to our aggressive prioritization of equality solving over other
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 64a80b2e94..80f6e7f3a8 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies #-}
+{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables, TypeApplications,
+ DerivingStrategies, GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}
-- | Type definitions for the constraint solver
module GHC.Tc.Solver.Monad (
@@ -8,10 +9,10 @@ module GHC.Tc.Solver.Monad (
-- The work list
WorkList(..), isEmptyWorkList, emptyWorkList,
extendWorkListNonEq, extendWorkListCt,
- extendWorkListCts, extendWorkListEq, extendWorkListFunEq,
+ extendWorkListCts, extendWorkListEq,
appendWorkList,
selectNextWorkItem,
- workListSize, workListWantedCount,
+ workListSize,
getWorkList, updWorkListTcS, pushLevelNoWorkList,
-- The TcS monad
@@ -40,7 +41,7 @@ module GHC.Tc.Solver.Monad (
newWantedNC, newWantedEvVarNC,
newDerivedNC,
newBoundEvVarId,
- unifyTyVar, unflattenFmv, reportUnifications,
+ unifyTyVar, reportUnifications,
setEvBind, setWantedEq,
setWantedEvTerm, setEvBindIfWanted,
newEvVar, newGivenEvVar, newGivenEvVars,
@@ -57,7 +58,7 @@ module GHC.Tc.Solver.Monad (
-- Inerts
InertSet(..), InertCans(..), emptyInert,
updInertTcS, updInertCans, updInertDicts, updInertIrreds,
- getNoGivenEqs, setInertCans,
+ getHasGivenEqs, setInertCans,
getInertEqs, getInertCans, getInertGivens,
getInertInsols,
getTcSInerts, setTcSInerts,
@@ -79,9 +80,9 @@ module GHC.Tc.Solver.Monad (
DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,
addDictsByClass, delDict, foldDicts, filterDicts, findDict,
- -- Inert CTyEqCans
- EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,
- lookupInertTyVar,
+ -- Inert CEqCans
+ EqualCtList(..), findTyEqs, foldTyEqs,
+ findEq,
-- Inert solved dictionaries
addSolvedDict, lookupSolvedDict,
@@ -90,18 +91,17 @@ module GHC.Tc.Solver.Monad (
foldIrreds,
-- The flattening cache
- lookupFlatCache, extendFlatCache, newFlattenSkolem, -- Flatten skolems
- dischargeFunEq, pprKicked,
+ lookupFamAppInert, lookupFamAppCache, extendFamAppCache,
+ pprKicked,
- -- Inert CFunEqCans
- updInertFunEqs, findFunEq,
- findFunEqsByTyCon,
+ -- Inert function equalities
+ findFunEq, findFunEqsByTyCon,
instDFunType, -- Instantiation
-- MetaTyVars
newFlexiTcSTy, instFlexi, instFlexiX,
- cloneMetaTyVar, demoteUnfilledFmv,
+ cloneMetaTyVar,
tcInstSkolTyVarsX,
TcLevel,
@@ -118,11 +118,13 @@ module GHC.Tc.Solver.Monad (
getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
matchFam, matchFamTcM,
checkWellStagedDFun,
- pprEq -- Smaller utils, re-exported from TcM
+ pprEq, -- Smaller utils, re-exported from TcM
-- TODO (DV): these are only really used in the
-- instance matcher in GHC.Tc.Solver. I am wondering
-- if the whole instance matcher simply belongs
-- here
+
+ breakTyVarCycle, flattenView
) where
#include "HsVersions.h"
@@ -145,6 +147,7 @@ import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDict
import GHC.Tc.Utils.TcType
import GHC.Driver.Session
import GHC.Core.Type
+import qualified GHC.Core.TyCo.Rep as Rep -- this needs to be used only very locally
import GHC.Core.Coercion
import GHC.Core.Unify
@@ -172,9 +175,7 @@ import GHC.Tc.Types.Origin
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.DFM
+import GHC.Types.Unique.Set
import GHC.Core.TyCon.Env
import GHC.Data.Maybe
@@ -185,10 +186,13 @@ import Control.Monad
import GHC.Utils.Monad
import Data.IORef
import Data.List ( partition, mapAccumL )
+import qualified Data.Semigroup as S
+import Data.List.NonEmpty ( NonEmpty(..), cons, toList, nonEmpty )
+import qualified Data.List.NonEmpty as NE
+import Control.Arrow ( first )
#if defined(DEBUG)
import GHC.Data.Graph.Directed
-import GHC.Types.Unique.Set
#endif
{-
@@ -210,7 +214,6 @@ consider using this depth for prioritization as well in the future.
As a simple form of priority queue, our worklist separates out
* equalities (wl_eqs); see Note [Prioritise equalities]
-* type-function equalities (wl_funeqs)
* all the rest (wl_rest)
Note [Prioritise equalities]
@@ -268,15 +271,13 @@ So we arrange to put these particular class constraints in the wl_eqs.
-- See Note [WorkList priorities]
data WorkList
- = WL { wl_eqs :: [Ct] -- CTyEqCan, CDictCan, CIrredCan
+ = WL { wl_eqs :: [Ct] -- CEqCan, CDictCan, CIrredCan
-- Given, Wanted, and Derived
-- Contains both equality constraints and their
-- class-level variants (a~b) and (a~~b);
-- See Note [Prioritise equalities]
-- See Note [Prioritise class equalities]
- , wl_funeqs :: [Ct]
-
, wl_rest :: [Ct]
, wl_implics :: Bag Implication -- See Note [Residual implications]
@@ -284,37 +285,21 @@ data WorkList
appendWorkList :: WorkList -> WorkList -> WorkList
appendWorkList
- (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1
+ (WL { wl_eqs = eqs1, wl_rest = rest1
, wl_implics = implics1 })
- (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2
+ (WL { wl_eqs = eqs2, wl_rest = rest2
, wl_implics = implics2 })
= WL { wl_eqs = eqs1 ++ eqs2
- , wl_funeqs = funeqs1 ++ funeqs2
, wl_rest = rest1 ++ rest2
, wl_implics = implics1 `unionBags` implics2 }
workListSize :: WorkList -> Int
-workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
- = length eqs + length funeqs + length rest
-
-workListWantedCount :: WorkList -> Int
--- Count the things we need to solve
--- excluding the insolubles (c.f. inert_count)
-workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })
- = count isWantedCt eqs + count is_wanted rest
- where
- is_wanted ct
- | CIrredCan { cc_status = InsolubleCIS } <- ct
- = False
- | otherwise
- = isWantedCt ct
+workListSize (WL { wl_eqs = eqs, wl_rest = rest })
+ = length eqs + length rest
extendWorkListEq :: Ct -> WorkList -> WorkList
extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
-extendWorkListFunEq :: Ct -> WorkList -> WorkList
-extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }
-
extendWorkListNonEq :: Ct -> WorkList -> WorkList
-- Extension by non equality
extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
@@ -330,11 +315,6 @@ extendWorkListCt :: Ct -> WorkList -> WorkList
-- Agnostic
extendWorkListCt ct wl
= case classifyPredType (ctPred ct) of
- EqPred NomEq ty1 _
- | Just tc <- tcTyConAppTyCon_maybe ty1
- , isTypeFamilyTyCon tc
- -> extendWorkListFunEq ct wl
-
EqPred {}
-> extendWorkListEq ct wl
@@ -349,20 +329,16 @@ extendWorkListCts :: [Ct] -> WorkList -> WorkList
extendWorkListCts cts wl = foldr extendWorkListCt wl cts
isEmptyWorkList :: WorkList -> Bool
-isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
- , wl_rest = rest, wl_implics = implics })
- = null eqs && null rest && null funeqs && isEmptyBag implics
+isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })
+ = null eqs && null rest && isEmptyBag implics
emptyWorkList :: WorkList
-emptyWorkList = WL { wl_eqs = [], wl_rest = []
- , wl_funeqs = [], wl_implics = emptyBag }
+emptyWorkList = WL { wl_eqs = [], wl_rest = [], wl_implics = emptyBag }
selectWorkItem :: WorkList -> Maybe (Ct, WorkList)
-- See Note [Prioritise equalities]
-selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs
- , wl_rest = rest })
+selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })
| ct:cts <- eqs = Just (ct, wl { wl_eqs = cts })
- | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes })
| ct:cts <- rest = Just (ct, wl { wl_rest = cts })
| otherwise = Nothing
@@ -386,13 +362,10 @@ selectNextWorkItem
-- Pretty printing
instance Outputable WorkList where
- ppr (WL { wl_eqs = eqs, wl_funeqs = feqs
- , wl_rest = rest, wl_implics = implics })
+ ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })
= text "WL" <+> (braces $
vcat [ ppUnless (null eqs) $
text "Eqs =" <+> vcat (map ppr eqs)
- , ppUnless (null feqs) $
- text "Funeqs =" <+> vcat (map ppr feqs)
, ppUnless (null rest) $
text "Non-eqs =" <+> vcat (map ppr rest)
, ppUnless (isEmptyBag implics) $
@@ -413,30 +386,20 @@ data InertSet
-- Canonical Given, Wanted, Derived
-- Sometimes called "the inert set"
- , inert_fsks :: [(TcTyVar, TcType)]
- -- A list of (fsk, ty) pairs; we add one element when we flatten
- -- a function application in a Given constraint, creating
- -- a new fsk in newFlattenSkolem. When leaving a nested scope,
- -- unflattenGivens unifies fsk := ty
- --
- -- We could also get this info from inert_funeqs, filtered by
- -- level, but it seems simpler and more direct to capture the
- -- fsk as we generate them.
+ , inert_cycle_breakers :: [(TcTyVar, TcType)]
+ -- a list of CycleBreakerTv / original family applications
+ -- used to undo the cycle-breaking needed to handle
+ -- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical
- , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)
- -- See Note [Type family equations]
- -- If F tys :-> (co, rhs, flav),
- -- then co :: F tys ~ rhs
- -- flav is [G] or [WD]
+ , inert_famapp_cache :: FunEqMap (TcCoercion, TcType)
+ -- Just a hash-cons cache for use when reducing family applications
+ -- only
--
- -- Just a hash-cons cache for use when flattening only
- -- These include entirely un-processed goals, so don't use
- -- them to solve a top-level goal, else you may end up solving
- -- (w:F ty ~ a) by setting w:=w! We just use the flat-cache
- -- when allocating a new flatten-skolem.
- -- Not necessarily inert wrt top-level equations (or inert_cans)
-
- -- NB: An ExactFunEqMap -- this doesn't match via loose types!
+ -- If F tys :-> (co, rhs, flav),
+ -- then co :: rhs ~N F tys
+ -- all evidence is from instances or Givens; no coercion holes here
+ -- (We have no way of "kicking out" from the cache, so putting
+ -- wanteds here means we can end up solving a Wanted with itself. Bad)
, inert_solved_dicts :: DictMap CtEvidence
-- All Wanteds, of form ev :: C t1 .. tn
@@ -446,10 +409,8 @@ data InertSet
instance Outputable InertSet where
ppr (IS { inert_cans = ics
- , inert_fsks = ifsks
, inert_solved_dicts = solved_dicts })
= vcat [ ppr ics
- , text "Inert fsks =" <+> ppr ifsks
, ppUnless (null dicts) $
text "Solved dicts =" <+> vcat (map ppr dicts) ]
where
@@ -457,8 +418,7 @@ instance Outputable InertSet where
emptyInertCans :: InertCans
emptyInertCans
- = IC { inert_count = 0
- , inert_eqs = emptyDVarEnv
+ = IC { inert_eqs = emptyDVarEnv
, inert_dicts = emptyDicts
, inert_safehask = emptyDicts
, inert_funeqs = emptyFunEqs
@@ -467,10 +427,10 @@ emptyInertCans
emptyInert :: InertSet
emptyInert
- = IS { inert_cans = emptyInertCans
- , inert_fsks = []
- , inert_flat_cache = emptyExactFunEqs
- , inert_solved_dicts = emptyDictMap }
+ = IS { inert_cans = emptyInertCans
+ , inert_cycle_breakers = []
+ , inert_famapp_cache = emptyFunEqs
+ , inert_solved_dicts = emptyDictMap }
{- Note [Solved dictionaries]
@@ -708,16 +668,14 @@ Result
data InertCans -- See Note [Detailed InertCans Invariants] for more
= IC { inert_eqs :: InertEqs
-- See Note [inert_eqs: the inert equalities]
- -- All CTyEqCans; index is the LHS tyvar
+ -- All CEqCans with a TyVarLHS; index is the LHS tyvar
-- Domain = skolems and untouchables; a touchable would be unified
- , inert_funeqs :: FunEqMap Ct
- -- All CFunEqCans; index is the whole family head type.
- -- All Nominal (that's an invariant of all CFunEqCans)
+ , inert_funeqs :: FunEqMap EqualCtList
+ -- All CEqCans with a TyFamLHS; index is the whole family head type.
-- LHS is fully rewritten (modulo eqCanRewrite constraints)
-- wrt inert_eqs
-- Can include all flavours, [G], [W], [WD], [D]
- -- See Note [Type family equations]
, inert_dicts :: DictMap Ct
-- Dictionaries only
@@ -739,16 +697,38 @@ data InertCans -- See Note [Detailed InertCans Invariants] for more
-- Irreducible predicates that cannot be made canonical,
-- and which don't interact with others (e.g. (c a))
-- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a])
-
- , inert_count :: Int
- -- Number of Wanted goals in
- -- inert_eqs, inert_dicts, inert_safehask, inert_irreds
- -- Does not include insolubles
- -- When non-zero, keep trying to solve
}
type InertEqs = DTyVarEnv EqualCtList
-type EqualCtList = [Ct] -- See Note [EqualCtList invariants]
+
+newtype EqualCtList = EqualCtList (NonEmpty Ct)
+ deriving newtype Outputable
+ -- See Note [EqualCtList invariants]
+
+unitEqualCtList :: Ct -> EqualCtList
+unitEqualCtList ct = EqualCtList (ct :| [])
+
+addToEqualCtList :: Ct -> EqualCtList -> EqualCtList
+-- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList,
+-- but not the others. See Note [EqualCtList invariants]
+addToEqualCtList ct (EqualCtList old_eqs)
+ | isWantedCt ct
+ , eq1 :| eqs <- old_eqs
+ = EqualCtList (eq1 :| ct : eqs)
+ | otherwise
+ = EqualCtList (ct `cons` old_eqs)
+
+filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList
+filterEqualCtList pred (EqualCtList cts)
+ = fmap EqualCtList (nonEmpty $ NE.filter pred cts)
+
+equalCtListToList :: EqualCtList -> [Ct]
+equalCtListToList (EqualCtList cts) = toList cts
+
+listToEqualCtList :: [Ct] -> Maybe EqualCtList
+-- NB: This does not maintain invariants other than having the EqualCtList be
+-- non-empty
+listToEqualCtList cts = EqualCtList <$> nonEmpty cts
{- Note [Detailed InertCans Invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -766,11 +746,11 @@ The InertCans represents a collection of constraints with the following properti
* Given family or dictionary constraints don't mention touchable
unification variables
- * Non-CTyEqCan constraints are fully rewritten with respect
- to the CTyEqCan equalities (modulo canRewrite of course;
+ * Non-CEqCan constraints are fully rewritten with respect
+ to the CEqCan equalities (modulo eqCanRewrite of course;
eg a wanted cannot rewrite a given)
- * CTyEqCan equalities: see Note [inert_eqs: the inert equalities]
+ * CEqCan equalities: see Note [inert_eqs: the inert equalities]
Also see documentation in Constraint.Ct for a list of invariants
Note [EqualCtList invariants]
@@ -787,42 +767,6 @@ From the fourth invariant it follows that the list is
The Wanteds can't rewrite anything which is why we put them last
-Note [Type family equations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Type-family equations, CFunEqCans, of form (ev : F tys ~ ty),
-live in three places
-
- * The work-list, of course
-
- * The inert_funeqs are un-solved but fully processed, and in
- the InertCans. They can be [G], [W], [WD], or [D].
-
- * The inert_flat_cache. This is used when flattening, to get maximal
- sharing. Everything in the inert_flat_cache is [G] or [WD]
-
- It contains lots of things that are still in the work-list.
- E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the
- work list. Then we flatten w1, dumping (w3: G a ~ f1) in the work
- list. Now if we flatten w2 before we get to w3, we still want to
- share that (G a).
- Because it contains work-list things, DO NOT use the flat cache to solve
- a top-level goal. Eg in the above example we don't want to solve w3
- using w3 itself!
-
-The CFunEqCan Ownership Invariant:
-
- * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv
- It "owns" that fsk/fmv, in the sense that:
- - reducing a [W/WD] CFunEqCan fills in the fmv
- - unflattening a [W/WD] CFunEqCan fills in the fmv
- (in both cases unless an occurs-check would result)
-
- * In contrast a [D] CFunEqCan does not "own" its fmv:
- - reducing a [D] CFunEqCan does not fill in the fmv;
- it just generates an equality
- - unflattening ignores [D] CFunEqCans altogether
-
-
Note [inert_eqs: the inert equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Definition [Can-rewrite relation]
@@ -837,25 +781,25 @@ Lemma. If f1 >= f then f1 >= f1
Proof. By property (R2), with f1=f2
Definition [Generalised substitution]
-A "generalised substitution" S is a set of triples (a -f-> t), where
- a is a type variable
+A "generalised substitution" S is a set of triples (t0 -f-> t), where
+ t0 is a type variable or an exactly-saturated type family application
+ (that is, t0 is a CanEqLHS)
t is a type
f is a flavour
such that
- (WF1) if (a -f1-> t1) in S
- (a -f2-> t2) in S
- then neither (f1 >= f2) nor (f2 >= f1) hold
- (WF2) if (a -f-> t) is in S, then t /= a
+ (WF1) if (t0 -f1-> t1) in S
+ (t0' -f2-> t2) in S
+ then either not (f1 >= f2) or t0 does not appear within t0'
+ (WF2) if (t0 -f-> t) is in S, then t /= t0
Definition [Applying a generalised substitution]
If S is a generalised substitution
- S(f,a) = t, if (a -fs-> t) in S, and fs >= f
- = a, otherwise
-Application extends naturally to types S(f,t), modulo roles.
-See Note [Flavours with roles].
+ S(f,t0) = t, if (t0 -fs-> t) in S, and fs >= f
+ = apply S to components of t0, otherwise
+See also Note [Flavours with roles].
-Theorem: S(f,a) is well defined as a function.
-Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S,
+Theorem: S(f,t0) is well defined as a function.
+Proof: Suppose (t0 -f1-> t1) and (t0 -f2-> t2) are both in S,
and f1 >= f and f2 >= f
Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)
@@ -874,46 +818,47 @@ applying S(f,_) to t.
----------------------------------------------------------------
Our main invariant:
- the inert CTyEqCans should be an inert generalised substitution
+ the inert CEqCans should be an inert generalised substitution
----------------------------------------------------------------
Note that inertness is not the same as idempotence. To apply S to a
-type, you may have to apply it recursive. But inertness does
+type, you may have to apply it recursively. But inertness does
guarantee that this recursive use will terminate.
Note [Extending the inert equalities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Main Theorem [Stability under extension]
Suppose we have a "work item"
- a -fw-> t
+ t0 -fw-> t
and an inert generalised substitution S,
- THEN the extended substitution T = S+(a -fw-> t)
+ THEN the extended substitution T = S+(t0 -fw-> t)
is an inert generalised substitution
PROVIDED
- (T1) S(fw,a) = a -- LHS of work-item is a fixpoint of S(fw,_)
- (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_)
- (T3) a not in t -- No occurs check in the work item
+ (T1) S(fw,t0) = t0 -- LHS of work-item is a fixpoint of S(fw,_)
+ (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_)
+ (T3) t0 not in t -- No occurs check in the work item
- AND, for every (b -fs-> s) in S:
+ AND, for every (t0' -fs-> s) in S:
(K0) not (fw >= fs)
Reason: suppose we kick out (a -fs-> s),
- and add (a -fw-> t) to the inert set.
+ and add (t0 -fw-> t) to the inert set.
The latter can't rewrite the former,
so the kick-out achieved nothing
- OR { (K1) not (a = b)
+ OR { (K1) t0 is not rewritable in t0'. That is, t0 does not occur
+ in t0' (except perhaps in a cast or coercion).
Reason: if fw >= fs, WF1 says we can't have both
- a -fw-> t and a -fs-> s
+ t0 -fw-> t and F t0 -fs-> s
AND (K2): guarantees inertness of the new substitution
{ (K2a) not (fs >= fs)
OR (K2b) fs >= fw
- OR (K2d) a not in s }
+ OR (K2d) t0 not in s }
AND (K3) See Note [K3: completeness of solving]
- { (K3a) If the role of fs is nominal: s /= a
+ { (K3a) If the role of fs is nominal: s /= t0
(K3b) If the role of fs is representational:
- s is not of form (a t1 .. tn) } }
+ s is not of form (t0 t1 .. tn) } }
Conditions (T1-T3) are established by the canonicaliser
@@ -924,8 +869,8 @@ The idea is that
with S(fw,_).
* T3 is guaranteed by a simple occurs-check on the work item.
- This is done during canonicalisation, in canEqTyVar; invariant
- (TyEq:OC) of CTyEqCan.
+ This is done during canonicalisation, in canEqCanLHSFinish; invariant
+ (TyEq:OC) of CEqCan.
* (K1-3) are the "kick-out" criteria. (As stated, they are really the
"keep" criteria.) If the current inert S contains a triple that does
@@ -950,10 +895,10 @@ The idea is that
It's used to avoid even looking for constraint to kick out.
* Lemma (L1): The conditions of the Main Theorem imply that there is no
- (a -fs-> t) in S, s.t. (fs >= fw).
+ (t0 -fs-> t) in S, s.t. (fs >= fw).
Proof. Suppose the contrary (fs >= fw). Then because of (T1),
- S(fw,a)=a. But since fs>=fw, S(fw,a) = s, hence s=a. But now we
- have (a -fs-> a) in S, which contradicts (WF2).
+ S(fw,t0)=t0. But since fs>=fw, S(fw,t0) = s, hence s=t0. But now we
+ have (t0 -fs-> t0) in S, which contradicts (WF2).
* The extended substitution satisfies (WF1) and (WF2)
- (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).
@@ -1044,7 +989,7 @@ now reduced to reflexivity.
The solution here is to kick out representational inerts whenever the
tyvar of a work item is "exposed", where exposed means being at the
head of the top-level application chain (a t1 .. tn). See
-TcType.isTyVarHead. This is encoded in (K3b).
+is_can_eq_lhs_head. This is encoded in (K3b).
Beware: if we make this test succeed too often, we kick out too much,
and the solver might loop. Consider (#14363)
@@ -1082,14 +1027,14 @@ instance Outputable InertCans where
ppr (IC { inert_eqs = eqs
, inert_funeqs = funeqs, inert_dicts = dicts
, inert_safehask = safehask, inert_irreds = irreds
- , inert_insts = insts
- , inert_count = count })
+ , inert_insts = insts })
+
= braces $ vcat
[ ppUnless (isEmptyDVarEnv eqs) $
text "Equalities:"
- <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs)
+ <+> pprCts (foldDVarEnv folder emptyCts eqs)
, ppUnless (isEmptyTcAppMap funeqs) $
- text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs)
+ text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)
, ppUnless (isEmptyTcAppMap dicts) $
text "Dictionaries =" <+> pprCts (dictsToBag dicts)
, ppUnless (isEmptyTcAppMap safehask) $
@@ -1098,8 +1043,9 @@ instance Outputable InertCans where
text "Irreds =" <+> pprCts irreds
, ppUnless (null insts) $
text "Given instances =" <+> vcat (map ppr insts)
- , text "Unsolved goals =" <+> int count
]
+ where
+ folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest
{- *********************************************************************
* *
@@ -1115,21 +1061,13 @@ solving. Here's a classic example (indexed-types/should_fail/T4093a)
Ambiguity check for f: (Foo e ~ Maybe e) => Foo e
- We get [G] Foo e ~ Maybe e
- [W] Foo e ~ Foo ee -- ee is a unification variable
- [W] Foo ee ~ Maybe ee
+ We get [G] Foo e ~ Maybe e (CEqCan)
+ [W] Foo ee ~ Foo e (CEqCan) -- ee is a unification variable
+ [W] Foo ee ~ Maybe ee (CEqCan)
- Flatten: [G] Foo e ~ fsk
- [G] fsk ~ Maybe e -- (A)
+ The first Wanted gets rewritten to
- [W] Foo ee ~ fmv
- [W] fmv ~ fsk -- (B) From Foo e ~ Foo ee
- [W] fmv ~ Maybe ee
-
- --> rewrite (B) with (A)
- [W] Foo ee ~ fmv
- [W] fmv ~ Maybe e
- [W] fmv ~ Maybe ee
+ [W] Foo ee ~ Maybe e
But now we appear to be stuck, since we don't rewrite Wanteds with
Wanteds. This is silly because we can see that ee := e is the
@@ -1162,20 +1100,18 @@ More specifically, here's how it works (Oct 16):
putting the latter into the work list (see maybeEmitShadow).
In the example above, we get to the point where we are stuck:
- [WD] Foo ee ~ fmv
- [WD] fmv ~ Maybe e
- [WD] fmv ~ Maybe ee
+ [WD] Foo ee ~ Foo e
+ [WD] Foo ee ~ Maybe ee
-But now when [WD] fmv ~ Maybe ee is about to be added, we'll
-split it into [W] and [D], since the inert [WD] fmv ~ Maybe e
+But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll
+split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e
can rewrite it. Then:
- work item: [D] fmv ~ Maybe ee
- inert: [W] fmv ~ Maybe ee
- [WD] fmv ~ Maybe e -- (C)
- [WD] Foo ee ~ fmv
+ work item: [D] Foo ee ~ Maybe ee
+ inert: [W] Foo ee ~ Maybe ee
+ [WD] Foo ee ~ Maybe e
See Note [Splitting WD constraints]. Now the work item is rewritten
-by (C) and we soon get ee := e.
+by the [WD] and we soon get ee := e.
Additional notes:
@@ -1189,15 +1125,14 @@ Additional notes:
* We also get Derived equalities from functional dependencies
and type-function injectivity; see calls to unifyDerived.
- * This splitting business applies to CFunEqCans too; and then
- we do apply type-function reductions to the [D] CFunEqCan.
- See Note [Reduction for Derived CFunEqCans]
-
* It's worth having [WD] rather than just [W] and [D] because
* efficiency: silly to process the same thing twice
- * inert_funeqs, inert_dicts is a finite map keyed by
+ * inert_dicts is a finite map keyed by
the type; it's inconvenient for it to map to TWO constraints
+Another example requiring Deriveds is in
+Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical.
+
Note [Splitting WD constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are about to add a [WD] constraint to the inert set; and we
@@ -1205,7 +1140,7 @@ know that the inert set has fully rewritten it. Should we split
it into [W] and [D], and put the [D] in the work list for further
work?
-* CDictCan (C tys) or CFunEqCan (F tys ~ fsk):
+* CDictCan (C tys):
Yes if the inert set could rewrite tys to make the class constraint,
or type family, fire. That is, yes if the inert_eqs intersects
with the free vars of tys. For this test we use
@@ -1213,8 +1148,8 @@ work?
because rewriting the casts or coercions won't make the thing fire
more often.
-* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'.
- We need to check both 'a' and 'ty' against the inert set:
+* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'.
+ We need to check both 'lhs' and 'ty' against the inert set:
- Inert set contains [D] a ~ ty2
Then we want to put [D] a ~ ty in the worklist, so we'll
get [D] ty ~ ty2 with consequent good things
@@ -1245,22 +1180,17 @@ scenario:
work item: [WD] a ~ beta
-This is heterogeneous, so we try flattening the kinds.
-
- co :: F v ~ fmv
- [WD] (a |> co) ~ beta
-
-This is still hetero, so we emit a kind equality and make the work item an
+This is heterogeneous, so we emit a kind equality and make the work item an
inert Irred.
- work item: [D] fmv ~ alpha
+ work item: [D] F v ~ alpha
inert: [WD] (a |> co) ~ beta (CIrredCan)
Can't make progress on the work item. Add to inert set. This kicks out the
old inert, because a [D] can rewrite a [WD].
work item: [WD] (a |> co) ~ beta
- inert: [D] fmv ~ alpha (CTyEqCan)
+ inert: [D] F v ~ alpha (CEqCan)
Can't make progress on this work item either (although GHC tries by
decomposing the cast and reflattening... but that doesn't make a difference),
@@ -1268,25 +1198,24 @@ which is still hetero. Emit a new kind equality and add to inert set. But,
critically, we split the Irred.
work list:
- [D] fmv ~ alpha (CTyEqCan)
+ [D] F v ~ alpha (CEqCan)
[D] (a |> co) ~ beta (CIrred) -- this one was split off
inert:
[W] (a |> co) ~ beta
- [D] fmv ~ alpha
+ [D] F v ~ alpha
We quickly solve the first work item, as it's the same as an inert.
work item: [D] (a |> co) ~ beta
inert:
[W] (a |> co) ~ beta
- [D] fmv ~ alpha
+ [D] F v ~ alpha
We decompose the cast, yielding
[D] a ~ beta
-We then flatten the kinds. The lhs kind is F v, which flattens to fmv which
-then rewrites to alpha.
+We then flatten the kinds. The lhs kind is F v, which flattens to alpha.
co' :: F v ~ alpha
[D] (a |> co') ~ beta
@@ -1301,35 +1230,6 @@ If we don't split the Irreds, we loop. This is all dangerously subtle.
This is triggered by test case typecheck/should_compile/SplitWD.
-Note [Examples of how Derived shadows helps completeness]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticket #10009, a very nasty example:
-
- f :: (UnF (F b) ~ b) => F b -> ()
-
- g :: forall a. (UnF (F a) ~ a) => a -> ()
- g _ = f (undefined :: F a)
-
- For g we get [G] UnF (F a) ~ a
- [WD] UnF (F beta) ~ beta
- [WD] F a ~ F beta
- Flatten:
- [G] g1: F a ~ fsk1 fsk1 := F a
- [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1
- [G] g3: fsk2 ~ a
-
- [WD] w1: F beta ~ fmv1
- [WD] w2: UnF fmv1 ~ fmv2
- [WD] w3: fmv2 ~ beta
- [WD] w4: fmv1 ~ fsk1 -- From F a ~ F beta using flat-cache
- -- and re-orient to put meta-var on left
-
-Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2
-React that with g2: [D] d2: fmv2 ~ fsk2
-React that with w3: [D] beta ~ fsk2
- and g3: [D] beta ~ a -- Hooray beta := a
-And that is enough to solve everything
-
Note [Add derived shadows only for Wanteds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We only add shadows for Wanted constraints. That is, we have
@@ -1423,7 +1323,7 @@ maybeEmitShadow ics ct
| let ev = ctEvidence ct
, CtWanted { ctev_pred = pred, ctev_loc = loc
, ctev_nosh = WDeriv } <- ev
- , shouldSplitWD (inert_eqs ics) ct
+ , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct
= do { traceTcS "Emit derived shadow" (ppr ct)
; let derived_ev = CtDerived { ctev_pred = pred
, ctev_loc = loc }
@@ -1442,45 +1342,52 @@ maybeEmitShadow ics ct
| otherwise
= return ct
-shouldSplitWD :: InertEqs -> Ct -> Bool
+shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool
-- Precondition: 'ct' is [WD], and is inert
-- True <=> we should split ct ito [W] and [D] because
-- the inert_eqs can make progress on the [D]
-- See Note [Splitting WD constraints]
-shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys })
- = should_split_match_args inert_eqs tys
- -- We don't need to split if the tv is the RHS fsk
-
-shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })
- = should_split_match_args inert_eqs tys
+shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys })
+ = should_split_match_args inert_eqs fun_eqs tys
-- NB True: ignore coercions
-- See Note [Splitting WD constraints]
-shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty
- , cc_eq_rel = eq_rel })
+shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty
+ , cc_eq_rel = eq_rel })
= tv `elemDVarEnv` inert_eqs
- || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty
+ || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty
-- NB False: do not ignore casts and coercions
-- See Note [Splitting WD constraints]
-shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })
- = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)
+shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })
+ = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)
+ (ctEvPred ev)
+
+shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev })
+ = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs)
+ (canRewriteTyFam fun_eqs) (ctEvPred ev)
-shouldSplitWD _ _ = False -- No point in splitting otherwise
+shouldSplitWD _ _ _ = False -- No point in splitting otherwise
-should_split_match_args :: InertEqs -> [TcType] -> Bool
--- True if the inert_eqs can rewrite anything in the argument
--- types, ignoring casts and coercions
-should_split_match_args inert_eqs tys
- = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys
- -- NB True: ignore casts coercions
+should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool
+-- True if the inert_eqs can rewrite anything in the argument types
+should_split_match_args inert_eqs fun_eqs tys
+ = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys
-- See Note [Splitting WD constraints]
canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool
canRewriteTv inert_eqs eq_rel tv
- | Just (ct : _) <- lookupDVarEnv inert_eqs tv
- , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct
+ | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv
+ , CEqCan { cc_eq_rel = eq_rel1 } <- ct
+ = eq_rel1 `eqCanRewrite` eq_rel
+ | otherwise
+ = False
+
+canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool
+canRewriteTyFam fun_eqs eq_rel tf args
+ | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args
+ , CEqCan { cc_eq_rel = eq_rel1 } <- ct
= eq_rel1 `eqCanRewrite` eq_rel
| otherwise
= False
@@ -1499,32 +1406,46 @@ isImprovable _ = True
addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs
addTyEq old_eqs tv ct
- = extendDVarEnv_C add_eq old_eqs tv [ct]
+ = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct)
where
- add_eq old_eqs _
- | isWantedCt ct
- , (eq1 : eqs) <- old_eqs
- = eq1 : ct : eqs
- | otherwise
- = ct : old_eqs
+ add_eq old_eqs _ = addToEqualCtList ct old_eqs
+
+addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct
+ -> FunEqMap EqualCtList
+addCanFunEq old_eqs fun_tc fun_args ct
+ = alterTcApp old_eqs fun_tc fun_args upd
+ where
+ upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list
+ upd Nothing = Just $ unitEqualCtList ct
foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b
foldTyEqs k eqs z
- = foldDVarEnv (\cts z -> foldr k z cts) z eqs
-
-findTyEqs :: InertCans -> TyVar -> EqualCtList
-findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` []
+ = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs
+
+findTyEqs :: InertCans -> TyVar -> [Ct]
+findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $
+ lookupDVarEnv (inert_eqs icans) tv)
+
+delEq :: InertCans -> CanEqLHS -> TcType -> InertCans
+delEq ic lhs rhs = case lhs of
+ TyVarLHS tv
+ -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }
+ TyFamLHS tf args
+ -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }
+ where
+ isThisOne :: Ct -> Bool
+ isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1
+ isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)
-delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs
-delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv
- where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1
- isThisOne _ = False
+ upd :: Maybe EqualCtList -> Maybe EqualCtList
+ upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list
+ upd Nothing = Nothing
-lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType
-lookupInertTyVar ieqs tv
- = case lookupDVarEnv ieqs tv of
- Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs
- _ -> Nothing
+findEq :: InertCans -> CanEqLHS -> [Ct]
+findEq icans (TyVarLHS tv) = findTyEqs icans tv
+findEq icans (TyFamLHS fun_tc fun_args)
+ = maybe [] id (fmap @Maybe equalCtListToList $
+ findFunEq (inert_funeqs icans) fun_tc fun_args)
{- *********************************************************************
* *
@@ -1590,33 +1511,13 @@ When adding an equality to the inerts:
* Note that unifying a:=ty, is like adding [G] a~ty; just use
kickOutRewritable with Nominal, Given. See kickOutAfterUnification.
-
-Note [Kicking out CFunEqCan for fundeps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider:
- New: [D] fmv1 ~ fmv2
- Inert: [W] F alpha ~ fmv1
- [W] F beta ~ fmv2
-
-where F is injective. The new (derived) equality certainly can't
-rewrite the inerts. But we *must* kick out the first one, to get:
-
- New: [W] F alpha ~ fmv1
- Inert: [W] F beta ~ fmv2
- [D] fmv1 ~ fmv2
-
-and now improvement will discover [D] alpha ~ beta. This is important;
-eg in #9587.
-
-So in kickOutRewritable we look at all the tyvars of the
-CFunEqCan, including the fsk.
-}
-addInertCan :: Ct -> TcS () -- Constraints *other than* equalities
+addInertCan :: Ct -> TcS ()
-- Precondition: item /is/ canonical
-- See Note [Adding an equality to the InertCans]
addInertCan ct
- = do { traceTcS "insertInertCan {" $
+ = do { traceTcS "addInertCan {" $
text "Trying to insert new inert item:" <+> ppr ct
; ics <- getInertCans
@@ -1627,58 +1528,59 @@ addInertCan ct
; traceTcS "addInertCan }" $ empty }
maybeKickOut :: InertCans -> Ct -> TcS InertCans
--- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan
+-- For a CEqCan, kick out any inert that can be rewritten by the CEqCan
maybeKickOut ics ct
- | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
- = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics
+ | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
+ = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics
; return ics' }
| otherwise
= return ics
add_item :: InertCans -> Ct -> InertCans
-add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
- = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }
+add_item ics item@(CEqCan { cc_lhs = TyFamLHS tc tys })
+ = ics { inert_funeqs = addCanFunEq (inert_funeqs ics) tc tys item }
-add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev })
- = ics { inert_eqs = addTyEq (inert_eqs ics) tv item
- , inert_count = bumpUnsolvedCount ev (inert_count ics) }
+add_item ics item@(CEqCan { cc_lhs = TyVarLHS tv })
+ = ics { inert_eqs = addTyEq (inert_eqs ics) tv item }
-add_item ics@(IC { inert_irreds = irreds, inert_count = count })
- item@(CIrredCan { cc_ev = ev, cc_status = status })
- = ics { inert_irreds = irreds `Bag.snocBag` item
- , inert_count = case status of
- InsolubleCIS -> count
- _ -> bumpUnsolvedCount ev count }
- -- inert_count does not include insolubles
+add_item ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})
+ = ics { inert_irreds = irreds `Bag.snocBag` item }
-
-add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
- = ics { inert_dicts = addDict (inert_dicts ics) cls tys item
- , inert_count = bumpUnsolvedCount ev (inert_count ics) }
+add_item ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
+ = ics { inert_dicts = addDict (inert_dicts ics) cls tys item }
add_item _ item
= pprPanic "upd_inert set: can't happen! Inserting " $
ppr item -- Can't be CNonCanonical because they only land in inert_irreds
-bumpUnsolvedCount :: CtEvidence -> Int -> Int
-bumpUnsolvedCount ev n | isWanted ev = n+1
- | otherwise = n
-
-
-----------------------------------------
kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that
-- is being added to the inert set
- -> TcTyVar -- The new equality is tv ~ ty
- -> InertCans
- -> TcS (Int, InertCans)
-kickOutRewritable new_fr new_tv ics
- = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics
+ -> CanEqLHS -- The new equality is lhs ~ ty
+ -> InertCans
+ -> TcS (Int, InertCans)
+kickOutRewritable new_fr new_lhs ics
+ = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_lhs ics
n_kicked = workListSize kicked_out
; unless (n_kicked == 0) $
do { updWorkListTcS (appendWorkList kicked_out)
+
+ -- The famapp-cache contains Given evidence from the inert set.
+ -- If we're kicking out Givens, we need to remove this evidence
+ -- from the cache, too.
+ ; let kicked_given_ev_vars =
+ [ ev_var | ct <- wl_eqs kicked_out
+ , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]
+ ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&
+ -- if this isn't true, no use looking through the constraints
+ not (null kicked_given_ev_vars)) $
+ do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"
+ (ppr kicked_given_ev_vars)
+ ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }
+
; csTraceTcS $
- hang (text "Kick out, tv =" <+> ppr new_tv)
+ hang (text "Kick out, lhs =" <+> ppr new_lhs)
2 (vcat [ text "n-kicked =" <+> int n_kicked
, text "kicked_out =" <+> ppr kicked_out
, text "Residual inerts =" <+> ppr ics' ]) }
@@ -1687,18 +1589,17 @@ kickOutRewritable new_fr new_tv ics
kick_out_rewritable :: CtFlavourRole -- Flavour/role of the equality that
-- is being added to the inert set
- -> TcTyVar -- The new equality is tv ~ ty
+ -> CanEqLHS -- The new equality is lhs ~ ty
-> InertCans
-> (WorkList, InertCans)
-- See Note [kickOutRewritable]
-kick_out_rewritable new_fr new_tv
+kick_out_rewritable new_fr new_lhs
ics@(IC { inert_eqs = tv_eqs
, inert_dicts = dictmap
, inert_safehask = safehask
, inert_funeqs = funeqmap
, inert_irreds = irreds
- , inert_insts = old_insts
- , inert_count = n })
+ , inert_insts = old_insts })
| not (new_fr `eqMayRewriteFR` new_fr)
= (emptyWorkList, ics)
-- If new_fr can't rewrite itself, it can't rewrite
@@ -1714,25 +1615,24 @@ kick_out_rewritable new_fr new_tv
, inert_safehask = safehask -- ??
, inert_funeqs = feqs_in
, inert_irreds = irs_in
- , inert_insts = insts_in
- , inert_count = n - workListWantedCount kicked_out }
+ , inert_insts = insts_in }
kicked_out :: WorkList
-- NB: use extendWorkList to ensure that kicked-out equalities get priority
-- See Note [Prioritise equalities] (Kick-out).
-- The irreds may include non-canonical (hetero-kinded) equality
- -- constraints, which perhaps may have become soluble after new_tv
+ -- constraints, which perhaps may have become soluble after new_lhs
-- is substituted; ditto the dictionaries, which may include (a~b)
-- or (a~~b) constraints.
kicked_out = foldr extendWorkListCt
- (emptyWorkList { wl_eqs = tv_eqs_out
- , wl_funeqs = feqs_out })
+ (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })
((dicts_out `andCts` irs_out)
`extendCtsList` insts_out)
- (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs
- (feqs_out, feqs_in) = partitionFunEqs kick_out_ct funeqmap
- -- See Note [Kicking out CFunEqCan for fundeps]
+ (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs)
+ ([], emptyDVarEnv) tv_eqs
+ (feqs_out, feqs_in) = foldFunEqs (kick_out_eqs extend_fun_eqs)
+ funeqmap ([], emptyFunEqs)
(dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap
(irs_out, irs_in) = partitionBag kick_out_ct irreds
-- Kick out even insolubles: See Note [Rewrite insolubles]
@@ -1757,46 +1657,80 @@ kick_out_rewritable new_fr new_tv
(_, new_role) = new_fr
+ fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool
+ fr_tv_can_rewrite_ty new_tv role ty
+ = anyRewritableTyVar True role can_rewrite ty
+ -- True: ignore casts and coercions
+ where
+ can_rewrite :: EqRel -> TyVar -> Bool
+ can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv
+
+ fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool
+ fr_tf_can_rewrite_ty new_tf new_tf_args role ty
+ = anyRewritableTyFamApp role can_rewrite ty
+ where
+ can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool
+ can_rewrite old_role old_tf old_tf_args
+ = new_role `eqCanRewrite` old_role &&
+ tcEqTyConApps new_tf new_tf_args old_tf old_tf_args
+ -- it's possible for old_tf_args to have too many. This is fine;
+ -- we'll only check what we need to.
+
+ {-# INLINE fr_can_rewrite_ty #-} -- perform the check here only once
fr_can_rewrite_ty :: EqRel -> Type -> Bool
- fr_can_rewrite_ty role ty = anyRewritableTyVar False role
- fr_can_rewrite_tv ty
- fr_can_rewrite_tv :: EqRel -> TyVar -> Bool
- fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role
- && tv == new_tv
+ fr_can_rewrite_ty = case new_lhs of
+ TyVarLHS new_tv -> fr_tv_can_rewrite_ty new_tv
+ TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args
fr_may_rewrite :: CtFlavourRole -> Bool
fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs
-- Can the new item rewrite the inert item?
+ {-# INLINE kick_out_ct #-} -- perform case on new_lhs here only once
kick_out_ct :: Ct -> Bool
- -- Kick it out if the new CTyEqCan can rewrite the inert one
+ -- Kick it out if the new CEqCan can rewrite the inert one
-- See Note [kickOutRewritable]
- kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct
- = fr_may_rewrite fs
- && fr_can_rewrite_ty role (ctPred ct)
- -- False: ignore casts and coercions
- -- NB: this includes the fsk of a CFunEqCan. It can't
- -- actually be rewritten, but we need to kick it out
- -- so we get to take advantage of injectivity
- -- See Note [Kicking out CFunEqCan for fundeps]
-
- kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList)
- -> ([Ct], DTyVarEnv EqualCtList)
- kick_out_eqs eqs (acc_out, acc_in)
- = (eqs_out ++ acc_out, case eqs_in of
- [] -> acc_in
- (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)
+ kick_out_ct = case new_lhs of
+ TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in
+ fr_may_rewrite fs
+ && fr_tv_can_rewrite_ty new_tv role (ctPred ct)
+ TyFamLHS new_tf new_tf_args
+ -> \ct -> let fs@(_, role) = ctFlavourRole ct in
+ fr_may_rewrite fs
+ && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)
+
+ extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs
+ extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts
+ extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other)
+
+ extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList
+ -> FunEqMap EqualCtList
+ extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts
+ = insertTcApp eqs fam_tc fam_args cts
+ extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other)
+
+ kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container)
+ -> EqualCtList -> ([Ct], container)
+ -> ([Ct], container)
+ kick_out_eqs extend eqs (acc_out, acc_in)
+ = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of
+ Nothing -> acc_in
+ Just eqs_in_ecl@(EqualCtList (eq1 :| _))
+ -> extend acc_in (cc_lhs eq1) eqs_in_ecl)
where
- (eqs_out, eqs_in) = partition kick_out_eq eqs
+ (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs)
-- Implements criteria K1-K3 in Note [Extending the inert equalities]
- kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty
- , cc_ev = ev, cc_eq_rel = eq_rel })
+ kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty
+ , cc_ev = ev, cc_eq_rel = eq_rel })
| not (fr_may_rewrite fs)
= False -- Keep it in the inert set if the new thing can't rewrite it
-- Below here (fr_may_rewrite fs) is True
- | tv == new_tv = True -- (K1)
+ | fr_can_rewrite_ty eq_rel (canEqLHSType lhs) = True -- (K1)
+ -- The above check redundantly checks the role & flavour,
+ -- but it's very convenient
+
| kick_out_for_inertness = True
| kick_out_for_completeness = True
| otherwise = False
@@ -1809,27 +1743,48 @@ kick_out_rewritable new_fr new_tv
&& fr_can_rewrite_ty eq_rel rhs_ty -- (K2d)
-- (K2c) is guaranteed by the first guard of keep_eq
- kick_out_for_completeness
+ kick_out_for_completeness -- (K3) and Note [K3: completeness of solving]
= case eq_rel of
- NomEq -> rhs_ty `eqType` mkTyVarTy new_tv
- ReprEq -> isTyVarHead new_tv rhs_ty
+ NomEq -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)
+ ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty -- (K3b)
kick_out_eq ct = pprPanic "keep_eq" (ppr ct)
+ is_can_eq_lhs_head (TyVarLHS tv) = go
+ where
+ go (Rep.TyVarTy tv') = tv == tv'
+ go (Rep.AppTy fun _) = go fun
+ go (Rep.CastTy ty _) = go ty
+ go (Rep.TyConApp {}) = False
+ go (Rep.LitTy {}) = False
+ go (Rep.ForAllTy {}) = False
+ go (Rep.FunTy {}) = False
+ go (Rep.CoercionTy {}) = False
+ is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go
+ where
+ go (Rep.TyVarTy {}) = False
+ go (Rep.AppTy {}) = False -- no TyConApp to the left of an AppTy
+ go (Rep.CastTy ty _) = go ty
+ go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args
+ go (Rep.LitTy {}) = False
+ go (Rep.ForAllTy {}) = False
+ go (Rep.FunTy {}) = False
+ go (Rep.CoercionTy {}) = False
+
kickOutAfterUnification :: TcTyVar -> TcS Int
kickOutAfterUnification new_tv
= do { ics <- getInertCans
; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)
- new_tv ics
+ (TyVarLHS new_tv) ics
-- Given because the tv := xi is given; NomEq because
-- only nominal equalities are solved by unification
; setInertCans ics2
; return n_kicked }
--- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical"
-kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()
-kickOutAfterFillingCoercionHole hole
+-- See Wrinkle (2a) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical
+kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS ()
+kickOutAfterFillingCoercionHole hole filled_co
= do { ics <- getInertCans
; let (kicked_out, ics') = kick_out ics
n_kicked = workListSize kicked_out
@@ -1844,44 +1799,50 @@ kickOutAfterFillingCoercionHole hole
; setInertCans ics' }
where
+ holes_of_co = coercionHolesOfCo filled_co
+
kick_out :: InertCans -> (WorkList, InertCans)
kick_out ics@(IC { inert_irreds = irreds })
- = let (to_kick, to_keep) = partitionBag kick_ct irreds
+ = let (to_kick, to_keep) = partitionBagWith kick_ct irreds
kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList
ics' = ics { inert_irreds = to_keep }
in
(kicked_out, ics')
- kick_ct :: Ct -> Bool
- -- This is not particularly efficient. Ways to do better:
- -- 1) Have a custom function that looks for a coercion hole and returns a Bool
- -- 2) Keep co-hole-blocked constraints in a separate part of the inert set,
- -- keyed by their co-hole. (Is it possible for more than one co-hole to be
- -- in a constraint? I doubt it.)
- kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS })
- = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev)
- kick_ct _other = False
+ kick_ct :: Ct -> Either Ct Ct
+ -- Left: kick out; Right: keep. But even if we keep, we may need
+ -- to update the set of blocking holes
+ kick_ct ct@(CIrredCan { cc_status = BlockedCIS holes })
+ | hole `elementOfUniqSet` holes
+ = let new_holes = holes `delOneFromUniqSet` hole
+ `unionUniqSets` holes_of_co
+ updated_ct = ct { cc_status = BlockedCIS new_holes }
+ in
+ if isEmptyUniqSet new_holes
+ then Left updated_ct
+ else Right updated_ct
+ kick_ct other = Right other
{- Note [kickOutRewritable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
See also Note [inert_eqs: the inert equalities].
-When we add a new inert equality (a ~N ty) to the inert set,
+When we add a new inert equality (lhs ~N ty) to the inert set,
we must kick out any inert items that could be rewritten by the
new equality, to maintain the inert-set invariants.
- We want to kick out an existing inert constraint if
a) the new constraint can rewrite the inert one
- b) 'a' is free in the inert constraint (so that it *will*)
+ b) 'lhs' is free in the inert constraint (so that it *will*)
rewrite it if we kick it out.
- For (b) we use tyCoVarsOfCt, which returns the type variables /and
- the kind variables/ that are directly visible in the type. Hence
+ For (b) we use anyRewritableCanLHS, which examines the types /and
+ kinds/ that are directly visible in the type. Hence
we will have exposed all the rewriting we care about to make the
most precise kinds visible for matching classes etc. No need to
kick out constraints that mention type variables whose kinds
- contain this variable!
+ contain this LHS!
- A Derived equality can kick out [D] constraints in inert_eqs,
inert_dicts, inert_irreds etc.
@@ -1999,11 +1960,6 @@ updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()
updInertSafehask upd_fn
= updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }
-updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
--- Modify the inert set with the supplied function
-updInertFunEqs upd_fn
- = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) }
-
updInertIrreds :: (Cts -> Cts) -> TcS ()
-- Modify the inert set with the supplied function
updInertIrreds upd_fn
@@ -2019,13 +1975,13 @@ getInertInsols = do { inert <- getInertCans
; return (filterBag insolubleEqCt (inert_irreds inert)) }
getInertGivens :: TcS [Ct]
--- Returns the Given constraints in the inert set,
--- with type functions *not* unflattened
+-- Returns the Given constraints in the inert set
getInertGivens
= do { inerts <- getInertCans
; let all_cts = foldDicts (:) (inert_dicts inerts)
- $ foldFunEqs (:) (inert_funeqs inerts)
- $ concat (dVarEnvElts (inert_eqs inerts))
+ $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out)
+ (inert_funeqs inerts)
+ $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts))
; return (filter isGivenCt all_cts) }
getPendingGivenScs :: TcS [Ct]
@@ -2077,9 +2033,7 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
-- Note [The superclass story] in GHC.Tc.Solver.Canonical
getUnsolvedInerts :: TcS ( Bag Implication
- , Cts -- Tyvar eqs: a ~ ty
- , Cts -- Fun eqs: F a ~ ty
- , Cts ) -- All others
+ , Cts ) -- All simple constraints
-- Return all the unsolved [Wanted] or [Derived] constraints
--
-- Post-condition: the returned simple constraints are all fully zonked
@@ -2093,7 +2047,7 @@ getUnsolvedInerts
} <- getInertCans
; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts
- unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts
+ unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts
unsolved_irreds = Bag.filterBag is_unsolved irreds
unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts
unsolved_others = unsolved_irreds `unionBags` unsolved_dicts
@@ -2106,78 +2060,80 @@ getUnsolvedInerts
, text "others =" <+> ppr unsolved_others
, text "implics =" <+> ppr implics ]
- ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) }
+ ; return ( implics, unsolved_tv_eqs `unionBags`
+ unsolved_fun_eqs `unionBags`
+ unsolved_others) }
where
add_if_unsolved :: Ct -> Cts -> Cts
add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts
| otherwise = cts
+ add_if_unsolveds :: EqualCtList -> Cts -> Cts
+ add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts
+ (equalCtListToList new_cts)
+
is_unsolved ct = not (isGivenCt ct) -- Wanted or Derived
- -- For CFunEqCans we ignore the Derived ones, and keep
- -- only the Wanteds for flattening. The Derived ones
- -- share a unification variable with the corresponding
- -- Wanted, so we definitely don't want to participate
- -- in unflattening
- -- See Note [Type family equations]
- add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts
- | otherwise = cts
-
-isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool
--- True if (a ~N ty) is in the inert set, in either Given or Wanted
-isInInertEqs eqs tv rhs
- = case lookupDVarEnv eqs tv of
- Nothing -> False
- Just cts -> any (same_pred rhs) cts
- where
- same_pred rhs ct
- | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct
- , NomEq <- eq_rel
- , rhs `eqType` rhs2 = True
- | otherwise = False
-
-getNoGivenEqs :: TcLevel -- TcLevel of this implication
- -> [TcTyVar] -- Skolems of this implication
- -> TcS ( Bool -- True <=> definitely no residual given equalities
- , Cts ) -- Insoluble equalities arising from givens
+getHasGivenEqs :: TcLevel -- TcLevel of this implication
+ -> TcS ( HasGivenEqs -- are there Given equalities?
+ , Cts ) -- Insoluble equalities arising from givens
-- See Note [When does an implication have given equalities?]
-getNoGivenEqs tclvl skol_tvs
- = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
+getHasGivenEqs tclvl
+ = do { inerts@(IC { inert_eqs = ieqs, inert_funeqs = funeqs, inert_irreds = irreds })
<- getInertCans
- ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds
- || anyDVarEnv eqs_given_here ieqs
+ ; let has_given_eqs = foldMap check_local_given_ct irreds
+ S.<> foldMap (lift_equal_ct_list check_local_given_tv_eq) ieqs
+ S.<> foldMapFunEqs (lift_equal_ct_list check_local_given_ct) funeqs
insols = filterBag insolubleEqCt irreds
-- Specifically includes ones that originated in some
-- outer context but were refined to an insoluble by
-- a local equality; so do /not/ add ct_given_here.
- ; traceTcS "getNoGivenEqs" $
- vcat [ if has_given_eqs then text "May have given equalities"
- else text "No given equalities"
- , text "Skols:" <+> ppr skol_tvs
+ ; traceTcS "getHasGivenEqs" $
+ vcat [ text "has_given_eqs:" <+> ppr has_given_eqs
, text "Inerts:" <+> ppr inerts
, text "Insols:" <+> ppr insols]
- ; return (not has_given_eqs, insols) }
+ ; return (has_given_eqs, insols) }
where
- eqs_given_here :: EqualCtList -> Bool
- eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]
- -- Givens are always a singleton
- = not (skolem_bound_here tv) && ct_given_here ct
- eqs_given_here _ = False
+ check_local_given_ct :: Ct -> HasGivenEqs
+ check_local_given_ct ct
+ | given_here ev = if mentions_outer_var ev then MaybeGivenEqs else LocalGivenEqs
+ | otherwise = NoGivenEqs
+ where
+ ev = ctEvidence ct
+
+ lift_equal_ct_list :: (Ct -> HasGivenEqs) -> EqualCtList -> HasGivenEqs
+ -- returns NoGivenEqs for non-singleton lists, as Given lists are always
+ -- singletons
+ lift_equal_ct_list check (EqualCtList (ct :| [])) = check ct
+ lift_equal_ct_list _ _ = NoGivenEqs
+
+ check_local_given_tv_eq :: Ct -> HasGivenEqs
+ check_local_given_tv_eq (CEqCan { cc_lhs = TyVarLHS tv, cc_ev = ev})
+ | given_here ev
+ = if is_outer_var tv then MaybeGivenEqs else NoGivenEqs
+ -- See Note [Let-bound skolems]
+ | otherwise
+ = NoGivenEqs
+ check_local_given_tv_eq other_ct = check_local_given_ct other_ct
- ct_given_here :: Ct -> Bool
+ given_here :: CtEvidence -> Bool
-- True for a Given bound by the current implication,
-- i.e. the current level
- ct_given_here ct = isGiven ev
- && tclvl == ctLocLevel (ctEvLoc ev)
- where
- ev = ctEvidence ct
+ given_here ev = isGiven ev
+ && tclvl == ctLocLevel (ctEvLoc ev)
+
+ mentions_outer_var :: CtEvidence -> Bool
+ mentions_outer_var = anyFreeVarsOfType is_outer_var . ctEvPred
- skol_tv_set = mkVarSet skol_tvs
- skolem_bound_here tv -- See Note [Let-bound skolems]
- = case tcTyVarDetails tv of
- SkolemTv {} -> tv `elemVarSet` skol_tv_set
- _ -> False
+ is_outer_var :: TyCoVar -> Bool
+ is_outer_var tv
+ -- NB: a meta-tv alpha[3] may end up unifying with skolem b[2],
+ -- so treat it as an "outer" var, even at level 3.
+ -- This will become redundant after fixing #18929.
+ | isTyVar tv = isTouchableMetaTyVar tclvl tv ||
+ tclvl `strictlyDeeperThan` tcTyVarLevel tv
+ | otherwise = False
-- | Returns Given constraints that might,
-- potentially, match the given pred. This is used when checking to see if a
@@ -2208,10 +2164,26 @@ matchableGivens loc_w pred_w (IS { inert_cans = inert_cans })
= False
mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool
+-- See Note [What might match later?]
mightMatchLater given_pred given_loc wanted_pred wanted_loc
- = not (prohibitedSuperClassSolve given_loc wanted_loc)
- && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred])
+ | prohibitedSuperClassSolve given_loc wanted_loc
+ = False
+
+ | SurelyApart <- tcUnifyTysFG bind_meta_tv [flattened_given] [flattened_wanted]
+ = False
+
+ | otherwise
+ = True -- safe answer
where
+ in_scope = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]
+
+ -- NB: flatten both at the same time, so that we can share mappings
+ -- from type family applications to variables, and also to guarantee
+ -- that the fresh variables are really fresh between the given and
+ -- the wanted.
+ ([flattened_given, flattened_wanted], var_mapping)
+ = flattenTysX in_scope [given_pred, wanted_pred]
+
bind_meta_tv :: TcTyVar -> BindFlag
-- Any meta tyvar may be unified later, so we treat it as
-- bindable when unifying with givens. That ensures that we
@@ -2219,9 +2191,17 @@ mightMatchLater given_pred given_loc wanted_pred wanted_loc
-- something that matches the 'given', until demonstrated
-- otherwise. More info in Note [Instance and Given overlap]
-- in GHC.Tc.Solver.Interact
- bind_meta_tv tv | isMetaTyVar tv
- , not (isFskTyVar tv) = BindMe
- | otherwise = Skolem
+ bind_meta_tv tv | is_meta_tv tv = BindMe
+
+ | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv
+ , anyFreeVarsOfTypes is_meta_tv fam_args
+ = BindMe
+
+ | otherwise = Skolem
+
+ -- CycleBreakerTvs really stands for a type family application in
+ -- a given; these won't contain touchable meta-variables
+ is_meta_tv = isMetaTyVar <&&> not . isCycleBreakerTyVar
prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool
-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
@@ -2239,6 +2219,55 @@ because it is a candidate for floating out of this implication. We
only float equalities with a meta-tyvar on the left, so we only pull
those out here.
+Note [What might match later?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must determine whether a Given might later match a Wanted. We
+definitely need to account for the possibility that any metavariable
+in the Wanted might be arbitrarily instantiated. We do *not* want
+to allow skolems in the Given to be instantiated. But what about
+type family applications? (Examples are below the explanation.)
+
+To allow flexibility in how type family applications unify we use
+the Core flattener. See
+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.
+This is *distinct* from the flattener in GHC.Tc.Solver.Flatten.
+The Core flattener replaces all type family applications with
+fresh variables. The next question: should we allow these fresh
+variables in the domain of a unifying substitution?
+
+A type family application that mentions only skolems is settled: any
+skolems would have been rewritten w.r.t. Givens by now. These type
+family applications match only themselves. A type family application
+that mentions metavariables, on the other hand, can match anything.
+So, if the original type family application contains a metavariable,
+we use BindMe to tell the unifier to allow it in the substitution.
+On the other hand, a type family application with only skolems is
+considered rigid.
+
+Examples:
+ [G] C a
+ [W] C alpha
+ This easily might match later.
+
+ [G] C a
+ [W] C (F alpha)
+ This might match later, too, but we need to flatten the (F alpha)
+ to a fresh variable so that the unifier can connect the two.
+
+ [G] C (F alpha)
+ [W] C a
+ This also might match later. Again, we will need to flatten to
+ find this out. (Surprised about a metavariable in a Given? See
+ #18929.)
+
+ [G] C (F a)
+ [W] C a
+ This won't match later. We're not going to get new Givens that
+ can inform the F a, and so this is a no-go.
+
+This treatment fixes #18910 and is tested in
+typecheck/should_compile/InstanceGivenOverlap{,2}
+
Note [When does an implication have given equalities?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider an implication
@@ -2269,22 +2298,39 @@ are some wrinkles:
beta => ...blah...
If we still don't know what beta is, we conservatively treat it as potentially
becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs.
+ Note that we can't really know what's in an irred, so any irred is considered
+ a potential equality.
+
+ * What about something like forall a b. a ~ F b => [W] c ~ X y z? That Given
+ cannot affect the Wanted, because the Given is entirely *local*: it mentions
+ only skolems bound in the very same implication. Such equalities need not
+ prevent floating. (Test case typecheck/should_compile/LocalGivenEqs has a
+ real-life motivating example, with some detailed commentary.) These
+ equalities are noted with LocalGivenEqs: they do not prevent floating, but
+ they also are allowed to show up in error messages. See
+ Note [Suppress redundant givens during error reporting] in GHC.Tc.Errors.
+ The difference between what stops floating and what is suppressed from
+ error messages is why we need three options for HasGivenEqs.
+
+ There is also a simpler case that triggers this behaviour:
+
+ data T where
+ MkT :: F a ~ G b => a -> b -> T
- * When flattening givens, we generate Given equalities like
- <F [a]> : F [a] ~ f,
- with Refl evidence, and we *don't* want those to count as an equality
- in the givens! After all, the entire flattening business is just an
- internal matter, and the evidence does not mention any of the 'givens'
- of this implication. So we do not treat inert_funeqs as a 'given equality'.
+ f (MkT _ _) = True
+
+ Because of this behaviour around local equality givens, we can infer the
+ type of f. This is typecheck/should_compile/LocalGivenEqs2.
* See Note [Let-bound skolems] for another wrinkle
- * We do *not* need to worry about representational equalities, because
- these do not affect the ability to float constraints.
+ * We need not look at the equality relation involved (nominal vs representational),
+ because representational equalities can still imply nominal ones. For example,
+ if (G a ~R G b) and G's argument's role is nominal, then we can deduce a ~N b.
Note [Let-bound skolems]
~~~~~~~~~~~~~~~~~~~~~~~~
-If * the inert set contains a canonical Given CTyEqCan (a ~ ty)
+If * the inert set contains a canonical Given CEqCan (a ~ ty)
and * 'a' is a skolem bound in this very implication,
then:
@@ -2296,8 +2342,7 @@ a) The Given is pretty much a let-binding, like
and hence can be ignored by has_given_eqs
b) 'a' will have been completely substituted out in the inert set,
- so we can safely discard it. Notably, it doesn't need to be
- returned as part of 'fsks'
+ so we can safely discard it.
For an example, see #9211.
@@ -2343,32 +2388,25 @@ removeInertCt is ct =
CDictCan { cc_class = cl, cc_tyargs = tys } ->
is { inert_dicts = delDict (inert_dicts is) cl tys }
- CFunEqCan { cc_fun = tf, cc_tyargs = tys } ->
- is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }
-
- CTyEqCan { cc_tyvar = x, cc_rhs = ty } ->
- is { inert_eqs = delTyEq (inert_eqs is) x ty }
+ CEqCan { cc_lhs = lhs, cc_rhs = rhs } -> delEq is lhs rhs
CQuantCan {} -> panic "removeInertCt: CQuantCan"
CIrredCan {} -> panic "removeInertCt: CIrredEvCan"
CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
-lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))
-lookupFlatCache fam_tc tys
- = do { IS { inert_flat_cache = flat_cache
- , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
- ; return (firstJusts [lookup_inerts inert_funeqs,
- lookup_flats flat_cache]) }
+-- | Looks up a family application in the inerts; returned coercion
+-- is oriented input ~ output
+lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole))
+lookupFamAppInert fam_tc tys
+ = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
+ ; return (lookup_inerts inert_funeqs) }
where
lookup_inerts inert_funeqs
- | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk })
- <- findFunEq inert_funeqs fam_tc tys
- = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev)
+ | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _))
+ <- findFunEq inert_funeqs fam_tc tys
+ = Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev)
| otherwise = Nothing
- lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys
-
-
lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
-- Is this exact predicate type cached in the solved or canonicals of the InertSet?
lookupInInerts loc pty
@@ -2394,6 +2432,40 @@ lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
Just ev -> Just ev
_ -> Nothing
+---------------------------
+lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
+lookupFamAppCache fam_tc tys
+ = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts
+ ; case findFunEq famapp_cache fam_tc tys of
+ result@(Just (co, ty)) ->
+ do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)
+ , ppr ty
+ , ppr co ])
+ ; return result }
+ Nothing -> return Nothing }
+
+extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()
+-- NB: co :: rhs ~ F tys, to match expectations of flattener
+extendFamAppCache tc xi_args stuff@(_, ty)
+ = do { dflags <- getDynFlags
+ ; when (gopt Opt_FamAppCache dflags) $
+ do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args
+ , ppr ty ])
+ -- 'co' can be bottom, in the case of derived items
+ ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->
+ is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }
+
+-- Remove entries from the cache whose evidence mentions variables in the
+-- supplied set
+dropFromFamAppCache :: VarSet -> TcS ()
+dropFromFamAppCache varset
+ = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts
+ ; let filtered = filterTcAppMap check famapp_cache
+ ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }
+ where
+ check :: (TcCoercion, TcType) -> Bool
+ check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co)
+
{- *********************************************************************
* *
Irreds
@@ -2413,7 +2485,7 @@ foldIrreds k irreds z = foldr k z irreds
Note [Use loose types in inert set]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Whenever we are looking up an inert dictionary (CDictCan) or function
-equality (CFunEqCan), we use a TcAppMap, which uses the Unique of the
+equality (CEqCan), we use a TcAppMap, which uses the Unique of the
class/type family tycon and then a trie which maps the arguments. This
trie does *not* need to match the kinds of the arguments; this Note
explains why.
@@ -2433,54 +2505,56 @@ looking at kinds would be harmless.
-}
-type TcAppMap a = UniqDFM Unique (ListMap LooseTypeMap a)
+type TcAppMap a = DTyConEnv (ListMap LooseTypeMap a)
-- Indexed by tycon then the arg types, using "loose" matching, where
-- we don't require kind equality. This allows, for example, (a |> co)
-- to match (a).
-- See Note [Use loose types in inert set]
-- Used for types and classes; hence UniqDFM
- -- See Note [foldTM determinism] for why we use UniqDFM here
+ -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here
isEmptyTcAppMap :: TcAppMap a -> Bool
-isEmptyTcAppMap m = isNullUDFM m
+isEmptyTcAppMap m = isEmptyDTyConEnv m
emptyTcAppMap :: TcAppMap a
-emptyTcAppMap = emptyUDFM
+emptyTcAppMap = emptyDTyConEnv
-findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a
-findTcApp m u tys = do { tys_map <- lookupUDFM m u
- ; lookupTM tys tys_map }
+findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a
+findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc
+ ; lookupTM tys tys_map }
-delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a
-delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls
+delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a
+delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc
-insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a
-insertTcApp m cls tys ct = alterUDFM alter_tm m cls
+insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a
+insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc
where
alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))
--- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b
--- mapTcApp f = mapUDFM (mapTM f)
+alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> (Maybe a -> Maybe a) -> TcAppMap a
+alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc
+ where
+ alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)
+ alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))
-filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct
-filterTcAppMap f m
- = mapUDFM do_tm m
+filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a
+filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m
where
- do_tm tm = foldTM insert_mb tm emptyTM
- insert_mb ct tm
- | f ct = insertTM tys ct tm
- | otherwise = tm
- where
- tys = case ct of
- CFunEqCan { cc_tyargs = tys } -> tys
- CDictCan { cc_tyargs = tys } -> tys
- _ -> pprPanic "filterTcAppMap" (ppr ct)
+ one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)
+ one_tycon tm
+ | isEmptyTM filtered_tm = Nothing
+ | otherwise = Just filtered_tm
+ where
+ filtered_tm = filterTM f tm
tcAppMapToBag :: TcAppMap a -> Bag a
tcAppMapToBag m = foldTcAppMap consBag m emptyBag
foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
-foldTcAppMap k m z = foldUDFM (foldTM k) z m
+foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m
+
+foldMapTcAppMap :: Monoid m => (a -> m) -> TcAppMap a -> m
+foldMapTcAppMap f = foldMap (foldMap f)
{- *********************************************************************
@@ -2547,22 +2621,22 @@ findDict m loc cls tys
= Nothing -- See Note [Solving CallStack constraints]
| otherwise
- = findTcApp m (getUnique cls) tys
+ = findTcApp m (classTyCon cls) tys
findDictsByClass :: DictMap a -> Class -> Bag a
findDictsByClass m cls
- | Just tm <- lookupUDFM_Directly m (getUnique cls) = foldTM consBag tm emptyBag
- | otherwise = emptyBag
+ | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag
+ | otherwise = emptyBag
delDict :: DictMap a -> Class -> [Type] -> DictMap a
-delDict m cls tys = delTcApp m (getUnique cls) tys
+delDict m cls tys = delTcApp m (classTyCon cls) tys
addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
-addDict m cls tys item = insertTcApp m (getUnique cls) tys item
+addDict m cls tys item = insertTcApp m (classTyCon cls) tys item
addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
addDictsByClass m cls items
- = addToUDFM_Directly m (getUnique cls) (foldr add emptyTM items)
+ = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)
where
add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
add ct _ = pprPanic "addDictsByClass" (ppr ct)
@@ -2601,10 +2675,7 @@ emptyFunEqs :: TcAppMap a
emptyFunEqs = emptyTcAppMap
findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
-findFunEq m tc tys = findTcApp m (getUnique tc) tys
-
-funEqsToBag :: FunEqMap a -> Bag a
-funEqsToBag m = foldTcAppMap consBag m emptyBag
+findFunEq m tc tys = findTcApp m tc tys
findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
-- Get inert function equation constraints that have the given tycon
@@ -2612,50 +2683,17 @@ findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
-- We use this to check for derived interactions with built-in type-function
-- constructors.
findFunEqsByTyCon m tc
- | Just tm <- lookupUDFM m (getUnique tc) = foldTM (:) tm []
- | otherwise = []
+ | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []
+ | otherwise = []
foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
foldFunEqs = foldTcAppMap
--- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b
--- mapFunEqs = mapTcApp
-
--- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct
--- filterFunEqs = filterTcAppMap
+foldMapFunEqs :: Monoid m => (a -> m) -> FunEqMap a -> m
+foldMapFunEqs = foldMapTcAppMap
insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
-insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
-
-partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
--- Optimise for the case where the predicate is false
--- partitionFunEqs is called only from kick-out, and kick-out usually
--- kicks out very few equalities, so we want to optimise for that case
-partitionFunEqs f m = (yeses, foldr del m yeses)
- where
- yeses = foldTcAppMap k m []
- k ct yeses | f ct = ct : yeses
- | otherwise = yeses
- del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m
- = delFunEq m tc tys
- del ct _ = pprPanic "partitionFunEqs" (ppr ct)
-
-delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
-delFunEq m tc tys = delTcApp m (getUnique tc) tys
-
-------------------------------
-type ExactFunEqMap a = TyConEnv (ListMap TypeMap a)
-
-emptyExactFunEqs :: ExactFunEqMap a
-emptyExactFunEqs = emptyUFM
-
-findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a
-findExactFunEq m tc tys = do { tys_map <- lookupUFM m tc
- ; lookupTM tys tys_map }
-
-insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a
-insertExactFunEq m tc tys val = alterUFM alter_tm m tc
- where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))
+insertFunEq m tc tys val = insertTcApp m tc tys val
{-
************************************************************************
@@ -2691,7 +2729,7 @@ data TcSEnv
tcs_inerts :: IORef InertSet, -- Current inert set
-- The main work-list and the flattening worklist
- -- See Note [Work list priorities] and
+ -- See Note [WorkList priorities] and
tcs_worklist :: IORef WorkList -- Current worklist
}
@@ -2796,7 +2834,7 @@ runTcS :: TcS a -- What to run
-> TcM (a, EvBindMap)
runTcS tcs
= do { ev_binds_var <- TcM.newTcEvBinds
- ; res <- runTcSWithEvBinds ev_binds_var True tcs
+ ; res <- runTcSWithEvBinds ev_binds_var tcs
; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
; return (res, ev_binds) }
-- | This variant of 'runTcS' will keep solving, even when only Deriveds
@@ -2805,32 +2843,38 @@ runTcS tcs
runTcSDeriveds :: TcS a -> TcM a
runTcSDeriveds tcs
= do { ev_binds_var <- TcM.newTcEvBinds
- ; runTcSWithEvBinds ev_binds_var True tcs }
+ ; runTcSWithEvBinds ev_binds_var tcs }
-- | This can deal only with equality constraints.
runTcSEqualities :: TcS a -> TcM a
runTcSEqualities thing_inside
= do { ev_binds_var <- TcM.newNoTcEvBinds
- ; runTcSWithEvBinds ev_binds_var True thing_inside }
+ ; runTcSWithEvBinds ev_binds_var thing_inside }
-- | A variant of 'runTcS' that takes and returns an 'InertSet' for
--- later resumption of the 'TcS' session. Crucially, it doesn't
--- 'unflattenGivens' when done.
+-- later resumption of the 'TcS' session.
runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)
runTcSInerts inerts tcs = do
ev_binds_var <- TcM.newTcEvBinds
- -- Passing False here to prohibit unflattening
- runTcSWithEvBinds ev_binds_var False $ do
+ runTcSWithEvBinds' False ev_binds_var $ do
setTcSInerts inerts
a <- tcs
new_inerts <- getTcSInerts
return (a, new_inerts)
runTcSWithEvBinds :: EvBindsVar
- -> Bool -- ^ Unflatten types afterwards? Don't if you want to reuse the InertSet.
-> TcS a
-> TcM a
-runTcSWithEvBinds ev_binds_var unflatten tcs
+runTcSWithEvBinds = runTcSWithEvBinds' True
+
+runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?
+ -- Don't if you want to reuse the InertSet.
+ -- See also Note [Type variable cycles in Givens]
+ -- in GHC.Tc.Solver.Canonical
+ -> EvBindsVar
+ -> TcS a
+ -> TcM a
+runTcSWithEvBinds' restore_cycles ev_binds_var tcs
= do { unified_var <- TcM.newTcRef 0
; step_count <- TcM.newTcRef 0
; inert_var <- TcM.newTcRef emptyInert
@@ -2848,7 +2892,9 @@ runTcSWithEvBinds ev_binds_var unflatten tcs
; when (count > 0) $
csTraceTcM $ return (text "Constraint solver steps =" <+> int count)
- ; when unflatten $ unflattenGivens inert_var
+ ; when restore_cycles $
+ do { inert_set <- TcM.readTcRef inert_var
+ ; restoreTyVarCycles inert_set }
#if defined(DEBUG)
; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
@@ -2899,10 +2945,8 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
, tcs_count = count
} ->
do { inerts <- TcM.readTcRef old_inert_var
- ; let nest_inert = emptyInert
- { inert_cans = inert_cans inerts
- , inert_solved_dicts = inert_solved_dicts inerts }
- -- See Note [Do not inherit the flat cache]
+ ; let nest_inert = inerts { inert_cycle_breakers = [] }
+ -- all other InertSet fields are inherited
; new_inert_var <- TcM.newTcRef nest_inert
; new_wl_var <- TcM.newTcRef emptyWorkList
; let nest_env = TcSEnv { tcs_ev_binds = ref
@@ -2913,7 +2957,8 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
; res <- TcM.setTcLevel inner_tclvl $
thing_inside nest_env
- ; unflattenGivens new_inert_var
+ ; out_inert_set <- TcM.readTcRef new_inert_var
+ ; restoreTyVarCycles out_inert_set
#if defined(DEBUG)
-- Perform a check that the thing_inside did not cause cycles
@@ -2922,22 +2967,10 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
#endif
; return res }
-{- Note [Do not inherit the flat cache]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not want to inherit the flat cache when processing nested
-implications. Consider
- a ~ F b, forall c. b~Int => blah
-If we have F b ~ fsk in the flat-cache, and we push that into the
-nested implication, we might miss that F b can be rewritten to F Int,
-and hence perhaps solve it. Moreover, the fsk from outside is
-flattened out after solving the outer level, but and we don't
-do that flattening recursively.
--}
-
nestTcS :: TcS a -> TcS a
-- Use the current untouchables, augmenting the current
-- evidence bindings, and solved dictionaries
--- But have no effect on the InertCans, or on the inert_flat_cache
+-- But have no effect on the InertCans, or on the inert_famapp_cache
-- (we want to inherit the latter from processing the Givens)
nestTcS (TcS thing_inside)
= TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
@@ -3224,143 +3257,7 @@ zonkWC wc = wrapTcS (TcM.zonkWC wc)
zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar
zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)
-{- *********************************************************************
-* *
-* Flatten skolems *
-* *
-********************************************************************* -}
-
-newFlattenSkolem :: CtFlavour -> CtLoc
- -> TyCon -> [TcType] -- F xis
- -> TcS (CtEvidence, Coercion, TcTyVar) -- [G/WD] x:: F xis ~ fsk
-newFlattenSkolem flav loc tc xis
- = do { stuff@(ev, co, fsk) <- new_skolem
- ; let fsk_ty = mkTyVarTy fsk
- ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)
- ; return stuff }
- where
- fam_ty = mkTyConApp tc xis
-
- new_skolem
- | Given <- flav
- = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty)
-
- -- Extend the inert_fsks list, for use by unflattenGivens
- ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is }
-
- -- Construct the Refl evidence
- ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)
- co = mkNomReflCo fam_ty
- ; ev <- newGivenEvVar loc (pred, evCoercion co)
- ; return (ev, co, fsk) }
-
- | otherwise -- Generate a [WD] for both Wanted and Derived
- -- See Note [No Derived CFunEqCans]
- = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)
- -- See (2a) in "GHC.Tc.Solver.Canonical"
- -- Note [Equalities with incompatible kinds]
- ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal
- fam_ty (mkTyVarTy fmv)
- ; return (ev, hole_co, fmv) }
-
-----------------------------
-unflattenGivens :: IORef InertSet -> TcM ()
--- Unflatten all the fsks created by flattening types in Given
--- constraints. We must be sure to do this, else we end up with
--- flatten-skolems buried in any residual Wanteds
---
--- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv)
--- is filled in. Nothing else does so.
---
--- It's here (rather than in GHC.Tc.Solver.Flatten) because the Right Places
--- to call it are in runTcSWithEvBinds/nestImplicTcS, where it
--- is nicely paired with the creation an empty inert_fsks list.
-unflattenGivens inert_var
- = do { inerts <- TcM.readTcRef inert_var
- ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts))
- ; mapM_ flatten_one (inert_fsks inerts) }
- where
- flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty
-
-----------------------------
-extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()
-extendFlatCache tc xi_args stuff@(_, ty, fl)
- | isGivenOrWDeriv fl -- Maintain the invariant that inert_flat_cache
- -- only has [G] and [WD] CFunEqCans
- = do { dflags <- getDynFlags
- ; when (gopt Opt_FlatCache dflags) $
- do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args
- , ppr fl, ppr ty ])
- -- 'co' can be bottom, in the case of derived items
- ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->
- is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } }
-
- | otherwise
- = return ()
-
-----------------------------
-unflattenFmv :: TcTyVar -> TcType -> TcS ()
--- Fill a flatten-meta-var, simply by unifying it.
--- This does NOT count as a unification in tcs_unified.
-unflattenFmv tv ty
- = ASSERT2( isMetaTyVar tv, ppr tv )
- TcS $ \ _ ->
- do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)
- ; TcM.writeMetaTyVar tv ty }
-
----------------------------
-demoteUnfilledFmv :: TcTyVar -> TcS ()
--- If a flatten-meta-var is still un-filled,
--- turn it into an ordinary meta-var
-demoteUnfilledFmv fmv
- = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv
- ; unless is_filled $
- do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)
- ; TcM.writeMetaTyVar fmv tv_ty } }
-
------------------------------
-dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
--- (dischargeFunEq tv co ty)
--- Preconditions
--- - ev :: F tys ~ tv is a CFunEqCan
--- - tv is a FlatMetaTv of FlatSkolTv
--- - co :: F tys ~ xi
--- - fmv/fsk `notElem` xi
--- - fmv not filled (for Wanteds)
--- - xi is flattened (and obeys Note [Almost function-free] in GHC.Tc.Types)
---
--- Then for [W] or [WD], we actually fill in the fmv:
--- set fmv := xi,
--- set ev := co
--- kick out any inert things that are now rewritable
---
--- For [D], we instead emit an equality that must ultimately hold
--- [D] xi ~ fmv
--- Does not evaluate 'co' if 'ev' is Derived
---
--- For [G], emit this equality
--- [G] (sym ev; co) :: fsk ~ xi
-
--- See GHC.Tc.Solver.Flatten Note [The flattening story],
--- especially "Ownership of fsk/fmv"
-dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi
- = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co )
- ; emitWorkNC [new_ev] }
- where
- new_pred = mkPrimEqPred (mkTyVarTy fsk) xi
- new_co = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co
-
-dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi
- = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )
- do { setWantedEvTerm dest (evCoercion co)
- ; unflattenFmv fmv xi
- ; n_kicked <- kickOutAfterUnification fmv
- ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) }
-
-dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi
- = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv)
- -- FunEqs are always at Nominal role
-
pprKicked :: Int -> SDoc
pprKicked 0 = empty
pprKicked n = parens (int n <+> text "kicked out")
@@ -3486,7 +3383,7 @@ Yuk!
fillCoercionHole :: CoercionHole -> Coercion -> TcS ()
fillCoercionHole hole co
= do { wrapTcS $ TcM.fillCoercionHole hole co
- ; kickOutAfterFillingCoercionHole hole }
+ ; kickOutAfterFillingCoercionHole hole co }
setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()
setEvBindIfWanted ev tm
@@ -3533,13 +3430,13 @@ emitNewWantedEq loc role ty1 ty2
-- | Make a new equality CtEvidence
newWantedEq :: CtLoc -> Role -> TcType -> TcType
-> TcS (CtEvidence, Coercion)
-newWantedEq = newWantedEq_SI YesBlockSubst WDeriv
+newWantedEq = newWantedEq_SI WDeriv
-newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role
+newWantedEq_SI :: ShadowInfo -> CtLoc -> Role
-> TcType -> TcType
-> TcS (CtEvidence, Coercion)
-newWantedEq_SI blocker si loc role ty1 ty2
- = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty
+newWantedEq_SI si loc role ty1 ty2
+ = do { hole <- wrapTcS $ TcM.newCoercionHole pty
; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)
; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
, ctev_nosh = si
@@ -3585,7 +3482,7 @@ newWanted = newWanted_SI WDeriv
newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew
newWanted_SI si loc pty
| Just (role, ty1, ty2) <- getEqPredTys_maybe pty
- = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2
+ = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2
| otherwise
= newWantedEvVar_SI si loc pty
@@ -3632,8 +3529,8 @@ checkReductionDepth loc ty
solverDepthErrorTcS loc ty }
matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))
--- Given (F tys) return (ty, co), where co :: F tys ~N ty
-matchFam tycon args = wrapTcS $ matchFamTcM tycon args
+-- Given (F tys) return (ty, co), where co :: ty ~N F tys
+matchFam tycon args = fmap (fmap (first mkTcSymCo)) $ wrapTcS $ matchFamTcM tycon args
matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))
-- Given (F tys) return (ty, co), where co :: F tys ~N ty
@@ -3662,3 +3559,71 @@ from which we get the implication
(forall a. t1 ~ t2)
See GHC.Tc.Solver.Monad.deferTcSForAllEq
-}
+
+{-
+************************************************************************
+* *
+ Breaking type variable cycles
+* *
+************************************************************************
+-}
+
+-- | Replace all type family applications in the RHS with fresh variables,
+-- emitting givens that relate the type family application to the variable.
+-- See Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical.
+breakTyVarCycle :: CtLoc
+ -> TcType -- the RHS
+ -> TcS TcType -- new RHS that doesn't have any type families
+-- This could be considerably more efficient. See Detail (5) of Note.
+breakTyVarCycle loc = go
+ where
+ go ty | Just ty' <- flattenView ty = go ty'
+ go (Rep.TyConApp tc tys)
+ | isTypeFamilyTyCon tc
+ = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys
+ fun_app = mkTyConApp tc fun_args
+ fun_app_kind = tcTypeKind fun_app
+ ; new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind)
+ ; let new_ty = mkTyVarTy new_tv
+ given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind
+ fun_app new_ty
+ given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note
+ ; new_given <- newGivenEvVar loc (given_pred, given_term)
+ ; traceTcS "breakTyVarCycle replacing type family" (ppr new_given)
+ ; emitWorkNC [new_given]
+ ; updInertTcS $ \is ->
+ is { inert_cycle_breakers = (new_tv, fun_app) :
+ inert_cycle_breakers is }
+ ; extra_args' <- mapM go extra_args
+ ; return (mkAppTys new_ty extra_args') }
+ -- Worried that this substitution will change kinds?
+ -- See Detail (3) of Note
+
+ | otherwise
+ = mkTyConApp tc <$> mapM go tys
+
+ go (Rep.AppTy ty1 ty2) = mkAppTy <$> go ty1 <*> go ty2
+ go (Rep.FunTy vis w arg res) = mkFunTy vis <$> go w <*> go arg <*> go res
+ go (Rep.CastTy ty co) = mkCastTy <$> go ty <*> pure co
+
+ go ty@(Rep.TyVarTy {}) = return ty
+ go ty@(Rep.LitTy {}) = return ty
+ go ty@(Rep.ForAllTy {}) = return ty -- See Detail (1) of Note
+ go ty@(Rep.CoercionTy {}) = return ty -- See Detail (2) of Note
+
+-- | Fill in CycleBreakerTvs with the variables they stand for.
+-- See Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical.
+restoreTyVarCycles :: InertSet -> TcM ()
+restoreTyVarCycles is
+ = forM_ (inert_cycle_breakers is) $ \ (cycle_breaker_tv, orig_ty) ->
+ TcM.writeMetaTyVar cycle_breaker_tv orig_ty
+
+-- Unwrap a type synonym only when either:
+-- The type synonym is forgetful, or
+-- the type synonym mentions a type family in its expansion
+-- See Note [Flattening synonyms] in GHC.Tc.Solver.Flatten.
+flattenView :: TcType -> Maybe TcType
+flattenView ty@(Rep.TyConApp tc _)
+ | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc))
+ = tcView ty
+flattenView _other = Nothing
View Lorry Controller Status