-setFloatLevel :: Maybe Id -- Just id <=> the expression is already let-bound to id
- -- Nothing <=> it's a possible MFE
- -> Level -- of context
- -> LevelEnv
-
- -> CoreExprWithFVs -- Original rhs
- -> Type -- Type of rhs
-
- -> LvlM (Level, -- Level to attribute to this let-binding
- LevelledExpr) -- Final rhs
-
-setFloatLevel maybe_let_bound ctxt_lvl env expr@(expr_fvs, _) ty
-
--- Now deal with (by not floating) trivial non-let-bound expressions
--- which just aren't worth let-binding in order to float. We always
--- choose to float even trivial let-bound things because it doesn't do
--- any harm, and not floating it may pin something important. For
--- example
---
--- x = let v = []
--- w = 1:v
--- in ...
---
--- Here, if we don't float v we won't float w, which is Bad News.
--- If this gives any problems we could restrict the idea to things destined
--- for top level.
-
- | not alreadyLetBound
- && (expr_is_trivial || expr_is_bottom || not will_float_past_lambda)
-
- = -- Pin trivial non-let-bound expressions,
- -- or ones which aren't going anywhere useful
- lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
- returnLvl (safe_ctxt_lvl, expr')
-
-{- SDM 7/98
-The above case used to read (whnf_or_bottom || not will_float_past_lambda).
-It was changed because we really do want to float out constructors if possible:
-this can save a great deal of needless allocation inside a loop. On the other
-hand, there's no point floating out nullary constructors and literals, hence
-the expr_is_trivial condition.
--}
-
- | alreadyLetBound && not worth_type_abstraction
- = -- Process the expression with a new ctxt_lvl, obtained from
- -- the free vars of the expression itself
- lvlExpr expr_lvl env expr `thenLvl` \ expr' ->
- returnLvl (safe_expr_lvl, expr')
-
- | otherwise -- This will create a let anyway, even if there is no
- -- type variable to abstract, so we try to abstract anyway
- = abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr
- `thenLvl` \ final_expr ->
- returnLvl (safe_expr_lvl, final_expr)
- -- OLD LIE: The body of the let, just a type application, isn't worth floating
- -- so pin it with ctxt_lvl
- -- The truth: better to give it expr_lvl in case it is pinning
- -- something non-trivial which depends on it.
- where
- alreadyLetBound = maybeToBool maybe_let_bound
-
- safe_ctxt_lvl = unTopify ty ctxt_lvl
- safe_expr_lvl = unTopify ty expr_lvl
-
- fvs = case maybe_let_bound of
- Nothing -> expr_fvs
- Just id -> expr_fvs `unionVarSet` idFreeVars id
-
- ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL fvs
- tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL fvs
- expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
- lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
-
- -- Will escape lambda if let-bound
- will_float_past_lambda = ids_only_lvl `ltMajLvl` ctxt_lvl
-
- -- Will escape (more) lambda(s)/type lambda(s) if type abstracted
- worth_type_abstraction = (ids_only_lvl `ltLvl` tyvars_only_lvl)
- && not expr_is_trivial -- Avoids abstracting trivial type applications
-
- offending_tyvars = filter offending_tv (varSetElems fvs)
- offending_tv var | isId var = False
- | otherwise = ids_only_lvl `ltLvl` varLevel env var
-
- expr_is_trivial = exprIsTrivial de_ann_expr
- expr_is_bottom = exprIsBottom de_ann_expr
- de_ann_expr = deAnnotate expr
-\end{code}
-
-Abstract wrt tyvars, by making it just as if we had seen