import FamInstEnv
import TcDeriv
import TcEnv
-import RnEnv ( lookupGlobalOccRn )
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
import Class
import Var
import CoreUnfold ( mkDFunUnfolding )
-import PrelNames ( inlineIdName )
import Id
import MkId
import Name
{-# 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
* 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 element
+of {superclasses + methods}), then we still use the *same* 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)
+
+ 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. MkD ($cop_list a d)
+
+ $cop_list :: forall a. C a => a -> a
+ $cop_list = <blah>
+
+The "constructor" MkD expands to a cast, as does the class-op selector.
+The RULE works just like for multi-field dictionaries:
+ * (df a d) returns (Just (MkD,..,[$cop_list a d]))
+ to exprIsConApp_Maybe
+
+ * The RULE for op picks the right result
+
+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.
+
+The biggest reason for doing it this way, apart form uniformity, is
+that 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. The danger is that
+we'll get something like
+ foo = /\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 arond trying to fix it.
+Look at the test for Trac #3772.
Note [Subtle interaction of recursion and overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
complained if 'b' is mentioned in <rhs>.
-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.
%************************************************************************
; (tyvars, theta, tau) <- tcHsInstHead poly_ty
-- Now, check the validity of the instance.
- ; (clas, inst_tys) <- checkValidInstHead tau
- ; checkValidInstance tyvars theta clas inst_tys
+ ; (clas, inst_tys) <- checkValidInstance poly_ty tyvars theta tau
-- Next, process any associated types.
; idx_tycons <- recoverM (return []) $
-- If there are no superclasses, matters are simpler, because we don't need the case
-- see Note [Newtype deriving superclasses] in TcDeriv.lhs
-tc_inst_decl2 dfun_id (NewTypeDerived coi)
+tc_inst_decl2 dfun_id (NewTypeDerived coi _)
= do { let rigid_info = InstSkol
origin = SigOrigin rigid_info
inst_ty = idType dfun_id
; return (unitBag $ noLoc $
AbsBinds inst_tvs' (map instToVar dfun_dicts)
- [(inst_tvs', dfun_id, instToId this_dict, [])]
+ [(inst_tvs', dfun_id, instToId this_dict, noSpecPrags)]
(dict_bind `consBag` sc_binds)) }
where
-----------------------
; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs
-- Typecheck the methods
- ; let prag_fn = mkPragFun uprags
+ ; let prag_fn = mkPragFun uprags monobinds
tc_meth = tcInstanceMethod loc standalone_deriv
clas inst_tyvars'
dfun_dicts inst_tys'
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)
+ -- 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 dict_constr (sc_ids ++ meth_ids)
`setInlinePragma` dfunInlinePragma
- main_bind = noLoc $ AbsBinds
- inst_tyvars'
- dfun_lam_vars
- [(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)]
- (unitBag dict_bind)
+ main_bind = AbsBinds
+ inst_tyvars'
+ dfun_lam_vars
+ [(inst_tyvars', dfun_id_w_fun, this_dict_id, SpecPrags spec_inst_prags)]
+ (unitBag dict_bind)
; showLIE (text "instance")
- ; return (unitBag main_bind `unionBags`
- listToBag meth_binds `unionBags`
- listToBag sc_binds) }
+ ; return (unitBag (L loc main_bind) `unionBags`
+ listToBag meth_binds `unionBags`
+ listToBag sc_binds)
+ }
+{-
+ -- Create the result bindings
+ ; let this_dict_id = instToId this_dict
+ arg_ids = sc_ids ++ meth_ids
+ arg_binds = listToBag meth_binds `unionBags`
+ listToBag sc_binds
+
+ ; showLIE (text "instance")
+ ; case newTyConCo_maybe (classTyCon clas) of
+ Nothing -- A multi-method class
+ -> return (unitBag (L loc data_bind) `unionBags` arg_binds)
+ where
+ data_dfun_id = dfun_id -- Do not inline; instead give it a magic DFunFunfolding
+ -- See Note [ClassOp/DFun selection]
+ `setIdUnfolding` mkDFunUnfolding dict_constr arg_ids
+ `setInlinePragma` dfunInlinePragma
+
+ data_bind = AbsBinds inst_tyvars' dfun_lam_vars
+ [(inst_tyvars', data_dfun_id, this_dict_id, spec_inst_prags)]
+ (unitBag dict_bind)
+
+ dict_bind = mkVarBind this_dict_id dict_rhs
+ dict_rhs = foldl mk_app inst_constr arg_ids
+ dict_constr = classDataCon clas
+ 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.
+
+ 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 = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
+
+ Just the_nt_co -- (Just co) for a single-method class
+ -> return (unitBag (L loc nt_bind) `unionBags` arg_binds)
+ where
+ nt_dfun_id = dfun_id -- Just let the dfun inline; see Note [Single-method classes]
+ `setInlinePragma` alwaysInlinePragma
+
+ local_nt_dfun = setIdType this_dict_id inst_ty -- A bit of a hack, but convenient
+
+ nt_bind = AbsBinds [] []
+ [([], nt_dfun_id, local_nt_dfun, spec_inst_prags)]
+ (unitBag (mkVarBind local_nt_dfun (L loc (wrapId nt_cast the_meth_id))))
+
+ the_meth_id = ASSERT( length arg_ids == 1 ) head arg_ids
+ nt_cast = WpCast $ mkPiTypes (inst_tyvars' ++ dfun_lam_vars) $
+ mkSymCoercion (mkTyConApp the_nt_co inst_tys')
+-}
------------------------------
tcSuperClass :: InstLoc -> [TyVar] -> [Inst]
sc_id = instToVar sc_dict
sc_op_bind = AbsBinds tyvars
(map instToVar dicts)
- [(tyvars, sc_op_id, sc_id, [])]
+ [(tyvars, sc_op_id, sc_id, noSpecPrags)]
(this_bind `unionBags` sc_binds)
; return (sc_op_id, noLoc sc_op_bind) }
The "it turns out" bit is delicate, but it works fine!
\begin{code}
-tcSpecInst :: Id -> Sig Name -> TcM SpecPrag
+tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
= addErrCtxt (spec_ctxt prag) $
do { let name = idName dfun_id
-> [TcType]
-> (Inst, LHsBinds Id) -- "This" and its binding
-> TcPragFun -- Local prags
- -> [LSpecPrag] -- Arising from 'SPECLALISE instance'
+ -> [Located TcSpecPrag] -- Arising from 'SPECLALISE instance'
-> LHsBinds Name
-> (Id, DefMeth)
-> TcM (Id, LHsBind Id)
tc_body rn_bind
= add_meth_ctxt rn_bind $
do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True
- meth_id (prag_fn sel_name)
+ meth_id (prag_fn sel_name)
; tcInstanceMethodBody (instLoc this_dict)
tyvars dfun_dicts
([this_dict], this_dict_bind)
meth_id1 local_meth_id
meth_sig_fn
- (spec_inst_prags ++ spec_prags)
+ (SpecPrags (spec_inst_prags ++ spec_prags))
rn_bind }
--------------
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
; tc_body meth_bind }
- tc_default DefMeth -- An polymorphic default method
+ tc_default (DefMeth dm_name) -- An polymorphic default method
= do { -- Build the typechecked version directly,
-- without calling typecheck_method;
-- see Note [Default methods in instances]
-- in $dm inst_tys this
-- The 'let' is necessary only because HsSyn doesn't allow
-- you to apply a function to a dictionary *expression*.
- dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
- -- Might not be imported, but will be an OrigName
+
; dm_id <- tcLookupId dm_name
- ; inline_id <- tcLookupId inlineIdName
; let dm_inline_prag = idInlinePragma dm_id
- dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
- HsVar dm_id
- rhs | isInlinePragma dm_inline_prag -- See Note [INLINE and default methods]
- = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id)))
- (L loc dm_app)
- | otherwise = dm_app
+ rhs = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
+ HsVar dm_id
meth_bind = L loc $ VarBind { var_id = local_meth_id
, var_rhs = L loc rhs
-- method to this version. Note [INLINE and default methods]
bind = AbsBinds { abs_tvs = tyvars, abs_dicts = dfun_lam_vars
- , abs_exports = [( tyvars, meth_id1
- , local_meth_id, spec_inst_prags)]
+ , abs_exports = [( tyvars, meth_id1, local_meth_id
+ , SpecPrags spec_inst_prags)]
, abs_binds = this_dict_bind `unionBags` unitBag meth_bind }
-- Default methods in an instance declaration can't have their own
-- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
$dmfoo :: forall v x. Baz v x => x -> x
$dmfoo y = <blah>
-Notice that the type is ambiguous. That's fine, though. The instance decl generates
+Notice that the type is ambiguous. That's fine, though. The instance
+decl generates
$dBazIntInt = MkBaz fooIntInt
fooIntInt = $dmfoo Int Int $dBazIntInt
Note [INLINE and default methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We *copy* any INLINE pragma from the default method to the instance.
-Example:
+Default methods need special case. They are supposed to behave rather like
+macros. For exmample
+
class Foo a where
op1, op2 :: Bool -> a -> a
op1 b x = op2 (not b) x
instance Foo Int where
+ -- op1 via default method
op2 b x = <blah>
+
+The instance declaration should behave
+
+ just as if 'op1' had been defined with the
+ code, and INLINE pragma, from its original
+ definition.
+
+That is, just as if you'd written
+
+ instance Foo Int where
+ op2 b x = <blah>
+
+ {-# INLINE op1 #-}
+ op1 b x = op2 (not b) x
+
+So for the above example we generate:
-Then we generate:
{-# INLINE $dmop1 #-}
+ -- $dmop1 has an InlineCompulsory unfolding
$dmop1 d b x = op2 d (not b) x
$fFooInt = MkD $cop1 $cop2
{-# INLINE $cop1 #-}
- $cop1 = inline $dmop1 $fFooInt
+ $cop1 = $dmop1 $fFooInt
$cop2 = <blah>
-Note carefully:
- a) We copy $dmop1's inline pragma to $cop1. Otherwise
- we'll just inline the former in the latter and stop, which
- isn't what the user expected
+Note carefullly:
+
+* We *copy* any INLINE pragma from the default method $dmop1 to the
+ instance $cop1. Otherwise we'll just inline the former in the
+ latter and stop, which isn't what the user expected
+
+* Regardless of its pragma, we give the default method an
+ unfolding with an InlineCompulsory source. That means
+ that it'll be inlined at every use site, notably in
+ each instance declaration, such as $cop1. This inlining
+ must happen even though
+ a) $dmop1 is not saturated in $cop1
+ b) $cop1 itself has an INLINE pragma
- b) We use the magic 'inline' Id to ensure that $dmop1 really is
- inlined in $cop1, even though the latter itself has an INLINE pragma
- That is important to allow the mutual recursion between $fooInt and
- $cop1 to be broken
+ It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+ recursion between $fooInt and $cop1 to be broken
-This is all regrettably delicate.
+* To communicate the need for an InlineCompulsory to the desugarer
+ (which makes the Unfoldings), we use the IsDefaultMethod constructor
+ in TcSpecPrags.
%************************************************************************
projects / ghc-hetmet.git / blobdiff