ghc/compiler/simplCore/SetLevels.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section{SetLevels}
   5
   6 We attach binding levels to Core bindings, in preparation for floating
   7 outwards (@FloatOut@).
   8
   9 We also let-ify many applications (notably case scrutinees), so they
  10 will have a fighting chance of being floated sensible.
  11
  12 \begin{code}
  13 module SetLevels (
  14         setLevels,
  15
  16         Level(..), tOP_LEVEL,
  17
  18         incMinorLvl, ltMajLvl, ltLvl, isTopLvl
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 import AnnCoreSyn
  24 import CoreSyn
  25
  26 import CoreUtils        ( coreExprType )
  27 import CoreUnfold       ( FormSummary, whnfOrBottom, mkFormSummary )
  28 import FreeVars         -- all of it
  29 import MkId             ( mkSysLocal )
  30 import Id               ( idType,
  31                           nullIdEnv, addOneToIdEnv, growIdEnvList,
  32                           unionManyIdSets, minusIdSet, mkIdSet,
  33                           idSetToList, Id,
  34                           lookupIdEnv, IdEnv
  35                         )
  36 import SrcLoc           ( noSrcLoc )
  37 import Type             ( isUnpointedType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, Type )
  38 import TyVar            ( emptyTyVarEnv, addToTyVarEnv,
  39                           growTyVarEnvList, lookupTyVarEnv,
  40                           tyVarSetToList,
  41                           TyVarEnv, TyVar,
  42                           unionManyTyVarSets, unionTyVarSets
  43                         )
  44 import UniqSupply       ( thenUs, returnUs, mapUs, mapAndUnzipUs,
  45                           mapAndUnzip3Us, getUnique, UniqSM,
  46                           UniqSupply
  47                         )
  48 import BasicTypes       ( Unused )
  49 import Util             ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
  50 import Outputable
  51
  52 isLeakFreeType x y = False -- safe option; ToDo
  53 \end{code}
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 \subsection{Level numbers}
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 \begin{code}
  62 data Level
  63   = Top         -- Means *really* the top level.
  64   | Level   Int -- Level number of enclosing lambdas
  65             Int -- Number of big-lambda and/or case expressions between
  66                 -- here and the nearest enclosing lambda
  67 \end{code}
  68
  69 The {\em level number} on a (type-)lambda-bound variable is the
  70 nesting depth of the (type-)lambda which binds it.  On an expression,
  71 it's the maximum level number of its free (type-)variables.  On a
  72 let(rec)-bound variable, it's the level of its RHS.  On a case-bound
  73 variable, it's the number of enclosing lambdas.
  74
  75 Top-level variables: level~0.  Those bound on the RHS of a top-level
  76 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
  77 as ``subscripts'')...
  78 \begin{verbatim}
  79 a_0 = let  b_? = ...  in
  80            x_1 = ... b ... in ...
  81 \end{verbatim}
  82
  83 Level 0 0 will make something get floated to a top-level "equals",
  84 @Top@ makes it go right to the top.
  85
  86 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
  87 That's meant to be the level number of the enclosing binder in the
  88 final (floated) program.  If the level number of a sub-expression is
  89 less than that of the context, then it might be worth let-binding the
  90 sub-expression so that it will indeed float. This context level starts
  91 at @Level 0 0@; it is never @Top@.
  92
  93 \begin{code}
  94 type LevelledExpr  = GenCoreExpr    (Id, Level) Id Unused
  95 type LevelledArg   = GenCoreArg                 Id Unused
  96 type LevelledBind  = GenCoreBinding (Id, Level) Id Unused
  97
  98 type LevelEnvs = (IdEnv    Level, -- bind Ids to levels
  99                   TyVarEnv Level) -- bind type variables to levels
 100
 101 tOP_LEVEL = Top
 102
 103 incMajorLvl :: Level -> Level
 104 incMajorLvl Top                 = Level 1 0
 105 incMajorLvl (Level major minor) = Level (major+1) 0
 106
 107 incMinorLvl :: Level -> Level
 108 incMinorLvl Top                 = Level 0 1
 109 incMinorLvl (Level major minor) = Level major (minor+1)
 110
 111 maxLvl :: Level -> Level -> Level
 112 maxLvl Top l2 = l2
 113 maxLvl l1 Top = l1
 114 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
 115   | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
 116   | otherwise                                      = l2
 117
 118 ltLvl :: Level -> Level -> Bool
 119 ltLvl l1                Top               = False
 120 ltLvl Top               (Level _ _)       = True
 121 ltLvl (Level maj1 min1) (Level maj2 min2)
 122   = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
 123
 124 ltMajLvl :: Level -> Level -> Bool
 125     -- Tells if one level belongs to a difft *lambda* level to another
 126 ltMajLvl l1             Top            = False
 127 ltMajLvl Top            (Level 0 _)    = False
 128 ltMajLvl Top            (Level _ _)    = True
 129 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
 130
 131 isTopLvl :: Level -> Bool
 132 isTopLvl Top   = True
 133 isTopLvl other = False
 134
 135 isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
 136 isTopMajLvl Top           = True
 137 isTopMajLvl (Level maj _) = maj == 0
 138
 139 unTopify :: Level -> Level
 140 unTopify Top = Level 0 0
 141 unTopify lvl = lvl
 142
 143 instance Outputable Level where
 144   ppr Top             = ptext SLIT("<Top>")
 145   ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
 146 \end{code}
 147
 148 %************************************************************************
 149 %*                                                                      *
 150 \subsection{Main level-setting code}
 151 %*                                                                      *
 152 %************************************************************************
 153
 154 \begin{code}
 155 setLevels :: [CoreBinding]
 156           -> UniqSupply
 157           -> [LevelledBind]
 158
 159 setLevels binds us
 160   = do_them binds us
 161   where
 162     -- "do_them"'s main business is to thread the monad along
 163     -- It gives each top binding the same empty envt, because
 164     -- things unbound in the envt have level number zero implicitly
 165     do_them :: [CoreBinding] -> LvlM [LevelledBind]
 166
 167     do_them [] = returnLvl []
 168     do_them (b:bs)
 169       = lvlTopBind b    `thenLvl` \ (lvld_bind, _) ->
 170         do_them bs       `thenLvl` \ lvld_binds ->
 171         returnLvl (lvld_bind ++ lvld_binds)
 172
 173 initial_envs = (nullIdEnv, emptyTyVarEnv)
 174
 175 lvlTopBind (NonRec binder rhs)
 176   = lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs))
 177                                         -- Rhs can have no free vars!
 178
 179 lvlTopBind (Rec pairs)
 180   = lvlBind (Level 0 0) initial_envs (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
 181 \end{code}
 182
 183 %************************************************************************
 184 %*                                                                      *
 185 \subsection{Bindings}
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 The binding stuff works for top level too.
 190
 191 \begin{code}
 192 type CoreBindingWithFVs = AnnCoreBinding Id Id Unused FVInfo
 193
 194 lvlBind :: Level
 195         -> LevelEnvs
 196         -> CoreBindingWithFVs
 197         -> LvlM ([LevelledBind], LevelEnvs)
 198
 199 lvlBind ctxt_lvl envs@(venv, tenv) (AnnNonRec name rhs)
 200   = setFloatLevel True {- Already let-bound -}
 201         ctxt_lvl envs rhs ty    `thenLvl` \ (final_lvl, rhs') ->
 202     let
 203         new_envs = (addOneToIdEnv venv name final_lvl, tenv)
 204     in
 205     returnLvl ([NonRec (name, final_lvl) rhs'], new_envs)
 206   where
 207     ty = idType name
 208
 209
 210 lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec pairs)
 211   = decideRecFloatLevel ctxt_lvl envs binders rhss
 212                                 `thenLvl` \ (final_lvl, extra_binds, rhss') ->
 213     let
 214         binders_w_lvls = binders `zip` repeat final_lvl
 215         new_envs       = (growIdEnvList venv binders_w_lvls, tenv)
 216     in
 217     returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_envs)
 218   where
 219     (binders,rhss) = unzip pairs
 220 \end{code}
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 \subsection{Setting expression levels}
 225 %*                                                                      *
 226 %************************************************************************
 227
 228 \begin{code}
 229 lvlExpr :: Level                -- ctxt_lvl: Level of enclosing expression
 230         -> LevelEnvs            -- Level of in-scope names/tyvars
 231         -> CoreExprWithFVs      -- input expression
 232         -> LvlM LevelledExpr    -- Result expression
 233 \end{code}
 234
 235 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
 236 binder.
 237
 238 Here's an example
 239
 240         v = \x -> ...\y -> let r = case (..x..) of
 241                                         ..x..
 242                            in ..
 243
 244 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
 245 the level of @r@, even though it's inside a level-2 @\y@.  It's
 246 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
 247 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
 248 --- because it isn't a *maximal* free expression.
 249
 250 If there were another lambda in @r@'s rhs, it would get level-2 as well.
 251
 252 \begin{code}
 253 lvlExpr _ _ (_, AnnVar v)        = returnLvl (Var v)
 254 lvlExpr _ _ (_, AnnLit l)        = returnLvl (Lit l)
 255 lvlExpr _ _ (_, AnnCon con args) = returnLvl (Con con args)
 256 lvlExpr _ _ (_, AnnPrim op args) = returnLvl (Prim op args)
 257
 258 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg)
 259   = lvlExpr ctxt_lvl envs fun           `thenLvl` \ fun' ->
 260     returnLvl (App fun' arg)
 261
 262 lvlExpr ctxt_lvl envs (_, AnnNote note expr)
 263   = lvlExpr ctxt_lvl envs expr          `thenLvl` \ expr' ->
 264     returnLvl (Note note expr')
 265
 266 -- We don't split adjacent lambdas.  That is, given
 267 --      \x y -> (x+1,y)
 268 -- we don't float to give
 269 --      \x -> let v = x+y in \y -> (v,y)
 270 -- Why not?  Because partial applications are fairly rare, and splitting
 271 -- lambdas makes them more expensive.
 272
 273 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
 274   = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' ->
 275     returnLvl (foldr (Lam . ValBinder) body' lvld_args)
 276   where
 277     incd_lvl     = incMajorLvl ctxt_lvl
 278     (args, body) = annCollectValBinders rhs
 279     lvld_args    = [(a,incd_lvl) | a <- (arg:args)]
 280     new_venv     = growIdEnvList venv lvld_args
 281
 282 -- We don't need to play such tricks for type lambdas, because
 283 -- they don't get annotated
 284
 285 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
 286   = lvlExpr incd_lvl (venv, new_tenv) body      `thenLvl` \ body' ->
 287     returnLvl (Lam (TyBinder tyvar) body')
 288   where
 289     incd_lvl = incMinorLvl ctxt_lvl
 290     new_tenv = addToTyVarEnv tenv tyvar incd_lvl
 291
 292 lvlExpr ctxt_lvl envs (_, AnnLet bind body)
 293   = lvlBind ctxt_lvl envs bind          `thenLvl` \ (binds', new_envs) ->
 294     lvlExpr ctxt_lvl new_envs body      `thenLvl` \ body' ->
 295     returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
 296
 297 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
 298   = lvlMFE ctxt_lvl envs expr   `thenLvl` \ expr' ->
 299     lvl_alts alts               `thenLvl` \ alts' ->
 300     returnLvl (Case expr' alts')
 301     where
 302       expr_type = coreExprType (deAnnotate expr)
 303       incd_lvl  = incMinorLvl ctxt_lvl
 304
 305       lvl_alts (AnnAlgAlts alts deflt)
 306         = mapLvl lvl_alt alts   `thenLvl` \ alts' ->
 307           lvl_deflt deflt       `thenLvl` \ deflt' ->
 308           returnLvl (AlgAlts alts' deflt')
 309         where
 310           lvl_alt (con, bs, e)
 311             = let
 312                   bs'  = [ (b, incd_lvl) | b <- bs ]
 313                   new_envs = (growIdEnvList venv bs', tenv)
 314               in
 315               lvlMFE incd_lvl new_envs e        `thenLvl` \ e' ->
 316               returnLvl (con, bs', e')
 317
 318       lvl_alts (AnnPrimAlts alts deflt)
 319         = mapLvl lvl_alt alts   `thenLvl` \ alts' ->
 320           lvl_deflt deflt       `thenLvl` \ deflt' ->
 321           returnLvl (PrimAlts alts' deflt')
 322         where
 323           lvl_alt (lit, e)
 324             = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
 325               returnLvl (lit, e')
 326
 327       lvl_deflt AnnNoDefault = returnLvl NoDefault
 328
 329       lvl_deflt (AnnBindDefault b expr)
 330         = let
 331               new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
 332           in
 333           lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
 334           returnLvl (BindDefault (b, incd_lvl) expr')
 335 \end{code}
 336
 337 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 338 the expression, so that it can itself be floated.
 339
 340 \begin{code}
 341 lvlMFE ::  Level                -- Level of innermost enclosing lambda/tylam
 342         -> LevelEnvs            -- Level of in-scope names/tyvars
 343         -> CoreExprWithFVs      -- input expression
 344         -> LvlM LevelledExpr    -- Result expression
 345
 346 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
 347   | isUnpointedType ty  -- Can't let-bind it
 348   = lvlExpr ctxt_lvl envs ann_expr
 349
 350   | otherwise           -- Not primitive type so could be let-bound
 351   = setFloatLevel False {- Not already let-bound -}
 352         ctxt_lvl envs ann_expr ty       `thenLvl` \ (final_lvl, expr') ->
 353     returnLvl expr'
 354   where
 355     ty = coreExprType (deAnnotate ann_expr)
 356 \end{code}
 357
 358
 359 %************************************************************************
 360 %*                                                                      *
 361 \subsection{Deciding floatability}
 362 %*                                                                      *
 363 %************************************************************************
 364
 365 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
 366 are being created as let-bindings
 367
 368 Decision tree:
 369 Let Bound?
 370   YES. -> (a) try abstracting type variables.
 371        If we abstract type variables it will go further, that is, past more
 372        lambdas. same as asking if the level number given by the free
 373        variables is less than the level number given by free variables
 374        and type variables together.
 375        Abstract offending type variables, e.g.
 376        change f ty a b
 377        to let v = /\ty' -> f ty' a b
 378           in v ty
 379        so that v' is not stopped by the level number of ty
 380        tag the original let with its level number
 381        (from its variables and type variables)
 382   NO.  is a WHNF?
 383          YES. -> No point in let binding to float a WHNF.
 384                  Pin (leave) expression here.
 385          NO. -> Will float past a lambda?
 386                 (check using free variables only, not type variables)
 387                   YES. -> do the same as (a) above.
 388                   NO. -> No point in let binding if it is not going anywhere
 389                          Pin (leave) expression here.
 390
 391 \begin{code}
 392 setFloatLevel :: Bool                   -- True <=> the expression is already let-bound
 393                                         -- False <=> it's a possible MFE
 394               -> Level                  -- of context
 395               -> LevelEnvs
 396
 397               -> CoreExprWithFVs        -- Original rhs
 398               -> Type           -- Type of rhs
 399
 400               -> LvlM (Level,           -- Level to attribute to this let-binding
 401                        LevelledExpr)    -- Final rhs
 402
 403 setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 404               expr@(FVInfo fvs tfvs might_leak, _) ty
 405 -- Invariant: ctxt_lvl is never = Top
 406 -- Beautiful ASSERT, dudes (WDP 95/04)...
 407
 408 -- Now deal with (by not floating) trivial non-let-bound expressions
 409 -- which just aren't worth let-binding in order to float.  We always
 410 -- choose to float even trivial let-bound things because it doesn't do
 411 -- any harm, and not floating it may pin something important.  For
 412 -- example
 413 --
 414 --      x = let v = []
 415 --              w = 1:v
 416 --          in ...
 417 --
 418 -- Here, if we don't float v we won't float w, which is Bad News.
 419 -- If this gives any problems we could restrict the idea to things destined
 420 -- for top level.
 421
 422   | not alreadyLetBound
 423     && (manifestly_whnf || not will_float_past_lambda)
 424   =   -- Pin whnf non-let-bound expressions,
 425       -- or ones which aren't going anywhere useful
 426     lvlExpr ctxt_lvl envs expr        `thenLvl` \ expr' ->
 427     returnLvl (ctxt_lvl, expr')
 428
 429   | alreadyLetBound && not worth_type_abstraction
 430   =   -- Process the expression with a new ctxt_lvl, obtained from
 431       -- the free vars of the expression itself
 432     lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
 433     returnLvl (maybe_unTopify expr_lvl, expr')
 434
 435   | otherwise -- This will create a let anyway, even if there is no
 436               -- type variable to abstract, so we try to abstract anyway
 437   = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
 438                                               `thenLvl` \ final_expr ->
 439     returnLvl (expr_lvl, final_expr)
 440       -- OLD LIE: The body of the let, just a type application, isn't worth floating
 441       --          so pin it with ctxt_lvl
 442       -- The truth: better to give it expr_lvl in case it is pinning
 443       -- something non-trivial which depends on it.
 444   where
 445     fv_list = idSetToList    fvs
 446     tv_list = tyVarSetToList tfvs
 447     expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
 448     ids_only_lvl    = foldr (maxLvl . idLevel venv)    tOP_LEVEL fv_list
 449     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
 450     lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
 451
 452     will_float_past_lambda =    -- Will escape lambda if let-bound
 453                             ids_only_lvl `ltMajLvl` ctxt_lvl
 454
 455     worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
 456                              -- if type abstracted
 457       (ids_only_lvl `ltLvl` tyvars_only_lvl)
 458       && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
 459
 460     de_ann_expr = deAnnotate expr
 461
 462     is_trivial (App e a)
 463       | notValArg a     = is_trivial e
 464     is_trivial (Var _)  = True
 465     is_trivial _        = False
 466
 467     offending_tyvars = filter offending tv_list
 468     --non_offending_tyvars = filter (not . offending) tv_list
 469     --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
 470
 471     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 472
 473     manifestly_whnf = whnfOrBottom (mkFormSummary de_ann_expr)
 474
 475     maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
 476     maybe_unTopify lvl                                  = lvl
 477         {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
 478         -- so that the let will not go past the *last* lambda if it can
 479         -- generate a space leak. If it is already in major level 0
 480         -- It won't do any harm to give it a Level 1 0.
 481         -- we should do the same test not only for things with level Top,
 482         -- but also for anything that gets a major level 0.
 483            the problem is that
 484            f = \a -> let x = [1..1000]
 485                      in zip a x
 486            ==>
 487            f = let x = [1..1000]
 488                in \a -> zip a x
 489            is just as bad as floating x to the top level.
 490            Notice it would be OK in cases like
 491            f = \a -> let x = [1..1000]
 492                          y = length x
 493                      in a + y
 494            ==>
 495            f = let x = [1..1000]
 496                    y = length x
 497                in \a -> a + y
 498            as x will be gc'd after y is updated.
 499            [We did not hit any problems with the above (Level 0 0) code
 500             in nofib benchmark]
 501         -}
 502 \end{code}
 503
 504 Abstract wrt tyvars, by making it just as if we had seen
 505
 506      let v = /\a1..an. E
 507      in v a1 ... an
 508
 509 instead of simply E. The idea is that v can be freely floated, since it
 510 has no free type variables. Of course, if E has no free type
 511 variables, then we just return E.
 512
 513 \begin{code}
 514 abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
 515   = lvlExpr incd_lvl new_envs expr      `thenLvl` \ expr' ->
 516     newLvlVar poly_ty                   `thenLvl` \ poly_var ->
 517     let
 518        poly_var_rhs     = mkTyLam offending_tyvars expr'
 519        poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
 520        poly_var_app     = mkTyApp (Var poly_var) (mkTyVarTys offending_tyvars)
 521        final_expr       = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
 522     in
 523     returnLvl final_expr
 524   where
 525     poly_ty = mkForAllTys offending_tyvars ty
 526
 527         -- These defns are just like those in the TyLam case of lvlExpr
 528     (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
 529
 530     next lvl tyvar = (lvl1, (tyvar,lvl1))
 531                      where lvl1 = incMinorLvl lvl
 532
 533     new_tenv = growTyVarEnvList tenv tyvar_lvls
 534     new_envs = (venv, new_tenv)
 535 \end{code}
 536
 537 Recursive definitions.  We want to transform
 538
 539         letrec
 540            x1 = e1
 541            ...
 542            xn = en
 543         in
 544         body
 545
 546 to
 547
 548         letrec
 549            x1' = /\ ab -> let D' in e1
 550            ...
 551            xn' = /\ ab -> let D' in en
 552         in
 553         let D in body
 554
 555 where ab are the tyvars pinning the defn further in than it
 556 need be, and D  is a bunch of simple type applications:
 557
 558                 x1_cl = x1' ab
 559                 ...
 560                 xn_cl = xn' ab
 561
 562 The "_cl" indicates that in D, the level numbers on the xi are the context level
 563 number; type applications aren't worth floating.  The D' decls are
 564 similar:
 565
 566                 x1_ll = x1' ab
 567                 ...
 568                 xn_ll = xn' ab
 569
 570 but differ in their level numbers; here the ab are the newly-introduced
 571 type lambdas.
 572
 573 \begin{code}
 574 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
 575   | isTopMajLvl ids_only_lvl   &&               -- Destination = top
 576     not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top
 577   =     -- Pin it here
 578     let
 579         ids_w_lvls = ids `zip` repeat ctxt_lvl
 580         new_envs   = (growIdEnvList venv ids_w_lvls, tenv)
 581     in
 582     mapLvl (lvlExpr ctxt_lvl new_envs) rhss     `thenLvl` \ rhss' ->
 583     returnLvl (ctxt_lvl, [], rhss')
 584
 585 {- OMITTED; see comments above near isWorthFloatingExpr
 586
 587   | not (any (isWorthFloating True . deAnnotate) rhss)
 588   =     -- Pin it here
 589     mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
 590     returnLvl (ctxt_lvl, [], rhss')
 591
 592 -}
 593
 594   | ids_only_lvl `ltLvl` tyvars_only_lvl
 595   =     -- Abstract wrt tyvars;
 596         -- offending_tyvars is definitely non-empty
 597         -- (I love the ASSERT to check this...  WDP 95/02)
 598     let
 599         -- These defns are just like those in the TyLam case of lvlExpr
 600        (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
 601
 602        next lvl tyvar = (lvl1, (tyvar,lvl1))
 603                      where lvl1 = incMinorLvl lvl
 604
 605        ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
 606        new_tenv       = growTyVarEnvList tenv tyvar_lvls
 607        new_venv       = growIdEnvList    venv ids_w_incd_lvl
 608        new_envs       = (new_venv, new_tenv)
 609     in
 610     mapLvl (lvlExpr incd_lvl new_envs) rhss     `thenLvl` \ rhss' ->
 611     mapLvl newLvlVar poly_tys                   `thenLvl` \ poly_vars ->
 612     let
 613         ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
 614
 615                 -- The "d_rhss" are the right-hand sides of "D" and "D'"
 616                 -- in the documentation above
 617         d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
 618
 619                 -- "local_binds" are "D'" in the documentation above
 620         local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss
 621
 622         poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
 623                         | rhs' <- rhss' -- mkCoLet* requires Core...
 624                         ]
 625
 626         poly_binds  = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
 627                                             poly_var_rhss
 628
 629     in
 630     returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
 631         -- The new right-hand sides, just a type application, aren't worth floating
 632         -- so pin it with ctxt_lvl
 633
 634   | otherwise
 635   =     -- Let it float freely
 636     let
 637         ids_w_lvls = ids `zip` repeat expr_lvl
 638         new_envs   = (growIdEnvList venv ids_w_lvls, tenv)
 639     in
 640     mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss  `thenLvl` \ rhss' ->
 641     returnLvl (expr_lvl, [], rhss')
 642
 643   where
 644     tys  = map idType ids
 645
 646     fvs  = unionManyIdSets [freeVarsOf   rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
 647     tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
 648            `unionTyVarSets`
 649            tyVarsOfTypes tys
 650         -- Why the "tyVarsOfTypes" part?  Consider this:
 651         --      /\a -> letrec x::a = x in E
 652         -- Now, there are no explicit free type variables in the RHS of x,
 653         -- but nevertheless "a" is free in its definition.  So we add in
 654         -- the free tyvars of the types of the binders.
 655         -- This actually happened in the defn of errorIO in IOBase.lhs:
 656         --      errorIO (ST io) = case (errorIO# io) of
 657         --                          _ -> bottom
 658         --                        where
 659         --                          bottom = bottom -- Never evaluated
 660         -- I don't think this can every happen for non-recursive bindings.
 661
 662     fv_list = idSetToList fvs
 663     tv_list = tyVarSetToList tfvs
 664
 665     ids_only_lvl    = foldr (maxLvl . idLevel venv)    tOP_LEVEL fv_list
 666     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
 667     expr_lvl        = ids_only_lvl `maxLvl` tyvars_only_lvl
 668
 669     offending_tyvars
 670         | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
 671         | otherwise                            = []
 672
 673     offending_tyvar_tys = mkTyVarTys offending_tyvars
 674     poly_tys = map (mkForAllTys offending_tyvars) tys
 675
 676     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 677 \end{code}
 678
 679
 680 \begin{code}
 681 {- ******** OMITTED NOW
 682
 683 isWorthFloating :: Bool         -- True <=> already let-bound
 684                 -> CoreExpr     -- The expression
 685                 -> Bool
 686
 687 isWorthFloating alreadyLetBound expr
 688
 689   | alreadyLetBound = isWorthFloatingExpr expr
 690
 691   | otherwise       =   -- No point in adding a fresh let-binding for a WHNF, because
 692                         -- floating it isn't beneficial enough.
 693                       isWorthFloatingExpr expr &&
 694                       not (whnfOrBottom expr)
 695 ********** -}
 696
 697 isWorthFloatingExpr :: CoreExpr -> Bool
 698
 699 isWorthFloatingExpr (Var v)     = False
 700 isWorthFloatingExpr (Lit lit)   = False
 701 isWorthFloatingExpr (App e arg)
 702   | notValArg arg               = isWorthFloatingExpr e
 703 isWorthFloatingExpr (Con con as)
 704   | all notValArg as            = False -- Just a type application
 705 isWorthFloatingExpr _           = True
 706
 707 canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
 708
 709 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
 710 canFloatToTop (ty, (FVInfo _ _ MightLeak,    expr)) = isLeakFreeType [] ty
 711
 712 valSuggestsLeakFree expr = whnfOrBottom expr
 713 \end{code}
 714
 715
 716
 717 %************************************************************************
 718 %*                                                                      *
 719 \subsection{Help functions}
 720 %*                                                                      *
 721 %************************************************************************
 722
 723 \begin{code}
 724 idLevel :: IdEnv Level -> Id -> Level
 725 idLevel venv v
 726   = case lookupIdEnv venv v of
 727       Just level -> level
 728       Nothing    -> tOP_LEVEL
 729
 730 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
 731 tyvarLevel tenv tyvar
 732   = case lookupTyVarEnv tenv tyvar of
 733       Just level -> level
 734       Nothing    -> tOP_LEVEL
 735 \end{code}
 736
 737 \begin{code}
 738 annCollectValBinders (_, (AnnLam (ValBinder arg) rhs))
 739   = (arg:args, body)
 740   where
 741     (args, body) = annCollectValBinders rhs
 742
 743 annCollectValBinders body
 744   = ([], body)
 745 \end{code}
 746
 747 %************************************************************************
 748 %*                                                                      *
 749 \subsection{Free-To-Level Monad}
 750 %*                                                                      *
 751 %************************************************************************
 752
 753 \begin{code}
 754 type LvlM result = UniqSM result
 755
 756 thenLvl         = thenUs
 757 returnLvl       = returnUs
 758 mapLvl          = mapUs
 759 mapAndUnzipLvl  = mapAndUnzipUs
 760 mapAndUnzip3Lvl = mapAndUnzip3Us
 761 \end{code}
 762
 763 We create a let-binding for `interesting' (non-utterly-trivial)
 764 applications, to give them a fighting chance of being floated.
 765
 766 \begin{code}
 767 newLvlVar :: Type -> LvlM Id
 768
 769 newLvlVar ty us
 770   = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc
 771 \end{code}