X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=c7fc8ab56ff9f896303d4819c6462cc0c1ef7281;hb=65277a1c9ff86c28c656849d6f6cbb392f1eb3e7;hp=426da5220102943b7f3ac896311ee40070623e5d;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 426da52..c7fc8ab 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -122,16 +122,11 @@ Running example: {-# RULE "op1@C[a]" forall a, d:C a. op1 [a] (df_i d) = op1_i a d #-} -* The dictionary function itself is inlined as vigorously as we - possibly can, so that we expose that dictionary constructor to - selectors as much as poss. That is why the op_i stuff is in - *separate* bindings, so that the df_i binding is small enough - to inline. See Note [Inline dfuns unconditionally]. - +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. - Not even once! Else op1_i, op2_i may be inlined into df_i. * Instead the idea is to inline df_i into op1_i, which may then select methods from the MkC record, and thereby break the recursion with @@ -142,8 +137,74 @@ Running example: * If op1_i is marked INLINE by the user there's a danger that we won't inline df_i in it, and that in turn means that (since it'll be a loop-breaker because df_i isn't), op1_i will ironically never be - inlined. We need to fix this somehow -- perhaps allowing inlining - of INLINE functions inside other INLINE functions. + inlined. But this is OK: the recursion breaking happens by way of + 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -206,93 +267,6 @@ which brings appropriate tyvars into scope. This happens for both and for , but that doesn't matter: the *renamer* will have complained if 'b' is mentioned in . -Note [Inline dfuns unconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The code above unconditionally inlines dict funs. Here's why. -Consider this program: - - test :: Int -> Int -> Bool - test x y = (x,y) == (y,x) || test y x - -- Recursive to avoid making it inline. - -This needs the (Eq (Int,Int)) instance. If we inline that dfun -the code we end up with is good: - - Test.$wtest = - \r -> case ==# [ww ww1] of wild { - PrelBase.False -> Test.$wtest ww1 ww; - PrelBase.True -> - case ==# [ww1 ww] of wild1 { - PrelBase.False -> Test.$wtest ww1 ww; - PrelBase.True -> PrelBase.True []; - }; - }; - Test.test = \r [w w1] - case w of w2 { - PrelBase.I# ww -> - case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; }; - }; - -If we don't inline the dfun, the code is not nearly as good: - - (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl { - PrelBase.:DEq tpl1 tpl2 -> tpl2; - }; - - Test.$wtest = - \r [ww ww1] - let { y = PrelBase.I#! [ww1]; } in - let { x = PrelBase.I#! [ww]; } in - let { sat_slx = PrelTup.(,)! [y x]; } in - let { sat_sly = PrelTup.(,)! [x y]; - } in - case == sat_sly sat_slx of wild { - PrelBase.False -> Test.$wtest ww1 ww; - PrelBase.True -> PrelBase.True []; - }; - - Test.test = - \r [w w1] - case w of w2 { - PrelBase.I# ww -> - case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; }; - }; - -Why didn't GHC inline $fEq in those days? Because it looked big: - - PrelTup.zdfEqZ1T{-rcX-} - = \ @ a{-reT-} :: * @ b{-reS-} :: * - zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}} - zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} -> - let { - zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-}) - zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in - let { - zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-}) - zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in - let { - zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-}) - zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-}) - ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) -> - case ds{-rf5-} - of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) -> - case ds1{-rf4-} - of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) -> - PrelBase.zaza{-r4e-} - (zeze1{-rf3-} a1{-rf2-} b1{-rf1-}) - (zeze{-rf0-} a2{-reZ-} b2{-reY-}) - } - } } in - let { - a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-}) - a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-}) - b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) -> - PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-}) - } in - PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-}) - -and it's not as bad as it seems, because it's further dramatically -simplified: only zeze2 is extracted and its body is simplified. %************************************************************************ @@ -795,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