From b10d7d079ec9c3fc22d4700fe484dd297bddb805 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 21 Oct 2010 07:08:37 +0000 Subject: [PATCH 1/1] Tidy-up sweep, following the Great Skolemisation Simplification --- compiler/typecheck/TcArrows.lhs | 9 ++++---- compiler/typecheck/TcBinds.lhs | 11 +++++----- compiler/typecheck/TcClassDcl.lhs | 3 +-- compiler/typecheck/TcExpr.lhs | 4 ++-- compiler/typecheck/TcInstDcls.lhs | 7 +++---- compiler/typecheck/TcMatches.lhs | 13 ++++++------ compiler/typecheck/TcPat.lhs | 41 ++++++++----------------------------- compiler/typecheck/TcRnTypes.lhs | 6 +++++- compiler/typecheck/TcSplice.lhs | 2 +- compiler/typecheck/TcUnify.lhs | 39 +++++++++++++++-------------------- 10 files changed, 54 insertions(+), 81 deletions(-) diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 14e561b..227c6ce 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -48,7 +48,7 @@ tcProc pat cmd exp_ty do { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty ; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat arg_ty res_ty $ + ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ tcCmdTop cmd_env cmd [] res_ty ; let res_coi = mkTransCoI coi (mkAppTyCoI coi1 (IdCo res_ty)) ; return (pat', cmd', res_coi) } @@ -180,8 +180,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig (kappaUnderflow cmd) -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats cmd_stk res_ty $ + ; (pats', grhss') <- setSrcSpan mtch_loc $ + tcPats LambdaExpr pats cmd_stk $ tc_grhss grhss res_ty ; let match' = L mtch_loc (Match pats' Nothing grhss') @@ -241,10 +241,9 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- -> a ((w,t1) .. tn) t ; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys] e_res_ty - free_tvs = tyVarsOfTypes (res_ty:cmd_stk) -- Check expr - ; (inst_binds, expr') <- checkConstraints ArrowSkol free_tvs [w_tv] [] $ + ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ escapeArrowScope (tcMonoExpr expr e_ty) -- OK, now we are in a position to unscramble diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index b1ad0d4..638f692 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -130,14 +130,12 @@ tcLocalBinds (HsValBinds binds) thing_inside tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside = do { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds - ; let ip_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet given_ips -- If the binding binds ?x = E, we must now -- discharge any ?x constraints in expr_lie + -- See Note [Implicit parameter untouchables] ; (ev_binds, result) <- checkConstraints (IPSkol ips) - ip_tvs -- See Note [Implicit parameter untouchables] - [] given_ips $ - thing_inside + [] given_ips thing_inside ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) } where @@ -164,6 +162,9 @@ doesn't float that solved constraint out (it's not an unsolved wanted. Result disaster: the (Num alpha) is again solved, this time by defaulting. No no no. +However [Oct 10] this is all handled automatically by the +untouchable-range idea. + \begin{code} tcValBinds :: TopLevelFlag -> HsValBinds Name -> TcM thing @@ -393,7 +394,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped ; let skol_info = SigSkol (FunSigCtxt (idName id)) ; (ev_binds, (binds', [mono_info])) - <- checkConstraints skol_info emptyVarSet tvs ev_vars $ + <- checkConstraints skol_info tvs ev_vars $ tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $ tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 1a5697e..839a5a2 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -35,7 +35,6 @@ import MkId import Id import Name import Var -import VarSet import NameEnv import NameSet import Outputable @@ -255,7 +254,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars -- NB: the binding is always a FunBind ; (ev_binds, (tc_bind, _)) - <- checkConstraints skol_info emptyVarSet tyvars full_given $ + <- checkConstraints skol_info tyvars full_given $ tcExtendIdEnv [local_meth_id] $ tcPolyBinds TopLevel meth_sig_fn no_prag_fn NonRecursive NonRecursive diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 531b1b0..7205287 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -82,7 +82,7 @@ tcPolyExpr expr res_ty tcPolyExprNC expr res_ty = do { traceTc "tcPolyExprNC" (ppr res_ty) - ; (gen_fn, expr') <- tcGen (GenSkol res_ty) emptyVarSet res_ty $ \ _ rho -> + ; (gen_fn, expr') <- tcGen (GenSkol res_ty) res_ty $ \ _ rho -> tcMonoExprNC expr rho ; return (mkLHsWrap gen_fn expr') } @@ -191,7 +191,7 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty -- Remember to extend the lexical type-variable environment ; (gen_fn, expr') - <- tcGen (SigSkol ExprSigCtxt) emptyVarSet sig_tc_ty $ \ skol_tvs res_ty -> + <- tcGen (SigSkol ExprSigCtxt) sig_tc_ty $ \ skol_tvs res_ty -> tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ -- See Note [More instantiated than scoped] in TcBinds tcMonoExprNC expr res_ty diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 76ba66f..4e40be3 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -33,7 +33,6 @@ import TyCon import DataCon import Class import Var -import VarSet ( emptyVarSet ) import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var) ) @@ -638,7 +637,7 @@ tc_inst_decl2 dfun_id inst_binds mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts) -- NOT FINISHED! - ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol emptyVarSet + ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol inst_tyvars' dfun_ev_vars $ emitWanteds ScOrigin sc_eqs @@ -707,7 +706,7 @@ tcSuperClass tyvars dicts self_ev_bind@(EvBind self_dict _) (sc_sel, sc_pred) = do { (ev_binds, wanted, sc_dict) - <- newImplication InstSkol emptyVarSet tyvars dicts $ + <- newImplication InstSkol tyvars dicts $ emitWanted ScOrigin sc_pred ; simplifySuperClass self_dict wanted @@ -970,7 +969,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- by the constraint solver, since the may be -- user-specified. - = do { rep_d_stuff <- checkConstraints InstSkol emptyVarSet tyvars dfun_ev_vars $ + = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $ emitWanted ScOrigin rep_pred ; mapAndUnzipM (tc_item rep_d_stuff) op_items } diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 1442ac6..a73b1d3 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -32,7 +32,6 @@ import TyCon import TysPrim import Coercion ( mkSymCoI ) import Outputable -import VarSet import BasicTypes ( Arity ) import Util import SrcLoc @@ -76,7 +75,7 @@ tcMatchesFun fun_name inf matches exp_ty ; checkArgs fun_name matches ; (wrap_gen, (wrap_fun, group)) - <- tcGen (SigSkol (FunSigCtxt fun_name)) emptyVarSet exp_ty $ \ _ exp_rho -> + <- tcGen (SigSkol (FunSigCtxt fun_name)) exp_ty $ \ _ exp_rho -> -- Note [Polymorphic expected type for tcMatchesFun] matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty matches @@ -186,7 +185,7 @@ tcMatch ctxt pat_tys rhs_ty match where tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss) = add_match_ctxt match $ - do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $ + do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ tc_grhss ctxt maybe_rhs_sig grhss rhs_ty ; return (Match pats' Nothing grhss') } @@ -345,7 +344,7 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty $ thing_inside res_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } @@ -363,7 +362,7 @@ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ thing_inside res_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } @@ -516,7 +515,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty) ; rhs' <- tcMonoExprNC rhs rhs_ty - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ thing_inside new_res_ty ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } @@ -600,7 +599,7 @@ tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference -> TcStmtChecker tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- tc_rhs rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ thing_inside res_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f8c98b5..7cb16de 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -32,7 +32,6 @@ import Coercion import StaticFlags import TyCon import DataCon -import VarSet ( emptyVarSet ) import PrelNames import BasicTypes hiding (SuccessFlag(..)) import DynFlags @@ -59,14 +58,13 @@ tcLetPat :: TcSigFun -> LetBndrSpec tcLetPat sig_fn no_gen pat pat_ty thing_inside = tc_lpat pat pat_ty penv thing_inside where - penv = PE { pe_res_tvs = emptyVarSet, pe_lazy = True + penv = PE { pe_lazy = True , pe_ctxt = LetPat sig_fn no_gen } ----------------- tcPats :: HsMatchContext Name -> [LPat Name] -- Patterns, -> [TcSigmaType] -- and their types - -> TcRhoType -- Result type, -> TcM a -- and the checker for the body -> TcM ([LPat TcId], a) @@ -81,39 +79,27 @@ tcPats :: HsMatchContext Name -- 3. Check the body -- 4. Check that no existentials escape -tcPats ctxt pats pat_tys res_ty thing_inside +tcPats ctxt pats pat_tys thing_inside = tc_lpats penv pats pat_tys thing_inside where - penv = PE { pe_res_tvs = tyVarsOfTypes (res_ty : pat_tys) - , pe_lazy = False - , pe_ctxt = LamPat ctxt } + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt } tcPat :: HsMatchContext Name -> LPat Name -> TcSigmaType - -> TcRhoType -- Result type -> TcM a -- Checker for body, given -- its result type -> TcM (LPat TcId, a) -tcPat ctxt pat pat_ty res_ty thing_inside +tcPat ctxt pat pat_ty thing_inside = tc_lpat pat pat_ty penv thing_inside where - penv = PE { pe_res_tvs = tyVarsOfTypes [res_ty, pat_ty] - , pe_lazy = False - , pe_ctxt = LamPat ctxt } + penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt } ----------------- data PatEnv - = PE { pe_res_tvs :: TcTyVarSet - -- For existential escape check; see Note [Existential check] - -- Nothing <=> inside a "~" - -- Just tvs <=> unification tvs free in the result - -- (which should be made untouchable in - -- any existentials we encounter in the pattern) - - , pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed + = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed , pe_ctxt :: PatCtxt -- Context in which the whole pattern appears - } + } data PatCtxt = LamPat -- Used for lambdas, case etc @@ -188,7 +174,7 @@ Note [Existential check] Lazy patterns can't bind existentials. They arise in two ways: * Let bindings let { C a b = e } in b * Twiddle patterns f ~(C a b) = e -The pe_res_tvs field of PatEnv says whether we are inside a lazy +The pe_lazy field of PatEnv says whether we are inside a lazy pattern (perhaps deeply) If we aren't inside a lazy pattern then we can bind existentials, @@ -736,17 +722,8 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside -- should require the GADT language flag ; given <- newEvVars theta' - ; let free_tvs = pe_res_tvs penv - -- Since we have done checkExistentials, - -- pe_res_tvs can only be Just at this point - -- - -- Nor do we need pat_ty, because we've put all the - -- unification variables in right at the start when - -- initialising the PatEnv; and the pattern itself - -- only adds skolems. - ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info free_tvs ex_tvs' given $ + <- checkConstraints skol_info ex_tvs' given $ tcConArgs data_con arg_tys' arg_pats penv thing_inside ; let res_pat = ConPatOut { pat_con = L con_span data_con, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 8f02da6..4abb408 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -28,7 +28,7 @@ module TcRnTypes( ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, -- Constraints - Untouchables(..), inTouchableRange, + Untouchables(..), inTouchableRange, isNoUntouchables, WantedConstraints, emptyWanteds, andWanteds, extendWanteds, WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc, wantedEvVarToVar, wantedEvVarPred, splitWanteds, @@ -698,6 +698,10 @@ instance Outputable Untouchables where ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+> ppr low <+> char '-' <+> ppr high +isNoUntouchables :: Untouchables -> Bool +isNoUntouchables NoUntouchables = True +isNoUntouchables (TouchableRange {}) = False + inTouchableRange :: Untouchables -> TcTyVar -> Bool inTouchableRange NoUntouchables _ = True inTouchableRange (TouchableRange low high) tv diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index b96307d..2a3bce6 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -395,7 +395,7 @@ tc_bracket _ (DecBrG decls) tc_bracket _ (PatBr pat) = do { any_ty <- newFlexiTyVarTy liftedTypeKind - ; _ <- tcPat ThPatQuote pat any_ty unitTy $ + ; _ <- tcPat ThPatQuote pat any_ty $ return () ; tcMetaTy patQTyConName } -- Result type is PatQ (= Q Pat) diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 529d624..ade2db0 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -304,9 +304,8 @@ tcSubType :: CtOrigin -> SkolemInfo -> TcSigmaType -> TcSigmaType -> TcM HsWrapp -- Returns a wrapper of shape ty_actual ~ ty_expected tcSubType origin skol_info ty_actual ty_expected | isSigmaTy ty_actual - = do { let extra_tvs = tyVarsOfType ty_actual - ; (sk_wrap, inst_wrap) - <- tcGen skol_info extra_tvs ty_expected $ \ _ sk_rho -> do + = do { (sk_wrap, inst_wrap) + <- tcGen skol_info ty_expected $ \ _ sk_rho -> do { (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual ; coi <- unifyType in_rho sk_rho ; return (coiToHsWrapper coi <.> in_wrap) } @@ -354,14 +353,14 @@ wrapFunResCoercion arg_tys co_fn_res %************************************************************************ \begin{code} -tcGen :: SkolemInfo -> TcTyVarSet -> TcType +tcGen :: SkolemInfo -> TcType -> ([TcTyVar] -> TcRhoType -> TcM result) -> TcM (HsWrapper, result) -- The expression has type: spec_ty -> expected_ty -tcGen skol_info extra_tvs - expected_ty thing_inside -- We expect expected_ty to be a forall-type - -- If not, the call is a no-op +tcGen skol_info expected_ty thing_inside + -- We expect expected_ty to be a forall-type + -- If not, the call is a no-op = do { traceTc "tcGen" empty ; (wrap, tvs', given, rho') <- deeplySkolemise skol_info expected_ty @@ -370,7 +369,7 @@ tcGen skol_info extra_tvs text "expected_ty" <+> ppr expected_ty, text "inst ty" <+> ppr tvs' <+> ppr rho' ] - -- In 'free_tvs' we must check that the "forall_tvs" havn't been constrained + -- Generally we must check that the "forall_tvs" havn't been constrained -- The interesting bit here is that we must include the free variables -- of the expected_ty. Here's an example: -- runST (newVar True) @@ -378,10 +377,12 @@ tcGen skol_info extra_tvs -- for (newVar True), with s fresh. Then we unify with the runST's arg type -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. -- So now s' isn't unconstrained because it's linked to a. - -- Conclusion: pass the free vars of the expected_ty to checkConsraints - ; let free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs + -- + -- However [Oct 10] now that the untouchables are a range of + -- TcTyVars, all tihs is handled automatically with no need for + -- extra faffing around - ; (ev_binds, result) <- checkConstraints skol_info free_tvs tvs' given $ + ; (ev_binds, result) <- checkConstraints skol_info tvs' given $ thing_inside tvs' rho' ; return (wrap <.> mkWpLet ev_binds, result) } @@ -389,36 +390,30 @@ tcGen skol_info extra_tvs -- often empty, in which case mkWpLet is a no-op checkConstraints :: SkolemInfo - -> TcTyVarSet -- Free variables (other than the type envt) - -- for the skolem escape check -> [TcTyVar] -- Skolems -> [EvVar] -- Given -> TcM result -> TcM (TcEvBinds, result) -checkConstraints skol_info free_tvs skol_tvs given thing_inside +checkConstraints skol_info skol_tvs given thing_inside | null skol_tvs && null given = do { res <- thing_inside; return (emptyTcEvBinds, res) } -- Just for efficiency. We check every function argument with -- tcPolyExpr, which uses tcGen and hence checkConstraints. | otherwise - = do { (ev_binds, wanted, result) <- newImplication skol_info free_tvs + = do { (ev_binds, wanted, result) <- newImplication skol_info skol_tvs given thing_inside ; emitConstraints wanted ; return (ev_binds, result) } -newImplication :: SkolemInfo -> TcTyVarSet -> [TcTyVar] +newImplication :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM result -> TcM (TcEvBinds, WantedConstraints, result) -newImplication skol_info _free_tvs skol_tvs given thing_inside +newImplication skol_info skol_tvs given thing_inside = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { -- gbl_tvs <- tcGetGlobalTyVars - -- ; free_tvs <- zonkTcTyVarsAndFV free_tvs - -- ; let untch = gbl_tvs `unionVarSet` free_tvs - - ; ((result, untch), wanted) <- captureConstraints $ + do { ((result, untch), wanted) <- captureConstraints $ captureUntouchables $ thing_inside -- 1.7.10.4