Commit e74fbf0c authored by dimitris's avatar dimitris

Started investigating how performance is affected and how intensively our caches are used.

parent bf334d28
......@@ -678,13 +678,15 @@ flatten d fl (TyConApp tc tys)
-- cache as well when we interact an equality with the inert.
-- The design choice is: do we keep the flat cache rewritten or not?
-- For now I say we don't keep it fully rewritten.
do { let rhs_xi = cc_rhs ct
do { traceTcS "flatten/flat-cache hit" $ ppr ct
; let rhs_xi = cc_rhs ct
; (flat_rhs_xi,co) <- flatten (cc_depth ct) (cc_flavor ct) rhs_xi
; let final_co = mkTcCoVarCo (ctId "flatten" ct) `mkTcTransCo` (mkTcSymCo co)
; let final_co = mkTcCoVarCo (ctId ct) `mkTcTransCo` (mkTcSymCo co)
; return (final_co, flat_rhs_xi,[]) }
_ | isGivenOrSolved fl -- Given or Solved: make new flatten skolem
-> do { rhs_xi_var <- newFlattenSkolemTy fam_ty
-> do { traceTcS "flatten/flat-cache miss" $ empty
; rhs_xi_var <- newFlattenSkolemTy fam_ty
; mg <- newGivenEvVar (mkTcEqPred fam_ty rhs_xi_var)
(EvCoercion (mkTcReflCo fam_ty))
; case mg of
......@@ -700,7 +702,8 @@ flatten d fl (TyConApp tc tys)
; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) }
Cached {} -> panic "flatten TyConApp, var must be fresh!" }
| otherwise -- Wanted or Derived: make new unification variable
-> do { rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
-> do { traceTcS "flatten/flat-cache miss" $ empty
; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
; mw <- newWantedEvVar (mkTcEqPred fam_ty rhs_xi_var)
; case mw of
Fresh eqv ->
......@@ -768,7 +771,7 @@ flattenTyVar d ctxt tv
where tv_eq_subst subst tv
| Just ct <- lookupVarEnv subst tv
, cc_flavor ct `canRewrite` ctxt
= Just (mkTcCoVarCo (ctId "tv_eq_subst" ct),cc_rhs ct)
= Just (mkTcCoVarCo (ctId ct),cc_rhs ct)
-- NB: even if ct is Derived we are not going to
-- touch the actual coercion so we are fine.
| otherwise = Nothing
......
......@@ -163,7 +163,7 @@ deferToRuntime ev_binds_var ctxt mk_err_msg ct
, Wanted loc _ <- fl
= do { err <- setCtLoc loc $
mk_err_msg ctxt ct
; let ev_id = ctId "deferToRuntime" ct -- Prec satisfied: Wanted
; let ev_id = ctId ct -- Prec satisfied: Wanted
err_msg = pprLocErrMsg err
err_fs = mkFastString $ showSDoc $
err_msg $$ text "(deferred type error)"
......
......@@ -52,6 +52,7 @@ import TrieMap
import VarEnv
import qualified Data.Traversable as Traversable
import Data.Maybe ( isJust )
import Control.Monad( when, unless )
import Pair ( pSnd )
......@@ -878,7 +879,7 @@ doInteractWithInert (CIPCan { cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 })
; case wfl of
Wanted {} ->
let ip_co = mkTcTyConAppCo (ipTyCon nm1) [mkTcCoVarCo cv]
in do { setEvBind (ctId "doInteractWithInert" workItem) $
in do { setEvBind (ctId workItem) $
mkEvCast (flav_evar ifl) (mkTcSymCo ip_co)
; irWorkItemConsumed "IP/IP (solved by rewriting)" }
_ -> pprPanic "Unexpected IP constraint" (ppr workItem) }
......@@ -1084,7 +1085,7 @@ solveOneFromTheOther info ifl workItem
; irWorkItemConsumed ("Solved " ++ info) }
where
wfl = cc_flavor workItem
wid = ctId "solveOneFromtheOther" workItem
wid = ctId workItem
iid = flav_evar ifl
\end{code}
......@@ -1683,11 +1684,13 @@ doTopReact _inerts workItem@(CFunEqCan { cc_flavor = fl, cc_depth = d
; case match_res of
Nothing -> return NoTopInt
Just (famInst, rep_tys)
-> do { traceTcS "doTopReact: Family instance matched, but looking in solved funeq cache first" $ empty
; mb_already_solved <- lkpFunEqCache (mkTyConApp tc args)
-> do { mb_already_solved <- lkpFunEqCache (mkTyConApp tc args)
; traceTcS "doTopReact: Family instance matches" $
vcat [ text "solved-fun-cache" <+> if isJust mb_already_solved then text "hit" else text "miss"
, text "workItem =" <+> ppr workItem ]
; let (coe,rhs_ty)
| Just cached_ct <- mb_already_solved
= (mkTcCoVarCo (ctId "doTopReact" cached_ct),
= (mkTcCoVarCo (ctId cached_ct),
cc_rhs cached_ct)
| otherwise
= let coe_ax = famInstAxiom famInst
......@@ -1730,7 +1733,8 @@ lkpFunEqCache :: TcType -> TcS (Maybe Ct)
lkpFunEqCache fam_head
= do { (subst,_inscope) <- getInertEqs
; fun_cache <- getTcSInerts >>= (return . inert_solved_funeqs)
; traceTcS "lkpFunEqCache" $ text "fam_head =" <+> ppr fam_head
; 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) }
where rewrite_cached Nothing = return Nothing
......
......@@ -920,9 +920,9 @@ ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi })
ctPred (CIrredEvCan { cc_ty = xi }) = xi
ctId :: String -> Ct -> EvVar
ctId :: Ct -> EvVar
-- Precondition: not a derived!
ctId origin ct = ctFlavId origin (cc_flavor ct)
ctId ct = ctFlavId (cc_flavor ct)
\end{code}
......@@ -1252,13 +1252,12 @@ ctFlavPred (Solved _ evar) = evVarPred evar
ctFlavPred (Wanted _ evar) = evVarPred evar
ctFlavPred (Derived { flav_der_pty = pty }) = pty
ctFlavId :: String -> CtFlavor -> EvVar
ctFlavId :: CtFlavor -> EvVar
-- Precondition: can't be derived
ctFlavId origin (Derived _ pty)
ctFlavId (Derived _ pty)
= pprPanic "ctFlavId: derived constraint cannot have id" $
vcat [ text "origin=" <+> text origin
, text "pty =" <+> ppr pty ]
ctFlavId _ fl = flav_evar fl
text "pty =" <+> ppr pty
ctFlavId fl = flav_evar fl
instance Outputable CtFlavor where
ppr fl = case fl of
......
......@@ -1340,7 +1340,7 @@ newGivenEvVar pty evterm
= do { is <- getTcSInerts
; case lookupInInerts is pty of
Just ct | isGivenOrSolvedCt ct
-> return (Cached (ctId "newGivenEvVar" ct))
-> return (Cached (ctId ct))
_ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty
; setEvBind new_ev evterm
; return (Fresh new_ev) } }
......@@ -1350,8 +1350,10 @@ newWantedEvVar pty
= do { is <- getTcSInerts
; case lookupInInerts is pty of
Just ct | not (isDerivedCt ct)
-> return (Cached (ctId "newWantedEvVar" ct))
-> do { traceTcS "newWantedEvVar/cache hit" $ ppr ct
; return (Cached (ctId ct)) }
_ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty
; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev
; return (Fresh new_ev) } }
newDerived :: TcPredType -> TcS (MaybeNew TcPredType)
......@@ -1812,6 +1814,6 @@ getCtCoercion bs ct
_ -> mkTcCoVarCo (setVarType cc_id (ctPred ct))
where cc_id = ctId "getCtCoercion" ct
where cc_id = ctId ct
\end{code}
......@@ -611,7 +611,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
-- Don't quantify over equalities (judgement call here)
; let (eqs, dicts) = partitionBag (isEqPred . ctPred)
(wc_flat lhs_results)
lhs_dicts = map (ctId "tcSimplify") (bagToList dicts)
lhs_dicts = map ctId (bagToList dicts)
-- Dicts and implicit parameters
-- NB: dicts come from lhs_results which
-- are all Wanted, hence have ids, hence
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment