Commit 8dc6d645 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Re-engineer Given flatten-skolems

The big change here is to fix an outright bug in flattening of Givens,
albeit one that is very hard to exhibit.  Suppose we have the constraint
    forall a. (a ~ F b) => ..., (forall c. ....(F b)...) ...

Then
 - we'll flatten the (F) b to a fsk, say  (F b ~ fsk1)
 - we'll rewrite the (F b) inside the inner implication to 'fsk1'
 - when we leave the outer constraint we are suppose to unflatten;
   but that fsk1 will still be there
 - if we re-simplify the entire outer implication, we'll re-flatten
   the Given (F b) to, say, (F b ~ fsk2)
Now we have two fsks standing for the same thing, and that is very
wrong.

Solution: make fsks behave more like fmvs:
 - A flatten-skolem is now a MetaTyVar, whose MetaInfo is FlatSkolTv
 - We "fill in" that meta-tyvar when leaving the implication
 - The old FlatSkol form of TcTyVarDetails is gone completely
 - We track the flatten-skolems for the current implication in
   a new field of InertSet, inert_fsks.

See Note [The flattening story] in TcFlatten.

In doing this I found various other things to fix:

* I removed the zonkSimples from TcFlatten.unflattenWanteds; it wasn't
  needed.   But I added one in TcSimplify.floatEqualities, which does
  the zonk precisely when it is needed.

* Trac #13674 showed up a case where we had
     - an insoluble Given,   e.g.  a ~ [a]
     - the same insoluble Wanted   a ~ [a]
  We don't use the Given to rewwrite the Wanted (obviously), but
  we therefore ended up reporting
      Can't deduce (a ~ [a]) from (a ~ [a])
  which is silly.

  Conclusion: when reporting errors, make the occurs check "win"
  See Note [Occurs check wins] in TcErrors
parent c2eea089
...@@ -1538,7 +1538,7 @@ Suppose we have [G] Num (F [a]) ...@@ -1538,7 +1538,7 @@ Suppose we have [G] Num (F [a])
then we flatten to then we flatten to
[G] Num fsk [G] Num fsk
[G] F [a] ~ fsk [G] F [a] ~ fsk
where fsk is a flatten-skolem (FlatSkol). Suppose we have where fsk is a flatten-skolem (FlatSkolTv). Suppose we have
type instance F [a] = a type instance F [a] = a
then we'll reduce the second constraint to then we'll reduce the second constraint to
[G] a ~ fsk [G] a ~ fsk
......
...@@ -1466,7 +1466,7 @@ mkEqErr1 ctxt ct -- Wanted or derived; ...@@ -1466,7 +1466,7 @@ mkEqErr1 ctxt ct -- Wanted or derived;
NomEq -> empty NomEq -> empty
ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
; dflags <- getDynFlags ; dflags <- getDynFlags
; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going)
; let report = mconcat [important wanted_msg, important coercible_msg, ; let report = mconcat [important wanted_msg, important coercible_msg,
relevant_bindings binds_msg] relevant_bindings binds_msg]
; if keep_going ; if keep_going
...@@ -1604,15 +1604,21 @@ reportEqErr ctxt report ct oriented ty1 ty2 ...@@ -1604,15 +1604,21 @@ reportEqErr ctxt report ct oriented ty1 ty2
where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2 where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2
eqInfo = important $ mkEqInfoMsg ct ty1 ty2 eqInfo = important $ mkEqInfoMsg ct ty1 ty2
mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> Report -> Ct mkTyVarEqErr, mkTyVarEqErr'
:: DynFlags -> ReportErrCtxt -> Report -> Ct
-> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
-- tv1 and ty2 are already tidied -- tv1 and ty2 are already tidied
mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2 mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
| isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
; mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2 }
mkTyVarEqErr' dflags ctxt report ct oriented tv1 ty2
| not insoluble_occurs_check -- See Note [Occurs check wins]
, isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would
-- be oriented the other way round; -- be oriented the other way round;
-- see TcCanonical.canEqTyVarTyVar -- see TcCanonical.canEqTyVarTyVar
|| isSigTyVar tv1 && not (isTyVarTy ty2) || isSigTyVar tv1 && not (isTyVarTy ty2)
|| ctEqRel ct == ReprEq && not insoluble_occurs_check || ctEqRel ct == ReprEq
-- the cases below don't really apply to ReprEq (except occurs check) -- the cases below don't really apply to ReprEq (except occurs check)
= mkErrorMsgFromCt ctxt ct $ mconcat = mkErrorMsgFromCt ctxt ct $ mconcat
[ important $ misMatchOrCND ctxt ct oriented ty1 ty2 [ important $ misMatchOrCND ctxt ct oriented ty1 ty2
...@@ -1827,7 +1833,6 @@ extraTyVarInfo ctxt tv ...@@ -1827,7 +1833,6 @@ extraTyVarInfo ctxt tv
= ASSERT2( isTyVar tv, ppr tv ) = ASSERT2( isTyVar tv, ppr tv )
case tcTyVarDetails tv of case tcTyVarDetails tv of
SkolemTv {} -> pprSkol implics tv SkolemTv {} -> pprSkol implics tv
FlatSkol {} -> pp_tv <+> text "is a flattening type variable"
RuntimeUnk {} -> pp_tv <+> text "is an interactive-debugger skolem" RuntimeUnk {} -> pp_tv <+> text "is an interactive-debugger skolem"
MetaTv {} -> empty MetaTv {} -> empty
where where
...@@ -2016,7 +2021,22 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act ...@@ -2016,7 +2021,22 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg" mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg"
{- {- Note [Insoluble occurs check wins]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider [G] a ~ [a], [W] a ~ [a] (Trac #13674). The Given is insoluble
so we don't use it for rewriting. The Wanted is also insoluble, and
we don't solve it from the Given. It's very confusing to say
Cannot solve a ~ [a] from given constraints a ~ [a]
And indeed even thinking about the Givens is silly; [W] a ~ [a] is
just as insoluble as Int ~ Bool.
Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck)
then report it first.
(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't
wnat to be as draconian with them.)
Note [Expanding type synonyms to make types similar] Note [Expanding type synonyms to make types similar]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -4,7 +4,7 @@ module TcFlatten( ...@@ -4,7 +4,7 @@ module TcFlatten(
FlattenMode(..), FlattenMode(..),
flatten, flattenManyNom, flatten, flattenManyNom,
unflatten, unflattenWanteds
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -36,31 +36,50 @@ import Control.Arrow ( first ) ...@@ -36,31 +36,50 @@ import Control.Arrow ( first )
Note [The flattening story] Note [The flattening story]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* A CFunEqCan is either of form * A CFunEqCan is either of form
[G] <F xis> : F xis ~ fsk -- fsk is a FlatSkol [G] <F xis> : F xis ~ fsk -- fsk is a FlatSkolTv
[W] x : F xis ~ fmv -- fmv is a unification variable, [W] x : F xis ~ fmv -- fmv is a FlatMetaTv
-- but untouchable,
-- with MetaInfo = FlatMetaTv
where where
x is the witness variable x is the witness variable
fsk/fmv is a flatten skolem
xis are function-free xis are function-free
CFunEqCans are always [Wanted], or [Given], never [Derived] fsk/fmv is a flatten skolem;
it is always untouchable (level 0)
fmv untouchable just means that in a CTyVarEq, say, * CFunEqCans can have any flavour: [G], [W], [WD] or [D]
fmv ~ Int
we do NOT unify fmv.
* KEY INSIGHTS: * KEY INSIGHTS:
- A given flatten-skolem, fsk, is known a-priori to be equal to - A given flatten-skolem, fsk, is known a-priori to be equal to
F xis (the LHS), with <F xis> evidence 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 - A unification flatten-skolem, fmv, stands for the as-yet-unknown
type to which (F xis) will eventually reduce type to which (F xis) will eventually reduce. It is filled in
only by dischargeFmv.
* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2 - All fsk/fmv variables are "untouchable". To make it simple to test,
then xis1 /= xis2 we simply give them TcLevel=0. This means that in a CTyVarEq, say,
i.e. at most one CFunEqCan with a particular LHS fmv ~ Int
we NEVER unify fmv.
- A unification flatten-skolems, 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.
* Each canonical [G], [W], or [WD] CFunEqCan x : F xis ~ fsk/fmv * Each canonical [G], [W], or [WD] CFunEqCan x : F xis ~ fsk/fmv
has its own distinct evidence variable x and flatten-skolem fsk/fmv. has its own distinct evidence variable x and flatten-skolem fsk/fmv.
...@@ -70,7 +89,11 @@ Note [The flattening story] ...@@ -70,7 +89,11 @@ Note [The flattening story]
In contrast a [D] CFunEqCan shares its fmv with its partner [W], 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 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. say type instance F Int = ty, then we don't discharge fmv := ty.
Rather we simply generate [D] fmv ~ ty Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq)
* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2
then xis1 /= xis2
i.e. at most one CFunEqCan with a particular LHS
* Function applications can occur in the RHS of a CTyEqCan. No reason * Function applications can occur in the RHS of a CTyEqCan. No reason
not allow this, and it reduces the amount of flattening that must occur. not allow this, and it reduces the amount of flattening that must occur.
...@@ -104,20 +127,6 @@ Note [The flattening story] ...@@ -104,20 +127,6 @@ Note [The flattening story]
- Add new wanted to flat cache - Add new wanted to flat cache
- Discharge x = F cos ; x2 - Discharge x = F cos ; x2
* Unification flatten-skolems, fmv, ONLY get unified when either
a) The CFunEqCan takes a step, using an axiom
b) During un-flattening
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!)
* [Interacting rule] * [Interacting rule]
(inert) [W] x1 : F tys ~ fmv1 (inert) [W] x1 : F tys ~ fmv1
(work item) [W] x2 : F tys ~ fmv2 (work item) [W] x2 : F tys ~ fmv2
...@@ -1476,8 +1485,8 @@ flattens to ...@@ -1476,8 +1485,8 @@ flattens to
We must solve both! We must solve both!
-} -}
unflatten :: Cts -> Cts -> TcS Cts unflattenWanteds :: Cts -> Cts -> TcS Cts
unflatten tv_eqs funeqs unflattenWanteds tv_eqs funeqs
= do { tclvl <- getTcLevel = do { tclvl <- getTcLevel
; traceTcS "Unflattening" $ braces $ ; traceTcS "Unflattening" $ braces $
...@@ -1506,10 +1515,7 @@ unflatten tv_eqs funeqs ...@@ -1506,10 +1515,7 @@ unflatten tv_eqs funeqs
; let all_flat = tv_eqs `andCts` funeqs ; let all_flat = tv_eqs `andCts` funeqs
; traceTcS "Unflattening done" $ braces (pprCts all_flat) ; traceTcS "Unflattening done" $ braces (pprCts all_flat)
-- Step 5: zonk the result ; return all_flat }
-- Motivation: makes them nice and ready for the next step
-- (see TcInteract.solveSimpleWanteds)
; zonkSimples all_flat }
where where
---------------- ----------------
unflatten_funeq :: Ct -> Cts -> TcS Cts unflatten_funeq :: Ct -> Cts -> TcS Cts
......
...@@ -1557,7 +1557,6 @@ zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv ...@@ -1557,7 +1557,6 @@ zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
= case tcTyVarDetails tv of = case tcTyVarDetails tv of
SkolemTv {} -> lookup_in_env SkolemTv {} -> lookup_in_env
RuntimeUnk {} -> lookup_in_env RuntimeUnk {} -> lookup_in_env
FlatSkol ty -> zonkTcTypeToType env ty
MetaTv { mtv_ref = ref } MetaTv { mtv_ref = ref }
-> do { cts <- readMutVar ref -> do { cts <- readMutVar ref
; case cts of ; case cts of
......
...@@ -160,6 +160,7 @@ solveSimpleGivens givens ...@@ -160,6 +160,7 @@ solveSimpleGivens givens
solveSimpleWanteds :: Cts -> TcS WantedConstraints solveSimpleWanteds :: Cts -> TcS WantedConstraints
-- NB: 'simples' may contain /derived/ equalities, floated -- NB: 'simples' may contain /derived/ equalities, floated
-- out from a nested implication. So don't discard deriveds! -- out from a nested implication. So don't discard deriveds!
-- The result is not necessarily zonked
solveSimpleWanteds simples solveSimpleWanteds simples
= do { traceTcS "solveSimpleWanteds {" (ppr simples) = do { traceTcS "solveSimpleWanteds {" (ppr simples)
; dflags <- getDynFlags ; dflags <- getDynFlags
...@@ -199,12 +200,13 @@ solveSimpleWanteds simples ...@@ -199,12 +200,13 @@ solveSimpleWanteds simples
solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints) solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)
-- Try solving these constraints -- Try solving these constraints
-- Affects the unification state (of course) but not the inert set -- 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_insol = insols1, wc_impl = implics1 }) solve_simple_wanteds (WC { wc_simple = simples1, wc_insol = insols1, wc_impl = implics1 })
= nestTcS $ = nestTcS $
do { solveSimples simples1 do { solveSimples simples1
; (implics2, tv_eqs, fun_eqs, insols2, others) <- getUnsolvedInerts ; (implics2, tv_eqs, fun_eqs, insols2, others) <- getUnsolvedInerts
; (unif_count, unflattened_eqs) <- reportUnifications $ ; (unif_count, unflattened_eqs) <- reportUnifications $
unflatten tv_eqs fun_eqs unflattenWanteds tv_eqs fun_eqs
-- See Note [Unflatten after solving the simple wanteds] -- See Note [Unflatten after solving the simple wanteds]
; return ( unif_count ; return ( unif_count
, WC { wc_simple = others `andCts` unflattened_eqs , WC { wc_simple = others `andCts` unflattened_eqs
...@@ -2241,6 +2243,13 @@ Other notes: ...@@ -2241,6 +2243,13 @@ Other notes:
- natural numbers - natural numbers
- Typeable - 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!
* The given-overlap problem is arguably not easy to appear in practice * The given-overlap problem is arguably not easy to appear in practice
due to our aggressive prioritization of equality solving over other due to our aggressive prioritization of equality solving over other
constraints, but it is possible. I've added a test case in constraints, but it is possible. I've added a test case in
...@@ -2274,7 +2283,7 @@ Other notes: ...@@ -2274,7 +2283,7 @@ Other notes:
in point. in point.
All of this is disgustingly delicate, so to discourage people from writing All of this is disgustingly delicate, so to discourage people from writing
simplifiable class givens, we warn about signatures that contain them;# simplifiable class givens, we warn about signatures that contain them;
see TcValidity Note [Simplifiable given constraints]. see TcValidity Note [Simplifiable given constraints].
-} -}
......
...@@ -550,8 +550,13 @@ instSkolTyCoVarX mk_tcv subst tycovar ...@@ -550,8 +550,13 @@ instSkolTyCoVarX mk_tcv subst tycovar
newFskTyVar :: TcType -> TcM TcTyVar newFskTyVar :: TcType -> TcM TcTyVar
newFskTyVar fam_ty newFskTyVar fam_ty
= do { uniq <- newUnique = do { uniq <- newUnique
; let name = mkSysTvName uniq (fsLit "fsk") ; ref <- newMutVar Flexi
; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) } ; let details = MetaTv { mtv_info = FlatSkolTv
, mtv_ref = ref
, mtv_tclvl = fmvTcLevel }
name = mkMetaTyVarName uniq (fsLit "fsk")
; return (mkTcTyVar name (typeKind fam_ty) details) }
{- {-
Note [Kind substitution when instantiating] Note [Kind substitution when instantiating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -593,10 +598,9 @@ newFmvTyVar :: TcType -> TcM TcTyVar ...@@ -593,10 +598,9 @@ newFmvTyVar :: TcType -> TcM TcTyVar
newFmvTyVar fam_ty newFmvTyVar fam_ty
= do { uniq <- newUnique = do { uniq <- newUnique
; ref <- newMutVar Flexi ; ref <- newMutVar Flexi
; cur_lvl <- getTcLevel
; let details = MetaTv { mtv_info = FlatMetaTv ; let details = MetaTv { mtv_info = FlatMetaTv
, mtv_ref = ref , mtv_ref = ref
, mtv_tclvl = fmvTcLevel cur_lvl } , mtv_tclvl = fmvTcLevel }
name = mkMetaTyVarName uniq (fsLit "s") name = mkMetaTyVarName uniq (fsLit "s")
; return (mkTcTyVar name (typeKind fam_ty) details) } ; return (mkTcTyVar name (typeKind fam_ty) details) }
...@@ -707,7 +711,7 @@ writeMetaTyVarRef tyvar ref ty ...@@ -707,7 +711,7 @@ writeMetaTyVarRef tyvar ref ty
tv_lvl = tcTyVarLevel tyvar tv_lvl = tcTyVarLevel tyvar
ty_lvl = tcTypeLevel ty ty_lvl = tcTypeLevel ty
level_check_ok = isFmvTyVar tyvar level_check_ok = isFlattenTyVar tyvar
|| not (ty_lvl `strictlyDeeperThan` tv_lvl) || not (ty_lvl `strictlyDeeperThan` tv_lvl)
level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty
...@@ -768,6 +772,7 @@ newAnonMetaTyVar meta_info kind ...@@ -768,6 +772,7 @@ newAnonMetaTyVar meta_info kind
s = case meta_info of s = case meta_info of
TauTv -> fsLit "t" TauTv -> fsLit "t"
FlatMetaTv -> fsLit "fmv" FlatMetaTv -> fsLit "fmv"
FlatSkolTv -> fsLit "fsk"
SigTv -> fsLit "a" SigTv -> fsLit "a"
; details <- newMetaDetails meta_info ; details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) } ; return (mkTcTyVar name kind details) }
...@@ -998,7 +1003,7 @@ zonkQuantifiedTyVar tv ...@@ -998,7 +1003,7 @@ zonkQuantifiedTyVar tv
MetaTv {} -> skolemiseUnboundMetaTyVar tv MetaTv {} -> skolemiseUnboundMetaTyVar tv
_other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- RuntimeUnk
defaultTyVar :: Bool -- True <=> please default this kind variable to * defaultTyVar :: Bool -- True <=> please default this kind variable to *
-> TcTyVar -- If it's a MetaTyVar then it is unbound -> TcTyVar -- If it's a MetaTyVar then it is unbound
...@@ -1490,7 +1495,6 @@ zonkTcTyVar tv ...@@ -1490,7 +1495,6 @@ zonkTcTyVar tv
= case tcTyVarDetails tv of = case tcTyVarDetails tv of
SkolemTv {} -> zonk_kind_and_return SkolemTv {} -> zonk_kind_and_return
RuntimeUnk {} -> zonk_kind_and_return RuntimeUnk {} -> zonk_kind_and_return
FlatSkol ty -> zonkTcType ty
MetaTv { mtv_ref = ref } MetaTv { mtv_ref = ref }
-> do { cts <- readMutVar ref -> do { cts <- readMutVar ref
; case cts of ; case cts of
......
...@@ -1589,8 +1589,8 @@ data Ct ...@@ -1589,8 +1589,8 @@ data Ct
-- *never* over-saturated (because if so -- *never* over-saturated (because if so
-- we should have decomposed) -- we should have decomposed)
cc_fsk :: TcTyVar -- [Given] always a FlatSkol skolem cc_fsk :: TcTyVar -- [Given] always a FlatSkolTv
-- [Wanted] always a FlatMetaTv unification variable -- [Wanted] always a FlatMetaTv
-- See Note [The flattening story] in TcFlatten -- See Note [The flattening story] in TcFlatten
} }
......
...@@ -52,7 +52,7 @@ module TcSMonad ( ...@@ -52,7 +52,7 @@ module TcSMonad (
getNoGivenEqs, setInertCans, getNoGivenEqs, setInertCans,
getInertEqs, getInertCans, getInertGivens, getInertEqs, getInertCans, getInertGivens,
getInertInsols, getInertInsols,
emptyInert, getTcSInerts, setTcSInerts, getTcSInerts, setTcSInerts,
matchableGivens, prohibitedSuperClassSolve, matchableGivens, prohibitedSuperClassSolve,
getUnsolvedInerts, getUnsolvedInerts,
removeInertCts, getPendingScDicts, removeInertCts, getPendingScDicts,
...@@ -383,6 +383,16 @@ data InertSet ...@@ -383,6 +383,16 @@ data InertSet
-- Canonical Given, Wanted, Derived -- Canonical Given, Wanted, Derived
-- Sometimes called "the inert set" -- 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_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour) , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)
-- See Note [Type family equations] -- See Note [Type family equations]
-- If F tys :-> (co, rhs, flav), -- If F tys :-> (co, rhs, flav),
...@@ -421,6 +431,7 @@ emptyInert ...@@ -421,6 +431,7 @@ emptyInert
, inert_irreds = emptyCts , inert_irreds = emptyCts
, inert_insols = emptyCts } , inert_insols = emptyCts }
, inert_flat_cache = emptyExactFunEqs , inert_flat_cache = emptyExactFunEqs
, inert_fsks = []
, inert_solved_dicts = emptyDictMap } , inert_solved_dicts = emptyDictMap }
...@@ -1814,24 +1825,21 @@ getNoGivenEqs :: TcLevel -- TcLevel of this implication ...@@ -1814,24 +1825,21 @@ getNoGivenEqs :: TcLevel -- TcLevel of this implication
-- See Note [When does an implication have given equalities?] -- See Note [When does an implication have given equalities?]
getNoGivenEqs tclvl skol_tvs getNoGivenEqs tclvl skol_tvs
= do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = iirreds
, inert_funeqs = funeqs
, inert_insols = insols }) , inert_insols = insols })
<- getInertCans <- getInertCans
; let local_fsks = foldFunEqs add_fsk funeqs emptyVarSet ; let has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence) False
has_given_eqs = foldrBag ((||) . ev_given_here . ctEvidence) False
(iirreds `unionBags` insols) (iirreds `unionBags` insols)
|| anyDVarEnv (eqs_given_here local_fsks) ieqs || anyDVarEnv eqs_given_here ieqs
; traceTcS "getNoGivenEqs" (vcat [ ppr has_given_eqs, ppr inerts ; traceTcS "getNoGivenEqs" (vcat [ ppr has_given_eqs, ppr inerts
, ppr insols]) , ppr insols])
; return (not has_given_eqs, insols) } ; return (not has_given_eqs, insols) }
where where
eqs_given_here :: VarSet -> EqualCtList -> Bool eqs_given_here :: EqualCtList -> Bool
eqs_given_here local_fsks [CTyEqCan { cc_tyvar = tv, cc_ev = ev }] eqs_given_here [CTyEqCan { cc_tyvar = tv, cc_ev = ev }]
-- Givens are always a sigleton -- Givens are always a sigleton
= not (skolem_bound_here local_fsks tv) && ev_given_here ev = not (skolem_bound_here tv) && ev_given_here ev
eqs_given_here _ _ = False eqs_given_here _ = False
ev_given_here :: CtEvidence -> Bool ev_given_here :: CtEvidence -> Bool
-- True for a Given bound by the curent implication, -- True for a Given bound by the curent implication,
...@@ -1840,16 +1848,10 @@ getNoGivenEqs tclvl skol_tvs ...@@ -1840,16 +1848,10 @@ getNoGivenEqs tclvl skol_tvs
= isGiven ev = isGiven ev
&& tclvl == ctLocLevel (ctEvLoc ev) && tclvl == ctLocLevel (ctEvLoc ev)
add_fsk :: Ct -> VarSet -> VarSet
add_fsk ct fsks | CFunEqCan { cc_fsk = tv, cc_ev = ev } <- ct
, isGiven ev = extendVarSet fsks tv
| otherwise = fsks
skol_tv_set = mkVarSet skol_tvs skol_tv_set = mkVarSet skol_tvs
skolem_bound_here local_fsks tv -- See Note [Let-bound skolems] skolem_bound_here tv -- See Note [Let-bound skolems]
= case tcTyVarDetails tv of = case tcTyVarDetails tv of
SkolemTv {} -> tv `elemVarSet` skol_tv_set SkolemTv {} -> tv `elemVarSet` skol_tv_set
FlatSkol {} -> not (tv `elemVarSet` local_fsks)
_ -> False _ -> False
-- | Returns Given constraints that might, -- | Returns Given constraints that might,
...@@ -1889,9 +1891,11 @@ matchableGivens loc_w pred (IS { inert_cans = inert_cans }) ...@@ -1889,9 +1891,11 @@ matchableGivens loc_w pred (IS { inert_cans = inert_cans })
-- bindable when unifying with givens. That ensures that we -- bindable when unifying with givens. That ensures that we
-- conservatively assume that a meta tyvar might get unified with -- conservatively assume that a meta tyvar might get unified with
-- something that matches the 'given', until demonstrated -- something that matches the 'given', until demonstrated
-- otherwise. -- otherwise. More info in Note [Instance and Given overlap]
bind_meta_tv tv | isMetaTyVar tv = BindMe -- in TcInteract
| otherwise = Skolem bind_meta_tv tv | isMetaTyVar tv
, not (isFskTyVar tv) = BindMe
| otherwise = Skolem
prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool
-- See Note [Solving superclass constraints] in TcInstDcls -- See Note [Solving superclass constraints] in TcInstDcls
...@@ -2413,6 +2417,8 @@ runTcSWithEvBinds ev_binds_var tcs ...@@ -2413,6 +2417,8 @@ runTcSWithEvBinds ev_binds_var tcs
; when (count > 0) $ ; when (count > 0) $
csTraceTcM $ return (text "Constraint solver steps =" <+> int count) csTraceTcM $ return (text "Constraint solver steps =" <+> int count)
; unflattenGivens inert_var
#if defined(DEBUG) #if defined(DEBUG)
; ev_binds <- TcM.getTcEvBindsMap ev_binds_var ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
; checkForCyclicBinds ev_binds ; checkForCyclicBinds ev_binds
...@@ -2420,6 +2426,7 @@ runTcSWithEvBinds ev_binds_var tcs ...@@ -2420,6 +2426,7 @@ runTcSWithEvBinds ev_binds_var tcs
; return res } ; return res }
</