Commit b6264a6b authored by dimitris's avatar dimitris
Browse files

Fixes the way we check if flattening happened during

canonicalization. We now check whether the returned
coercion is an identity coercion. We used to check
whether we return any constraints from flattening but
that's wrong in the presence of the flattening cache.
parent 9591547f
...@@ -94,6 +94,7 @@ multiple times. ...@@ -94,6 +94,7 @@ multiple times.
\begin{code} \begin{code}
-- Flatten a bunch of types all at once. -- Flatten a bunch of types all at once.
flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts) flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
-- Coercions :: Xi ~ Type -- Coercions :: Xi ~ Type
...@@ -112,8 +113,8 @@ flatten ctxt ty ...@@ -112,8 +113,8 @@ flatten ctxt ty
-- Preserve type synonyms if possible -- Preserve type synonyms if possible
-- We can tell if ty' is function-free by -- We can tell if ty' is function-free by
-- whether there are any floated constraints -- whether there are any floated constraints
; if isEmptyCCan ccs then ; if isIdentityCoercion co then
return (ty, ty, emptyCCan) return (ty, ty, emptyCCan)
else else
return (xi, co, ccs) } return (xi, co, ccs) }
...@@ -257,7 +258,7 @@ mkCanonical fl ev = case evVarPred ev of ...@@ -257,7 +258,7 @@ mkCanonical fl ev = case evVarPred ev of
canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
canClassToWorkList fl v cn tys canClassToWorkList fl v cn tys
= do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys = do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys
; let no_flattening_happened = isEmptyCCan ccs ; let no_flattening_happened = all isIdentityCoercion cos
dict_co = mkTyConCoercion (classTyCon cn) cos dict_co = mkTyConCoercion (classTyCon cn) cos
; v_new <- if no_flattening_happened then return v ; v_new <- if no_flattening_happened then return v
else if isGivenOrSolved fl then return v else if isGivenOrSolved fl then return v
...@@ -796,7 +797,7 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1 ...@@ -796,7 +797,7 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2 -- cv : F tys1
; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS ; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS
-- co2 :: xi2 ~ s2 -- co2 :: xi2 ~ s2
; let ccs = ccs1 `andCCan` ccs2 ; let ccs = ccs1 `andCCan` ccs2
no_flattening_happened = isEmptyCCan ccs no_flattening_happened = all isIdentityCoercion (co2:cos1)
; cv_new <- if no_flattening_happened then return cv ; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv else if isGivenOrSolved fl then return cv
else if isWanted fl then else if isWanted fl then
...@@ -842,7 +843,7 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2 ...@@ -842,7 +843,7 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2
; case mxi2' of { ; case mxi2' of {
Nothing -> canEqFailure fl cv ; Nothing -> canEqFailure fl cv ;
Just xi2' -> Just xi2' ->
do { let no_flattening_happened = isEmptyCCan ccs2 do { let no_flattening_happened = isIdentityCoercion co
; cv_new <- if no_flattening_happened then return cv ; cv_new <- if no_flattening_happened then return cv
else if isGivenOrSolved fl then return cv else if isGivenOrSolved fl then return cv
else if isWanted fl then else if isWanted fl then
......
...@@ -595,7 +595,9 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) ...@@ -595,7 +595,9 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
-- outer ones! -- outer ones!
; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
; flat_cache_var <- TcM.newTcRef orig_flat_cache -- emptyFlatCache ; flat_cache_var <- TcM.newTcRef orig_flat_cache
-- One could be more conservative as well:
-- ; flat_cache_var <- TcM.newTcRef emptyFlatCache
-- Consider copying the results the tcs_flat_map of the -- Consider copying the results the tcs_flat_map of the
-- incomping constraint, but we must make sure that we -- incomping constraint, but we must make sure that we
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment