2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
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
27 import AbsUniType ( isPrimType, isLeakFreeType, mkTyVarTy,
28 quantifyTy, TyVarTemplate -- Needed for quantifyTy
31 import BasicLit ( BasicLit(..) )
32 import CmdLineOpts ( GlobalSwitch(..) )
34 import Id ( mkSysLocal, getIdUniType, eqId,
35 isBottomingId, toplevelishId, DataCon(..)
36 IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
39 import Maybes ( Maybe(..) )
40 import Pretty -- debugging only
41 import PrimKind ( PrimKind(..) )
43 import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
50 %************************************************************************
52 \subsection{Level numbers}
54 %************************************************************************
58 Int -- Level number of enclosing lambdas
59 Int -- Number of big-lambda and/or case expressions between
60 -- here and the nearest enclosing lambda
62 | Top -- Means *really* the top level.
65 The {\em level number} on a (type-)lambda-bound variable is the
66 nesting depth of the (type-)lambda which binds it. On an expression, it's the
67 maximum level number of its free (type-)variables. On a let(rec)-bound
68 variable, it's the level of its RHS. On a case-bound variable, it's
69 the number of enclosing lambdas.
71 Top-level variables: level~0. Those bound on the RHS of a top-level
72 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
75 a_0 = let b_? = ... in
76 x_1 = ... b ... in ...
79 Level 0 0 will make something get floated to a top-level "equals", @Top@
80 makes it go right to the top.
82 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@). That's
83 meant to be the level number of the enclosing binder in the final (floated)
84 program. If the level number of a sub-expression is less than that of the
85 context, then it might be worth let-binding the sub-expression so that it
86 will indeed float. This context level starts at @Level 0 0@; it is never @Top@.
89 type LevelledExpr = CoreExpr (Id, Level) Id
90 type LevelledAtom = CoreAtom Id
91 type LevelledBind = CoreBinding (Id, Level) Id
93 type LevelEnvs = (IdEnv Level, -- bind Ids to levels
94 TyVarEnv Level) -- bind type variables to levels
98 incMajorLvl :: Level -> Level
99 incMajorLvl Top = Level 1 0
100 incMajorLvl (Level major minor) = Level (major+1) 0
102 incMinorLvl :: Level -> Level
103 incMinorLvl Top = Level 0 1
104 incMinorLvl (Level major minor) = Level major (minor+1)
106 maxLvl :: Level -> Level -> Level
109 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
110 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
113 ltLvl :: Level -> Level -> Bool
115 ltLvl Top (Level _ _) = True
116 ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) ||
117 (maj1 == maj2 && min1 < min2)
119 ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft
120 -- *lambda* level to another
121 ltMajLvl l1 Top = False
122 ltMajLvl Top (Level 0 _) = False
123 ltMajLvl Top (Level _ _) = True
124 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
126 isTopLvl :: Level -> Bool
128 isTopLvl other = False
130 isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
131 isTopMajLvl Top = True
132 isTopMajLvl (Level maj _) = maj == 0
134 unTopify :: Level -> Level
135 unTopify Top = Level 0 0
138 instance Outputable Level where
139 ppr sty Top = ppStr "<Top>"
140 ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ]
143 %************************************************************************
145 \subsection{Main level-setting code}
147 %************************************************************************
150 setLevels :: [PlainCoreBinding]
151 -> (GlobalSwitch -> Bool) -- access to all global cmd-line opts
155 setLevels binds sw us
156 = do_them binds sw us
158 -- "do_them"'s main business is to thread the monad along
159 -- It gives each top binding the same empty envt, because
160 -- things unbound in the envt have level number zero implicitly
161 do_them :: [PlainCoreBinding] -> LvlM [LevelledBind]
163 do_them [] = returnLvl []
165 = lvlTopBind b `thenLvl` \ (lvld_bind, _) ->
166 do_them bs `thenLvl` \ lvld_binds ->
167 returnLvl (lvld_bind ++ lvld_binds)
169 initial_envs = (nullIdEnv, nullTyVarEnv)
172 lvlTopBind (CoNonRec binder rhs)
173 = lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder (freeVars rhs))
174 -- Rhs can have no free vars!
176 lvlTopBind (CoRec pairs)
177 = lvlBind (Level 0 0) initial_envs (AnnCoRec [(b,freeVars rhs) | (b,rhs) <- pairs])
179 {- NEWER: Too bad about the types: WDP:
180 lvlTopBind (CoNonRec binder rhs)
181 = {-SIGH:wrong type: ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} -- Rhs can have no free vars!
182 lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder emptyUniqSet)
184 lvlTopBind (CoRec pairs)
185 = lvlBind (Level 0 0) initial_envs
186 (AnnCoRec [(b, emptyUniqSet)
188 {-SIGH:ditto:ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} True])
192 %************************************************************************
194 \subsection{Bindings}
196 %************************************************************************
198 The binding stuff works for top level too.
201 type CoreBindingWithFVs = AnnCoreBinding Id Id FVInfo
205 -> CoreBindingWithFVs
206 -> LvlM ([LevelledBind], LevelEnvs)
208 lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoNonRec name rhs)
209 = setFloatLevel True {- Already let-bound -}
210 ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') ->
212 new_envs = (addOneToIdEnv venv name final_lvl, tenv)
214 returnLvl ([CoNonRec (name, final_lvl) rhs'], new_envs)
216 ty = getIdUniType name
219 lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs)
220 = decideRecFloatLevel ctxt_lvl envs binders rhss
221 `thenLvl` \ (final_lvl, extra_binds, rhss') ->
223 binders_w_lvls = binders `zip` repeat final_lvl
224 new_envs = (growIdEnvList venv binders_w_lvls, tenv)
226 returnLvl (extra_binds ++ [CoRec (binders_w_lvls `zip` rhss')], new_envs)
228 (binders,rhss) = unzip pairs
231 %************************************************************************
233 \subsection{Setting expression levels}
235 %************************************************************************
238 lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
239 -> LevelEnvs -- Level of in-scope names/tyvars
240 -> CoreExprWithFVs -- input expression
241 -> LvlM LevelledExpr -- Result expression
244 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
249 v = \x -> ...\y -> let r = case (..x..) of
253 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
254 the level of @r@, even though it's inside a level-2 @\y@. It's
255 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
256 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
257 --- because it isn't a *maximal* free expression.
259 If there were another lambda in @r@'s rhs, it would get level-2 as well.
262 lvlExpr _ _ (_, AnnCoVar v) = returnLvl (CoVar v)
263 lvlExpr _ _ (_, AnnCoLit l) = returnLvl (CoLit l)
264 lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (CoCon con tys atoms)
265 lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (CoPrim op tys atoms)
267 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty)
268 = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
269 returnLvl (CoTyApp expr' ty)
271 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoApp fun arg)
272 = lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
273 returnLvl (CoApp fun' arg)
275 lvlExpr ctxt_lvl envs (_, AnnCoSCC cc expr)
276 = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
277 returnLvl (CoSCC cc expr')
279 lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e)
280 = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
281 returnLvl (CoTyLam tyvar e')
283 incd_lvl = incMinorLvl ctxt_lvl
284 new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
286 {- if we were splitting lambdas:
287 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam [arg] rhs)
288 = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
289 returnLvl (CoLam arg_w_lvl rhs')
291 incd_lvl = incMajorLvl ctxt_lvl
292 arg_w_lvl = [(arg, incd_lvl)]
293 new_venv = growIdEnvList venv arg_w_lvl
295 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam (a:args) rhs)
296 = lvlExpr incd_lvl (new_venv, tenv) (AnnCoLam args rhs) `thenLvl` \ rhs' ->
297 -- don't use mkCoLam!
298 returnLvl (CoLam arg_w_lvl rhs')
300 incd_lvl = incMajorLvl ctxt_lvl
301 arg_w_lvl = [(a,incd_lvl)]
302 new_venv = growIdEnvList venv arg_w_lvl
305 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam args rhs)
306 = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
307 returnLvl (CoLam args_w_lvls rhs')
309 incd_lvl = incMajorLvl ctxt_lvl
310 args_w_lvls = [ (a, incd_lvl) | a <- args ]
311 new_venv = growIdEnvList venv args_w_lvls
313 lvlExpr ctxt_lvl envs (_, AnnCoLet bind body)
314 = lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) ->
315 lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' ->
316 returnLvl (foldr CoLet body' binds') -- mkCoLet* requires PlainCore...
318 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts)
319 = lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' ->
320 lvl_alts alts `thenLvl` \ alts' ->
321 returnLvl (CoCase expr' alts')
323 expr_type = typeOfCoreExpr (deAnnotate expr)
324 incd_lvl = incMinorLvl ctxt_lvl
326 lvl_alts (AnnCoAlgAlts alts deflt)
327 = mapLvl lvl_alt alts `thenLvl` \ alts' ->
328 lvl_deflt deflt `thenLvl` \ deflt' ->
329 returnLvl (CoAlgAlts alts' deflt')
333 bs' = [ (b, incd_lvl) | b <- bs ]
334 new_envs = (growIdEnvList venv bs', tenv)
336 lvlMFE incd_lvl new_envs e `thenLvl` \ e' ->
337 returnLvl (con, bs', e')
339 lvl_alts (AnnCoPrimAlts alts deflt)
340 = mapLvl lvl_alt alts `thenLvl` \ alts' ->
341 lvl_deflt deflt `thenLvl` \ deflt' ->
342 returnLvl (CoPrimAlts alts' deflt')
345 = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
348 lvl_deflt AnnCoNoDefault = returnLvl CoNoDefault
350 lvl_deflt (AnnCoBindDefault b expr)
352 new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
354 lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
355 returnLvl (CoBindDefault (b, incd_lvl) expr')
358 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
359 the expression, so that it can itself be floated.
362 lvlMFE :: Level -- Level of innermost enclosing lambda/tylam
363 -> LevelEnvs -- Level of in-scope names/tyvars
364 -> CoreExprWithFVs -- input expression
365 -> LvlM LevelledExpr -- Result expression
367 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
368 | isPrimType ty -- Can't let-bind it
369 = lvlExpr ctxt_lvl envs ann_expr
371 | otherwise -- Not primitive type so could be let-bound
372 = setFloatLevel False {- Not already let-bound -}
373 ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') ->
376 ty = typeOfCoreExpr (deAnnotate ann_expr)
380 %************************************************************************
382 \subsection{Deciding floatability}
384 %************************************************************************
386 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
387 are being created as let-bindings
391 YES. -> (a) try abstracting type variables.
392 If we abstract type variables it will go further, that is, past more
393 lambdas. same as asking if the level number given by the free
394 variables is less than the level number given by free variables
395 and type variables together.
396 Abstract offending type variables, e.g.
398 to let v = /\ty' -> f ty' a b
400 so that v' is not stopped by the level number of ty
401 tag the original let with its level number
402 (from its variables and type variables)
404 YES. -> No point in let binding to float a WHNF.
405 Pin (leave) expression here.
406 NO. -> Will float past a lambda?
407 (check using free variables only, not type variables)
408 YES. -> do the same as (a) above.
409 NO. -> No point in let binding if it is not going anywhere
410 Pin (leave) expression here.
413 setFloatLevel :: Bool -- True <=> the expression is already let-bound
414 -- False <=> it's a possible MFE
415 -> Level -- of context
418 -> CoreExprWithFVs -- Original rhs
419 -> UniType -- Type of rhs
421 -> LvlM (Level, -- Level to attribute to this let-binding
422 LevelledExpr) -- Final rhs
424 setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
425 expr@(FVInfo fvs tfvs might_leak, _) ty
426 -- Invariant: ctxt_lvl is never = Top
427 -- Beautiful ASSERT, dudes (WDP 95/04)...
429 -- Now deal with (by not floating) trivial non-let-bound expressions
430 -- which just aren't worth let-binding in order to float. We always
431 -- choose to float even trivial let-bound things because it doesn't do
432 -- any harm, and not floating it may pin something important. For
439 -- Here, if we don't float v we won't float w, which is Bad News.
440 -- If this gives any problems we could restrict the idea to things destined
443 | not alreadyLetBound
444 && (manifestly_whnf || not will_float_past_lambda)
445 = -- Pin whnf non-let-bound expressions,
446 -- or ones which aren't going anywhere useful
447 lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
448 returnLvl (ctxt_lvl, expr')
450 | alreadyLetBound && not worth_type_abstraction
451 = -- Process the expression with a new ctxt_lvl, obtained from
452 -- the free vars of the expression itself
453 lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
454 returnLvl (maybe_unTopify expr_lvl, expr')
456 | otherwise -- This will create a let anyway, even if there is no
457 -- type variable to abstract, so we try to abstract anyway
458 = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
459 `thenLvl` \ final_expr ->
460 returnLvl (expr_lvl, final_expr)
461 -- OLD LIE: The body of the let, just a type application, isn't worth floating
462 -- so pin it with ctxt_lvl
463 -- The truth: better to give it expr_lvl in case it is pinning
464 -- something non-trivial which depends on it.
466 fv_list = uniqSetToList fvs
467 tv_list = uniqSetToList tfvs
468 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
469 ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
470 tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
471 lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
473 will_float_past_lambda = -- Will escape lambda if let-bound
474 ids_only_lvl `ltMajLvl` ctxt_lvl
476 worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
477 -- if type abstracted
478 (ids_only_lvl `ltLvl` tyvars_only_lvl)
479 && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
481 de_ann_expr = deAnnotate expr
483 is_trivial (CoTyApp e _) = is_trivial e
484 is_trivial (CoVar _) = True
487 offending_tyvars = filter offending tv_list
488 --non_offending_tyvars = filter (not . offending) tv_list
489 --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
491 offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
493 manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
495 maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
496 maybe_unTopify lvl = lvl
497 {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
498 -- so that the let will not go past the *last* lambda if it can
499 -- generate a space leak. If it is already in major level 0
500 -- It won't do any harm to give it a Level 1 0.
501 -- we should do the same test not only for things with level Top,
502 -- but also for anything that gets a major level 0.
504 f = \a -> let x = [1..1000]
507 f = let x = [1..1000]
509 is just as bad as floating x to the top level.
510 Notice it would be OK in cases like
511 f = \a -> let x = [1..1000]
515 f = let x = [1..1000]
518 as x will be gc'd after y is updated.
519 [We did not hit any problems with the above (Level 0 0) code
524 Abstract wrt tyvars, by making it just as if we had seen
529 instead of simply E. The idea is that v can be freely floated, since it
530 has no free type variables. Of course, if E has no free type
531 variables, then we just return E.
534 abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
535 = lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' ->
536 newLvlVar poly_ty `thenLvl` \ poly_var ->
538 poly_var_rhs = mkCoTyLam offending_tyvars expr'
539 poly_var_binding = CoNonRec (poly_var, lvl) poly_var_rhs
540 poly_var_app = mkCoTyApps (CoVar poly_var) (map mkTyVarTy offending_tyvars)
541 final_expr = CoLet poly_var_binding poly_var_app -- mkCoLet* requires PlainCore
545 poly_ty = snd (quantifyTy offending_tyvars ty)
547 -- These defns are just like those in the TyLam case of lvlExpr
548 (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
550 next lvl tyvar = (lvl1, (tyvar,lvl1))
551 where lvl1 = incMinorLvl lvl
553 new_tenv = growTyVarEnvList tenv tyvar_lvls
554 new_envs = (venv, new_tenv)
557 Recursive definitions. We want to transform
569 x1' = /\ ab -> let D' in e1
571 xn' = /\ ab -> let D' in en
575 where ab are the tyvars pinning the defn further in than it
576 need be, and D is a bunch of simple type applications:
582 The "_cl" indicates that in D, the level numbers on the xi are the context level
583 number; type applications aren't worth floating. The D' decls are
590 but differ in their level numbers; here the ab are the newly-introduced
594 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
595 | isTopMajLvl ids_only_lvl && -- Destination = top
596 not (all canFloatToTop (tys `zip` rhss)) -- Some can't float to top
599 ids_w_lvls = ids `zip` repeat ctxt_lvl
600 new_envs = (growIdEnvList venv ids_w_lvls, tenv)
602 mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' ->
603 returnLvl (ctxt_lvl, [], rhss')
605 {- OMITTED; see comments above near isWorthFloatingExpr
607 | not (any (isWorthFloating True . deAnnotate) rhss)
609 mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
610 returnLvl (ctxt_lvl, [], rhss')
614 | ids_only_lvl `ltLvl` tyvars_only_lvl
615 = -- Abstract wrt tyvars;
616 -- offending_tyvars is definitely non-empty
617 -- (I love the ASSERT to check this... WDP 95/02)
619 -- These defns are just like those in the TyLam case of lvlExpr
620 (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
622 next lvl tyvar = (lvl1, (tyvar,lvl1))
623 where lvl1 = incMinorLvl lvl
625 ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
626 new_tenv = growTyVarEnvList tenv tyvar_lvls
627 new_venv = growIdEnvList venv ids_w_incd_lvl
628 new_envs = (new_venv, new_tenv)
630 mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' ->
631 mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
633 ids_w_poly_vars = ids `zip` poly_vars
635 -- The "d_rhss" are the right-hand sides of "D" and "D'"
636 -- in the documentation above
637 d_rhss = [ mkCoTyApps (CoVar poly_var) offending_tyvar_tys | poly_var <- poly_vars]
639 -- "local_binds" are "D'" in the documentation above
640 local_binds = zipWith CoNonRec ids_w_incd_lvl d_rhss
642 poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr CoLet rhs' local_binds)
643 | rhs' <- rhss' -- mkCoLet* requires PlainCore...
646 poly_binds = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss
649 returnLvl (ctxt_lvl, [CoRec poly_binds], d_rhss)
650 -- The new right-hand sides, just a type application, aren't worth floating
651 -- so pin it with ctxt_lvl
654 = -- Let it float freely
656 ids_w_lvls = ids `zip` repeat expr_lvl
657 new_envs = (growIdEnvList venv ids_w_lvls, tenv)
659 mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss `thenLvl` \ rhss' ->
660 returnLvl (expr_lvl, [], rhss')
663 tys = map getIdUniType ids
665 fvs = unionManyUniqSets [freeVarsOf rhs | rhs <- rhss] `minusUniqSet` mkUniqSet ids
666 tfvs = unionManyUniqSets [freeTyVarsOf rhs | rhs <- rhss]
667 fv_list = uniqSetToList fvs
668 tv_list = uniqSetToList tfvs
670 ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list
671 tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
672 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
675 | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
678 offending_tyvar_tys = map mkTyVarTy offending_tyvars
679 poly_tys = [ snd (quantifyTy offending_tyvars ty)
683 offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
688 {- ******** OMITTED NOW
690 isWorthFloating :: Bool -- True <=> already let-bound
691 -> PlainCoreExpr -- The expression
694 isWorthFloating alreadyLetBound expr
696 | alreadyLetBound = isWorthFloatingExpr expr
698 | otherwise = -- No point in adding a fresh let-binding for a WHNF, because
699 -- floating it isn't beneficial enough.
700 isWorthFloatingExpr expr &&
701 not (manifestlyWHNF expr || manifestlyBottom expr)
704 isWorthFloatingExpr :: PlainCoreExpr -> Bool
705 isWorthFloatingExpr (CoVar v) = False
706 isWorthFloatingExpr (CoLit lit) = False
707 isWorthFloatingExpr (CoCon con tys []) = False -- Just a type application
708 isWorthFloatingExpr (CoTyApp expr ty) = isWorthFloatingExpr expr
709 isWorthFloatingExpr other = True
711 canFloatToTop :: (UniType, CoreExprWithFVs) -> Bool
713 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
714 canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty
716 valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
721 %************************************************************************
723 \subsection{Help functions}
725 %************************************************************************
728 idLevel :: IdEnv Level -> Id -> Level
730 = case lookupIdEnv venv v of
732 Nothing -> ASSERT(toplevelishId v)
735 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
736 tyvarLevel tenv tyvar
737 = case lookupTyVarEnv tenv tyvar of
742 %************************************************************************
744 \subsection{Free-To-Level Monad}
746 %************************************************************************
750 = (GlobalSwitch -> Bool) -> SplitUniqSupply -> result
753 = case splitUniqSupply us of { (s1, s2) ->
754 case m sw s1 of { m_result ->
757 returnLvl v sw us = v
759 mapLvl f [] = returnLvl []
761 = f x `thenLvl` \ r ->
762 mapLvl f xs `thenLvl` \ rs ->
765 mapAndUnzipLvl f [] = returnLvl ([], [])
766 mapAndUnzipLvl f (x:xs)
767 = f x `thenLvl` \ (r1, r2) ->
768 mapAndUnzipLvl f xs `thenLvl` \ (rs1, rs2) ->
769 returnLvl (r1:rs1, r2:rs2)
771 mapAndUnzip3Lvl f [] = returnLvl ([], [], [])
772 mapAndUnzip3Lvl f (x:xs)
773 = f x `thenLvl` \ (r1, r2, r3) ->
774 mapAndUnzip3Lvl f xs `thenLvl` \ (rs1, rs2, rs3) ->
775 returnLvl (r1:rs1, r2:rs2, r3:rs3)
778 We create a let-binding for `interesting' (non-utterly-trivial)
779 applications, to give them a fighting chance of being floated.
782 newLvlVar :: UniType -> LvlM Id
787 id = mkSysLocal SLIT("lvl") uniq ty mkUnknownSrcLoc