X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=0ffc466e53f74b28b7832270a8df148bf2227d9f;hp=16ae6410f298ae8e92961ec697285a887e089311;hb=2a26efb65343e31957b043f63c43caf24d5eeb30;hpb=a3bab0506498db41853543558c52a4fda0d183af diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 16ae641..0ffc466 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -13,7 +13,6 @@ import TcBinds import TcTyClsDecls import TcClassDcl import TcPat( addInlinePrags ) -import TcSimplify( simplifyTop ) import TcRnMonad import TcMType import TcType @@ -183,13 +182,14 @@ Instead we use a cunning trick. Note [Single-method classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the class has just one method (or, more accurately, just one element -of {superclasses + methods}), then we still use the *same* strategy +of {superclasses + methods}), then we use a different strategy. class C a where op :: a -> a instance C a => C [a] where op = -We translate the class decl into a newtype, which just gives -a top-level axiom: +We translate the class decl into a newtype, which just gives a +top-level axiom. The "constructor" MkC expands to a cast, as does the +class-op selector. axiom Co:C a :: C a ~ (a->a) @@ -199,44 +199,82 @@ a top-level axiom: MkC :: forall a. (a->a) -> C a MkC = /\a.\op. op |> (sym Co:C a) - df :: forall a. C a => C [a] - {-# NOINLINE df DFun[ $cop_list ] #-} - df = /\a. \d. MkC ($cop_list a d) +The clever RULE stuff doesn't work now, because ($df a d) isn't +a constructor application, so exprIsConApp_maybe won't return +Just . - $cop_list :: forall a. C a => [a] -> [a] - $cop_list = +Instead, we simply rely on the fact that casts are cheap: -The "constructor" MkC expands to a cast, as does the class-op selector. -The RULE works just like for multi-field dictionaries: + $df :: forall a. C a => C [a] + {-# INLINE df #} -- NB: INLINE this + $df = /\a. \d. MkC [a] ($cop_list a d) + = $cop_list |> forall a. C a -> (sym (Co:C [a])) - * (df a d) returns (Just (MkC,..,[$cop_list a d])) - to exprIsConApp_Maybe + $cop_list :: forall a. C a => [a] -> [a] + $cop_list = - * The RULE for op picks the right result +So if we see + (op ($df a d)) +we'll inline 'op' and '$df', since both are simply casts, and +good things happen. -This is a bit of a hack, because (df a d) isn't *really* a constructor -application. But it works just fine in this case, exprIsConApp_maybe -is otherwise used only when we hit a case expression which will have -a real data constructor in it. +Why do we use this different strategy? Because otherwise we +end up with non-inlined dictionaries that look like + $df = $cop |> blah +which adds an extra indirection to every use, which seems stupid. See +Trac #4138 for an example (although the regression reported there +wasn't due to the indirction). -The biggest reason for doing it this way, apart from uniformity, is -that we want to be very careful when we have +There is an awkward wrinkle though: we want to be very +careful when we have instance C a => C [a] where {-# INLINE op #-} op = ... then we'll get an INLINE pragma on $cop_list but it's important that $cop_list only inlines when it's applied to *two* arguments (the -dictionary and the list argument +dictionary and the list argument). So we nust not eta-expand $df +above. We ensure that this doesn't happen by putting an INLINE +pragma on the dfun itself; after all, it ends up being just a cast. + +There is one more dark corner to the INLINE story, even more deeply +buried. Consider this (Trac #3772): + + class DeepSeq a => C a where + gen :: Int -> a + + instance C a => C [a] where + gen n = ... -The danger is that we'll get something like - op_list :: C a => [a] -> [a] - op_list = /\a.\d. $cop_list a d -and then we'll eta expand, and then we'll inline TOO EARLY. This happened in -Trac #3772 and I spent far too long fiddling around trying to fix it. -Look at the test for Trac #3772. + class DeepSeq a where + deepSeq :: a -> b -> b - (Note: re-reading the above, I can't see how using the - uniform story solves the problem.) + instance DeepSeq a => DeepSeq [a] where + {-# INLINE deepSeq #-} + deepSeq xs b = foldr deepSeq b xs + +That gives rise to these defns: + + $cdeepSeq :: DeepSeq a -> [a] -> b -> b + -- User INLINE( 3 args )! + $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... + + $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] + -- DFun (with auto INLINE pragma) + $fDeepSeq[] a d = $cdeepSeq a d |> blah + + $cp1 a d :: C a => DeepSep [a] + -- We don't want to eta-expand this, lest + -- $cdeepSeq gets inlined in it! + $cp1 a d = $fDeepSep[] a (scsel a d) + + $fC[] :: C a => C [a] + -- Ordinary DFun + $fC[] a d = MkC ($cp1 a d) ($cgen a d) + +Here $cp1 is the code that generates the superclass for C [a]. The +issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] +and then $cdeepSeq will inline there, which is definitely wrong. Like +on the dfun, we solve this by adding an INLINE pragma to $cp1. Note [Subtle interaction of recursion and overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -332,7 +370,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; let { (local_info, at_tycons_s) = unzip local_info_tycons ; at_idx_tycons = concat at_tycons_s ++ idx_tycons - ; clas_decls = filter (isClassDecl.unLoc) tycl_decls + ; clas_decls = filter (isClassDecl . unLoc) tycl_decls ; implicit_things = concatMap implicitTyThings at_idx_tycons ; aux_binds = mkRecSelBinds at_idx_tycons } @@ -359,12 +397,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- NB: class instance declarations can contain derivings as -- part of associated data type declarations failIfErrsM -- If the addInsts stuff gave any errors, don't - -- try the deriving stuff, becuase that may give + -- try the deriving stuff, because that may give -- more errors still - ; (deriv_inst_info, deriv_binds, deriv_dus) + ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) <- tcDeriving tycl_decls inst_decls deriv_decls - ; gbl_env <- addInsts deriv_inst_info getGblEnv - ; return ( addTcgDUs gbl_env deriv_dus, + + -- Extend the global environment also with the generated datatypes for + -- the generic representation + ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $ + tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $ + addInsts deriv_inst_info getGblEnv +-- ; traceTc "Generic deriving" (vcat (map pprInstInfo deriv_inst_info)) + ; return ( addTcgDUs gbl_env deriv_dus, generic_inst_info ++ deriv_inst_info ++ local_info, aux_binds `plusHsValBinds` deriv_binds) }}} @@ -582,7 +626,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) setSrcSpan loc $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do { -- Instantiate the instance decl with skolem constants - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id) + ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id) ; let (clas, inst_tys) = tcSplitDFunHead inst_head (class_tyvars, sc_theta, _, op_items) = classBigSig clas sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta @@ -594,20 +638,19 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; orig_ev_vars <- newEvVars orig_theta ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars - ; (sc_binds, sc_dicts, sc_args) - <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta' + ; (sc_dicts, sc_args) + <- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta' -- Check that any superclasses gotten from a silent arguemnt -- can be deduced from the originally-specified dfun arguments ; ct_loc <- getCtLoc ScOrigin ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $ - emitConstraints $ listToBag $ - [ WcEvVar (WantedEvVar sc ct_loc) - | sc <- sc_dicts, isSilentEvVar sc ] + emitFlats $ listToBag $ + [ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ] -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] - ; spec_info <- tcSpecInstPrags dfun_id ibinds + ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds -- Typecheck the methods ; (meth_ids, meth_binds) @@ -621,18 +664,19 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Create the result bindings ; self_dict <- newEvVar (ClassP clas inst_tys) - ; let dict_constr = classDataCon clas - dict_bind = mkVarBind self_dict dict_rhs - dict_rhs = foldl mk_app inst_constr $ - map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids - inst_constr = L loc $ wrapId (mkWpTyApps inst_tys) - (dataConWrapId dict_constr) + ; let class_tc = classTyCon clas + [dict_constr] = tyConDataCons class_tc + dict_bind = mkVarBind self_dict dict_rhs + dict_rhs = foldl mk_app inst_constr $ + map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids + inst_constr = L loc $ wrapId (mkWpTyApps inst_tys) + (dataConWrapId dict_constr) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application -- We do this rather than generate an HsCon directly, because -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId code rather - -- than needing to be repeated here. + -- member) are dealt with by the common MkId.mkDataConWrapId + -- code rather than needing to be repeated here. mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id mk_app fun arg = L loc (HsApp fun (L loc arg)) @@ -642,20 +686,22 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Do not inline the dfun; instead give it a magic DFunFunfolding -- See Note [ClassOp/DFun selection] -- See also note [Single-method classes] - dfun_id_w_fun = dfun_id - `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args) - `setInlinePragma` dfunInlinePragma + dfun_id_w_fun + | isNewTyCon class_tc + = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + | otherwise + = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args) + `setInlinePragma` dfunInlinePragma meth_args = map (DFunPolyArg . Var) meth_ids main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict, - SpecPrags [] {- spec_inst_prags -})] + SpecPrags spec_inst_prags)] , abs_ev_binds = emptyTcEvBinds , abs_binds = unitBag dict_bind } ; return (unitBag (L loc main_bind) `unionBags` - unionManyBags sc_binds `unionBags` listToBag meth_binds) } where @@ -665,23 +711,17 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) loc = getSrcSpan dfun_id ------------------------------ -tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr) +tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr) +-- All superclasses should be either +-- (a) be one of the arguments to the dfun, of +-- (b) be a constant, soluble at top level tcSuperClass n_ty_args ev_vars pred | Just (ev, i) <- find n_ty_args ev_vars - = return (emptyBag, ev, DFunLamArg i) + = return (ev, DFunLamArg i) | otherwise - = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) - do { sc_dict <- newWantedEvVar pred - ; loc <- getCtLoc ScOrigin - ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc))) - ; let ev_wrap = WpLet (EvBinds ev_binds) - sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict)) - ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) } - -- It's very important to solve the superclass constraint *in isolation* - -- so that it isn't generated by superclass selection from something else - -- We then generate the (also rather degenerate) top-level binding: - -- sc_dict = let sc_dict = in sc_dict - -- where is generated by solving the implication constraint + = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) -- Constant! + do { sc_dict <- emitWanted ScOrigin pred + ; return (sc_dict, DFunConstArg (Var sc_dict)) } where find _ [] = Nothing find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i) @@ -820,7 +860,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty) ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys - ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) + ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where @@ -883,10 +923,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------------- tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) + + -- JPM: This is probably not that simple... + tc_default sel_id (GenDefMeth dm_name) = tc_default sel_id (DefMeth dm_name) +{- tc_default sel_id GenDefMeth -- Derivable type classes stuff = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id ; tc_body sel_id False {- Not generated code? -} meth_bind } - +-} tc_default sel_id NoDefMeth -- No default method at all = do { warnMissingMethod sel_id ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars @@ -1206,7 +1250,7 @@ instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) where - (_,cls,tys) = tcSplitDFunTy dfun_ty + (_,_,cls,tys) = tcSplitDFunTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc