X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=801992c7addd9ecf0756946fb6ed7d5964fdc09c;hb=ef6d82a4e1d4ba4884c322be85cff291e017f0e6;hp=a76d87bdf234257b6e15fe8a919a8bca749c13ed;hpb=edeee10702955ca3c53444f2f328b4cce0ab3e32;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index a76d87b..801992c 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) ) @@ -617,7 +616,9 @@ tc_inst_decl2 dfun_id inst_binds -- to use in each method binding -- Why? See Note [Subtle interaction of recursion and overlap] ; let self_ev_bind = EvBind self_dict $ - EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars + EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars [] + -- Empty dependencies [], since it only + -- depends on "given" things -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] @@ -638,7 +639,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 @@ -696,7 +697,7 @@ tcSpecInstPrags dfun_id (VanillaInst binds uprags _) ------------------------------ tcSuperClass :: [TyVar] -> [EvVar] -> EvBind - -> (Id, PredType) -> TcM (Id, LHsBind Id) + -> (Id, PredType) -> TcM (Id, LHsBind Id) -- Build a top level decl like -- sc_op = /\a \d. let this = ... in -- let sc = ... in @@ -704,16 +705,10 @@ tcSuperClass :: [TyVar] -> [EvVar] -- The "this" part is just-in-case (discarded if not used) -- See Note [Recursive superclasses] tcSuperClass tyvars dicts - self_ev_bind@(EvBind self_dict _) - (sc_sel, sc_pred) - = do { (ev_binds, wanted, sc_dict) - <- newImplication InstSkol emptyVarSet tyvars dicts $ - emitWanted ScOrigin sc_pred - - ; simplifySuperClass self_dict wanted - -- We include self_dict in the 'givens'; the simplifier - -- is clever enough to stop sc_pred geting bound by just - -- selecting from self_dict!! + self_ev_bind + (sc_sel, sc_pred) + = do { sc_dict <- newWantedEvVar sc_pred + ; ev_binds <- simplifySuperClass tyvars dicts sc_dict self_ev_bind ; uniq <- newUnique ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict) @@ -724,8 +719,7 @@ tcSuperClass tyvars dicts , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict } sc_wrapper = mkWpTyLams tyvars <.> mkWpLams dicts - <.> mkWpLet (EvBinds (unitBag self_ev_bind)) - <.> mkWpLet ev_binds + <.> mkWpLet ev_binds ; return (sc_op_id, noLoc sc_op_bind) } \end{code} @@ -789,7 +783,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty) ; let spec_ty = mkSigmaTy tyvars theta tau ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) (idType dfun_id) spec_ty - ; return (SpecPrag co_fn defaultInlinePragma) } + ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) @@ -840,15 +834,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; let prags = prag_fn (idName sel_id) - ; meth_id1 <- addInlinePrags meth_id prags - ; spec_prags <- tcSpecPrags True meth_id prags - + ; meth_id1 <- addInlinePrags meth_id prags + ; spec_prags <- tcSpecPrags meth_id1 prags ; bind <- tcInstanceMethodBody InstSkol - tyvars dfun_ev_vars - mb_dict_ev - meth_id1 local_meth_id - meth_sig_fn - (SpecPrags (spec_inst_prags ++ spec_prags)) + tyvars dfun_ev_vars mb_dict_ev + meth_id1 local_meth_id meth_sig_fn + (mk_meth_spec_prags meth_id1 spec_prags) rn_bind ; return (meth_id1, bind) } @@ -898,7 +889,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [( tyvars, meth_id1, local_meth_id - , SpecPrags spec_inst_prags)] + , mk_meth_spec_prags meth_id1 [])] , abs_ev_binds = EvBinds (unitBag self_dict_ev) , abs_binds = unitBag meth_bind } -- Default methods in an instance declaration can't have their own @@ -909,6 +900,18 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; return (meth_id1, L loc bind) } ---------------------- + mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags + -- Adapt the SPECIALISE pragmas to work for this method Id + -- There are two sources: + -- * spec_inst_prags: {-# SPECIALISE instance :: #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper + -- * spec_prags_for_me: {-# SPECIALISE op :: #-} + mk_meth_spec_prags meth_id spec_prags_for_me + = SpecPrags (spec_prags_for_me ++ + [ L loc (SpecPrag meth_id wrap inl) + | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]) + loc = getSrcSpan dfun_id meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig" -- But there are no scoped type variables from local_method_id @@ -961,7 +964,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 }