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 = <blah>
-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)
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 <blah>.
- $cop_list :: forall a. C a => [a] -> [a]
- $cop_list = <blah>
+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 = <blah>
- * 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 = ...
+
+ class DeepSeq a where
+ deepSeq :: a -> b -> b
+
+ 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)
-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.
+ $fC[] :: C a => C [a]
+ -- Ordinary DFun
+ $fC[] a d = MkC ($cp1 a d) ($cgen a d)
- (Note: re-reading the above, I can't see how using the
- uniform story solves the problem.)
+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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; 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
}
-- 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))
-- 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
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
projects / ghc-hetmet.git / blobdiff