X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=801992c7addd9ecf0756946fb6ed7d5964fdc09c;hb=081632b8f49b5afae43afa8b4fac9c2334e7a3ec;hp=e8182aca095bd6616b4708f03e87e2167fe3f035;hpb=0ccc12b6d176efe4a6d605864412deda75b62459;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index e8182ac..801992c 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -12,6 +12,7 @@ import HsSyn import TcBinds import TcTyClsDecls import TcClassDcl +import TcPat( addInlinePrags ) import TcRnMonad import TcMType import TcType @@ -32,7 +33,6 @@ import TyCon import DataCon import Class import Var -import VarSet ( emptyVarSet ) import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var) ) @@ -616,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] @@ -637,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 @@ -695,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 @@ -703,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) @@ -723,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} @@ -788,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) @@ -838,15 +833,13 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys = add_meth_ctxt sel_id generated_code rn_bind $ do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - ; (meth_id1, spec_prags) <- tcPrags NonRecursive False True - meth_id (prag_fn (idName sel_id)) - + ; let prags = prag_fn (idName sel_id) + ; 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) } @@ -896,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 @@ -907,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 @@ -959,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 } @@ -1029,7 +1034,7 @@ wrapId wrapper id = mkHsWrap wrapper (HsVar id) derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc derivBindCtxt sel_id clas tys _bind - = vcat [ ptext (sLit "When typechecking the code for ") <+> ppr sel_id + = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id) , nest 2 (ptext (sLit "in a standalone derived instance for") <+> quotes (pprClassPred clas tys) <> colon) , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]