2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 ***************************
8 ***************************
10 * We attach binding levels to Core bindings, in preparation for floating
11 outwards (@FloatOut@).
13 * We also let-ify many expressions (notably case scrutinees), so they
14 will have a fighting chance of being floated sensible.
16 * We clone the binders of any floatable let-binding, so that when it is
17 floated out it will be unique. (This used to be done by the simplifier
18 but the latter now only ensures that there's no shadowing.)
19 NOTE: Very tiresomely, we must apply this substitution to
20 the rules stored inside a variable too.
22 We do *not* clone top-level bindings, because some of them must not change,
23 but we *do* clone bindings that are heading for the top level
33 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
36 #include "HsVersions.h"
40 import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom )
41 import CoreFVs -- all of it
42 import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo )
43 import IdInfo ( specInfo, setSpecInfo )
44 import Var ( IdOrTyVar, Var, setVarUnique )
48 import Type ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
49 import BasicTypes ( TopLevelFlag(..) )
53 import Maybes ( maybeToBool )
54 import Util ( zipWithEqual, zipEqual )
57 isLeakFreeType x y = False -- safe option; ToDo
60 %************************************************************************
62 \subsection{Level numbers}
64 %************************************************************************
68 = Top -- Means *really* the top level; short for (Level 0 0).
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. The outermost lambda
76 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
78 On an expression, it's the maximum level number of its free
79 (type-)variables. On a let(rec)-bound variable, it's the level of its
80 RHS. On a case-bound variable, it's the number of enclosing lambdas.
82 Top-level variables: level~0. Those bound on the RHS of a top-level
83 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
86 a_0 = let b_? = ... in
87 x_1 = ... b ... in ...
90 Level 0 0 will make something get floated to a top-level "equals",
91 @Top@ makes it go right to the top.
93 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
94 That's meant to be the level number of the enclosing binder in the
95 final (floated) program. If the level number of a sub-expression is
96 less than that of the context, then it might be worth let-binding the
97 sub-expression so that it will indeed float. This context level starts
98 at @Level 0 0@; it is never @Top@.
101 type LevelledExpr = TaggedExpr Level
102 type LevelledArg = TaggedArg Level
103 type LevelledBind = TaggedBind Level
107 incMajorLvl :: Level -> Level
108 incMajorLvl Top = Level 1 0
109 incMajorLvl (Level major minor) = Level (major+1) 0
111 incMinorLvl :: Level -> Level
112 incMinorLvl Top = Level 0 1
113 incMinorLvl (Level major minor) = Level major (minor+1)
115 unTopify :: Type -> Level -> Level
117 | isUnLiftedType ty = case lvl of
118 Top -> Level 0 0 -- Unboxed floats can't go right
119 other -> lvl -- to the top
122 maxLvl :: Level -> Level -> Level
125 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
126 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
129 ltLvl :: Level -> Level -> Bool
131 ltLvl Top (Level _ _) = True
132 ltLvl (Level maj1 min1) (Level maj2 min2)
133 = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
135 ltMajLvl :: Level -> Level -> Bool
136 -- Tells if one level belongs to a difft *lambda* level to another
137 ltMajLvl l1 Top = False
138 ltMajLvl Top (Level 0 _) = False
139 ltMajLvl Top (Level _ _) = True
140 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
142 isTopLvl :: Level -> Bool
144 isTopLvl other = False
146 isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
147 isTopMajLvl Top = True
148 isTopMajLvl (Level maj _) = maj == 0
150 instance Outputable Level where
151 ppr Top = ptext SLIT("<Top>")
152 ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
155 %************************************************************************
157 \subsection{Main level-setting code}
159 %************************************************************************
162 setLevels :: [CoreBind]
167 = initLvl us (do_them binds)
169 -- "do_them"'s main business is to thread the monad along
170 -- It gives each top binding the same empty envt, because
171 -- things unbound in the envt have level number zero implicitly
172 do_them :: [CoreBind] -> LvlM [LevelledBind]
174 do_them [] = returnLvl []
176 = lvlTopBind b `thenLvl` \ (lvld_bind, _) ->
177 do_them bs `thenLvl` \ lvld_binds ->
178 returnLvl (lvld_bind ++ lvld_binds)
180 lvlTopBind (NonRec binder rhs)
181 = lvlBind TopLevel Top initialEnv (AnnNonRec binder (freeVars rhs))
182 -- Rhs can have no free vars!
184 lvlTopBind (Rec pairs)
185 = lvlBind TopLevel Top initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
188 %************************************************************************
190 \subsection{Bindings}
192 %************************************************************************
194 The binding stuff works for top level too.
197 lvlBind :: TopLevelFlag -- Used solely to decide whether to clone
198 -> Level -- Context level; might be Top even for bindings nested in the RHS
199 -- of a top level binding
202 -> LvlM ([LevelledBind], LevelEnv)
204 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs)
205 = setFloatLevel (Just bndr) ctxt_lvl env rhs ty `thenLvl` \ (final_lvl, rhs') ->
206 cloneVar top_lvl env bndr final_lvl `thenLvl` \ (new_env, new_bndr) ->
207 returnLvl ([NonRec (new_bndr, final_lvl) rhs'], new_env)
212 lvlBind top_lvl ctxt_lvl env (AnnRec pairs) = lvlRecBind top_lvl ctxt_lvl env pairs
215 %************************************************************************
217 \subsection{Setting expression levels}
219 %************************************************************************
222 lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
223 -> LevelEnv -- Level of in-scope names/tyvars
224 -> CoreExprWithFVs -- input expression
225 -> LvlM LevelledExpr -- Result expression
228 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
233 v = \x -> ...\y -> let r = case (..x..) of
237 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
238 the level of @r@, even though it's inside a level-2 @\y@. It's
239 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
240 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
241 --- because it isn't a *maximal* free expression.
243 If there were another lambda in @r@'s rhs, it would get level-2 as well.
246 lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
247 lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)
249 lvlExpr ctxt_lvl env (_, AnnCon con args)
250 = mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' ->
251 returnLvl (Con con args')
253 lvlExpr ctxt_lvl env (_, AnnApp fun arg)
254 = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' ->
255 lvlMFE ctxt_lvl env arg `thenLvl` \ arg' ->
256 returnLvl (App fun' arg')
258 lvlExpr ctxt_lvl env (_, AnnNote note expr)
259 = lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
260 returnLvl (Note note expr')
262 -- We don't split adjacent lambdas. That is, given
264 -- we don't float to give
265 -- \x -> let v = x+y in \y -> (v,y)
266 -- Why not? Because partial applications are fairly rare, and splitting
267 -- lambdas makes them more expensive.
269 lvlExpr ctxt_lvl env (_, AnnLam bndr rhs)
270 = lvlMFE incd_lvl new_env body `thenLvl` \ body' ->
271 returnLvl (mkLams lvld_bndrs body')
273 bndr_is_id = isId bndr
274 bndr_is_tyvar = isTyVar bndr
275 (more_bndrs, body) = go rhs
276 bndrs = bndr : more_bndrs
278 incd_lvl | bndr_is_id && not (all isOneShotLambda bndrs) = incMajorLvl ctxt_lvl
279 | otherwise = incMinorLvl ctxt_lvl
280 -- Only bump the major level number if the binders include
281 -- at least one more-than-one-shot lambda
283 lvld_bndrs = [(b,incd_lvl) | b <- bndrs]
284 new_env = extendLvlEnv env lvld_bndrs
286 go (_, AnnLam bndr rhs) | bndr_is_id && isId bndr
287 || bndr_is_tyvar && isTyVar bndr
288 = case go rhs of { (bndrs, body) -> (bndr:bndrs, body) }
291 lvlExpr ctxt_lvl env (_, AnnLet bind body)
292 = lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (binds', new_env) ->
293 lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
294 returnLvl (mkLets binds' body')
296 lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
297 = lvlMFE ctxt_lvl env expr `thenLvl` \ expr' ->
298 mapLvl lvl_alt alts `thenLvl` \ alts' ->
299 returnLvl (Case expr' (case_bndr, incd_lvl) alts')
301 expr_type = coreExprType (deAnnotate expr)
302 incd_lvl = incMinorLvl ctxt_lvl
303 alts_env = extendLvlEnv env [(case_bndr,incd_lvl)]
305 lvl_alt (con, bs, rhs)
307 bs' = [ (b, incd_lvl) | b <- bs ]
308 new_env = extendLvlEnv alts_env bs'
310 lvlMFE incd_lvl new_env rhs `thenLvl` \ rhs' ->
311 returnLvl (con, bs', rhs')
314 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
315 the expression, so that it can itself be floated.
318 lvlMFE :: Level -- Level of innermost enclosing lambda/tylam
319 -> LevelEnv -- Level of in-scope names/tyvars
320 -> CoreExprWithFVs -- input expression
321 -> LvlM LevelledExpr -- Result expression
323 lvlMFE ctxt_lvl env (_, AnnType ty)
324 = returnLvl (Type ty)
326 lvlMFE ctxt_lvl env ann_expr
327 | isUnLiftedType ty -- Can't let-bind it
328 = lvlExpr ctxt_lvl env ann_expr
330 | otherwise -- Not primitive type so could be let-bound
331 = setFloatLevel Nothing {- Not already let-bound -}
332 ctxt_lvl env ann_expr ty `thenLvl` \ (final_lvl, expr') ->
335 ty = coreExprType (deAnnotate ann_expr)
339 %************************************************************************
341 \subsection{Deciding floatability}
343 %************************************************************************
345 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
346 are being created as let-bindings
350 YES. -> (a) try abstracting type variables.
351 If we abstract type variables it will go further, that is, past more
352 lambdas. same as asking if the level number given by the free
353 variables is less than the level number given by free variables
354 and type variables together.
355 Abstract offending type variables, e.g.
357 to let v = /\ty' -> f ty' a b
359 so that v' is not stopped by the level number of ty
360 tag the original let with its level number
361 (from its variables and type variables)
363 YES. -> No point in let binding to float a WHNF.
364 Pin (leave) expression here.
365 NO. -> Will float past a lambda?
366 (check using free variables only, not type variables)
367 YES. -> do the same as (a) above.
368 NO. -> No point in let binding if it is not going anywhere
369 Pin (leave) expression here.
372 setFloatLevel :: Maybe Id -- Just id <=> the expression is already let-bound to id
373 -- Nothing <=> it's a possible MFE
374 -> Level -- of context
377 -> CoreExprWithFVs -- Original rhs
378 -> Type -- Type of rhs
380 -> LvlM (Level, -- Level to attribute to this let-binding
381 LevelledExpr) -- Final rhs
383 setFloatLevel maybe_let_bound ctxt_lvl env expr@(expr_fvs, _) ty
385 -- Now deal with (by not floating) trivial non-let-bound expressions
386 -- which just aren't worth let-binding in order to float. We always
387 -- choose to float even trivial let-bound things because it doesn't do
388 -- any harm, and not floating it may pin something important. For
395 -- Here, if we don't float v we won't float w, which is Bad News.
396 -- If this gives any problems we could restrict the idea to things destined
399 | not alreadyLetBound
400 && (expr_is_trivial || expr_is_bottom || not will_float_past_lambda)
402 = -- Pin trivial non-let-bound expressions,
403 -- or ones which aren't going anywhere useful
404 lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
405 returnLvl (safe_ctxt_lvl, expr')
408 The above case used to read (whnf_or_bottom || not will_float_past_lambda).
409 It was changed because we really do want to float out constructors if possible:
410 this can save a great deal of needless allocation inside a loop. On the other
411 hand, there's no point floating out nullary constructors and literals, hence
412 the expr_is_trivial condition.
415 | alreadyLetBound && not worth_type_abstraction
416 = -- Process the expression with a new ctxt_lvl, obtained from
417 -- the free vars of the expression itself
418 lvlExpr expr_lvl env expr `thenLvl` \ expr' ->
419 returnLvl (safe_expr_lvl, expr')
421 | otherwise -- This will create a let anyway, even if there is no
422 -- type variable to abstract, so we try to abstract anyway
423 = abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr
424 `thenLvl` \ final_expr ->
425 returnLvl (safe_expr_lvl, final_expr)
426 -- OLD LIE: The body of the let, just a type application, isn't worth floating
427 -- so pin it with ctxt_lvl
428 -- The truth: better to give it expr_lvl in case it is pinning
429 -- something non-trivial which depends on it.
431 alreadyLetBound = maybeToBool maybe_let_bound
433 safe_ctxt_lvl = unTopify ty ctxt_lvl
434 safe_expr_lvl = unTopify ty expr_lvl
436 fvs = case maybe_let_bound of
438 Just id -> expr_fvs `unionVarSet` idFreeVars id
440 ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL fvs
441 tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL fvs
442 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
443 lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
445 -- Will escape lambda if let-bound
446 will_float_past_lambda = ids_only_lvl `ltMajLvl` ctxt_lvl
448 -- Will escape (more) lambda(s)/type lambda(s) if type abstracted
449 worth_type_abstraction = (ids_only_lvl `ltLvl` tyvars_only_lvl)
450 && not expr_is_trivial -- Avoids abstracting trivial type applications
452 offending_tyvars = filter offending_tv (varSetElems fvs)
453 offending_tv var | isId var = False
454 | otherwise = ids_only_lvl `ltLvl` varLevel env var
456 expr_is_trivial = exprIsTrivial de_ann_expr
457 expr_is_bottom = exprIsBottom de_ann_expr
458 de_ann_expr = deAnnotate expr
461 Abstract wrt tyvars, by making it just as if we had seen
466 instead of simply E. The idea is that v can be freely floated, since it
467 has no free type variables. Of course, if E has no free type
468 variables, then we just return E.
471 abstractWrtTyVars offending_tyvars ty env lvl expr
472 = lvlExpr incd_lvl new_env expr `thenLvl` \ expr' ->
473 newLvlVar poly_ty `thenLvl` \ poly_var ->
475 poly_var_rhs = mkLams tyvar_lvls expr'
476 poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
477 poly_var_app = mkTyApps (Var poly_var) (mkTyVarTys offending_tyvars)
478 final_expr = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
482 poly_ty = mkForAllTys offending_tyvars ty
484 -- These defns are just like those in the TyLam case of lvlExpr
485 incd_lvl = incMinorLvl lvl
486 tyvar_lvls = [(tv,incd_lvl) | tv <- offending_tyvars]
487 new_env = extendLvlEnv env tyvar_lvls
490 Recursive definitions. We want to transform
502 x1' = /\ ab -> let D' in e1
504 xn' = /\ ab -> let D' in en
508 where ab are the tyvars pinning the defn further in than it
509 need be, and D is a bunch of simple type applications:
515 The "_cl" indicates that in D, the level numbers on the xi are the context level
516 number; type applications aren't worth floating. The D' decls are
523 but differ in their level numbers; here the ab are the newly-introduced
527 lvlRecBind top_lvl ctxt_lvl env pairs
528 | ids_only_lvl `ltLvl` tyvars_only_lvl
529 = -- Abstract wrt tyvars;
530 -- offending_tyvars is definitely non-empty
531 -- (I love the ASSERT to check this... WDP 95/02)
533 incd_lvl = incMinorLvl ids_only_lvl
534 tyvars_w_rhs_lvl = [(var,incd_lvl) | var <- offending_tyvars]
535 bndrs_w_rhs_lvl = [(var,incd_lvl) | var <- bndrs]
536 rhs_env = extendLvlEnv env (tyvars_w_rhs_lvl ++ bndrs_w_rhs_lvl)
538 mapLvl (lvlExpr incd_lvl rhs_env) rhss `thenLvl` \ rhss' ->
539 mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars ->
540 cloneVars top_lvl env bndrs ctxt_lvl `thenLvl` \ (new_env, new_bndrs) ->
542 -- The "d_rhss" are the right-hand sides of "D" and "D'"
543 -- in the documentation above
544 d_rhss = [ mkTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
546 -- "local_binds" are "D'" in the documentation above
547 local_binds = zipWithEqual "SetLevels" NonRec bndrs_w_rhs_lvl d_rhss
549 poly_var_rhss = [ mkLams tyvars_w_rhs_lvl (mkLets local_binds rhs')
553 poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
556 -- The new right-hand sides, just a type application,
557 -- aren't worth floating so pin it with ctxt_lvl
558 bndrs_w_lvl = new_bndrs `zip` repeat ctxt_lvl
560 -- "d_binds" are the "D" in the documentation above
561 d_binds = zipWithEqual "SetLevels" NonRec bndrs_w_lvl d_rhss
563 returnLvl (Rec poly_binds : d_binds, new_env)
566 = -- Let it float freely
567 cloneVars top_lvl env bndrs expr_lvl `thenLvl` \ (new_env, new_bndrs) ->
569 bndrs_w_lvls = new_bndrs `zip` repeat expr_lvl
571 mapLvl (lvlExpr expr_lvl new_env) rhss `thenLvl` \ rhss' ->
572 returnLvl ([Rec (bndrs_w_lvls `zip` rhss')], new_env)
575 (bndrs,rhss) = unzip pairs
577 -- Finding the free vars of the binding group is annoying
578 bind_fvs = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars bndrs))
582 ids_only_lvl = foldVarSet (maxIdLvl env) tOP_LEVEL bind_fvs
583 tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL bind_fvs
584 expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
586 offending_tyvars = filter offending_tv (varSetElems bind_fvs)
587 offending_tv var | isId var = False
588 | otherwise = ids_only_lvl `ltLvl` varLevel env var
589 offending_tyvar_tys = mkTyVarTys offending_tyvars
591 tys = map idType bndrs
592 poly_tys = map (mkForAllTys offending_tyvars) tys
595 %************************************************************************
597 \subsection{Free-To-Level Monad}
599 %************************************************************************
602 type LevelEnv = (VarEnv Level, SubstEnv)
603 -- We clone let-bound variables so that they are still
604 -- distinct when floated out; hence the SubstEnv
605 -- The domain of the VarEnv is *pre-cloned* Ids, though
607 initialEnv :: LevelEnv
608 initialEnv = (emptyVarEnv, emptySubstEnv)
610 extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
611 -- Used when *not* cloning
612 extendLvlEnv (lvl_env, subst_env) prs
613 = (foldl add lvl_env prs, subst_env)
615 add env (v,l) = extendVarEnv env v l
617 varLevel :: LevelEnv -> IdOrTyVar -> Level
618 varLevel (lvl_env, _) v
619 = case lookupVarEnv lvl_env v of
623 lookupVar :: LevelEnv -> Id -> LevelledExpr
624 lookupVar (_, subst) v = case lookupSubstEnv subst v of
625 Just (DoneEx (Var v')) -> Var v' -- Urgh! Types don't match
628 maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
629 maxIdLvl (lvl_env,_) var lvl | isTyVar var = lvl
630 | otherwise = case lookupVarEnv lvl_env var of
631 Just lvl' -> maxLvl lvl' lvl
634 maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
635 maxTyVarLvl (lvl_env,_) var lvl | isId var = lvl
636 | otherwise = case lookupVarEnv lvl_env var of
637 Just lvl' -> maxLvl lvl' lvl
642 type LvlM result = UniqSM result
651 newLvlVar :: Type -> LvlM Id
652 newLvlVar ty = getUniqueUs `thenLvl` \ uniq ->
653 returnUs (mkSysLocal SLIT("lvl") uniq ty)
655 -- The deeply tiresome thing is that we have to apply the substitution
656 -- to the rules inside each Id. Grr. But it matters.
658 cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id)
659 cloneVar TopLevel env v lvl
660 = returnUs (env, v) -- Don't clone top level things
661 cloneVar NotTopLevel (lvl_env, subst_env) v lvl
662 = getUniqueUs `thenLvl` \ uniq ->
664 subst = mkSubst emptyVarSet subst_env
665 v' = setVarUnique v uniq
666 v'' = modifyIdInfo (\info -> substIdInfo subst info info) v'
667 subst_env' = extendSubstEnv subst_env v (DoneEx (Var v''))
668 lvl_env' = extendVarEnv lvl_env v lvl
670 returnUs ((lvl_env', subst_env'), v'')
672 cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id])
673 cloneVars TopLevel env vs lvl
674 = returnUs (env, vs) -- Don't clone top level things
675 cloneVars NotTopLevel (lvl_env, subst_env) vs lvl
676 = getUniquesUs (length vs) `thenLvl` \ uniqs ->
678 subst = mkSubst emptyVarSet subst_env'
679 vs' = zipWith setVarUnique vs uniqs
680 vs'' = map (modifyIdInfo (\info -> substIdInfo subst info info)) vs'
681 subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs'']
682 lvl_env' = extendVarEnvList lvl_env (vs `zip` repeat lvl)
684 returnUs ((lvl_env', subst_env'), vs'')