From 85e16365444e938b4adff9d241d56df4c1fbca91 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Mon, 5 Nov 2007 22:08:07 +0000 Subject: [PATCH] Inline implication constraints This patch fixes Trac #1643, where Lennart found that GHC was generating code with unnecessary dictionaries. The reason was that we were getting an implication constraint floated out of an INLINE (actually an instance decl), and the implication constraint therefore wasn't inlined even though it was used only once (but inside the INLINE). Thus we were getting: ic = \d -> foo = _inline_me_ (...ic...) Then 'foo' gets inlined in lots of places, but 'ic' now looks a bit big. But implication constraints should *always* be inlined; they are just artefacts of the constraint simplifier. This patch solves the problem, by adding a WpInline form to the HsWrap type. --- compiler/deSugar/DsBinds.lhs | 2 ++ compiler/hsSyn/HsBinds.lhs | 2 ++ compiler/typecheck/TcHsSyn.lhs | 3 ++- compiler/typecheck/TcSimplify.lhs | 23 ++++++++++++++++++++--- 4 files changed, 26 insertions(+), 4 deletions(-) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 6492dd6..3f66158 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -463,6 +463,8 @@ dsCoercion (WpApp id) thing_inside = do { expr <- thing_inside ; return (App expr (Var id)) } dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside ; return (App expr (Type ty)) } +dsCoercion WpInline thing_inside = do { expr <- thing_inside + ; return (mkInlineMe expr) } dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs ; expr <- thing_inside ; return (Let (Rec prs) expr) } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 8e10667..46bd392 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -345,6 +345,7 @@ data HsWrapper | WpTyApp Type -- [] t the 't' is a type or corecion | WpLam Id -- \d. [] the 'd' is a type-class dictionary | WpTyLam TyVar -- \a. [] the 'a' is a type or coercion variable + | WpInline -- inline_me [] Wrap inline around the thing -- Non-empty bindings, so that the identity coercion -- is always exactly WpHole @@ -365,6 +366,7 @@ pprHsWrapper it wrap = help it (WpLam id) = sep [ptext SLIT("\\") <> pprBndr LambdaBind id <> dot, it] help it (WpTyLam tv) = sep [ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot, it] help it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it] + help it WpInline = sep [ptext SLIT("_inline_me_"), it] in -- in debug mode, print the wrapper -- otherwise just print what's inside diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index f9b390f..ec93e84 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -543,7 +543,8 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) -zonkCoFn env WpHole = return (env, WpHole) +zonkCoFn env WpHole = return (env, WpHole) +zonkCoFn env WpInline = return (env, WpInline) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 5b654fc..769068b 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1014,7 +1014,9 @@ makeImplicationBind loc all_tvs reft tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids) pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty rhs = L span (mkHsWrap co (HsVar (instToId implic_inst))) - co = mkWpApps (map instToId dict_givens) <.> mkWpTyApps eq_tyvar_cos <.> mkWpTyApps (mkTyVarTys all_tvs) + co = mkWpApps (map instToId dict_givens) + <.> mkWpTyApps eq_tyvar_cos + <.> mkWpTyApps (mkTyVarTys all_tvs) bind | [dict_irred_id] <- dict_irred_ids = VarBind dict_irred_id rhs | otherwise = PatBind { pat_lhs = L span pat, pat_rhs = unguardedGRHSs rhs, @@ -2216,8 +2218,13 @@ reduceImplication env orig_avails name reft tvs extra_givens wanteds inst_loc -- SLPJ Sept07: this looks Utterly Wrong to me, but I think -- that current extra_givens has no EqInsts, so -- it makes no difference - -- dict_ids = map instToId extra_givens - co = mkWpTyLams tvs <.> mkWpTyLams eq_tyvars <.> mkWpLams dict_ids <.> WpLet (binds `unionBags` bind) + co = wrap_inline -- Note [Always inline implication constraints] + <.> mkWpTyLams tvs + <.> mkWpTyLams eq_tyvars + <.> mkWpLams dict_ids + <.> WpLet (binds `unionBags` bind) + wrap_inline | null dict_ids = idHsWrapper + | otherwise = WpInline rhs = mkHsWrap co payload loc = instLocSpan inst_loc payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted) @@ -2232,6 +2239,16 @@ reduceImplication env orig_avails name reft tvs extra_givens wanteds inst_loc } \end{code} +Note [Always inline implication constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose an implication constraint floats out of an INLINE function. +Then although the implication has a single call site, it won't be +inlined. And that is bad because it means that even if there is really +*no* overloading (type signatures specify the exact types) there will +still be dictionary passing in the resulting code. To avert this, +we mark the implication constraints themselves as INLINE, at least when +there is no loss of sharing as a result. + Note [Reducing implication constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are trying to simplify -- 1.7.10.4