Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/b6264a6b8a8e22e24464da39ca0a3a0176d91f4e >--------------------------------------------------------------- commit b6264a6b8a8e22e24464da39ca0a3a0176d91f4e Author: Dimitrios Vytiniotis <[email protected]> Date: Wed May 18 10:13:55 2011 +0100 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. >--------------------------------------------------------------- compiler/typecheck/TcCanonical.lhs | 9 +++++---- compiler/typecheck/TcSMonad.lhs | 4 +++- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 435cfc4..711c356 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -94,6 +94,7 @@ multiple times. \begin{code} + -- Flatten a bunch of types all at once. flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts) -- Coercions :: Xi ~ Type @@ -112,7 +113,7 @@ flatten ctxt ty -- Preserve type synonyms if possible -- We can tell if ty' is function-free by -- whether there are any floated constraints - ; if isEmptyCCan ccs then + ; if isIdentityCoercion co then return (ty, ty, emptyCCan) 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 - ; 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 @@ -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 - 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 @@ -842,7 +843,7 @@ canEqLeafTyVarLeft fl cv tv s2 -- cv : tv ~ s2 ; 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 diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 8a63e86..f527ff7 100644 --- 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 - ; 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
