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, manifestlyWHNF, manifestlyBottom )
30 import FreeVars -- all of it
31 import Id ( idType, mkSysLocal, toplevelishId,
32 nullIdEnv, addOneToIdEnv, growIdEnvList,
33 unionManyIdSets, minusIdSet, mkIdSet,
35 lookupIdEnv, SYN_IE(IdEnv)
37 import Pretty ( ppStr, ppBesides, ppChar, ppInt )
38 import SrcLoc ( mkUnknownSrcLoc )
39 import Type ( isPrimType, mkTyVarTys, mkForAllTys )
40 import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
41 growTyVarEnvList, lookupTyVarEnv,
46 import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs,
47 mapAndUnzip3Us, getUnique, SYN_IE(UniqSM),
50 import Usage ( SYN_IE(UVar) )
51 import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
53 isLeakFreeType x y = False -- safe option; ToDo
56 %************************************************************************
58 \subsection{Level numbers}
60 %************************************************************************
64 = Top -- Means *really* the top level.
65 | Level Int -- Level number of enclosing lambdas
66 Int -- Number of big-lambda and/or case expressions between
67 -- here and the nearest enclosing lambda
70 The {\em level number} on a (type-)lambda-bound variable is the
71 nesting depth of the (type-)lambda which binds it. On an expression,
72 it's the maximum level number of its free (type-)variables. On a
73 let(rec)-bound variable, it's the level of its RHS. On a case-bound
74 variable, it's the number of enclosing lambdas.
76 Top-level variables: level~0. Those bound on the RHS of a top-level
77 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
80 a_0 = let b_? = ... in
81 x_1 = ... b ... in ...
84 Level 0 0 will make something get floated to a top-level "equals",
85 @Top@ makes it go right to the top.
87 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
88 That's meant to be the level number of the enclosing binder in the
89 final (floated) program. If the level number of a sub-expression is
90 less than that of the context, then it might be worth let-binding the
91 sub-expression so that it will indeed float. This context level starts
92 at @Level 0 0@; it is never @Top@.
95 type LevelledExpr = GenCoreExpr (Id, Level) Id TyVar UVar
96 type LevelledArg = GenCoreArg Id TyVar UVar
97 type LevelledBind = GenCoreBinding (Id, Level) Id TyVar UVar
99 type LevelEnvs = (IdEnv Level, -- bind Ids to levels
100 TyVarEnv Level) -- bind type variables to levels
104 incMajorLvl :: Level -> Level
105 incMajorLvl Top = Level 1 0
106 incMajorLvl (Level major minor) = Level (major+1) 0
108 incMinorLvl :: Level -> Level
109 incMinorLvl Top = Level 0 1
110 incMinorLvl (Level major minor) = Level major (minor+1)
112 maxLvl :: Level -> Level -> Level
115 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
116 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
119 ltLvl :: Level -> Level -> Bool
121 ltLvl Top (Level _ _) = True
122 ltLvl (Level maj1 min1) (Level maj2 min2)
123 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
125 ltMajLvl :: Level -> Level -> Bool
126 -- Tells if one level belongs to a difft *lambda* level to another
127 ltMajLvl l1 Top = False
128 ltMajLvl Top (Level 0 _) = False
129 ltMajLvl Top (Level _ _) = True
130 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
132 isTopLvl :: Level -> Bool
134 isTopLvl other = False
136 isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
137 isTopMajLvl Top = True
138 isTopMajLvl (Level maj _) = maj == 0
140 unTopify :: Level -> Level
141 unTopify Top = Level 0 0
144 instance Outputable Level where
145 ppr sty Top = ppStr "<Top>"
146 ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ]
149 %************************************************************************
151 \subsection{Main level-setting code}
153 %************************************************************************
156 setLevels :: [CoreBinding]
163 -- "do_them"'s main business is to thread the monad along
164 -- It gives each top binding the same empty envt, because
165 -- things unbound in the envt have level number zero implicitly
166 do_them :: [CoreBinding] -> LvlM [LevelledBind]
168 do_them [] = returnLvl []
170 = lvlTopBind b `thenLvl` \ (lvld_bind, _) ->
171 do_them bs `thenLvl` \ lvld_binds ->
172 returnLvl (lvld_bind ++ lvld_binds)
174 initial_envs = (nullIdEnv, nullTyVarEnv)
176 lvlTopBind (NonRec binder rhs)
177 = lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs))
178 -- Rhs can have no free vars!
180 lvlTopBind (Rec pairs)
181 = lvlBind (Level 0 0) initial_envs (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
184 %************************************************************************
186 \subsection{Bindings}
188 %************************************************************************
190 The binding stuff works for top level too.
193 type CoreBindingWithFVs = AnnCoreBinding Id Id TyVar UVar FVInfo
197 -> CoreBindingWithFVs
198 -> LvlM ([LevelledBind], LevelEnvs)
200 lvlBind ctxt_lvl envs@(venv, tenv) (AnnNonRec name rhs)
201 = setFloatLevel True {- Already let-bound -}
202 ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') ->
204 new_envs = (addOneToIdEnv venv name final_lvl, tenv)
206 returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
211 lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec pairs)
212 = decideRecFloatLevel ctxt_lvl envs binders rhss
213 `thenLvl` \ (final_lvl, extra_binds, rhss') ->
215 binders_w_lvls = binders `zip` repeat final_lvl
216 new_envs = (growIdEnvList venv binders_w_lvls, tenv)
218 returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_envs)
220 (binders,rhss) = unzip pairs
223 %************************************************************************
225 \subsection{Setting expression levels}
227 %************************************************************************
230 lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
231 -> LevelEnvs -- Level of in-scope names/tyvars
232 -> CoreExprWithFVs -- input expression
233 -> LvlM LevelledExpr -- Result expression
236 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
241 v = \x -> ...\y -> let r = case (..x..) of
245 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
246 the level of @r@, even though it's inside a level-2 @\y@. It's
247 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
248 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
249 --- because it isn't a *maximal* free expression.
251 If there were another lambda in @r@'s rhs, it would get level-2 as well.
254 lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v)
255 lvlExpr _ _ (_, AnnLit l) = returnLvl (Lit l)
256 lvlExpr _ _ (_, AnnCon con args) = returnLvl (Con con args)
257 lvlExpr _ _ (_, AnnPrim op args) = returnLvl (Prim op args)
259 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg)
260 = lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
261 returnLvl (App fun' arg)
263 lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
264 = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
265 returnLvl (SCC cc expr')
267 lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr)
268 = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
269 returnLvl (Coerce c ty expr')
271 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
272 = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
273 returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
275 incd_lvl = incMajorLvl ctxt_lvl
276 new_venv = growIdEnvList venv [(arg,incd_lvl)]
278 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e)
279 = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
280 returnLvl (Lam (TyBinder tyvar) e')
282 incd_lvl = incMinorLvl ctxt_lvl
283 new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
285 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
286 = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
288 lvlExpr ctxt_lvl envs (_, AnnLet bind body)
289 = lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) ->
290 lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' ->
291 returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
293 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
294 = lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' ->
295 lvl_alts alts `thenLvl` \ alts' ->
296 returnLvl (Case expr' alts')
298 expr_type = coreExprType (deAnnotate expr)
299 incd_lvl = incMinorLvl ctxt_lvl
301 lvl_alts (AnnAlgAlts alts deflt)
302 = mapLvl lvl_alt alts `thenLvl` \ alts' ->
303 lvl_deflt deflt `thenLvl` \ deflt' ->
304 returnLvl (AlgAlts alts' deflt')
308 bs' = [ (b, incd_lvl) | b <- bs ]
309 new_envs = (growIdEnvList venv bs', tenv)
311 lvlMFE incd_lvl new_envs e `thenLvl` \ e' ->
312 returnLvl (con, bs', e')
314 lvl_alts (AnnPrimAlts alts deflt)
315 = mapLvl lvl_alt alts `thenLvl` \ alts' ->
316 lvl_deflt deflt `thenLvl` \ deflt' ->
317 returnLvl (PrimAlts alts' deflt')
320 = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
323 lvl_deflt AnnNoDefault = returnLvl NoDefault
325 lvl_deflt (AnnBindDefault b expr)
327 new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
329 lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
330 returnLvl (BindDefault (b, incd_lvl) expr')
333 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
334 the expression, so that it can itself be floated.
337 lvlMFE :: Level -- Level of innermost enclosing lambda/tylam
338 -> LevelEnvs -- Level of in-scope names/tyvars
339 -> CoreExprWithFVs -- input expression
340 -> LvlM LevelledExpr -- Result expression
342 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
343 | isPrimType ty -- Can't let-bind it
344 = lvlExpr ctxt_lvl envs ann_expr
346 | otherwise -- Not primitive type so could be let-bound
347 = setFloatLevel False {- Not already let-bound -}
348 ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') ->
351 ty = coreExprType (deAnnotate ann_expr)
355 %************************************************************************
357 \subsection{Deciding floatability}
359 %************************************************************************
361 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
362 are being created as let-bindings
366 YES. -> (a) try abstracting type variables.
367 If we abstract type variables it will go further, that is, past more
368 lambdas. same as asking if the level number given by the free
369 variables is less than the level number given by free variables
370 and type variables together.
371 Abstract offending type variables, e.g.
373 to let v = /\ty' -> f ty' a b
375 so that v' is not stopped by the level number of ty
376 tag the original let with its level number
377 (from its variables and type variables)
379 YES. -> No point in let binding to float a WHNF.
380 Pin (leave) expression here.
381 NO. -> Will float past a lambda?
382 (check using free variables only, not type variables)
383 YES. -> do the same as (a) above.
384 NO. -> No point in let binding if it is not going anywhere
385 Pin (leave) expression here.
388 setFloatLevel :: Bool -- True <=> the expression is already let-bound
389 -- False <=> it's a possible MFE
390 -> Level -- of context
393 -> CoreExprWithFVs -- Original rhs
394 -> Type -- Type of rhs
396 -> LvlM (Level, -- Level to attribute to this let-binding
397 LevelledExpr) -- Final rhs
399 setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
400 expr@(FVInfo fvs tfvs might_leak, _) ty
401 -- Invariant: ctxt_lvl is never = Top
402 -- Beautiful ASSERT, dudes (WDP 95/04)...
404 -- Now deal with (by not floating) trivial non-let-bound expressions
405 -- which just aren't worth let-binding in order to float. We always
406 -- choose to float even trivial let-bound things because it doesn't do
407 -- any harm, and not floating it may pin something important. For
414 -- Here, if we don't float v we won't float w, which is Bad News.
415 -- If this gives any problems we could restrict the idea to things destined
418 | not alreadyLetBound
419 && (manifestly_whnf || not will_float_past_lambda)
420 = -- Pin whnf non-let-bound expressions,
421 -- or ones which aren't going anywhere useful
422 lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
423 returnLvl (ctxt_lvl, expr')
425 | alreadyLetBound && not worth_type_abstraction
426 = -- Process the expression with a new ctxt_lvl, obtained from
427 -- the free vars of the expression itself
428 lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
429 returnLvl (maybe_unTopify expr_lvl, expr')
431 | otherwise -- This will create a let anyway, even if there is no
432 -- type variable to abstract, so we try to abstract anyway
433 = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
434 `thenLvl` \ final_expr ->
435 returnLvl (expr_lvl, final_expr)
436 -- OLD LIE: The body of the let, just a type application, isn't worth floating
437 -- so pin it with ctxt_lvl
438 -- The truth: better to give it expr_lvl in case it is pinning
439 -- something non-trivial which depends on it.
441 fv_list = idSetToList fvs
442 tv_list = tyVarSetToList tfvs
443 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
444 ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
445 tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
446 lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
448 will_float_past_lambda = -- Will escape lambda if let-bound
449 ids_only_lvl `ltMajLvl` ctxt_lvl
451 worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
452 -- if type abstracted
453 (ids_only_lvl `ltLvl` tyvars_only_lvl)
454 && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
456 de_ann_expr = deAnnotate expr
459 | notValArg a = is_trivial e
460 is_trivial (Var _) = True
463 offending_tyvars = filter offending tv_list
464 --non_offending_tyvars = filter (not . offending) tv_list
465 --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
467 offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
469 manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
471 maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
472 maybe_unTopify lvl = lvl
473 {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
474 -- so that the let will not go past the *last* lambda if it can
475 -- generate a space leak. If it is already in major level 0
476 -- It won't do any harm to give it a Level 1 0.
477 -- we should do the same test not only for things with level Top,
478 -- but also for anything that gets a major level 0.
480 f = \a -> let x = [1..1000]
483 f = let x = [1..1000]
485 is just as bad as floating x to the top level.
486 Notice it would be OK in cases like
487 f = \a -> let x = [1..1000]
491 f = let x = [1..1000]
494 as x will be gc'd after y is updated.
495 [We did not hit any problems with the above (Level 0 0) code
500 Abstract wrt tyvars, by making it just as if we had seen
505 instead of simply E. The idea is that v can be freely floated, since it
506 has no free type variables. Of course, if E has no free type
507 variables, then we just return E.
510 abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
511 = lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' ->
512 newLvlVar poly_ty `thenLvl` \ poly_var ->
514 poly_var_rhs = mkTyLam offending_tyvars expr'
515 poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
516 poly_var_app = mkTyApp (Var poly_var) (mkTyVarTys offending_tyvars)
517 final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
521 poly_ty = mkForAllTys offending_tyvars ty
523 -- These defns are just like those in the TyLam case of lvlExpr
524 (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
526 next lvl tyvar = (lvl1, (tyvar,lvl1))
527 where lvl1 = incMinorLvl lvl
529 new_tenv = growTyVarEnvList tenv tyvar_lvls
530 new_envs = (venv, new_tenv)
533 Recursive definitions. We want to transform
545 x1' = /\ ab -> let D' in e1
547 xn' = /\ ab -> let D' in en
551 where ab are the tyvars pinning the defn further in than it
552 need be, and D is a bunch of simple type applications:
558 The "_cl" indicates that in D, the level numbers on the xi are the context level
559 number; type applications aren't worth floating. The D' decls are
566 but differ in their level numbers; here the ab are the newly-introduced
570 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
571 | isTopMajLvl ids_only_lvl && -- Destination = top
572 not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top
575 ids_w_lvls = ids `zip` repeat ctxt_lvl
576 new_envs = (growIdEnvList venv ids_w_lvls, tenv)
578 mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' ->
579 returnLvl (ctxt_lvl, [], rhss')
581 {- OMITTED; see comments above near isWorthFloatingExpr
583 | not (any (isWorthFloating True . deAnnotate) rhss)
585 mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
586 returnLvl (ctxt_lvl, [], rhss')
590 | ids_only_lvl `ltLvl` tyvars_only_lvl
591 = -- Abstract wrt tyvars;
592 -- offending_tyvars is definitely non-empty
593 -- (I love the ASSERT to check this... WDP 95/02)
595 -- These defns are just like those in the TyLam case of lvlExpr
596 (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
598 next lvl tyvar = (lvl1, (tyvar,lvl1))
599 where lvl1 = incMinorLvl lvl
601 ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
602 new_tenv = growTyVarEnvList tenv tyvar_lvls
603 new_venv = growIdEnvList venv ids_w_incd_lvl
604 new_envs = (new_venv, new_tenv)
606 mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' ->
607 mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
609 ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
611 -- The "d_rhss" are the right-hand sides of "D" and "D'"
612 -- in the documentation above
613 d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
615 -- "local_binds" are "D'" in the documentation above
616 local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss
618 poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
619 | rhs' <- rhss' -- mkCoLet* requires Core...
622 poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars] poly_var_rhss
625 returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
626 -- The new right-hand sides, just a type application, aren't worth floating
627 -- so pin it with ctxt_lvl
630 = -- Let it float freely
632 ids_w_lvls = ids `zip` repeat expr_lvl
633 new_envs = (growIdEnvList venv ids_w_lvls, tenv)
635 mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss `thenLvl` \ rhss' ->
636 returnLvl (expr_lvl, [], rhss')
641 fvs = unionManyIdSets [freeVarsOf rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
642 tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
643 fv_list = idSetToList fvs
644 tv_list = tyVarSetToList tfvs
646 ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
647 tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
648 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
651 | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
654 offending_tyvar_tys = mkTyVarTys offending_tyvars
655 poly_tys = map (mkForAllTys offending_tyvars) tys
657 offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
662 {- ******** OMITTED NOW
664 isWorthFloating :: Bool -- True <=> already let-bound
665 -> CoreExpr -- The expression
668 isWorthFloating alreadyLetBound expr
670 | alreadyLetBound = isWorthFloatingExpr expr
672 | otherwise = -- No point in adding a fresh let-binding for a WHNF, because
673 -- floating it isn't beneficial enough.
674 isWorthFloatingExpr expr &&
675 not (manifestlyWHNF expr || manifestlyBottom expr)
678 isWorthFloatingExpr :: CoreExpr -> Bool
680 isWorthFloatingExpr (Var v) = False
681 isWorthFloatingExpr (Lit lit) = False
682 isWorthFloatingExpr (App e arg)
683 | notValArg arg = isWorthFloatingExpr e
684 isWorthFloatingExpr (Con con as)
685 | all notValArg as = False -- Just a type application
686 isWorthFloatingExpr _ = True
688 canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
690 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
691 canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
693 valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
698 %************************************************************************
700 \subsection{Help functions}
702 %************************************************************************
705 idLevel :: IdEnv Level -> Id -> Level
707 = case lookupIdEnv venv v of
709 Nothing -> ASSERT(toplevelishId v)
712 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
713 tyvarLevel tenv tyvar
714 = case lookupTyVarEnv tenv tyvar of
719 %************************************************************************
721 \subsection{Free-To-Level Monad}
723 %************************************************************************
726 type LvlM result = UniqSM result
731 mapAndUnzipLvl = mapAndUnzipUs
732 mapAndUnzip3Lvl = mapAndUnzip3Us
735 We create a let-binding for `interesting' (non-utterly-trivial)
736 applications, to give them a fighting chance of being floated.
739 newLvlVar :: Type -> LvlM Id
742 = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc