+
+{- Note [Abstracting over tyvars only]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ When abstracting over type variable only (not dictionaries), we don't really need to
+ built a tuple and select from it, as we do in the general case. Instead we can take
+
+ AbsBinds [a,b] [ ([a,b], fg, fl, _),
+ ([b], gg, gl, _) ]
+ { fl = e1
+ gl = e2
+ h = e3 }
+
+ and desugar it to
+
+ fg = /\ab. let B in e1
+ gg = /\b. let a = () in let B in S(e2)
+ h = /\ab. let B in e3
+
+ where B is the *non-recursive* binding
+ fl = fg a b
+ gl = gg b
+ h = h a b
+
+ Notice (a) g has a different number of type variables to f, so we must
+ use the mkArbitraryType thing to fill in the gaps.
+ We use a type-let to do that.
+
+ (b) The local variable h isn't in the exports, and rather than
+ clone a fresh copy we simply replace h by (h a b).
+
+ (c) The result is *still* quadratic-sized if there are a lot of
+ small bindings. So if there are more than some small
+ number (10), we filter the binding set B by the free
+ variables of the particular RHS. Tiresome.
+
+ Why got to this trouble? It's a common case, and it removes the
+ quadratic-sized tuple desugaring. Less clutter, hopefullly faster
+ compilation, especially in a case where there are a *lot* of
+ bindings.
+-}
+
+
+dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
+ | opt_DsMultiTyVar -- This (static) debug flag just lets us
+ -- switch on and off this optimisation to
+ -- see if it has any impact; it is on by default
+ = -- Note [Abstracting over tyvars only]
+ do { core_prs <- ds_lhs_binds NoSccs binds
+ ; arby_env <- mkArbitraryTypeEnv tyvars exports
+ ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
+ bndrs = mkVarSet (map fst core_prs)
+
+ add_lets | core_prs `lengthExceeds` 10 = add_some
+ | otherwise = mkLets lg_binds
+ add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
+ , b `elemVarSet` fvs] rhs
+ where
+ fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
+
+ env = mkABEnv exports
+
+ do_one (lcl_id, rhs)
+ | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
+ = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
+ addInlinePrags prags gbl_id $
+ addAutoScc auto_scc gbl_id $
+ mkLams id_tvs $
+ mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
+ | tv <- tyvars, not (tv `elem` id_tvs)] $
+ add_lets rhs)
+ | otherwise
+ = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
+ (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
+ where
+ non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
+
+ ; return (core_prs' ++ rest) }
+