+%************************************************************************
+%* *
+\subsection{Floating lets out of big lambdas}
+%* *
+%************************************************************************
+
+tryRhsTyLam tries this transformation, when the big lambda appears as
+the RHS of a let(rec) binding:
+
+ /\abc -> let(rec) x = e in b
+ ==>
+ let(rec) x' = /\abc -> let x = x' a b c in e
+ in
+ /\abc -> let x = x' a b c in b
+
+This is good because it can turn things like:
+
+ let f = /\a -> letrec g = ... g ... in g
+into
+ letrec g' = /\a -> ... g' a ...
+ in
+ let f = /\ a -> g' a
+
+which is better. In effect, it means that big lambdas don't impede
+let-floating.
+
+This optimisation is CRUCIAL in eliminating the junk introduced by
+desugaring mutually recursive definitions. Don't eliminate it lightly!
+
+So far as the implementation is concerned:
+
+ Invariant: go F e = /\tvs -> F e
+
+ Equalities:
+ go F (Let x=e in b)
+ = Let x' = /\tvs -> F e
+ in
+ go G b
+ where
+ G = F . Let x = x' tvs
+
+ go F (Letrec xi=ei in b)
+ = Letrec {xi' = /\tvs -> G ei}
+ in
+ go G b
+ where
+ G = F . Let {xi = xi' tvs}
+
+[May 1999] If we do this transformation *regardless* then we can
+end up with some pretty silly stuff. For example,
+
+ let
+ st = /\ s -> let { x1=r1 ; x2=r2 } in ...
+ in ..
+becomes
+ let y1 = /\s -> r1
+ y2 = /\s -> r2
+ st = /\s -> ...[y1 s/x1, y2 s/x2]
+ in ..
+
+Unless the "..." is a WHNF there is really no point in doing this.
+Indeed it can make things worse. Suppose x1 is used strictly,
+and is of the form
+
+ x1* = case f y of { (a,b) -> e }
+
+If we abstract this wrt the tyvar we then can't do the case inline
+as we would normally do.
+
+
+\begin{code}
+{- Trying to do this in full laziness
+
+tryRhsTyLam :: SimplEnv -> [OutTyVar] -> OutExpr -> SimplM FloatsWithExpr
+-- Call ensures that all the binders are type variables
+
+tryRhsTyLam env tyvars body -- Only does something if there's a let
+ | not (all isTyVar tyvars)
+ || not (worth_it body) -- inside a type lambda,
+ = returnSmpl (emptyFloats env, body) -- and a WHNF inside that
+
+ | otherwise
+ = go env (\x -> x) body
+
+ where
+ worth_it e@(Let _ _) = whnf_in_middle e
+ worth_it e = False
+
+ whnf_in_middle (Let (NonRec x rhs) e) | isUnLiftedType (idType x) = False
+ whnf_in_middle (Let _ e) = whnf_in_middle e
+ whnf_in_middle e = exprIsCheap e
+
+ main_tyvar_set = mkVarSet tyvars
+
+ go env fn (Let bind@(NonRec var rhs) body)
+ | exprIsTrivial rhs
+ = go env (fn . Let bind) body
+
+ go env fn (Let (NonRec var rhs) body)
+ = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
+ addAuxiliaryBind env (NonRec var' (mkLams tyvars_here (fn rhs))) $ \ env ->
+ go env (fn . Let (mk_silly_bind var rhs')) body
+
+ where
+
+ tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprSomeFreeVars isTyVar rhs)
+ -- Abstract only over the type variables free in the rhs
+ -- wrt which the new binding is abstracted. But the naive
+ -- approach of abstract wrt the tyvars free in the Id's type
+ -- fails. Consider:
+ -- /\ a b -> let t :: (a,b) = (e1, e2)
+ -- x :: a = fst t
+ -- in ...
+ -- Here, b isn't free in x's type, but we must nevertheless
+ -- abstract wrt b as well, because t's type mentions b.
+ -- Since t is floated too, we'd end up with the bogus:
+ -- poly_t = /\ a b -> (e1, e2)
+ -- poly_x = /\ a -> fst (poly_t a *b*)
+ -- So for now we adopt the even more naive approach of
+ -- abstracting wrt *all* the tyvars. We'll see if that
+ -- gives rise to problems. SLPJ June 98
+
+ go env fn (Let (Rec prs) body)
+ = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
+ let
+ gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
+ pairs = vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]
+ in
+ addAuxiliaryBind env (Rec pairs) $ \ env ->
+ go env gn body
+ where
+ (vars,rhss) = unzip prs
+ tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprsSomeFreeVars isTyVar (map snd prs))
+ -- See notes with tyvars_here above
+
+ go env fn body = returnSmpl (emptyFloats env, fn body)
+
+ mk_poly tyvars_here var
+ = getUniqueSmpl `thenSmpl` \ uniq ->
+ let
+ poly_name = setNameUnique (idName var) uniq -- Keep same name
+ poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
+ poly_id = mkLocalId poly_name poly_ty
+
+ -- In the olden days, it was crucial to copy the occInfo of the original var,
+ -- because we were looking at occurrence-analysed but as yet unsimplified code!
+ -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking
+ -- at already simplified code, so it doesn't matter
+ --
+ -- It's even right to retain single-occurrence or dead-var info:
+ -- Suppose we started with /\a -> let x = E in B
+ -- where x occurs once in B. Then we transform to:
+ -- let x' = /\a -> E in /\a -> let x* = x' a in B
+ -- where x* has an INLINE prag on it. Now, once x* is inlined,
+ -- the occurrences of x' will be just the occurrences originally
+ -- pinned on x.
+ in
+ returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
+
+ mk_silly_bind var rhs = NonRec var (Note InlineMe rhs)
+ -- Suppose we start with:
+ --
+ -- x = /\ a -> let g = G in E
+ --
+ -- Then we'll float to get
+ --
+ -- x = let poly_g = /\ a -> G
+ -- in /\ a -> let g = poly_g a in E
+ --
+ -- But now the occurrence analyser will see just one occurrence
+ -- of poly_g, not inside a lambda, so the simplifier will
+ -- PreInlineUnconditionally poly_g back into g! Badk to square 1!
+ -- (I used to think that the "don't inline lone occurrences" stuff
+ -- would stop this happening, but since it's the *only* occurrence,
+ -- PreInlineUnconditionally kicks in first!)
+ --
+ -- Solution: put an INLINE note on g's RHS, so that poly_g seems
+ -- to appear many times. (NB: mkInlineMe eliminates
+ -- such notes on trivial RHSs, so do it manually.)
+-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Case alternative filtering
+%* *
+%************************************************************************