2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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"
25 import CoreUtils ( coreExprType, exprIsTrivial, idFreeVars, exprIsBottom
27 import FreeVars -- all of it
28 import Id ( Id, idType, mkSysLocal )
29 import Var ( IdOrTyVar )
32 import Type ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
35 import UniqSupply ( initUs, thenUs, returnUs, mapUs, mapAndUnzipUs, getUniqueUs,
36 mapAndUnzip3Us, UniqSM, UniqSupply )
37 import Maybes ( maybeToBool )
38 import Util ( zipWithEqual, zipEqual )
41 isLeakFreeType x y = False -- safe option; ToDo
44 %************************************************************************
46 \subsection{Level numbers}
48 %************************************************************************
52 = Top -- Means *really* the top level; short for (Level 0 0).
53 | Level Int -- Level number of enclosing lambdas
54 Int -- Number of big-lambda and/or case expressions between
55 -- here and the nearest enclosing lambda
58 The {\em level number} on a (type-)lambda-bound variable is the
59 nesting depth of the (type-)lambda which binds it. The outermost lambda
60 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
62 On an expression, it's the maximum level number of its free
63 (type-)variables. On a let(rec)-bound variable, it's the level of its
64 RHS. On a case-bound variable, it's the number of enclosing lambdas.
66 Top-level variables: level~0. Those bound on the RHS of a top-level
67 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
70 a_0 = let b_? = ... in
71 x_1 = ... b ... in ...
74 Level 0 0 will make something get floated to a top-level "equals",
75 @Top@ makes it go right to the top.
77 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
78 That's meant to be the level number of the enclosing binder in the
79 final (floated) program. If the level number of a sub-expression is
80 less than that of the context, then it might be worth let-binding the
81 sub-expression so that it will indeed float. This context level starts
82 at @Level 0 0@; it is never @Top@.
85 type LevelledExpr = TaggedExpr Level
86 type LevelledArg = TaggedArg Level
87 type LevelledBind = TaggedBind Level
91 incMajorLvl :: Level -> Level
92 incMajorLvl Top = Level 1 0
93 incMajorLvl (Level major minor) = Level (major+1) 0
95 incMinorLvl :: Level -> Level
96 incMinorLvl Top = Level 0 1
97 incMinorLvl (Level major minor) = Level major (minor+1)
99 maxLvl :: Level -> Level -> Level
102 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
103 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
106 ltLvl :: Level -> Level -> Bool
108 ltLvl Top (Level _ _) = True
109 ltLvl (Level maj1 min1) (Level maj2 min2)
110 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
112 ltMajLvl :: Level -> Level -> Bool
113 -- Tells if one level belongs to a difft *lambda* level to another
114 ltMajLvl l1 Top = False
115 ltMajLvl Top (Level 0 _) = False
116 ltMajLvl Top (Level _ _) = True
117 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
119 isTopLvl :: Level -> Bool
121 isTopLvl other = False
123 isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
124 isTopMajLvl Top = True
125 isTopMajLvl (Level maj _) = maj == 0
127 instance Outputable Level where
128 ppr Top = ptext SLIT("<Top>")
129 ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
133 type LevelEnv = VarEnv Level
135 varLevel :: LevelEnv -> IdOrTyVar -> Level
137 = case lookupVarEnv env v of
141 maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
142 maxIdLvl env var lvl | isTyVar var = lvl
143 | otherwise = case lookupVarEnv env var of
144 Just lvl' -> maxLvl lvl' lvl
147 maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
148 maxTyVarLvl env var lvl | isId var = lvl
149 | otherwise = case lookupVarEnv env var of
150 Just lvl' -> maxLvl lvl' lvl
154 %************************************************************************
156 \subsection{Main level-setting code}
158 %************************************************************************
161 setLevels :: [CoreBind]
166 = initLvl us (do_them binds)
168 -- "do_them"'s main business is to thread the monad along
169 -- It gives each top binding the same empty envt, because
170 -- things unbound in the envt have level number zero implicitly
171 do_them :: [CoreBind] -> LvlM [LevelledBind]
173 do_them [] = returnLvl []
175 = lvlTopBind b `thenLvl` \ (lvld_bind, _) ->
176 do_them bs `thenLvl` \ lvld_binds ->
177 returnLvl (lvld_bind ++ lvld_binds)
179 initialEnv = emptyVarEnv
181 lvlTopBind (NonRec binder rhs)
182 = lvlBind Top initialEnv (AnnNonRec binder (freeVars rhs))
183 -- Rhs can have no free vars!
185 lvlTopBind (Rec pairs)
186 = lvlBind Top initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
189 %************************************************************************
191 \subsection{Bindings}
193 %************************************************************************
195 The binding stuff works for top level too.
201 -> LvlM ([LevelledBind], LevelEnv)
203 lvlBind ctxt_lvl env (AnnNonRec name rhs)
204 = setFloatLevel (Just name) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') ->
206 new_env = extendVarEnv env name final_lvl
208 returnLvl ([NonRec (name, final_lvl) rhs'], new_env)
213 lvlBind ctxt_lvl env (AnnRec pairs)
214 = decideRecFloatLevel ctxt_lvl env binders rhss `thenLvl` \ (final_lvl, extra_binds, rhss') ->
216 binders_w_lvls = binders `zip` repeat final_lvl
217 new_env = extendVarEnvList env binders_w_lvls
219 returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_env)
221 (binders,rhss) = unzip pairs
224 %************************************************************************
226 \subsection{Setting expression levels}
228 %************************************************************************
231 lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
232 -> LevelEnv -- Level of in-scope names/tyvars
233 -> CoreExprWithFVs -- input expression
234 -> LvlM LevelledExpr -- Result expression
237 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
242 v = \x -> ...\y -> let r = case (..x..) of
246 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
247 the level of @r@, even though it's inside a level-2 @\y@. It's
248 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
249 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
250 --- because it isn't a *maximal* free expression.
252 If there were another lambda in @r@'s rhs, it would get level-2 as well.
255 lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
256 lvlExpr _ _ (_, AnnVar v) = returnLvl (Var v)
258 lvlExpr ctxt_lvl env (_, AnnCon con args)
259 = mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' ->
260 returnLvl (Con con args')
262 lvlExpr ctxt_lvl env (_, AnnApp fun arg)
263 = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' ->
264 lvlMFE ctxt_lvl env arg `thenLvl` \ arg' ->
265 returnLvl (App fun' arg')
267 lvlExpr ctxt_lvl env (_, AnnNote note expr)
268 = lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
269 returnLvl (Note note expr')
271 -- We don't split adjacent lambdas. That is, given
273 -- we don't float to give
274 -- \x -> let v = x+y in \y -> (v,y)
275 -- Why not? Because partial applications are fairly rare, and splitting
276 -- lambdas makes them more expensive.
278 lvlExpr ctxt_lvl env (_, AnnLam bndr rhs)
279 = lvlMFE incd_lvl new_env body `thenLvl` \ body' ->
280 returnLvl (mkLams lvld_bndrs body')
282 bndr_is_id = isId bndr
283 bndr_is_tyvar = isTyVar bndr
284 (bndrs, body) = go rhs
286 incd_lvl | bndr_is_id = incMajorLvl ctxt_lvl
287 | otherwise = incMinorLvl ctxt_lvl
288 lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
289 new_env = extendVarEnvList env lvld_bndrs
291 go (_, AnnLam bndr rhs) | bndr_is_id && isId bndr
292 || bndr_is_tyvar && isTyVar bndr
293 = case go rhs of { (bndrs, body) -> (bndr:bndrs, body) }
296 lvlExpr ctxt_lvl env (_, AnnLet bind body)
297 = lvlBind ctxt_lvl env bind `thenLvl` \ (binds', new_env) ->
298 lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
299 returnLvl (mkLets binds' body')
301 lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
302 = lvlMFE ctxt_lvl env expr `thenLvl` \ expr' ->
303 mapLvl lvl_alt alts `thenLvl` \ alts' ->
304 returnLvl (Case expr' (case_bndr, incd_lvl) alts')
306 expr_type = coreExprType (deAnnotate expr)
307 incd_lvl = incMinorLvl ctxt_lvl
308 alts_env = extendVarEnv env case_bndr incd_lvl
310 lvl_alt (con, bs, rhs)
312 bs' = [ (b, incd_lvl) | b <- bs ]
313 new_env = extendVarEnvList alts_env bs'
315 lvlMFE incd_lvl new_env rhs `thenLvl` \ rhs' ->
316 returnLvl (con, bs', rhs')
319 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
320 the expression, so that it can itself be floated.
323 lvlMFE :: Level -- Level of innermost enclosing lambda/tylam
324 -> LevelEnv -- Level of in-scope names/tyvars
325 -> CoreExprWithFVs -- input expression
326 -> LvlM LevelledExpr -- Result expression
328 lvlMFE ctxt_lvl env (_, AnnType ty)
329 = returnLvl (Type ty)
331 lvlMFE ctxt_lvl env ann_expr
332 | isUnLiftedType ty -- Can't let-bind it
333 = lvlExpr ctxt_lvl env ann_expr
335 | otherwise -- Not primitive type so could be let-bound
336 = setFloatLevel Nothing {- Not already let-bound -}
337 ctxt_lvl env ann_expr ty `thenLvl` \ (final_lvl, expr') ->
340 ty = coreExprType (deAnnotate ann_expr)
344 %************************************************************************
346 \subsection{Deciding floatability}
348 %************************************************************************
350 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
351 are being created as let-bindings
355 YES. -> (a) try abstracting type variables.
356 If we abstract type variables it will go further, that is, past more
357 lambdas. same as asking if the level number given by the free
358 variables is less than the level number given by free variables
359 and type variables together.
360 Abstract offending type variables, e.g.
362 to let v = /\ty' -> f ty' a b
364 so that v' is not stopped by the level number of ty
365 tag the original let with its level number
366 (from its variables and type variables)
368 YES. -> No point in let binding to float a WHNF.
369 Pin (leave) expression here.
370 NO. -> Will float past a lambda?
371 (check using free variables only, not type variables)
372 YES. -> do the same as (a) above.
373 NO. -> No point in let binding if it is not going anywhere
374 Pin (leave) expression here.
377 setFloatLevel :: Maybe Id -- Just id <=> the expression is already let-bound to id
378 -- Nothing <=> it's a possible MFE
379 -> Level -- of context
382 -> CoreExprWithFVs -- Original rhs
383 -> Type -- Type of rhs
385 -> LvlM (Level, -- Level to attribute to this let-binding
386 LevelledExpr) -- Final rhs
388 setFloatLevel maybe_let_bound ctxt_lvl env expr@(expr_fvs, _) ty
390 -- Now deal with (by not floating) trivial non-let-bound expressions
391 -- which just aren't worth let-binding in order to float. We always
392 -- choose to float even trivial let-bound things because it doesn't do
393 -- any harm, and not floating it may pin something important. For
400 -- Here, if we don't float v we won't float w, which is Bad News.
401 -- If this gives any problems we could restrict the idea to things destined
404 | not alreadyLetBound
405 && (expr_is_trivial || expr_is_bottom || not will_float_past_lambda)
406 = -- Pin trivial non-let-bound expressions,
407 -- or ones which aren't going anywhere useful
408 lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
409 returnLvl (ctxt_lvl, expr')
412 The above case used to read (whnf_or_bottom || not will_float_past_lambda).
413 It was changed because we really do want to float out constructors if possible:
414 this can save a great deal of needless allocation inside a loop. On the other
415 hand, there's no point floating out nullary constructors and literals, hence
416 the expr_is_trivial condition.
419 | alreadyLetBound && not worth_type_abstraction
420 = -- Process the expression with a new ctxt_lvl, obtained from
421 -- the free vars of the expression itself
422 lvlExpr expr_lvl env expr `thenLvl` \ expr' ->
423 returnLvl (expr_lvl, expr')
425 | otherwise -- This will create a let anyway, even if there is no
426 -- type variable to abstract, so we try to abstract anyway
427 = abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr
428 `thenLvl` \ final_expr ->
429 returnLvl (expr_lvl, final_expr)
430 -- OLD LIE: The body of the let, just a type application, isn't worth floating
431 -- so pin it with ctxt_lvl
432 -- The truth: better to give it expr_lvl in case it is pinning
433 -- something non-trivial which depends on it.
435 alreadyLetBound = maybeToBool maybe_let_bound
437 fvs = case maybe_let_bound of
439 Just id -> expr_fvs `unionVarSet` idFreeVars id
441 ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL fvs
442 tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL fvs
443 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
444 lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
446 -- Will escape lambda if let-bound
447 will_float_past_lambda = ids_only_lvl `ltMajLvl` ctxt_lvl
449 -- Will escape (more) lambda(s)/type lambda(s) if type abstracted
450 worth_type_abstraction = (ids_only_lvl `ltLvl` tyvars_only_lvl)
451 && not expr_is_trivial -- Avoids abstracting trivial type applications
453 offending_tyvars = filter offending_tv (varSetElems fvs)
454 offending_tv var | isId var = False
455 | otherwise = ids_only_lvl `ltLvl` varLevel env var
457 expr_is_trivial = exprIsTrivial de_ann_expr
458 expr_is_bottom = exprIsBottom de_ann_expr
459 de_ann_expr = deAnnotate expr
462 Abstract wrt tyvars, by making it just as if we had seen
467 instead of simply E. The idea is that v can be freely floated, since it
468 has no free type variables. Of course, if E has no free type
469 variables, then we just return E.
472 abstractWrtTyVars offending_tyvars ty env lvl expr
473 = lvlExpr incd_lvl new_env expr `thenLvl` \ expr' ->
474 newLvlVar poly_ty `thenLvl` \ poly_var ->
476 poly_var_rhs = mkLams tyvar_lvls expr'
477 poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
478 poly_var_app = mkTyApps (Var poly_var) (mkTyVarTys offending_tyvars)
479 final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
483 poly_ty = mkForAllTys offending_tyvars ty
485 -- These defns are just like those in the TyLam case of lvlExpr
486 incd_lvl = incMinorLvl lvl
487 tyvar_lvls = [(tv,incd_lvl) | tv <- offending_tyvars]
488 new_env = extendVarEnvList env tyvar_lvls
491 Recursive definitions. We want to transform
503 x1' = /\ ab -> let D' in e1
505 xn' = /\ ab -> let D' in en
509 where ab are the tyvars pinning the defn further in than it
510 need be, and D is a bunch of simple type applications:
516 The "_cl" indicates that in D, the level numbers on the xi are the context level
517 number; type applications aren't worth floating. The D' decls are
524 but differ in their level numbers; here the ab are the newly-introduced
528 decideRecFloatLevel ctxt_lvl env ids rhss
529 | ids_only_lvl `ltLvl` tyvars_only_lvl
530 = -- Abstract wrt tyvars;
531 -- offending_tyvars is definitely non-empty
532 -- (I love the ASSERT to check this... WDP 95/02)
534 incd_lvl = incMinorLvl ids_only_lvl
535 tyvars_w_lvl = [(var,incd_lvl) | var <- offending_tyvars]
536 ids_w_lvl = [(var,incd_lvl) | var <- ids]
537 new_env = extendVarEnvList env (tyvars_w_lvl ++ ids_w_lvl)
539 mapLvl (lvlExpr incd_lvl new_env) rhss `thenLvl` \ rhss' ->
540 mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
542 ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
544 -- The "d_rhss" are the right-hand sides of "D" and "D'"
545 -- in the documentation above
546 d_rhss = [ mkTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
548 -- "local_binds" are "D'" in the documentation above
549 local_binds = zipWithEqual "SetLevels" NonRec ids_w_lvl d_rhss
551 poly_var_rhss = [ mkLams tyvars_w_lvl (mkLets local_binds rhs')
555 poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
559 returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
560 -- The new right-hand sides, just a type application, aren't worth floating
561 -- so pin it with ctxt_lvl
564 = -- Let it float freely
566 ids_w_lvls = ids `zip` repeat expr_lvl
567 new_env = extendVarEnvList env ids_w_lvls
569 mapLvl (lvlExpr expr_lvl new_env) rhss `thenLvl` \ rhss' ->
570 returnLvl (expr_lvl, [], rhss')
573 -- Finding the free vars of the binding group is annoying
574 bind_fvs = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars ids))
578 ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL bind_fvs
579 tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL bind_fvs
580 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
582 offending_tyvars = filter offending_tv (varSetElems bind_fvs)
583 offending_tv var | isId var = False
584 | otherwise = ids_only_lvl `ltLvl` varLevel env var
585 offending_tyvar_tys = mkTyVarTys offending_tyvars
588 poly_tys = map (mkForAllTys offending_tyvars) tys
591 %************************************************************************
593 \subsection{Free-To-Level Monad}
595 %************************************************************************
598 type LvlM result = UniqSM result
604 mapAndUnzipLvl = mapAndUnzipUs
605 mapAndUnzip3Lvl = mapAndUnzip3Us
608 We create a let-binding for `interesting' (non-utterly-trivial)
609 applications, to give them a fighting chance of being floated.
612 newLvlVar :: Type -> LvlM Id
613 newLvlVar ty = getUniqueUs `thenLvl` \ uniq ->
614 returnUs (mkSysLocal SLIT("lvl") uniq ty)