From 3d16d9d805e321c58459d0b62223591c19013060 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 21 Dec 2010 16:19:11 +0000 Subject: [PATCH] Single-method classes are implemented with a newtype This patch changes things so that such classes rely on the coercion mechanism for inlining (since the constructor is really just a cast) rather than on the dfun mechanism, therby removing some needless runtime indirections. --- compiler/basicTypes/MkId.lhs | 17 ++++++++------ compiler/typecheck/TcInstDcls.lhs | 47 +++++++++++++++++++------------------ 2 files changed, 34 insertions(+), 30 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 7bd9910..5aebd37 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -235,9 +235,9 @@ mkDataConIds wrap_name wkr_name data_con wkr_arity = dataConRepArity data_con wkr_info = noCafIdInfo - `setArityInfo` wkr_arity + `setArityInfo` wkr_arity `setStrictnessInfo` Just wkr_sig - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) @@ -270,6 +270,7 @@ mkDataConIds wrap_name wkr_name data_con nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` newtype_unf id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) newtype_unf = ASSERT2( isVanillaDataCon data_con && @@ -899,7 +900,8 @@ unsafeCoerceId :: Id unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkForAllTys [argAlphaTyVar,openBetaTyVar] @@ -915,15 +917,16 @@ nullAddrId :: Id -- a way to write this literal in Haskell. nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where - info = noCafIdInfo `setUnfoldingInfo` - mkCompulsoryUnfolding (Lit nullAddrLit) + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) ------------------------------------------------ seqId :: Id -- See Note [seqId magic] seqId = pcMiscPrelId seqName ty info where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs - `setSpecInfo` mkSpecInfo [seq_cast_rule] + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setSpecInfo` mkSpecInfo [seq_cast_rule] ty = mkForAllTys [alphaTyVar,argBetaTyVar] diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index ddfb970..f4e338d 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -659,12 +659,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) op_items ibinds -- Create the result bindings - ; 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) + ; self_dict <- newEvVar (ClassP clas inst_tys) + ; 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 @@ -672,17 +674,21 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- member) are dealt with by the common MkId.mkDataConWrapId -- code rather than needing to be repeated here. - mk_app :: LHsExpr Id -> Id -> LHsExpr Id - mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id))) - arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars') + mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id + mk_app fun arg = L loc (HsApp fun (L loc arg)) + + arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars) -- 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 inst_ty (map Var dict_and_meth_ids) - -- Not right for equality superclasses - `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 @@ -744,16 +750,11 @@ Consider the following (extreme) situation: Although this looks wrong (assume D [a] to prove D [a]), it is only a more extreme case of what happens with recursive dictionaries. - ; uniq <- newUnique - ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict) - sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq - (getName sc_sel) - sc_op_id = mkLocalId sc_op_name sc_op_ty - sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False - , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict } - sc_wrapper = mkWpTyLams tyvars - <.> mkWpLams dicts - <.> mkWpLet ev_binds +To implement the dfun we must generate code for the superclass C [a], +which we can get by superclass selection from the supplied argument! +So we’d generate: + dfun :: forall a. D [a] -> D [a] + dfun = \d::D [a] -> MkD (scsel d) .. However this means that if we later encounter a situation where we have a [Wanted] dw::D [a] we could solve it thus: -- 1.7.10.4