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
26 case x of wild { p -> ...wild... }
27 we substitute x for wild in the RHS of the case alternatives:
28 case x of wild { p -> ...x... }
29 This means that a sub-expression involving x is not "trapped" inside the RHS.
30 And it's not inconvenient because we already have a substitution.
38 incMinorLvl, ltMajLvl, ltLvl, isTopLvl
41 #include "HsVersions.h"
45 import CoreUtils ( coreExprType, exprIsTrivial, exprIsBottom )
46 import CoreFVs -- all of it
47 import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo,
48 getIdSpecialisation, getIdWorkerInfo
50 import IdInfo ( workerExists )
51 import Var ( IdOrTyVar, Var, TyVar, setVarUnique )
55 import Name ( getOccName )
56 import OccName ( occNameUserString )
57 import Type ( isUnLiftedType, mkTyVarTy, mkForAllTys, Type )
58 import BasicTypes ( TopLevelFlag(..) )
62 import Maybes ( maybeToBool )
63 import Util ( zipWithEqual, zipEqual )
68 %************************************************************************
70 \subsection{Level numbers}
72 %************************************************************************
75 data Level = Level Int -- Level number of enclosing lambdas
76 Int -- Number of big-lambda and/or case expressions between
77 -- here and the nearest enclosing lambda
80 The {\em level number} on a (type-)lambda-bound variable is the
81 nesting depth of the (type-)lambda which binds it. The outermost lambda
82 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
84 On an expression, it's the maximum level number of its free
85 (type-)variables. On a let(rec)-bound variable, it's the level of its
86 RHS. On a case-bound variable, it's the number of enclosing lambdas.
88 Top-level variables: level~0. Those bound on the RHS of a top-level
89 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
92 a_0 = let b_? = ... in
93 x_1 = ... b ... in ...
96 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
97 That's meant to be the level number of the enclosing binder in the
98 final (floated) program. If the level number of a sub-expression is
99 less than that of the context, then it might be worth let-binding the
100 sub-expression so that it will indeed float. This context level starts
104 type LevelledExpr = TaggedExpr Level
105 type LevelledArg = TaggedArg Level
106 type LevelledBind = TaggedBind Level
108 tOP_LEVEL = Level 0 0
110 incMajorLvl :: Level -> Level
111 incMajorLvl (Level major minor) = Level (major+1) 0
113 incMinorLvl :: Level -> Level
114 incMinorLvl (Level major minor) = Level major (minor+1)
116 maxLvl :: Level -> Level -> Level
117 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
118 | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
121 ltLvl :: Level -> Level -> Bool
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 (Level maj1 _) (Level maj2 _) = maj1 < maj2
129 isTopLvl :: Level -> Bool
130 isTopLvl (Level 0 0) = True
131 isTopLvl other = False
133 instance Outputable Level where
134 ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
137 %************************************************************************
139 \subsection{Main level-setting code}
141 %************************************************************************
144 setLevels :: [CoreBind]
149 = initLvl us (do_them binds)
151 -- "do_them"'s main business is to thread the monad along
152 -- It gives each top binding the same empty envt, because
153 -- things unbound in the envt have level number zero implicitly
154 do_them :: [CoreBind] -> LvlM [LevelledBind]
156 do_them [] = returnLvl []
158 = lvlTopBind b `thenLvl` \ (lvld_bind, _) ->
159 do_them bs `thenLvl` \ lvld_binds ->
160 returnLvl (lvld_bind : lvld_binds)
162 lvlTopBind (NonRec binder rhs)
163 = lvlBind TopLevel tOP_LEVEL initialEnv (AnnNonRec binder (freeVars rhs))
164 -- Rhs can have no free vars!
166 lvlTopBind (Rec pairs)
167 = lvlBind TopLevel tOP_LEVEL initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
170 %************************************************************************
172 \subsection{Setting expression levels}
174 %************************************************************************
177 lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression
178 -> LevelEnv -- Level of in-scope names/tyvars
179 -> CoreExprWithFVs -- input expression
180 -> LvlM LevelledExpr -- Result expression
183 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
184 binder. Here's an example
186 v = \x -> ...\y -> let r = case (..x..) of
190 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
191 the level of @r@, even though it's inside a level-2 @\y@. It's
192 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
193 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
194 --- because it isn't a *maximal* free expression.
196 If there were another lambda in @r@'s rhs, it would get level-2 as well.
199 lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
200 lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)
202 lvlExpr ctxt_lvl env (_, AnnCon con args)
203 = mapLvl (lvlExpr ctxt_lvl env) args `thenLvl` \ args' ->
204 returnLvl (Con con args')
206 lvlExpr ctxt_lvl env (_, AnnApp fun arg)
207 = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' ->
208 lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' ->
209 returnLvl (App fun' arg')
211 lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr)
212 -- Don't float anything out of an InlineMe
213 = lvlExpr tOP_LEVEL env expr `thenLvl` \ expr' ->
214 returnLvl (Note InlineMe expr')
216 lvlExpr ctxt_lvl env (_, AnnNote note expr)
217 = lvlExpr ctxt_lvl env expr `thenLvl` \ expr' ->
218 returnLvl (Note note expr')
220 -- We don't split adjacent lambdas. That is, given
222 -- we don't float to give
223 -- \x -> let v = x+y in \y -> (v,y)
224 -- Why not? Because partial applications are fairly rare, and splitting
225 -- lambdas makes them more expensive.
227 lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs)
228 = go (incMinorLvl ctxt_lvl) env False {- Havn't bumped major level in this group -} expr
230 go lvl env bumped_major (_, AnnLam bndr body)
231 = go new_lvl new_env new_bumped_major body `thenLvl` \ new_body ->
232 returnLvl (Lam lvld_bndr new_body)
234 -- Go to the next major level if this is a value binder,
235 -- and we havn't already gone to the next level (one jump per group)
236 -- and it isn't a one-shot lambda
237 (new_lvl, new_bumped_major)
240 not (isOneShotLambda bndr) = (incMajorLvl ctxt_lvl, True)
241 | otherwise = (lvl, bumped_major)
242 new_env = extendLvlEnv env [lvld_bndr]
243 lvld_bndr = (bndr, new_lvl)
245 -- Ignore notes, because we don't want to split
246 -- a lambda like this (\x -> coerce t (\s -> ...))
247 -- This happens quite a bit in state-transformer programs
248 go lvl env bumped_major (_, AnnNote note body)
249 = go lvl env bumped_major body `thenLvl` \ new_body ->
250 returnLvl (Note note new_body)
252 go lvl env bumped_major body
253 = lvlMFE True lvl env body
256 lvlExpr ctxt_lvl env (_, AnnLet bind body)
257 = lvlBind NotTopLevel ctxt_lvl env bind `thenLvl` \ (bind', new_env) ->
258 lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
259 returnLvl (Let bind' body')
261 lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
262 = lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' ->
264 alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl
266 mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' ->
267 returnLvl (Case expr' (case_bndr, incd_lvl) alts')
269 expr_type = coreExprType (deAnnotate expr)
270 incd_lvl = incMinorLvl ctxt_lvl
272 lvl_alt alts_env (con, bs, rhs)
273 = lvlMFE True incd_lvl new_env rhs `thenLvl` \ rhs' ->
274 returnLvl (con, bs', rhs')
276 bs' = [ (b, incd_lvl) | b <- bs ]
277 new_env = extendLvlEnv alts_env bs'
280 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
281 the expression, so that it can itself be floated.
284 lvlMFE :: Bool -- True <=> strict context [body of case or let]
285 -> Level -- Level of innermost enclosing lambda/tylam
286 -> LevelEnv -- Level of in-scope names/tyvars
287 -> CoreExprWithFVs -- input expression
288 -> LvlM LevelledExpr -- Result expression
290 lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
291 = returnLvl (Type ty)
293 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
294 | isUnLiftedType ty -- Can't let-bind it
295 || not (dest_lvl `ltMajLvl` ctxt_lvl) -- Does not escape a value lambda
296 -- A decision to float entails let-binding this thing, and we only do
297 -- that if we'll escape a value lambda. I considered doing it if it
298 -- would make the thing go to top level, but I found things like
299 -- concat = /\ a -> foldr ..a.. (++) []
300 -- was getting turned into
301 -- concat = /\ a -> lvl a
302 -- lvl = /\ a -> foldr ..a.. (++) []
303 -- which is pretty stupid. So for now at least, I don't let-bind things
304 -- simply because they could go to top level.
305 || exprIsTrivial expr -- Is trivial
306 || (strict_ctxt && exprIsBottom expr) -- Strict context and is bottom
307 = -- Don't float it out
308 lvlExpr ctxt_lvl env ann_expr
310 | otherwise -- Float it out!
311 = lvlExpr expr_lvl expr_env ann_expr `thenLvl` \ expr' ->
312 newLvlVar "lvl" (mkForAllTys tyvars ty) `thenLvl` \ var ->
313 returnLvl (Let (NonRec (var,dest_lvl) (mkLams tyvars_w_lvls expr'))
314 (mkTyVarApps var tyvars))
316 expr = deAnnotate ann_expr
317 ty = coreExprType expr
318 dest_lvl = destLevel env fvs
319 (tyvars, tyvars_w_lvls, expr_lvl) = abstractTyVars dest_lvl env fvs
320 expr_env = extendLvlEnv env tyvars_w_lvls
324 %************************************************************************
326 \subsection{Bindings}
328 %************************************************************************
330 The binding stuff works for top level too.
333 lvlBind :: TopLevelFlag -- Used solely to decide whether to clone
334 -> Level -- Context level; might be Top even for bindings nested in the RHS
335 -- of a top level binding
338 -> LvlM (LevelledBind, LevelEnv)
340 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
342 = -- No type abstraction; clone existing binder
343 lvlExpr rhs_lvl rhs_env rhs `thenLvl` \ rhs' ->
344 cloneVar top_lvl env bndr dest_lvl `thenLvl` \ (env', bndr') ->
345 returnLvl (NonRec (bndr', dest_lvl) rhs', env')
348 = -- Yes, type abstraction; create a new binder, extend substitution, etc
349 WARN( workerExists (getIdWorkerInfo bndr)
350 || not (isEmptyCoreRules (getIdSpecialisation bndr)),
351 text "lvlBind: discarding info on" <+> ppr bndr )
353 lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env rhs `thenLvl` \ rhs' ->
354 new_poly_bndr tyvars bndr `thenLvl` \ bndr' ->
356 env' = extendPolyLvlEnv env dest_lvl tyvars [(bndr, bndr')]
358 returnLvl (NonRec (bndr', dest_lvl) rhs', env')
361 bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr
363 dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs `maxLvl` Level 1 0
364 | otherwise = destLevel env bind_fvs
365 -- Hack alert! We do have some unlifted bindings, for cheap primops, and
366 -- it is ok to float them out; but not to the top level. If they would otherwise
367 -- go to the top level, we pin them inside the topmost lambda
369 (tyvars, tyvars_w_lvls, rhs_lvl) = abstractTyVars dest_lvl env bind_fvs
370 rhs_env = extendLvlEnv env tyvars_w_lvls
375 lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
377 = cloneVars top_lvl env bndrs dest_lvl `thenLvl` \ (new_env, new_bndrs) ->
378 mapLvl (lvlExpr rhs_lvl new_env) rhss `thenLvl` \ new_rhss ->
379 returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
382 = mapLvl (new_poly_bndr tyvars) bndrs `thenLvl` \ new_bndrs ->
384 new_env = extendPolyLvlEnv env dest_lvl tyvars (bndrs `zip` new_bndrs)
385 rhs_env = extendLvlEnv new_env tyvars_w_lvls
387 mapLvl (lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env) rhss `thenLvl` \ new_rhss ->
388 returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
391 (bndrs,rhss) = unzip pairs
393 -- Finding the free vars of the binding group is annoying
394 bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs
395 | (bndr, (rhs_fvs,_)) <- pairs])
399 dest_lvl = destLevel env bind_fvs
401 (tyvars, tyvars_w_lvls, rhs_lvl) = abstractTyVars dest_lvl env bind_fvs
403 ----------------------------------------------------
404 -- Three help functons Stuff for the type-abstraction case
406 new_poly_bndr tyvars bndr
407 = newLvlVar ("poly_" ++ occNameUserString (getOccName bndr))
408 (mkForAllTys tyvars (idType bndr))
410 lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env rhs
411 = lvlExpr rhs_lvl rhs_env rhs `thenLvl` \ rhs' ->
412 returnLvl (mkLams tyvars_w_lvls rhs')
416 %************************************************************************
418 \subsection{Deciding floatability}
420 %************************************************************************
423 abstractTyVars :: Level -> LevelEnv -> VarSet
424 -> ([TyVar], [(TyVar,Level)], Level)
425 -- Find the tyvars whose level is higher than the supplied level
426 -- There should be no Ids with this property
427 abstractTyVars lvl env fvs
428 | null tyvars = ([], [], lvl) -- Don't increment level
431 = ASSERT( not (any bad fv_list) )
432 (tyvars, tyvars_w_lvls, incd_lvl)
434 bad v = isId v && lvl `ltLvl` varLevel env v
435 fv_list = varSetElems fvs
436 tyvars = nub [tv | v <- fv_list, tv <- tvs_of v, abstract_tv tv]
438 -- If f is free in the exression, and f maps to poly_f a b c in the
439 -- current substitution, then we must report a b c as candidate type
441 tvs_of v | isId v = lookupTyVars env v
444 abstract_tv var | isId var = False
445 | otherwise = lvl `ltLvl` varLevel env var
447 -- These defns are just like those in the TyLam case of lvlExpr
448 incd_lvl = incMinorLvl lvl
449 tyvars_w_lvls = [(tv,incd_lvl) | tv <- tyvars]
452 -- Destintion level is the max Id level of the expression
453 -- (We'll abstract the type variables, if any.)
454 destLevel :: LevelEnv -> VarSet -> Level
455 destLevel env fvs = foldVarSet (maxIdLvl env) tOP_LEVEL fvs
457 maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
458 maxIdLvl (lvl_env,_,_) var lvl | isTyVar var = lvl
459 | otherwise = case lookupVarEnv lvl_env var of
460 Just lvl' -> maxLvl lvl' lvl
465 %************************************************************************
467 \subsection{Free-To-Level Monad}
469 %************************************************************************
472 type LevelEnv = (VarEnv Level, SubstEnv, IdEnv ([TyVar], LevelledExpr))
473 -- We clone let-bound variables so that they are still
474 -- distinct when floated out; hence the SubstEnv/IdEnv.
475 -- We also use these envs when making a variable polymorphic
476 -- because we want to float it out past a big lambda.
478 -- The two Envs always implement the same mapping, but the
479 -- SubstEnv maps to CoreExpr and the IdEnv to LevelledExpr
480 -- Since the range is always a variable or type application,
481 -- there is never any difference between the two, but sadly
482 -- the types differ. The SubstEnv is used when substituting in
483 -- a variable's IdInfo; the IdEnv when we find a Var.
485 -- In addition the IdEnv records a list of tyvars free in the
486 -- type application, just so we don't have to call freeVars on
487 -- the type application repeatedly.
489 -- The domain of the both envs is *pre-cloned* Ids, though
491 initialEnv :: LevelEnv
492 initialEnv = (emptyVarEnv, emptySubstEnv, emptyVarEnv)
494 extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
495 -- Used when *not* cloning
496 extendLvlEnv (lvl_env, subst_env, id_env) prs
497 = (foldl add lvl_env prs, subst_env, id_env)
499 add env (v,l) = extendVarEnv env v l
501 -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can
502 extendCaseBndrLvlEnv (lvl_env, subst_env, id_env) scrut case_bndr lvl
504 Var v -> (new_lvl_env, extendSubstEnv subst_env case_bndr (DoneEx (Var v)),
505 extendVarEnv id_env case_bndr ([], scrut))
506 other -> (new_lvl_env, subst_env, id_env)
508 new_lvl_env = extendVarEnv lvl_env case_bndr lvl
510 extendPolyLvlEnv (lvl_env, subst_env, id_env) dest_lvl tyvars bndr_pairs
511 = (foldl add_lvl lvl_env bndr_pairs,
512 foldl add_subst subst_env bndr_pairs,
513 foldl add_id id_env bndr_pairs)
515 add_lvl env (v,_ ) = extendVarEnv env v dest_lvl
516 add_subst env (v,v') = extendSubstEnv env v (DoneEx (mkTyVarApps v' tyvars))
517 add_id env (v,v') = extendVarEnv env v (tyvars, mkTyVarApps v' tyvars)
519 varLevel :: LevelEnv -> IdOrTyVar -> Level
520 varLevel (lvl_env, _, _) v
521 = case lookupVarEnv lvl_env v of
525 lookupVar :: LevelEnv -> Id -> LevelledExpr
526 lookupVar (_, _, id_env) v = case lookupVarEnv id_env v of
527 Just (_, expr) -> expr
530 lookupTyVars :: LevelEnv -> Id -> [TyVar]
531 lookupTyVars (_, _, id_env) v = case lookupVarEnv id_env v of
532 Just (tyvars, _) -> tyvars
537 type LvlM result = UniqSM result
546 newLvlVar :: String -> Type -> LvlM Id
547 newLvlVar str ty = getUniqueUs `thenLvl` \ uniq ->
548 returnUs (mkSysLocal (_PK_ str) uniq ty)
550 -- The deeply tiresome thing is that we have to apply the substitution
551 -- to the rules inside each Id. Grr. But it matters.
553 cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id)
554 cloneVar TopLevel env v lvl
555 = returnUs (env, v) -- Don't clone top level things
556 cloneVar NotTopLevel (lvl_env, subst_env, id_env) v lvl
557 = getUniqueUs `thenLvl` \ uniq ->
559 subst = mkSubst emptyVarSet subst_env
560 v' = setVarUnique v uniq
561 v'' = modifyIdInfo (\info -> substIdInfo subst info info) v'
562 subst_env' = extendSubstEnv subst_env v (DoneEx (Var v''))
563 id_env' = extendVarEnv id_env v ([], Var v'')
564 lvl_env' = extendVarEnv lvl_env v lvl
566 returnUs ((lvl_env', subst_env', id_env'), v'')
568 cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id])
569 cloneVars TopLevel env vs lvl
570 = returnUs (env, vs) -- Don't clone top level things
571 cloneVars NotTopLevel (lvl_env, subst_env, id_env) vs lvl
572 = getUniquesUs (length vs) `thenLvl` \ uniqs ->
574 subst = mkSubst emptyVarSet subst_env'
575 vs' = zipWith setVarUnique vs uniqs
576 vs'' = map (modifyIdInfo (\info -> substIdInfo subst info info)) vs'
577 subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs'']
578 id_env' = extendVarEnvList id_env (vs `zip` [([], Var v') | v' <- vs''])
579 lvl_env' = extendVarEnvList lvl_env (vs `zip` repeat lvl)
581 returnUs ((lvl_env', subst_env', id_env'), vs'')
583 mkTyVarApps var tyvars = foldl (\e tv -> App e (Type (mkTyVarTy tv)))