-setFloatLevel :: Maybe Id -- Just id <=> the expression is already let-bound to id
- -- Nothing <=> it's a possible MFE
- -> Level -- of context
- -> LevelEnvs
-
- -> 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 envs@(venv, tenv)
- expr@(FVInfo fvs tfvs might_leak, _) ty
--- Invariant: ctxt_lvl is never = Top
--- Beautiful ASSERT, dudes (WDP 95/04)...
-
--- 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
- && (manifestly_whnf || not will_float_past_lambda)
- = -- Pin whnf non-let-bound expressions,
- -- or ones which aren't going anywhere useful
- lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (ctxt_lvl, expr')
-
- | alreadyLetBound && not worth_type_abstraction
- = -- Process the expression with a new ctxt_lvl, obtained from
- -- the free vars of the expression itself
- lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
- returnLvl (maybe_unTopify 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 envs lvl_after_ty_abstr expr
- `thenLvl` \ final_expr ->
- returnLvl (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
-
-
-
- real_fvs = case maybe_let_bound of
- Nothing -> fvs -- Just the expr fvs
- Just id -> fvs `unionIdSets` mkIdSet (idSpecVars id)
- -- Tiresome! Add the specVars
-
- fv_list = idSetToList real_fvs
- tv_list = tyVarSetToList tfvs
- expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
- ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
- tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
- lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
-
- will_float_past_lambda = -- Will escape lambda if let-bound
- ids_only_lvl `ltMajLvl` ctxt_lvl
-
- worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
- -- if type abstracted
- (ids_only_lvl `ltLvl` tyvars_only_lvl)
- && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
-
- de_ann_expr = deAnnotate expr
-
- is_trivial (App e a)
- | notValArg a = is_trivial e
- is_trivial (Var _) = True
- is_trivial _ = False
-
- offending_tyvars = filter offending tv_list
- --non_offending_tyvars = filter (not . offending) tv_list
- --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
-
- offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
-
- manifestly_whnf = whnfOrBottom (mkFormSummary de_ann_expr)
-
- maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
- maybe_unTopify lvl = lvl
- {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
- -- so that the let will not go past the *last* lambda if it can
- -- generate a space leak. If it is already in major level 0
- -- It won't do any harm to give it a Level 1 0.
- -- we should do the same test not only for things with level Top,
- -- but also for anything that gets a major level 0.
- the problem is that
- f = \a -> let x = [1..1000]
- in zip a x
- ==>
- f = let x = [1..1000]
- in \a -> zip a x
- is just as bad as floating x to the top level.
- Notice it would be OK in cases like
- f = \a -> let x = [1..1000]
- y = length x
- in a + y
- ==>
- f = let x = [1..1000]
- y = length x
- in \a -> a + y
- as x will be gc'd after y is updated.
- [We did not hit any problems with the above (Level 0 0) code
- in nofib benchmark]
- -}
-\end{code}
-
-Abstract wrt tyvars, by making it just as if we had seen