2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
6 We attach binding levels to Core bindings, in preparation for floating
9 We also let-ify many applications (notably case scrutinees), so they
10 will have a fighting chance of being floated sensible.
18 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
21 #include "HsVersions.h"
26 import CoreUtils ( coreExprType, idSpecVars )
27 import CoreUnfold ( FormSummary, whnfOrBottom, mkFormSummary )
28 import FreeVars -- all of it
29 import MkId ( mkSysLocal )
31 nullIdEnv, addOneToIdEnv, growIdEnvList,
32 unionManyIdSets, unionIdSets, minusIdSet, mkIdSet,
36 import SrcLoc ( noSrcLoc )
37 import Type ( isUnpointedType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, Type )
38 import TyVar ( emptyTyVarEnv, addToTyVarEnv,
39 growTyVarEnvList, lookupTyVarEnv,
42 unionManyTyVarSets, unionTyVarSets
44 import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
45 mapAndUnzip3Us, getUnique, UniqSM,
48 import BasicTypes ( Unused )
49 import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
52 isLeakFreeType x y = False -- safe option; ToDo
55 %************************************************************************
57 \subsection{Level numbers}
59 %************************************************************************
63 = Top -- Means *really* the top level.
64 | Level Int -- Level number of enclosing lambdas
65 Int -- Number of big-lambda and/or case expressions between
66 -- here and the nearest enclosing lambda
69 The {\em level number} on a (type-)lambda-bound variable is the
70 nesting depth of the (type-)lambda which binds it. On an expression,
71 it's the maximum level number of its free (type-)variables. On a
72 let(rec)-bound variable, it's the level of its RHS. On a case-bound
73 variable, it's the number of enclosing lambdas.
75 Top-level variables: level~0. Those bound on the RHS of a top-level
76 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
79 a_0 = let b_? = ... in
80 x_1 = ... b ... in ...
83 Level 0 0 will make something get floated to a top-level "equals",
84 @Top@ makes it go right to the top.
86 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
87 That's meant to be the level number of the enclosing binder in the
88 final (floated) program. If the level number of a sub-expression is
89 less than that of the context, then it might be worth let-binding the
90 sub-expression so that it will indeed float. This context level starts
91 at @Level 0 0@; it is never @Top@.
94 type LevelledExpr = GenCoreExpr (Id, Level) Id Unused
95 type LevelledArg = GenCoreArg Id Unused
96 type LevelledBind = GenCoreBinding (Id, Level) Id Unused
98 type LevelEnvs = (IdEnv Level, -- bind Ids to levels
99 TyVarEnv Level) -- bind type variables to levels
103 incMajorLvl :: Level -> Level
104 incMajorLvl Top = Level 1 0
105 incMajorLvl (Level major minor) = Level (major+1) 0
107 incMinorLvl :: Level -> Level
108 incMinorLvl Top = Level 0 1
109 incMinorLvl (Level major minor) = Level major (minor+1)
111 maxLvl :: Level -> Level -> Level
114 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
115 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
118 ltLvl :: Level -> Level -> Bool
120 ltLvl Top (Level _ _) = True
121 ltLvl (Level maj1 min1) (Level maj2 min2)
122 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
124 ltMajLvl :: Level -> Level -> Bool
125 -- Tells if one level belongs to a difft *lambda* level to another
126 ltMajLvl l1 Top = False
127 ltMajLvl Top (Level 0 _) = False
128 ltMajLvl Top (Level _ _) = True
129 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
131 isTopLvl :: Level -> Bool
133 isTopLvl other = False
135 isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
136 isTopMajLvl Top = True
137 isTopMajLvl (Level maj _) = maj == 0
139 unTopify :: Level -> Level
140 unTopify Top = Level 0 0
143 instance Outputable Level where
144 ppr Top = ptext SLIT("<Top>")
145 ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
148 %************************************************************************
150 \subsection{Main level-setting code}
152 %************************************************************************
155 setLevels :: [CoreBinding]
162 -- "do_them"'s main business is to thread the monad along
163 -- It gives each top binding the same empty envt, because
164 -- things unbound in the envt have level number zero implicitly
165 do_them :: [CoreBinding] -> LvlM [LevelledBind]
167 do_them [] = returnLvl []
169 = lvlTopBind b `thenLvl` \ (lvld_bind, _) ->
170 do_them bs `thenLvl` \ lvld_binds ->
171 returnLvl (lvld_bind ++ lvld_binds)
173 initial_envs = (nullIdEnv, emptyTyVarEnv)
175 lvlTopBind (NonRec binder rhs)
176 = lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs))
177 -- Rhs can have no free vars!
179 lvlTopBind (Rec pairs)
180 = lvlBind (Level 0 0) initial_envs (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
183 %************************************************************************
185 \subsection{Bindings}
187 %************************************************************************
189 The binding stuff works for top level too.
192 type CoreBindingWithFVs = AnnCoreBinding Id Id Unused FVInfo
196 -> CoreBindingWithFVs
197 -> LvlM ([LevelledBind], LevelEnvs)
199 lvlBind ctxt_lvl envs@(venv, tenv) (AnnNonRec name rhs)
200 = setFloatLevel True {- Already let-bound -}
201 ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') ->
203 new_envs = (addOneToIdEnv venv name final_lvl, tenv)
205 returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
210 lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec pairs)
211 = decideRecFloatLevel ctxt_lvl envs binders rhss
212 `thenLvl` \ (final_lvl, extra_binds, rhss') ->
214 binders_w_lvls = binders `zip` repeat final_lvl
215 new_envs = (growIdEnvList venv binders_w_lvls, tenv)
217 returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_envs)
219 (binders,rhss) = unzip pairs
222 %************************************************************************
224 \subsection{Setting expression levels}
226 %************************************************************************
229 lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
230 -> LevelEnvs -- Level of in-scope names/tyvars
231 -> CoreExprWithFVs -- input expression
232 -> LvlM LevelledExpr -- Result expression
235 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
240 v = \x -> ...\y -> let r = case (..x..) of
244 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
245 the level of @r@, even though it's inside a level-2 @\y@. It's
246 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
247 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
248 --- because it isn't a *maximal* free expression.
250 If there were another lambda in @r@'s rhs, it would get level-2 as well.
253 lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v)
254 lvlExpr _ _ (_, AnnLit l) = returnLvl (Lit l)
255 lvlExpr _ _ (_, AnnCon con args) = returnLvl (Con con args)
256 lvlExpr _ _ (_, AnnPrim op args) = returnLvl (Prim op args)
258 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg)
259 = lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
260 returnLvl (App fun' arg)
262 lvlExpr ctxt_lvl envs (_, AnnNote note expr)
263 = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
264 returnLvl (Note note expr')
266 -- We don't split adjacent lambdas. That is, given
268 -- we don't float to give
269 -- \x -> let v = x+y in \y -> (v,y)
270 -- Why not? Because partial applications are fairly rare, and splitting
271 -- lambdas makes them more expensive.
273 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
274 = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' ->
275 returnLvl (foldr (Lam . ValBinder) body' lvld_args)
277 incd_lvl = incMajorLvl ctxt_lvl
278 (args, body) = annCollectValBinders rhs
279 lvld_args = [(a,incd_lvl) | a <- (arg:args)]
280 new_venv = growIdEnvList venv lvld_args
282 -- We don't need to play such tricks for type lambdas, because
283 -- they don't get annotated
285 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
286 = lvlExpr incd_lvl (venv, new_tenv) body `thenLvl` \ body' ->
287 returnLvl (Lam (TyBinder tyvar) body')
289 incd_lvl = incMinorLvl ctxt_lvl
290 new_tenv = addToTyVarEnv tenv tyvar incd_lvl
292 lvlExpr ctxt_lvl envs (_, AnnLet bind body)
293 = lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) ->
294 lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' ->
295 returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
297 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
298 = lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' ->
299 lvl_alts alts `thenLvl` \ alts' ->
300 returnLvl (Case expr' alts')
302 expr_type = coreExprType (deAnnotate expr)
303 incd_lvl = incMinorLvl ctxt_lvl
305 lvl_alts (AnnAlgAlts alts deflt)
306 = mapLvl lvl_alt alts `thenLvl` \ alts' ->
307 lvl_deflt deflt `thenLvl` \ deflt' ->
308 returnLvl (AlgAlts alts' deflt')
312 bs' = [ (b, incd_lvl) | b <- bs ]
313 new_envs = (growIdEnvList venv bs', tenv)
315 lvlMFE incd_lvl new_envs e `thenLvl` \ e' ->
316 returnLvl (con, bs', e')
318 lvl_alts (AnnPrimAlts alts deflt)
319 = mapLvl lvl_alt alts `thenLvl` \ alts' ->
320 lvl_deflt deflt `thenLvl` \ deflt' ->
321 returnLvl (PrimAlts alts' deflt')
324 = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
327 lvl_deflt AnnNoDefault = returnLvl NoDefault
329 lvl_deflt (AnnBindDefault b expr)
331 new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
333 lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
334 returnLvl (BindDefault (b, incd_lvl) expr')
337 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
338 the expression, so that it can itself be floated.
341 lvlMFE :: Level -- Level of innermost enclosing lambda/tylam
342 -> LevelEnvs -- Level of in-scope names/tyvars
343 -> CoreExprWithFVs -- input expression
344 -> LvlM LevelledExpr -- Result expression
346 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
347 | isUnpointedType ty -- Can't let-bind it
348 = lvlExpr ctxt_lvl envs ann_expr
350 | otherwise -- Not primitive type so could be let-bound
351 = setFloatLevel False {- Not already let-bound -}
352 ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') ->
355 ty = coreExprType (deAnnotate ann_expr)
359 %************************************************************************
361 \subsection{Deciding floatability}
363 %************************************************************************
365 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
366 are being created as let-bindings
370 YES. -> (a) try abstracting type variables.
371 If we abstract type variables it will go further, that is, past more
372 lambdas. same as asking if the level number given by the free
373 variables is less than the level number given by free variables
374 and type variables together.
375 Abstract offending type variables, e.g.
377 to let v = /\ty' -> f ty' a b
379 so that v' is not stopped by the level number of ty
380 tag the original let with its level number
381 (from its variables and type variables)
383 YES. -> No point in let binding to float a WHNF.
384 Pin (leave) expression here.
385 NO. -> Will float past a lambda?
386 (check using free variables only, not type variables)
387 YES. -> do the same as (a) above.
388 NO. -> No point in let binding if it is not going anywhere
389 Pin (leave) expression here.
392 setFloatLevel :: Bool -- True <=> the expression is already let-bound
393 -- False <=> it's a possible MFE
394 -> Level -- of context
397 -> CoreExprWithFVs -- Original rhs
398 -> Type -- Type of rhs
400 -> LvlM (Level, -- Level to attribute to this let-binding
401 LevelledExpr) -- Final rhs
403 setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
404 expr@(FVInfo fvs tfvs might_leak, _) ty
405 -- Invariant: ctxt_lvl is never = Top
406 -- Beautiful ASSERT, dudes (WDP 95/04)...
408 -- Now deal with (by not floating) trivial non-let-bound expressions
409 -- which just aren't worth let-binding in order to float. We always
410 -- choose to float even trivial let-bound things because it doesn't do
411 -- any harm, and not floating it may pin something important. For
418 -- Here, if we don't float v we won't float w, which is Bad News.
419 -- If this gives any problems we could restrict the idea to things destined
422 | not alreadyLetBound
423 && (manifestly_whnf || not will_float_past_lambda)
424 = -- Pin whnf non-let-bound expressions,
425 -- or ones which aren't going anywhere useful
426 lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
427 returnLvl (ctxt_lvl, expr')
429 | alreadyLetBound && not worth_type_abstraction
430 = -- Process the expression with a new ctxt_lvl, obtained from
431 -- the free vars of the expression itself
432 lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
433 returnLvl (maybe_unTopify expr_lvl, expr')
435 | otherwise -- This will create a let anyway, even if there is no
436 -- type variable to abstract, so we try to abstract anyway
437 = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
438 `thenLvl` \ final_expr ->
439 returnLvl (expr_lvl, final_expr)
440 -- OLD LIE: The body of the let, just a type application, isn't worth floating
441 -- so pin it with ctxt_lvl
442 -- The truth: better to give it expr_lvl in case it is pinning
443 -- something non-trivial which depends on it.
445 fv_list = idSetToList fvs
446 tv_list = tyVarSetToList tfvs
447 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
448 ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
449 tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
450 lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
452 will_float_past_lambda = -- Will escape lambda if let-bound
453 ids_only_lvl `ltMajLvl` ctxt_lvl
455 worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
456 -- if type abstracted
457 (ids_only_lvl `ltLvl` tyvars_only_lvl)
458 && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
460 de_ann_expr = deAnnotate expr
463 | notValArg a = is_trivial e
464 is_trivial (Var _) = True
467 offending_tyvars = filter offending tv_list
468 --non_offending_tyvars = filter (not . offending) tv_list
469 --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
471 offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
473 manifestly_whnf = whnfOrBottom (mkFormSummary de_ann_expr)
475 maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
476 maybe_unTopify lvl = lvl
477 {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
478 -- so that the let will not go past the *last* lambda if it can
479 -- generate a space leak. If it is already in major level 0
480 -- It won't do any harm to give it a Level 1 0.
481 -- we should do the same test not only for things with level Top,
482 -- but also for anything that gets a major level 0.
484 f = \a -> let x = [1..1000]
487 f = let x = [1..1000]
489 is just as bad as floating x to the top level.
490 Notice it would be OK in cases like
491 f = \a -> let x = [1..1000]
495 f = let x = [1..1000]
498 as x will be gc'd after y is updated.
499 [We did not hit any problems with the above (Level 0 0) code
504 Abstract wrt tyvars, by making it just as if we had seen
509 instead of simply E. The idea is that v can be freely floated, since it
510 has no free type variables. Of course, if E has no free type
511 variables, then we just return E.
514 abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
515 = lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' ->
516 newLvlVar poly_ty `thenLvl` \ poly_var ->
518 poly_var_rhs = mkTyLam offending_tyvars expr'
519 poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
520 poly_var_app = mkTyApp (Var poly_var) (mkTyVarTys offending_tyvars)
521 final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
525 poly_ty = mkForAllTys offending_tyvars ty
527 -- These defns are just like those in the TyLam case of lvlExpr
528 (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
530 next lvl tyvar = (lvl1, (tyvar,lvl1))
531 where lvl1 = incMinorLvl lvl
533 new_tenv = growTyVarEnvList tenv tyvar_lvls
534 new_envs = (venv, new_tenv)
537 Recursive definitions. We want to transform
549 x1' = /\ ab -> let D' in e1
551 xn' = /\ ab -> let D' in en
555 where ab are the tyvars pinning the defn further in than it
556 need be, and D is a bunch of simple type applications:
562 The "_cl" indicates that in D, the level numbers on the xi are the context level
563 number; type applications aren't worth floating. The D' decls are
570 but differ in their level numbers; here the ab are the newly-introduced
574 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
575 | isTopMajLvl ids_only_lvl && -- Destination = top
576 not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top
579 ids_w_lvls = ids `zip` repeat ctxt_lvl
580 new_envs = (growIdEnvList venv ids_w_lvls, tenv)
582 mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' ->
583 returnLvl (ctxt_lvl, [], rhss')
585 {- OMITTED; see comments above near isWorthFloatingExpr
587 | not (any (isWorthFloating True . deAnnotate) rhss)
589 mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
590 returnLvl (ctxt_lvl, [], rhss')
594 | ids_only_lvl `ltLvl` tyvars_only_lvl
595 = -- Abstract wrt tyvars;
596 -- offending_tyvars is definitely non-empty
597 -- (I love the ASSERT to check this... WDP 95/02)
599 -- These defns are just like those in the TyLam case of lvlExpr
600 (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
602 next lvl tyvar = (lvl1, (tyvar,lvl1))
603 where lvl1 = incMinorLvl lvl
605 ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
606 new_tenv = growTyVarEnvList tenv tyvar_lvls
607 new_venv = growIdEnvList venv ids_w_incd_lvl
608 new_envs = (new_venv, new_tenv)
610 mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' ->
611 mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
613 ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
615 -- The "d_rhss" are the right-hand sides of "D" and "D'"
616 -- in the documentation above
617 d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
619 -- "local_binds" are "D'" in the documentation above
620 local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss
622 poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
623 | rhs' <- rhss' -- mkCoLet* requires Core...
626 poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
630 returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
631 -- The new right-hand sides, just a type application, aren't worth floating
632 -- so pin it with ctxt_lvl
635 = -- Let it float freely
637 ids_w_lvls = ids `zip` repeat expr_lvl
638 new_envs = (growIdEnvList venv ids_w_lvls, tenv)
640 mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss `thenLvl` \ rhss' ->
641 returnLvl (expr_lvl, [], rhss')
646 fvs = (unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `unionIdSets`
647 mkIdSet (concat (map idSpecVars ids)))
648 `minusIdSet` mkIdSet ids
649 tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
652 -- Why the "tyVarsOfTypes" part? Consider this:
653 -- /\a -> letrec x::a = x in E
654 -- Now, there are no explicit free type variables in the RHS of x,
655 -- but nevertheless "a" is free in its definition. So we add in
656 -- the free tyvars of the types of the binders.
657 -- This actually happened in the defn of errorIO in IOBase.lhs:
658 -- errorIO (ST io) = case (errorIO# io) of
661 -- bottom = bottom -- Never evaluated
662 -- I don't think this can every happen for non-recursive bindings.
664 fv_list = idSetToList fvs
665 tv_list = tyVarSetToList tfvs
667 ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
668 tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
669 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
672 | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
675 offending_tyvar_tys = mkTyVarTys offending_tyvars
676 poly_tys = map (mkForAllTys offending_tyvars) tys
678 offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
683 {- ******** OMITTED NOW
685 isWorthFloating :: Bool -- True <=> already let-bound
686 -> CoreExpr -- The expression
689 isWorthFloating alreadyLetBound expr
691 | alreadyLetBound = isWorthFloatingExpr expr
693 | otherwise = -- No point in adding a fresh let-binding for a WHNF, because
694 -- floating it isn't beneficial enough.
695 isWorthFloatingExpr expr &&
696 not (whnfOrBottom expr)
699 isWorthFloatingExpr :: CoreExpr -> Bool
701 isWorthFloatingExpr (Var v) = False
702 isWorthFloatingExpr (Lit lit) = False
703 isWorthFloatingExpr (App e arg)
704 | notValArg arg = isWorthFloatingExpr e
705 isWorthFloatingExpr (Con con as)
706 | all notValArg as = False -- Just a type application
707 isWorthFloatingExpr _ = True
709 canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
711 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
712 canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
714 valSuggestsLeakFree expr = whnfOrBottom expr
719 %************************************************************************
721 \subsection{Help functions}
723 %************************************************************************
726 idLevel :: IdEnv Level -> Id -> Level
728 = case lookupIdEnv venv v of
732 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
733 tyvarLevel tenv tyvar
734 = case lookupTyVarEnv tenv tyvar of
740 annCollectValBinders (_, (AnnLam (ValBinder arg) rhs))
743 (args, body) = annCollectValBinders rhs
745 annCollectValBinders body
749 %************************************************************************
751 \subsection{Free-To-Level Monad}
753 %************************************************************************
756 type LvlM result = UniqSM result
761 mapAndUnzipLvl = mapAndUnzipUs
762 mapAndUnzip3Lvl = mapAndUnzip3Us
765 We create a let-binding for `interesting' (non-utterly-trivial)
766 applications, to give them a fighting chance of being floated.
769 newLvlVar :: Type -> LvlM Id
772 = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc