Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : tc-untouchables
http://hackage.haskell.org/trac/ghc/changeset/453e0ce0733fb71eaf594f1ed1a72cacb919f9cb >--------------------------------------------------------------- commit 453e0ce0733fb71eaf594f1ed1a72cacb919f9cb Author: Simon Peyton Jones <simo...@microsoft.com> Date: Mon Oct 1 10:40:35 2012 +0100 Modest refactoring in TcCanonical (and TcSMonad) >--------------------------------------------------------------- compiler/typecheck/TcCanonical.lhs | 41 +++++++++++++++--------------------- compiler/typecheck/TcSMonad.lhs | 25 +++++++++++++++------- 2 files changed, 34 insertions(+), 32 deletions(-) diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 18bfe2b..a966a39 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -247,20 +247,15 @@ canClassNC d ev cls tys `andWhenContinue` emitSuperclasses canClass d ev cls tys - = do { -- sctx <- getTcSContext - ; (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys + = do { (xis, cos) <- flattenMany d FMFullFlatten (ctEvFlavour ev) tys ; let co = mkTcTyConAppCo (classTyCon cls) cos xi = mkClassPred cls xis - ; mb <- rewriteCtFlavor ev xi co - ; case mb of - Just new_ev -> - let (ClassPred cls xis_for_dict) = classifyPredType (ctEvPred new_ev) - in continueWith $ - CDictCan { cc_ev = new_ev, cc_loc = d - , cc_tyargs = xis_for_dict, cc_class = cls } - Nothing -> return Stop } + Nothing -> return Stop + Just new_ev -> continueWith $ + CDictCan { cc_ev = new_ev, cc_loc = d + , cc_tyargs = xis, cc_class = cls } } emitSuperclasses :: Ct -> TcS StopOrContinue emitSuperclasses ct@(CDictCan { cc_loc = d, cc_ev = ev @@ -567,24 +562,22 @@ flatten loc f ctxt (TyConApp tc tys) , cc_tyargs = xi_args , cc_rhs = rhs_ty , cc_loc = loc } - ; updWorkListTcS $ extendWorkListEq ct + ; updWorkListTcS $ extendWorkListFunEq ct ; return (co, rhs_ty) } | otherwise -- Wanted or Derived: make new unification variable -> do { traceTcS "flatten/flat-cache miss" $ empty ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) - ; let pred = mkTcEqPred fam_ty rhs_xi_var - ; mw <- newWantedEvVar pred - ; case mw of - Fresh ctev -> - do { let ct = CFunEqCan { cc_ev = ctev - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_loc = loc } - ; updWorkListTcS $ extendWorkListEq ct - ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) } - Cached {} -> panic "flatten TyConApp, var must be fresh!" } + ; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_xi_var) + -- NC (no-cache) version because we've already + -- looked in the solved goals an inerts (lookupFlatEqn) + ; let ct = CFunEqCan { cc_ev = ctev + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_xi_var + , cc_loc = loc } + ; updWorkListTcS $ extendWorkListFunEq ct + ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var) } } -- Emit the flat constraints ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable @@ -1149,7 +1142,7 @@ canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2 Nothing -> return Stop ; Just new_ev | isTcReflCo xco -> continueWith new_ct - | otherwise -> do { updWorkListTcS (extendWorkListEq new_ct); return Stop } + | otherwise -> do { updWorkListTcS (extendWorkListFunEq new_ct); return Stop } where new_ct = CFunEqCan { cc_ev = new_ev, cc_loc = loc , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } } diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 7324798..43457f4 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -13,7 +13,8 @@ module TcSMonad ( WorkList(..), isEmptyWorkList, emptyWorkList, workListFromEq, workListFromNonEq, workListFromCt, - extendWorkListEq, extendWorkListNonEq, extendWorkListCt, + extendWorkListEq, extendWorkListFunEq, + extendWorkListNonEq, extendWorkListCt, extendWorkListCts, extendWorkListEqs, appendWorkList, selectWorkItem, withWorkList, @@ -46,7 +47,7 @@ module TcSMonad ( xCtFlavor, -- Transform a CtEvidence during a step rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions - newWantedEvVar, instDFunConstraints, + newWantedEvVar, newWantedEvVarNC, instDFunConstraints, newDerived, -- Creation of evidence variables @@ -237,10 +238,14 @@ extendWorkListEq :: Ct -> WorkList -> WorkList -- Extension by equality extendWorkListEq ct wl | Just {} <- isCFunEqCan_Maybe ct - = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) } + = extendWorkListFunEq ct wl | otherwise = wl { wl_eqs = ct : wl_eqs wl } +extendWorkListFunEq :: Ct -> WorkList -> WorkList +extendWorkListFunEq ct wl + = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) } + extendWorkListEqs :: [Ct] -> WorkList -> WorkList -- Append a list of equalities extendWorkListEqs cts wl = foldr extendWorkListEq wl cts @@ -1404,6 +1409,12 @@ newGivenEvVar pred rhs ; setEvBind new_ev rhs ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev }) } +newWantedEvVarNC :: TcPredType -> TcS CtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC pty + = do { new_ev <- wrapTcS $ TcM.newEvVar pty + ; return (CtWanted { ctev_pred = pty, ctev_evar = new_ev })} + newWantedEvVar :: TcPredType -> TcS MaybeNew newWantedEvVar pty = do { mb_ct <- lookupInInerts pty @@ -1411,10 +1422,8 @@ newWantedEvVar pty Just ctev | not (isDerived ctev) -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev ; return (Cached (ctEvTerm ctev)) } - _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty - ; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev - ; let ctev = CtWanted { ctev_pred = pty - , ctev_evar = new_ev } + _ -> do { ctev <- newWantedEvVarNC pty + ; traceTcS "newWantedEvVar/cache miss" $ ppr ctev ; return (Fresh ctev) } } newDerived :: TcPredType -> TcS (Maybe CtEvidence) @@ -1471,7 +1480,7 @@ See Note [Coercion evidence terms] in TcEvidence. \begin{code} -xCtFlavor :: CtEvidence -- Original flavor +xCtFlavor :: CtEvidence -- Original flavor -> [TcPredType] -- New predicate types -> XEvTerm -- Instructions about how to manipulate evidence -> TcS [CtEvidence] _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
