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.
13 #include "HsVersions.h"
20 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
21 -- not exported: , incMajorLvl, isTopMajLvl, unTopify
29 import CoreUtils ( coreExprType )
30 import CoreUnfold ( whnfOrBottom )
31 import FreeVars -- all of it
32 import Id ( idType, mkSysLocal,
33 nullIdEnv, addOneToIdEnv, growIdEnvList,
34 unionManyIdSets, minusIdSet, mkIdSet,
35 idSetToList, SYN_IE(Id),
36 lookupIdEnv, SYN_IE(IdEnv)
38 import Pretty ( ptext, hcat, char, int )
39 import SrcLoc ( noSrcLoc )
40 import Type ( isPrimType, mkTyVarTys, mkForAllTys, SYN_IE(Type) )
41 import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
42 growTyVarEnvList, lookupTyVarEnv,
44 SYN_IE(TyVarEnv), SYN_IE(TyVar),
47 import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
48 mapAndUnzip3Us, getUnique, SYN_IE(UniqSM),
51 import Usage ( SYN_IE(UVar) )
52 import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
53 #if __GLASGOW_HASKELL__ >= 202
54 import Outputable ( Outputable(..) )
57 isLeakFreeType x y = False -- safe option; ToDo
60 %************************************************************************
62 \subsection{Level numbers}
64 %************************************************************************
68 = Top -- Means *really* the top level.
69 | Level Int -- Level number of enclosing lambdas
70 Int -- Number of big-lambda and/or case expressions between
71 -- here and the nearest enclosing lambda
74 The {\em level number} on a (type-)lambda-bound variable is the
75 nesting depth of the (type-)lambda which binds it. On an expression,
76 it's the maximum level number of its free (type-)variables. On a
77 let(rec)-bound variable, it's the level of its RHS. On a case-bound
78 variable, it's the number of enclosing lambdas.
80 Top-level variables: level~0. Those bound on the RHS of a top-level
81 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
84 a_0 = let b_? = ... in
85 x_1 = ... b ... in ...
88 Level 0 0 will make something get floated to a top-level "equals",
89 @Top@ makes it go right to the top.
91 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
92 That's meant to be the level number of the enclosing binder in the
93 final (floated) program. If the level number of a sub-expression is
94 less than that of the context, then it might be worth let-binding the
95 sub-expression so that it will indeed float. This context level starts
96 at @Level 0 0@; it is never @Top@.
99 type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar
100 type LevelledArg = GenCoreArg Id TyVar UVar
101 type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar
103 type LevelEnvs = (IdEnv Level, -- bind Ids to levels
104 TyVarEnv Level) -- bind type variables to levels
108 incMajorLvl :: Level -> Level
109 incMajorLvl Top = Level 1 0
110 incMajorLvl (Level major minor) = Level (major+1) 0
112 incMinorLvl :: Level -> Level
113 incMinorLvl Top = Level 0 1
114 incMinorLvl (Level major minor) = Level major (minor+1)
116 maxLvl :: Level -> Level -> Level
119 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
120 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
123 ltLvl :: Level -> Level -> Bool
125 ltLvl Top (Level _ _) = True
126 ltLvl (Level maj1 min1) (Level maj2 min2)
127 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
129 ltMajLvl :: Level -> Level -> Bool
130 -- Tells if one level belongs to a difft *lambda* level to another
131 ltMajLvl l1 Top = False
132 ltMajLvl Top (Level 0 _) = False
133 ltMajLvl Top (Level _ _) = True
134 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
136 isTopLvl :: Level -> Bool
138 isTopLvl other = False
140 isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
141 isTopMajLvl Top = True
142 isTopMajLvl (Level maj _) = maj == 0
144 unTopify :: Level -> Level
145 unTopify Top = Level 0 0
148 instance Outputable Level where
149 ppr sty Top = ptext SLIT("<Top>")
150 ppr sty (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
153 %************************************************************************
155 \subsection{Main level-setting code}
157 %************************************************************************
160 setLevels :: [CoreBinding]
167 -- "do_them"'s main business is to thread the monad along
168 -- It gives each top binding the same empty envt, because
169 -- things unbound in the envt have level number zero implicitly
170 do_them :: [CoreBinding] -> LvlM [LevelledBind]
172 do_them [] = returnLvl []
174 = lvlTopBind b `thenLvl` \ (lvld_bind, _) ->
175 do_them bs `thenLvl` \ lvld_binds ->
176 returnLvl (lvld_bind ++ lvld_binds)
178 initial_envs = (nullIdEnv, nullTyVarEnv)
180 lvlTopBind (NonRec binder rhs)
181 = lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs))
182 -- Rhs can have no free vars!
184 lvlTopBind (Rec pairs)
185 = lvlBind (Level 0 0) initial_envs (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
188 %************************************************************************
190 \subsection{Bindings}
192 %************************************************************************
194 The binding stuff works for top level too.
197 type CoreBindingWithFVs = AnnCoreBinding Id Id TyVar UVar FVInfo
201 -> CoreBindingWithFVs
202 -> LvlM ([LevelledBind], LevelEnvs)
204 lvlBind ctxt_lvl envs@(venv, tenv) (AnnNonRec name rhs)
205 = setFloatLevel True {- Already let-bound -}
206 ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') ->
208 new_envs = (addOneToIdEnv venv name final_lvl, tenv)
210 returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
215 lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec pairs)
216 = decideRecFloatLevel ctxt_lvl envs binders rhss
217 `thenLvl` \ (final_lvl, extra_binds, rhss') ->
219 binders_w_lvls = binders `zip` repeat final_lvl
220 new_envs = (growIdEnvList venv binders_w_lvls, tenv)
222 returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_envs)
224 (binders,rhss) = unzip pairs
227 %************************************************************************
229 \subsection{Setting expression levels}
231 %************************************************************************
234 lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
235 -> LevelEnvs -- Level of in-scope names/tyvars
236 -> CoreExprWithFVs -- input expression
237 -> LvlM LevelledExpr -- Result expression
240 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
245 v = \x -> ...\y -> let r = case (..x..) of
249 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
250 the level of @r@, even though it's inside a level-2 @\y@. It's
251 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
252 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
253 --- because it isn't a *maximal* free expression.
255 If there were another lambda in @r@'s rhs, it would get level-2 as well.
258 lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v)
259 lvlExpr _ _ (_, AnnLit l) = returnLvl (Lit l)
260 lvlExpr _ _ (_, AnnCon con args) = returnLvl (Con con args)
261 lvlExpr _ _ (_, AnnPrim op args) = returnLvl (Prim op args)
263 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg)
264 = lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
265 returnLvl (App fun' arg)
267 lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
268 = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
269 returnLvl (SCC cc expr')
271 lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr)
272 = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
273 returnLvl (Coerce c ty expr')
275 -- We don't split adjacent lambdas. That is, given
277 -- we don't float to give
278 -- \x -> let v = x+y in \y -> (v,y)
279 -- Why not? Because partial applications are fairly rare, and splitting
280 -- lambdas makes them more expensive.
282 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
283 = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' ->
284 returnLvl (foldr (Lam . ValBinder) body' lvld_args)
286 incd_lvl = incMajorLvl ctxt_lvl
287 (args, body) = annCollectValBinders rhs
288 lvld_args = [(a,incd_lvl) | a <- (arg:args)]
289 new_venv = growIdEnvList venv lvld_args
291 -- We don't need to play such tricks for type lambdas, because
292 -- they don't get annotated
294 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
295 = lvlExpr incd_lvl (venv, new_tenv) body `thenLvl` \ body' ->
296 returnLvl (Lam (TyBinder tyvar) body')
298 incd_lvl = incMinorLvl ctxt_lvl
299 new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
301 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
302 = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
304 lvlExpr ctxt_lvl envs (_, AnnLet bind body)
305 = lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) ->
306 lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' ->
307 returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
309 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
310 = lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' ->
311 lvl_alts alts `thenLvl` \ alts' ->
312 returnLvl (Case expr' alts')
314 expr_type = coreExprType (deAnnotate expr)
315 incd_lvl = incMinorLvl ctxt_lvl
317 lvl_alts (AnnAlgAlts alts deflt)
318 = mapLvl lvl_alt alts `thenLvl` \ alts' ->
319 lvl_deflt deflt `thenLvl` \ deflt' ->
320 returnLvl (AlgAlts alts' deflt')
324 bs' = [ (b, incd_lvl) | b <- bs ]
325 new_envs = (growIdEnvList venv bs', tenv)
327 lvlMFE incd_lvl new_envs e `thenLvl` \ e' ->
328 returnLvl (con, bs', e')
330 lvl_alts (AnnPrimAlts alts deflt)
331 = mapLvl lvl_alt alts `thenLvl` \ alts' ->
332 lvl_deflt deflt `thenLvl` \ deflt' ->
333 returnLvl (PrimAlts alts' deflt')
336 = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
339 lvl_deflt AnnNoDefault = returnLvl NoDefault
341 lvl_deflt (AnnBindDefault b expr)
343 new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
345 lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
346 returnLvl (BindDefault (b, incd_lvl) expr')
349 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
350 the expression, so that it can itself be floated.
353 lvlMFE :: Level -- Level of innermost enclosing lambda/tylam
354 -> LevelEnvs -- Level of in-scope names/tyvars
355 -> CoreExprWithFVs -- input expression
356 -> LvlM LevelledExpr -- Result expression
358 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
359 | isPrimType ty -- Can't let-bind it
360 = lvlExpr ctxt_lvl envs ann_expr
362 | otherwise -- Not primitive type so could be let-bound
363 = setFloatLevel False {- Not already let-bound -}
364 ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') ->
367 ty = coreExprType (deAnnotate ann_expr)
371 %************************************************************************
373 \subsection{Deciding floatability}
375 %************************************************************************
377 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
378 are being created as let-bindings
382 YES. -> (a) try abstracting type variables.
383 If we abstract type variables it will go further, that is, past more
384 lambdas. same as asking if the level number given by the free
385 variables is less than the level number given by free variables
386 and type variables together.
387 Abstract offending type variables, e.g.
389 to let v = /\ty' -> f ty' a b
391 so that v' is not stopped by the level number of ty
392 tag the original let with its level number
393 (from its variables and type variables)
395 YES. -> No point in let binding to float a WHNF.
396 Pin (leave) expression here.
397 NO. -> Will float past a lambda?
398 (check using free variables only, not type variables)
399 YES. -> do the same as (a) above.
400 NO. -> No point in let binding if it is not going anywhere
401 Pin (leave) expression here.
404 setFloatLevel :: Bool -- True <=> the expression is already let-bound
405 -- False <=> it's a possible MFE
406 -> Level -- of context
409 -> CoreExprWithFVs -- Original rhs
410 -> Type -- Type of rhs
412 -> LvlM (Level, -- Level to attribute to this let-binding
413 LevelledExpr) -- Final rhs
415 setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
416 expr@(FVInfo fvs tfvs might_leak, _) ty
417 -- Invariant: ctxt_lvl is never = Top
418 -- Beautiful ASSERT, dudes (WDP 95/04)...
420 -- Now deal with (by not floating) trivial non-let-bound expressions
421 -- which just aren't worth let-binding in order to float. We always
422 -- choose to float even trivial let-bound things because it doesn't do
423 -- any harm, and not floating it may pin something important. For
430 -- Here, if we don't float v we won't float w, which is Bad News.
431 -- If this gives any problems we could restrict the idea to things destined
434 | not alreadyLetBound
435 && (manifestly_whnf || not will_float_past_lambda)
436 = -- Pin whnf non-let-bound expressions,
437 -- or ones which aren't going anywhere useful
438 lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
439 returnLvl (ctxt_lvl, expr')
441 | alreadyLetBound && not worth_type_abstraction
442 = -- Process the expression with a new ctxt_lvl, obtained from
443 -- the free vars of the expression itself
444 lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
445 returnLvl (maybe_unTopify expr_lvl, expr')
447 | otherwise -- This will create a let anyway, even if there is no
448 -- type variable to abstract, so we try to abstract anyway
449 = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
450 `thenLvl` \ final_expr ->
451 returnLvl (expr_lvl, final_expr)
452 -- OLD LIE: The body of the let, just a type application, isn't worth floating
453 -- so pin it with ctxt_lvl
454 -- The truth: better to give it expr_lvl in case it is pinning
455 -- something non-trivial which depends on it.
457 fv_list = idSetToList fvs
458 tv_list = tyVarSetToList tfvs
459 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
460 ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
461 tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
462 lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
464 will_float_past_lambda = -- Will escape lambda if let-bound
465 ids_only_lvl `ltMajLvl` ctxt_lvl
467 worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
468 -- if type abstracted
469 (ids_only_lvl `ltLvl` tyvars_only_lvl)
470 && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
472 de_ann_expr = deAnnotate expr
475 | notValArg a = is_trivial e
476 is_trivial (Var _) = True
479 offending_tyvars = filter offending tv_list
480 --non_offending_tyvars = filter (not . offending) tv_list
481 --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
483 offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
485 manifestly_whnf = whnfOrBottom de_ann_expr
487 maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
488 maybe_unTopify lvl = lvl
489 {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
490 -- so that the let will not go past the *last* lambda if it can
491 -- generate a space leak. If it is already in major level 0
492 -- It won't do any harm to give it a Level 1 0.
493 -- we should do the same test not only for things with level Top,
494 -- but also for anything that gets a major level 0.
496 f = \a -> let x = [1..1000]
499 f = let x = [1..1000]
501 is just as bad as floating x to the top level.
502 Notice it would be OK in cases like
503 f = \a -> let x = [1..1000]
507 f = let x = [1..1000]
510 as x will be gc'd after y is updated.
511 [We did not hit any problems with the above (Level 0 0) code
516 Abstract wrt tyvars, by making it just as if we had seen
521 instead of simply E. The idea is that v can be freely floated, since it
522 has no free type variables. Of course, if E has no free type
523 variables, then we just return E.
526 abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
527 = lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' ->
528 newLvlVar poly_ty `thenLvl` \ poly_var ->
530 poly_var_rhs = mkTyLam offending_tyvars expr'
531 poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
532 poly_var_app = mkTyApp (Var poly_var) (mkTyVarTys offending_tyvars)
533 final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
537 poly_ty = mkForAllTys offending_tyvars ty
539 -- These defns are just like those in the TyLam case of lvlExpr
540 (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
542 next lvl tyvar = (lvl1, (tyvar,lvl1))
543 where lvl1 = incMinorLvl lvl
545 new_tenv = growTyVarEnvList tenv tyvar_lvls
546 new_envs = (venv, new_tenv)
549 Recursive definitions. We want to transform
561 x1' = /\ ab -> let D' in e1
563 xn' = /\ ab -> let D' in en
567 where ab are the tyvars pinning the defn further in than it
568 need be, and D is a bunch of simple type applications:
574 The "_cl" indicates that in D, the level numbers on the xi are the context level
575 number; type applications aren't worth floating. The D' decls are
582 but differ in their level numbers; here the ab are the newly-introduced
586 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
587 | isTopMajLvl ids_only_lvl && -- Destination = top
588 not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top
591 ids_w_lvls = ids `zip` repeat ctxt_lvl
592 new_envs = (growIdEnvList venv ids_w_lvls, tenv)
594 mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' ->
595 returnLvl (ctxt_lvl, [], rhss')
597 {- OMITTED; see comments above near isWorthFloatingExpr
599 | not (any (isWorthFloating True . deAnnotate) rhss)
601 mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
602 returnLvl (ctxt_lvl, [], rhss')
606 | ids_only_lvl `ltLvl` tyvars_only_lvl
607 = -- Abstract wrt tyvars;
608 -- offending_tyvars is definitely non-empty
609 -- (I love the ASSERT to check this... WDP 95/02)
611 -- These defns are just like those in the TyLam case of lvlExpr
612 (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
614 next lvl tyvar = (lvl1, (tyvar,lvl1))
615 where lvl1 = incMinorLvl lvl
617 ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
618 new_tenv = growTyVarEnvList tenv tyvar_lvls
619 new_venv = growIdEnvList venv ids_w_incd_lvl
620 new_envs = (new_venv, new_tenv)
622 mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' ->
623 mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
625 ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
627 -- The "d_rhss" are the right-hand sides of "D" and "D'"
628 -- in the documentation above
629 d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
631 -- "local_binds" are "D'" in the documentation above
632 local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss
634 poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
635 | rhs' <- rhss' -- mkCoLet* requires Core...
638 poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars] poly_var_rhss
641 returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
642 -- The new right-hand sides, just a type application, aren't worth floating
643 -- so pin it with ctxt_lvl
646 = -- Let it float freely
648 ids_w_lvls = ids `zip` repeat expr_lvl
649 new_envs = (growIdEnvList venv ids_w_lvls, tenv)
651 mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss `thenLvl` \ rhss' ->
652 returnLvl (expr_lvl, [], rhss')
657 fvs = unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
658 tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
659 fv_list = idSetToList fvs
660 tv_list = tyVarSetToList tfvs
662 ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
663 tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
664 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
667 | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
670 offending_tyvar_tys = mkTyVarTys offending_tyvars
671 poly_tys = map (mkForAllTys offending_tyvars) tys
673 offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
678 {- ******** OMITTED NOW
680 isWorthFloating :: Bool -- True <=> already let-bound
681 -> CoreExpr -- The expression
684 isWorthFloating alreadyLetBound expr
686 | alreadyLetBound = isWorthFloatingExpr expr
688 | otherwise = -- No point in adding a fresh let-binding for a WHNF, because
689 -- floating it isn't beneficial enough.
690 isWorthFloatingExpr expr &&
691 not (whnfOrBottom expr)
694 isWorthFloatingExpr :: CoreExpr -> Bool
696 isWorthFloatingExpr (Var v) = False
697 isWorthFloatingExpr (Lit lit) = False
698 isWorthFloatingExpr (App e arg)
699 | notValArg arg = isWorthFloatingExpr e
700 isWorthFloatingExpr (Con con as)
701 | all notValArg as = False -- Just a type application
702 isWorthFloatingExpr _ = True
704 canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
706 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
707 canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
709 valSuggestsLeakFree expr = whnfOrBottom expr
714 %************************************************************************
716 \subsection{Help functions}
718 %************************************************************************
721 idLevel :: IdEnv Level -> Id -> Level
723 = case lookupIdEnv venv v of
727 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
728 tyvarLevel tenv tyvar
729 = case lookupTyVarEnv tenv tyvar of
735 annCollectValBinders (_, (AnnLam (ValBinder arg) rhs))
738 (args, body) = annCollectValBinders rhs
740 annCollectValBinders body
744 %************************************************************************
746 \subsection{Free-To-Level Monad}
748 %************************************************************************
751 type LvlM result = UniqSM result
756 mapAndUnzipLvl = mapAndUnzipUs
757 mapAndUnzip3Lvl = mapAndUnzip3Us
760 We create a let-binding for `interesting' (non-utterly-trivial)
761 applications, to give them a fighting chance of being floated.
764 newLvlVar :: Type -> LvlM Id
767 = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc