Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.4
http://hackage.haskell.org/trac/ghc/changeset/4703ff3b67ccbd8007ebe81f7d00aabacec6d243 >--------------------------------------------------------------- commit 4703ff3b67ccbd8007ebe81f7d00aabacec6d243 Author: Ian Lynagh <[email protected]> Date: Tue Jan 24 20:17:31 2012 +0000 MERGED: Do not combine dictionaries in the EvVarCache when simplEqsOnly is on commit f002a461768cb334355c17053dcd331aa9ed1e06 Author: Simon Peyton Jones <[email protected]> Date: Tue Jan 17 12:15:26 2012 +0000 Do not combine dictionaries in the EvVarCache when simplEqsOnly is on This fixes Trac #5776; the background is in Note [Simplifying RULE lhs constraints] in TcSimplify >--------------------------------------------------------------- compiler/typecheck/TcInteract.lhs | 57 ++++++++++++++++++++++++------------ 1 files changed, 38 insertions(+), 19 deletions(-) diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 93f499a..a579b87 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -96,25 +96,44 @@ solveInteractCts cts ; setTcSEvVarCacheMap new_evvar_cache ; updWorkListTcS (appendWorkListCt cts_thinner) >> solveInteract } - where add_cts_in_cache evvar_cache = foldM solve_or_cache ([],evvar_cache) - solve_or_cache :: ([Ct],TypeMap (EvVar,CtFlavor)) - -> Ct - -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) - solve_or_cache (acc_cts,acc_cache) ct - | isIPPred pty - = return (ct:acc_cts,acc_cache) -- Do not use the cache, - -- nor update it for IPPreds due to subtle shadowing - | Just (ev',fl') <- lookupTM pty acc_cache - , fl' `canSolve` fl - , isWanted fl - = do { _ <- setEvBind ev (EvId ev') fl - ; return (acc_cts,acc_cache) } - | otherwise -- If it's a given keep it in the work list, even if it exists in the cache! - = return (ct:acc_cts, alterTM pty (\_ -> Just (ev,fl)) acc_cache) - where fl = cc_flavor ct - ev = cc_id ct - pty = ctPred ct - + where + add_cts_in_cache evvar_cache cts + = do { ctxt <- getTcSContext + ; foldM (solve_or_cache (simplEqsOnly ctxt)) ([],evvar_cache) cts } + + solve_or_cache :: Bool -- Solve equalities only, not classes etc + -> ([Ct],TypeMap (EvVar,CtFlavor)) + -> Ct + -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) + solve_or_cache eqs_only (acc_cts,acc_cache) ct + | dont_cache eqs_only (classifyPredType pred_ty) + = return (ct:acc_cts,acc_cache) + + | Just (ev',fl') <- lookupTM pred_ty acc_cache + , fl' `canSolve` fl + , isWanted fl + = do { _ <- setEvBind ev (EvId ev') fl + ; return (acc_cts,acc_cache) } + + | otherwise -- If it's a given keep it in the work list, even if it exists in the cache! + = return (ct:acc_cts, alterTM pred_ty (\_ -> Just (ev,fl)) acc_cache) + where fl = cc_flavor ct + ev = cc_id ct + pred_ty = ctPred ct + + dont_cache :: Bool -> PredTree -> Bool + -- Do not use the cache, not update it, if this is true + dont_cache _ (IPPred {}) = True -- IPPreds have subtle shadowing + dont_cache _ (EqPred ty1 ty2) -- Report Int ~ Bool errors separately + | Just tc1 <- tyConAppTyCon_maybe ty1 + , Just tc2 <- tyConAppTyCon_maybe ty2 + , tc1 /= tc2 + = isDecomposableTyCon tc1 && isDecomposableTyCon tc2 + | otherwise = False + dont_cache eqs_only _ = eqs_only + -- If we are simplifying equalities only, + -- do not cache non-equalities + -- See Note [Simplifying RULE lhs constraints] in TcSimplify solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () solveInteractGiven gloc evs _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
