Improved caching: I was flushing the solved when going under implications,

this was the reason for the regression of T3064.

2 files changed, 31 insertions, 23 deletions

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 42b4f747f8..01dcda803a 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1597,12 +1597,18 @@ doTopReact _inerts _workItem = return NoTopInt
 
 lkpFunEqCache :: TcType -> TcS (Maybe Ct)
 lkpFunEqCache fam_head 
-  = do { (subst,_inscope) <- getInertEqs 
+  = do { (_subst,_inscope) <- getInertEqs 
        ; fun_cache <- getTcSInerts >>= (return . inert_solved_funeqs)
        ; traceTcS "lkpFunEqCache" $ vcat [ text "fam_head    =" <+> ppr fam_head
                                          , text "funeq cache =" <+> pprCtTypeMap (unCtFamHeadMap fun_cache) ]
        ; rewrite_cached $ 
-         lookupTypeMap_mod subst cc_rhs fam_head (unCtFamHeadMap fun_cache) }
+         lookupTM fam_head (unCtFamHeadMap fun_cache) }
+-- The two different calls do not seem to make a significant difference in 
+-- terms of hit/miss rate for many memory-critical/performance tests but the
+-- latter blows up the space on the heap somehow ... It maybe the niFixTvSubst.
+-- So, I am simply disabling it for now, until we investigate a bit more.
+--       lookupTypeMap_mod subst cc_rhs fam_head (unCtFamHeadMap fun_cache) }
+ 
   where rewrite_cached Nothing = return Nothing
         rewrite_cached (Just ct@(CFunEqCan { cc_flavor = fl, cc_depth = d
                                            , cc_fun = tc, cc_tyargs = xis
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 4c53dc4454..33a049e9b0 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -604,7 +604,11 @@ modifyInertTcS upd
 
 
 addToSolved :: Ct -> TcS ()
-addToSolved ct 
+-- Don't do any caching for IP preds because of delicate shadowing
+addToSolved ct
+  | isIPPred (ctPred ct)  
+  = return () 
+  | otherwise
   = ASSERT ( isSolved (cc_flavor ct) )
     updInertSetTcS ct
 
@@ -637,8 +641,10 @@ extractUnsolved (IS { inert_cans = IC { inert_eqs    = eqs
                                       , inert_dicts  = dicts
                                       }
                     , inert_frozen = frozen
-                    , inert_solved = _solved
-                    , inert_flat_cache = _flat_cache })
+                    , inert_solved = solved
+                    , inert_flat_cache = flat_cache 
+                    , inert_solved_funeqs = funeq_cache
+                    })
   
   = let is_solved  = IS { inert_cans = IC { inert_eqs    = solved_eqs
                                           , inert_eq_tvs = eq_tvs
@@ -648,15 +654,12 @@ extractUnsolved (IS { inert_cans = IC { inert_eqs    = eqs
                                           , inert_funeqs = solved_funeqs }
                         , inert_frozen = emptyCts -- All out
                                          
-                            -- DV: For solved and the flat cache, I am flushing them here:
-                            -- Solved cts may depend on wanteds which we kick out. But later
-                            -- we may try to re-solve some kicked-out wanteds and I am worried 
-                            -- that there is a danger or evidence loops if we keep the solved 
-                            -- in for caching purposes. So I am flushing the solved and the 
-                            -- flattening cache, quite conservatively.
-                        , inert_solved        = CtPredMap emptyTM
-                        , inert_flat_cache    = CtFamHeadMap emptyTM
-                        , inert_solved_funeqs = CtFamHeadMap emptyTM
+                              -- At some point, I used to flush all the solved, in 
+                              -- fear of evidence loops. But I think we are safe, 
+                              -- flushing is why T3064 had become slower
+                        , inert_solved        = solved      -- CtPredMap emptyTM
+                        , inert_flat_cache    = flat_cache  -- CtFamHeadMap emptyTM
+                        , inert_solved_funeqs = funeq_cache -- CtFamHeadMap emptyTM
                         }
     in ((frozen, unsolved), is_solved)
 
@@ -1287,18 +1290,17 @@ setEvBind ev t
        ; traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr ev
                                      , text "t  =" <+> ppr t ]
 
-#ifdef DEBUG
+#ifndef DEBUG
+       ; return () }
+#else
        ; binds <- getTcEvBindsMap
        ; let cycle = any (reaches binds) (evVarsOfTerm t)
-       ; when cycle (fail_if_co_loop binds)
-#endif
-       ; return () }
+       ; when cycle (fail_if_co_loop binds) }
 
-#ifdef DEBUG
   where fail_if_co_loop binds
-          = pprTrace "setEvBind" (vcat [ text "Cycle in evidence binds, evvar =" <+> ppr ev
-                                       , ppr (evBindMapBinds binds) ]) $
-            when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!"))
+          = do { traceTcS "Cycle in evidence binds" $ vcat [ text "evvar =" <+> ppr ev
+                                                           , ppr (evBindMapBinds binds) ]
+               ; when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) }
 
         reaches :: EvBindMap -> Var -> Bool 
         -- Does this evvar reach ev? 
@@ -1453,7 +1455,7 @@ matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcT
 matchClass clas tys
   = do	{ let pred = mkClassPred clas tys 
         ; instEnvs <- getInstEnvs
-        ; traceTcS "matchClass" $ text "instEnvs=" <+> ppr instEnvs
+--        ; traceTcS "matchClass" $ empty -- text "instEnvs=" <+> ppr instEnvs
         ; case lookupInstEnv instEnvs clas tys of {
             ([], unifs, _)               -- Nothing matches  
                 -> do { traceTcS "matchClass not matching"