[commit: ghc] master: Do not combine dictionaries in the EvVarCache when simplEqsOnly is on (f002a46)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/f002a461768cb334355c17053dcd331aa9ed1e06

>---------------------------------------------------------------

commit f002a461768cb334355c17053dcd331aa9ed1e06
Author: Simon Peyton Jones <simonpj at microsoft.com>
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 |   67 +++++++++++++++++++++----------------
 1 files changed, 38 insertions(+), 29 deletions(-)

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index c830277..3b46af4 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -98,35 +98,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
-          | dont_cache (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 :: 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
-        dont_cache _ = False
+  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