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.

diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 435cfc4..711c356 100644 (file)
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -94,6 +94,7 @@ multiple times.
 
 
 \begin{code}
 
 
 \begin{code}

+

 -- Flatten a bunch of types all at once.
 flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
 -- Coercions :: Xi ~ Type 
 -- Flatten a bunch of types all at once.
 flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
 -- Coercions :: Xi ~ Type 

@@ -112,8 +113,8 @@ flatten ctxt ty
        -- Preserve type synonyms if possible
        -- We can tell if ty' is function-free by
        -- whether there are any floated constraints
        -- Preserve type synonyms if possible
        -- We can tell if ty' is function-free by
        -- whether there are any floated constraints

-       ; if isEmptyCCan ccs then
-             return (ty, ty, emptyCCan)  
+        ; if isIdentityCoercion co then
+             return (ty, ty, emptyCCan)

          else
              return (xi, co, ccs) }
 
          else
              return (xi, co, ccs) }
 

@@ -257,7 +258,7 @@ mkCanonical fl ev = case evVarPred ev of
 canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
 canClassToWorkList fl v cn tys 
   = do { (xis,cos,ccs) <- flattenMany fl tys  -- cos :: xis ~ tys
 canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
 canClassToWorkList fl v cn 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
        ; v_new <- if no_flattening_happened  then return v
                   else if isGivenOrSolved fl then return v
              dict_co = mkTyConCoercion (classTyCon cn) cos
        ; v_new <- if no_flattening_happened  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
        ; (xi2, co2, ccs2) <- flatten fl s2       -- Flatten entire RHS
                                                  -- co2  :: xi2 ~ s2
        ; let ccs = ccs1 `andCCan` ccs2
        ; (xi2, co2, ccs2) <- flatten fl s2       -- Flatten entire RHS
                                                  -- co2  :: xi2 ~ s2
        ; 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
                    else if isGivenOrSolved fl then return cv
                    else if isWanted fl then 
        ; cv_new <- if no_flattening_happened  then return cv
                    else if isGivenOrSolved fl then return cv
                    else if isWanted fl then 

@@ -842,7 +843,7 @@ canEqLeafTyVarLeft fl cv tv s2       -- cv : tv ~ s2
        ; case mxi2' of {
            Nothing   -> canEqFailure fl cv ;
            Just xi2' ->
        ; case mxi2' of {
            Nothing   -> canEqFailure fl cv ;
            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
                    else if isGivenOrSolved fl then return cv
                    else if isWanted fl then 
        ; cv_new <- if no_flattening_happened  then return cv
                    else if isGivenOrSolved fl then return cv
                    else if isWanted fl then 

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 8a63e86..f527ff7 100644 (file)
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -595,7 +595,9 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
                   -- outer ones!
 
        ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
                   -- outer ones!
 
        ; 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 
                             -- incomping constraint, but we must make sure that we
 
                             -- Consider copying the results the tcs_flat_map of the 
                             -- incomping constraint, but we must make sure that we