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 -> <stuff>
	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.

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 6492dd6..3f66158 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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