- ------------------------------
- [Inline dfuns] Inlining 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 doesn't GHC inline $fEq? Because it looks 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.
+tcInstanceMethod
+- Make the method bindings, as a [(NonRec, HsBinds)], one per method
+- Remembering to use fresh Name (the instance method Name) as the binder
+- Bring the instance method Ids into scope, for the benefit of tcInstSig
+- Use sig_fn mapping instance method Name -> instance tyvars
+- Ditto prag_fn
+- Use tcValBinds to do the checking
+
+\begin{code}
+tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
+ -> [EvVar]
+ -> [TcType]
+ -> EvBind -- "This" and its binding
+ -> ([Located TcSpecPrag], PragFun)
+ -> [(Id, DefMeth)]
+ -> InstBindings Name
+ -> TcM ([Id], [LHsBind Id])
+ -- The returned inst_meth_ids all have types starting
+ -- forall tvs. theta => ...
+tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
+ self_dict_ev (spec_inst_prags, prag_fn)
+ op_items (VanillaInst binds _ standalone_deriv)
+ = mapAndUnzipM tc_item op_items
+ where
+ ----------------------
+ tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
+ tc_item (sel_id, dm_info)
+ = case findMethodBind (idName sel_id) binds of
+ Just user_bind -> tc_body sel_id standalone_deriv user_bind
+ Nothing -> tc_default sel_id dm_info
+
+ ----------------------
+ tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
+ tc_body sel_id generated_code rn_bind
+ = add_meth_ctxt generated_code rn_bind $
+ do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+ ; (meth_id1, spec_prags) <- tcPrags NonRecursive False True
+ meth_id (prag_fn (idName sel_id))
+
+ ; bind <- tcInstanceMethodBody InstSkol
+ tyvars dfun_ev_vars
+ mb_dict_ev
+ meth_id1 local_meth_id
+ meth_sig_fn
+ (SpecPrags (spec_inst_prags ++ spec_prags))
+ rn_bind
+ ; return (meth_id1, bind) }
+
+ ----------------------
+ tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+ tc_default sel_id GenDefMeth -- Derivable type classes stuff
+ = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
+ ; tc_body sel_id False {- Not generated code? -} meth_bind }
+
+ tc_default sel_id NoDefMeth -- No default method at all
+ = do { warnMissingMethod sel_id
+ ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+ ; return (meth_id, mkVarBind meth_id $
+ mkLHsWrap lam_wrapper error_rhs) }
+ where
+ error_rhs = L loc $ HsApp error_fun error_msg
+ error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
+ error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+ meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
+ error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+ lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
+
+ tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
+ = do { -- Build the typechecked version directly,
+ -- without calling typecheck_method;
+ -- see Note [Default methods in instances]
+ -- Generate /\as.\ds. let this = df as ds
+ -- in $dm inst_tys this
+ -- The 'let' is necessary only because HsSyn doesn't allow
+ -- you to apply a function to a dictionary *expression*.
+
+ ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+ ; dm_id <- tcLookupId dm_name
+ ; let dm_inline_prag = idInlinePragma dm_id
+ EvBind self_dict _ = self_dict_ev
+ rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
+ HsVar dm_id
+
+ meth_bind = L loc $ VarBind { var_id = local_meth_id
+ , var_rhs = L loc rhs
+ , var_inline = False }
+ meth_id1 = meth_id `setInlinePragma` dm_inline_prag
+ -- Copy the inline pragma (if any) from the default
+ -- method to this version. Note [INLINE and default methods]
+
+ bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
+ , abs_exports = [( tyvars, meth_id1, local_meth_id
+ , SpecPrags spec_inst_prags)]
+ , abs_ev_binds = EvBinds (unitBag self_dict_ev)
+ , abs_binds = 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
+ -- currently they are rejected with
+ -- "INLINE pragma lacks an accompanying binding"
+
+ ; return (meth_id1, L loc bind) }
+
+ ----------------------
+ loc = getSrcSpan dfun_id
+ meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
+ -- But there are no scoped type variables from local_method_id
+ -- Only the ones from the instance decl itself, which are already
+ -- in scope. Example:
+ -- class C a where { op :: forall b. Eq b => ... }
+ -- instance C [c] where { op = <rhs> }
+ -- In <rhs>, 'c' is scope but 'b' is not!
+
+ mb_dict_ev = if null tyvars then Nothing else Just self_dict_ev
+ -- Only need the self_dict stuff if there are type
+ -- variables involved; otherwise overlap is not possible
+ -- See Note [Subtle interaction of recursion and overlap]
+ -- in TcInstDcls
+
+ -- For instance decls that come from standalone deriving clauses
+ -- we want to print out the full source code if there's an error
+ -- because otherwise the user won't see the code at all
+ add_meth_ctxt generated_code rn_bind thing
+ | generated_code = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
+ | otherwise = thing
+
+
+tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
+ _ _ op_items (NewTypeDerived coi _)
+
+-- Running example:
+-- class Show b => Foo a b where
+-- op :: a -> b -> b
+-- newtype N a = MkN (Tree [a])
+-- deriving instance (Show p, Foo Int p) => Foo Int (N p)
+-- -- NB: standalone deriving clause means
+-- -- that the contex is user-specified
+-- Hence op :: forall a b. Foo a b => a -> b -> b
+--
+-- We're going to make an instance like
+-- instance (Show p, Foo Int p) => Foo Int (N p)
+-- op = $copT
+--
+-- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
+-- $copT p (d1:Show p) (d2:Foo Int p)
+-- = op Int (Tree [p]) rep_d |> op_co
+-- where
+-- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
+-- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
+-- We get op_co by substituting [Int/a] and [co/b] in type for op
+-- where co : [p] ~ T p
+--
+-- Notice that the dictionary bindings "..d1..d2.." must be generated
+-- by the constraint solver, since the <context> may be
+-- user-specified.
+
+ = do { rep_d_stuff <- checkConstraints InstSkol emptyVarSet tyvars dfun_ev_vars $
+ emitWanted ScOrigin rep_pred
+
+ ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
+ where
+ loc = getSrcSpan dfun_id
+
+ inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
+ Just (init_inst_tys, _) = snocView inst_tys
+ rep_ty = fst (coercionKind co) -- [p]
+ rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
+
+ -- co : [p] ~ T p
+ co = substTyWith inst_tvs (mkTyVarTys tyvars) $
+ case coi of { IdCo ty -> ty ;
+ ACo co -> mkSymCoercion co }
+
+ ----------------
+ tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
+ tc_item (rep_ev_binds, rep_d) (sel_id, _)
+ = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
+ inst_tys sel_id
+
+ ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
+ meth_bind = VarBind { var_id = local_meth_id
+ , var_rhs = L loc meth_rhs
+ , var_inline = False }
+
+ bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
+ , abs_exports = [(tyvars, meth_id,
+ local_meth_id, noSpecPrags)]
+ , abs_ev_binds = rep_ev_binds
+ , abs_binds = unitBag $ L loc meth_bind }
+
+ ; return (meth_id, L loc bind) }
+
+ ----------------
+ mk_op_wrapper :: Id -> EvVar -> HsWrapper
+ mk_op_wrapper sel_id rep_d
+ = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
+ <.> WpEvApp (EvId rep_d)
+ <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
+ where
+ (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
+ (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
+ `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
+
+----------------------
+mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
+mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
+ = do { uniq <- newUnique
+ ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
+ ; local_meth_name <- newLocalName sel_name
+ -- Base the local_meth_name on the selector name, becuase
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; let meth_id = mkLocalId meth_name meth_ty
+ local_meth_id = mkLocalId local_meth_name local_meth_ty
+ ; return (meth_id, local_meth_id) }
+ where
+ local_meth_ty = instantiateMethod clas sel_id inst_tys
+ meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
+ sel_name = idName sel_id
+
+----------------------
+wrapId :: HsWrapper -> id -> HsExpr id
+wrapId wrapper id = mkHsWrap wrapper (HsVar id)
+
+derivBindCtxt :: Class -> [Type ] -> LHsBind Name -> SDoc
+derivBindCtxt clas tys bind
+ = vcat [ ptext (sLit "When typechecking a standalone-derived method for")
+ <+> quotes (pprClassPred clas tys) <> colon
+ , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
+
+warnMissingMethod :: Id -> TcM ()
+warnMissingMethod sel_id
+ = do { warn <- doptM Opt_WarnMissingMethods
+ ; warnTc (warn -- Warn only if -fwarn-missing-methods
+ && not (startsWithUnderscore (getOccName sel_id)))
+ -- Don't warn about _foo methods
+ (ptext (sLit "No explicit method nor default method for")
+ <+> quotes (ppr sel_id)) }
+\end{code}
+
+Note [Export helper functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We arrange to export the "helper functions" of an instance declaration,
+so that they are not subject to preInlineUnconditionally, even if their
+RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
+the dict fun as Ids, not as CoreExprs, so we can't substitute a
+non-variable for them.
+
+We could change this by making DFunUnfoldings have CoreExprs, but it
+seems a bit simpler this way.
+
+Note [Default methods in instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+
+ class Baz v x where
+ foo :: x -> x
+ foo y = <blah>
+
+ instance Baz Int Int
+
+From the class decl we get
+
+ $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
+
+ $dBazIntInt = MkBaz fooIntInt
+ fooIntInt = $dmfoo Int Int $dBazIntInt
+
+BUT this does mean we must generate the dictionary translation of
+fooIntInt directly, rather than generating source-code and
+type-checking it. That was the bug in Trac #1061. In any case it's
+less work to generate the translated version!
+
+Note [INLINE and default methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Default methods need special case. They are supposed to behave rather like
+macros. For exmample
+
+ class Foo a where
+ op1, op2 :: Bool -> a -> a
+
+ {-# INLINE op1 #-}
+ 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:
+
+
+ {-# INLINE $dmop1 #-}
+ -- $dmop1 has an InlineCompulsory unfolding
+ $dmop1 d b x = op2 d (not b) x
+
+ $fFooInt = MkD $cop1 $cop2
+
+ {-# INLINE $cop1 #-}
+ $cop1 = $dmop1 $fFooInt
+
+ $cop2 = <blah>
+
+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
+
+ It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+ recursion between $fooInt and $cop1 to be broken
+
+* To communicate the need for an InlineCompulsory to the desugarer
+ (which makes the Unfoldings), we use the IsDefaultMethod constructor
+ in TcSpecPrags.