Commit bee4cdad authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot

Remove second tcLookupTcTyCon in tcDataDefn

Before this patch, tcDataDefn used to call tcLookupTcTyCon twice in a row:
	1. in bindTyClTyVars itself
	2. in the continuation passed to it

Now bindTyClTyVars passes the TcTyCon to the continuation, making
the second lookup unnecessary.
parent 93c88c26
Pipeline #16722 passed with stages
in 853 minutes and 25 seconds
......@@ -2748,7 +2748,7 @@ tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec
--------------------------------------
bindTyClTyVars :: Name
-> ([TyConBinder] -> Kind -> TcM a) -> TcM a
-> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a
-- ^ Used for the type variables of a type or class decl
-- in the "kind checking" and "type checking" pass,
-- but not in the initial-kind run.
......@@ -2759,7 +2759,7 @@ bindTyClTyVars tycon_name thing_inside
binders = tyConBinders tycon
; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)
; tcExtendNameTyVarEnv scoped_prs $
thing_inside binders res_kind }
thing_inside tycon binders res_kind }
{- *********************************************************************
......
......@@ -1536,20 +1536,20 @@ kcTyClDecl (DataDecl { tcdLName = (L _ name)
| HsDataDefn { dd_ctxt = ctxt
, dd_cons = cons
, dd_ND = new_or_data } <- defn
= bindTyClTyVars name $ \ _ _ ->
= bindTyClTyVars name $ \ _ _ _ ->
do { _ <- tcHsContext ctxt
; kcConDecls new_or_data (tyConResKind tyCon) cons
}
kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon
= bindTyClTyVars name $ \ _ res_kind ->
= bindTyClTyVars name $ \ _ _ res_kind ->
discardResult $ tcCheckLHsType rhs res_kind
-- NB: check against the result kind that we allocated
-- in inferInitialKinds.
kcTyClDecl (ClassDecl { tcdLName = L _ name
, tcdCtxt = ctxt, tcdSigs = sigs }) _tycon
= bindTyClTyVars name $ \ _ _ ->
= bindTyClTyVars name $ \ _ _ _ ->
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM_ kc_sig) sigs }
where
......@@ -2017,7 +2017,7 @@ tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn
tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
= fixM $ \ clas ->
-- We need the knot because 'clas' is passed into tcClassATs
bindTyClTyVars class_name $ \ binders res_kind ->
bindTyClTyVars class_name $ \ _ binders res_kind ->
do { checkClassKindSig res_kind
; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)
; let tycon_name = class_name -- We use the same name
......@@ -2298,7 +2298,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
, fdResultSig = L _ sig
, fdInjectivityAnn = inj })
| DataFamily <- fam_info
= bindTyClTyVars tc_name $ \ binders res_kind -> do
= bindTyClTyVars tc_name $ \ _ binders res_kind -> do
{ traceTc "data family:" (ppr tc_name)
; checkFamFlag tc_name
......@@ -2324,7 +2324,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
; return tycon }
| OpenTypeFamily <- fam_info
= bindTyClTyVars tc_name $ \ binders res_kind -> do
= bindTyClTyVars tc_name $ \ _ binders res_kind -> do
{ traceTc "open type family:" (ppr tc_name)
; checkFamFlag tc_name
; inj' <- tcInjectivity binders inj
......@@ -2341,7 +2341,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
-- the variables in the header scope only over the injectivity
-- declaration but this is not involved here
; (inj', binders, res_kind)
<- bindTyClTyVars tc_name $ \ binders res_kind ->
<- bindTyClTyVars tc_name $ \ _ binders res_kind ->
do { inj' <- tcInjectivity binders inj
; return (inj', binders, res_kind) }
......@@ -2439,7 +2439,7 @@ tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames)))
tcTySynRhs :: RolesInfo -> Name
-> LHsType GhcRn -> TcM TyCon
tcTySynRhs roles_info tc_name hs_ty
= bindTyClTyVars tc_name $ \ binders res_kind ->
= bindTyClTyVars tc_name $ \ _ binders res_kind ->
do { env <- getLclEnv
; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
; rhs_ty <- pushTcLevelM_ $
......@@ -2460,7 +2460,10 @@ tcDataDefn err_ctxt roles_info tc_name
-- via inferInitialKinds
, dd_cons = cons
, dd_derivs = derivs })
= bindTyClTyVars tc_name $ \ tycon_binders res_kind ->
= bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind ->
-- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need
-- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'
--
-- The TyCon tyvars must scope over
-- - the stupid theta (dd_ctxt)
-- - for H98 constructors only, the ConDecl
......@@ -2503,9 +2506,6 @@ tcDataDefn err_ctxt roles_info tc_name
stupid_theta tc_rhs
(VanillaAlgTyCon tc_rep_nm)
gadt_syntax) }
; tctc <- tcLookupTcTyCon tc_name
-- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need
-- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'
; let deriv_info = DerivInfo { di_rep_tc = tycon
, di_scoped_tvs = tcTyConScopedTyVars tctc
, di_clauses = unLoc derivs
......
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