Commit 3bc73cd6 authored by's avatar
Browse files

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
parent 014549ae
......@@ -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
......@@ -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
* 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 = <blah>
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 = <blah>
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
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment