From 4703ff3b67ccbd8007ebe81f7d00aabacec6d243 Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Tue, 24 Jan 2012 20:17:31 +0000
Subject: [PATCH] MERGED: Do not combine dictionaries in the EvVarCache when
simplEqsOnly is on
commit f002a461768cb334355c17053dcd331aa9ed1e06
Author: Simon Peyton Jones <simonpj@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 | 57 ++++++++++++++++++++-----------
1 file changed, 38 insertions(+), 19 deletions(-)
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 93f499ad42e8..a579b87f0c63 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
--
GitLab