Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/f15977c24f2ec96ea324cc7e8122f17ffe8b931c >--------------------------------------------------------------- commit f15977c24f2ec96ea324cc7e8122f17ffe8b931c Author: Dimitrios.Vytiniotis <[email protected]> Date: Thu Apr 5 20:37:17 2012 +0100 Improved caching: I was flushing the solved when going under implications, this was the reason for the regression of T3064. >--------------------------------------------------------------- compiler/typecheck/TcInteract.lhs | 10 +++++++- compiler/typecheck/TcSMonad.lhs | 42 +++++++++++++++++++----------------- 2 files changed, 30 insertions(+), 22 deletions(-) diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 42b4f74..01dcda8 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 4c53dc4..33a049e 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -604,7 +604,11 @@ modifyInertTcS upd addToSolved :: Ct -> TcS () +-- 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" _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
