From 3bc73cd67e6cfacd2fc823019f1b6012cdf1ccb4 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 13 Nov 2009 11:12:11 +0000 Subject: [PATCH] Make the new ClassOp/DFun selection mechanism work for single-method classes I'd forgotten the case of single-method classes! I've also improved the documentation. See Note [ClassOp/DFun selection] Note [Single-method classes] both in TcInstDcls --- compiler/basicTypes/MkId.lhs | 43 ++++++++++++-------- compiler/typecheck/TcInstDcls.lhs | 81 ++++++++++++++++++++++++++++++++----- 2 files changed, 98 insertions(+), 26 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 98425f1..6d8df87 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -457,17 +457,25 @@ mkDictSelId no_unf name clas -- But it's type must expose the representation of the dictionary -- to get (say) C a -> (a -> a) - info = noCafIdInfo - `setArityInfo` 1 + base_info = noCafIdInfo + `setArityInfo` 1 `setAllStrictnessInfo` Just strict_sig - `setSpecInfo` mkSpecInfo [rule] - `setInlinePragInfo` neverInlinePragma `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding rhs) - -- Experimental: NOINLINE, so that their rule matches - - -- We no longer use 'must-inline' on record selectors. They'll - -- inline like crazy if they scrutinise a constructor + else mkImplicitUnfolding rhs) + -- In module where class op is defined, we must add + -- the unfolding, even though it'll never be inlined + -- becuase we use that to generate a top-level binding + -- for the ClassOp + + info | new_tycon = base_info + -- For newtype dictionaries, just inline the class op + -- See Note [Single-method classes] in TcInstDcls + | otherwise = base_info + `setSpecInfo` mkSpecInfo [rule] + `setInlinePragInfo` neverInlinePragma + -- Otherwise add a magic BuiltinRule, and never inline it + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in TcInstDcls n_ty_args = length tyvars @@ -484,11 +492,12 @@ mkDictSelId no_unf name clas -- It's worth giving one, so that absence info etc is generated -- even if the selector isn't inlined strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes) - arg_dmd | isNewTyCon tycon = evalDmd - | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs - | id <- arg_ids ]) + arg_dmd | new_tycon = evalDmd + | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs + | id <- arg_ids ]) tycon = classTyCon clas + new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon tyvars = dataConUnivTyVars data_con arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con @@ -497,8 +506,8 @@ mkDictSelId no_unf name clas the_arg_id = arg_ids !! index pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 $ mkPredTy pred - (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta + dict_id = mkTemplateLocal 1 $ mkPredTy pred + (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta arg_ids = mkTemplateLocalsNum n arg_tys mkCoVarLocals i [] = ([],i) @@ -507,9 +516,9 @@ mkDictSelId no_unf name clas in (y:ys,j) rhs = mkLams tyvars (Lam dict_id rhs_body) - rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) - | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] + rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) + | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) + [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] dictSelRule :: Int -> Arity -> [CoreExpr] -> Maybe CoreExpr -- Oh, very clever diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 96e63aa..c7fc8ab 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -122,13 +122,8 @@ Running example: {-# RULE "op1@C[a]" forall a, d:C a. op1 [a] (df_i d) = op1_i a d #-} -* We want to inline the dictionary function itself as vigorously as we - possibly can, so that we expose that dictionary constructor to - selectors as much as poss. We don't actually inline it; rather, we - use a Builtin RULE for the ClassOps (see MkId.mkDictSelId) to short - circuit such applications. But the RULE only applies if it can "see" - the dfun's DFunUnfolding. - +Note [Instances and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Note that df_i may be mutually recursive with both op1_i and op2_i. It's crucial that df_i is not chosen as the loop breaker, even though op1_i has a (user-specified) INLINE pragma. @@ -146,6 +141,70 @@ Running example: a RULE (the magic ClassOp rule above), and RULES work inside InlineRule unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils +Note [ClassOp/DFun selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One thing we see a lot is stuff like + op2 (df d1 d2) +where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* +'op2' and 'df' to get + case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of + MkD _ op2 _ _ _ -> op2 +And that will reduce to ($cop2 d1 d2) which is what we wanted. + +But it's tricky to make this work in practice, because it requires us to +inline both 'op2' and 'df'. But neither is keen to inline without having +seen the other's result; and it's very easy to get code bloat (from the +big intermediate) if you inline a bit too much. + +Instead we use a cunning trick. + * We arrange that 'df' and 'op2' NEVER inline. + + * We arrange that 'df' is ALWAYS defined in the sylised form + df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... + + * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..]) + that lists its methods. + + * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return + a suitable constructor application -- inlining df "on the fly" as it + were. + + * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece + iff its argument satisfies exprIsConApp_maybe. This is done in + MkId mkDictSelId + + * We make 'df' CONLIKE, so that shared uses stil match; eg + let d = df d1 d2 + in ...(op2 d)...(op1 d)... + +Note [Single-method classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the class has just one method (or, more accurately, just one elemen +of {superclasses + methods}), then we want 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: + + axiom Co:C a :: C a ~ (a->a) + + op :: forall a. C a -> (a -> a) + op a d = d |> (Co:C a) + + df :: forall a. C a => C [a] + {-# INLINE df #-} + df = $cop_list |> (forall a. C a -> (sym (Co:C a)) + + $cop_list :: forall a. C a => a -> a + $cop_list = + +So the ClassOp is just a cast; and so is the dictionary function. +(The latter doesn't even have any lambdas.) We can inline both freely. +No need for fancy BuiltIn rules. Indeed the BuiltinRule stuff does +not work well for newtypes because it uses exprIsConApp_maybe. + Note [Subtle interaction of recursion and overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -710,8 +769,12 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id))) arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars') - dfun_id_w_fun = dfun_id - `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids) + dfun_id_w_fun | isNewTyCon (classTyCon clas) + = dfun_id -- Just let the dfun inline; see Note [Single-method classes] + | otherwise + = dfun_id -- Do not inline; instead give it a magic DFunFunfolding + -- See Note [ClassOp/DFun selection] + `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids) `setInlinePragma` dfunInlinePragma main_bind = noLoc $ AbsBinds -- 1.7.10.4