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 #include "HsVersions.h"
  14
  15 module SetLevels (
  16         setLevels,
  17
  18         Level(..), tOP_LEVEL,
  19
  20         incMinorLvl, ltMajLvl, ltLvl, isTopLvl
  21 -- not exported: , incMajorLvl, isTopMajLvl, unTopify
  22     ) where
  23
  24 import Ubiq{-uitous-}
  25
  26 import AnnCoreSyn
  27 import CoreSyn
  28
  29 import CoreUtils        ( coreExprType, manifestlyWHNF, manifestlyBottom )
  30 import FreeVars         -- all of it
  31 import Id               ( idType, mkSysLocal, toplevelishId,
  32                           nullIdEnv, addOneToIdEnv, growIdEnvList,
  33                           unionManyIdSets, minusIdSet, mkIdSet,
  34                           idSetToList,
  35                           lookupIdEnv, IdEnv(..)
  36                         )
  37 import Pretty           ( ppStr, ppBesides, ppChar, ppInt )
  38 import SrcLoc           ( mkUnknownSrcLoc )
  39 import Type             ( isPrimType, mkTyVarTys, mkForAllTys )
  40 import TyVar            ( nullTyVarEnv, addOneToTyVarEnv,
  41                           growTyVarEnvList, lookupTyVarEnv,
  42                           tyVarSetToList,
  43                           TyVarEnv(..),
  44                           unionManyTyVarSets
  45                         )
  46 import UniqSupply       ( thenUs, returnUs, mapUs, mapAndUnzipUs,
  47                           mapAndUnzip3Us, getUnique, UniqSM(..)
  48                         )
  49 import Usage            ( UVar(..) )
  50 import Util             ( mapAccumL, zipWithEqual, panic, assertPanic )
  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 TyVar UVar
  95 type LevelledArg   = GenCoreArg                 Id TyVar UVar
  96 type LevelledBind  = GenCoreBinding (Id, Level) Id TyVar UVar
  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 sty Top             = ppStr "<Top>"
 145   ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ]
 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, nullTyVarEnv)
 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 TyVar UVar 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 (binders_w_lvls `zip` 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 (_, AnnSCC cc expr)
 263   = lvlExpr ctxt_lvl envs expr          `thenLvl` \ expr' ->
 264     returnLvl (SCC cc expr')
 265
 266 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
 267   = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
 268     returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
 269   where
 270     incd_lvl = incMajorLvl ctxt_lvl
 271     new_venv = growIdEnvList venv [(arg,incd_lvl)]
 272
 273 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e)
 274   = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
 275     returnLvl (Lam (TyBinder tyvar) e')
 276   where
 277     incd_lvl   = incMinorLvl ctxt_lvl
 278     new_tenv   = addOneToTyVarEnv tenv tyvar incd_lvl
 279
 280 lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
 281   = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
 282
 283 lvlExpr ctxt_lvl envs (_, AnnLet bind body)
 284   = lvlBind ctxt_lvl envs bind          `thenLvl` \ (binds', new_envs) ->
 285     lvlExpr ctxt_lvl new_envs body      `thenLvl` \ body' ->
 286     returnLvl (foldr Let body' binds') -- mkCoLet* requires Core...
 287
 288 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCase expr alts)
 289   = lvlMFE ctxt_lvl envs expr   `thenLvl` \ expr' ->
 290     lvl_alts alts               `thenLvl` \ alts' ->
 291     returnLvl (Case expr' alts')
 292     where
 293       expr_type = coreExprType (deAnnotate expr)
 294       incd_lvl  = incMinorLvl ctxt_lvl
 295
 296       lvl_alts (AnnAlgAlts alts deflt)
 297         = mapLvl lvl_alt alts   `thenLvl` \ alts' ->
 298           lvl_deflt deflt       `thenLvl` \ deflt' ->
 299           returnLvl (AlgAlts alts' deflt')
 300         where
 301           lvl_alt (con, bs, e)
 302             = let
 303                   bs'  = [ (b, incd_lvl) | b <- bs ]
 304                   new_envs = (growIdEnvList venv bs', tenv)
 305               in
 306               lvlMFE incd_lvl new_envs e        `thenLvl` \ e' ->
 307               returnLvl (con, bs', e')
 308
 309       lvl_alts (AnnPrimAlts alts deflt)
 310         = mapLvl lvl_alt alts   `thenLvl` \ alts' ->
 311           lvl_deflt deflt       `thenLvl` \ deflt' ->
 312           returnLvl (PrimAlts alts' deflt')
 313         where
 314           lvl_alt (lit, e)
 315             = lvlMFE incd_lvl envs e `thenLvl` \ e' ->
 316               returnLvl (lit, e')
 317
 318       lvl_deflt AnnNoDefault = returnLvl NoDefault
 319
 320       lvl_deflt (AnnBindDefault b expr)
 321         = let
 322               new_envs = (addOneToIdEnv venv b incd_lvl, tenv)
 323           in
 324           lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' ->
 325           returnLvl (BindDefault (b, incd_lvl) expr')
 326 \end{code}
 327
 328 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 329 the expression, so that it can itself be floated.
 330
 331 \begin{code}
 332 lvlMFE ::  Level                -- Level of innermost enclosing lambda/tylam
 333         -> LevelEnvs            -- Level of in-scope names/tyvars
 334         -> CoreExprWithFVs      -- input expression
 335         -> LvlM LevelledExpr    -- Result expression
 336
 337 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
 338   | isPrimType ty       -- Can't let-bind it
 339   = lvlExpr ctxt_lvl envs ann_expr
 340
 341   | otherwise           -- Not primitive type so could be let-bound
 342   = setFloatLevel False {- Not already let-bound -}
 343         ctxt_lvl envs ann_expr ty       `thenLvl` \ (final_lvl, expr') ->
 344     returnLvl expr'
 345   where
 346     ty = coreExprType (deAnnotate ann_expr)
 347 \end{code}
 348
 349
 350 %************************************************************************
 351 %*                                                                      *
 352 \subsection{Deciding floatability}
 353 %*                                                                      *
 354 %************************************************************************
 355
 356 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
 357 are being created as let-bindings
 358
 359 Decision tree:
 360 Let Bound?
 361   YES. -> (a) try abstracting type variables.
 362        If we abstract type variables it will go further, that is, past more
 363        lambdas. same as asking if the level number given by the free
 364        variables is less than the level number given by free variables
 365        and type variables together.
 366        Abstract offending type variables, e.g.
 367        change f ty a b
 368        to let v = /\ty' -> f ty' a b
 369           in v ty
 370        so that v' is not stopped by the level number of ty
 371        tag the original let with its level number
 372        (from its variables and type variables)
 373   NO.  is a WHNF?
 374          YES. -> No point in let binding to float a WHNF.
 375                  Pin (leave) expression here.
 376          NO. -> Will float past a lambda?
 377                 (check using free variables only, not type variables)
 378                   YES. -> do the same as (a) above.
 379                   NO. -> No point in let binding if it is not going anywhere
 380                          Pin (leave) expression here.
 381
 382 \begin{code}
 383 setFloatLevel :: Bool                   -- True <=> the expression is already let-bound
 384                                         -- False <=> it's a possible MFE
 385               -> Level                  -- of context
 386               -> LevelEnvs
 387
 388               -> CoreExprWithFVs        -- Original rhs
 389               -> Type           -- Type of rhs
 390
 391               -> LvlM (Level,           -- Level to attribute to this let-binding
 392                        LevelledExpr)    -- Final rhs
 393
 394 setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 395               expr@(FVInfo fvs tfvs might_leak, _) ty
 396 -- Invariant: ctxt_lvl is never = Top
 397 -- Beautiful ASSERT, dudes (WDP 95/04)...
 398
 399 -- Now deal with (by not floating) trivial non-let-bound expressions
 400 -- which just aren't worth let-binding in order to float.  We always
 401 -- choose to float even trivial let-bound things because it doesn't do
 402 -- any harm, and not floating it may pin something important.  For
 403 -- example
 404 --
 405 --      x = let v = Nil
 406 --              w = 1:v
 407 --          in ...
 408 --
 409 -- Here, if we don't float v we won't float w, which is Bad News.
 410 -- If this gives any problems we could restrict the idea to things destined
 411 -- for top level.
 412
 413   | not alreadyLetBound
 414     && (manifestly_whnf || not will_float_past_lambda)
 415   =   -- Pin whnf non-let-bound expressions,
 416       -- or ones which aren't going anywhere useful
 417     lvlExpr ctxt_lvl envs expr        `thenLvl` \ expr' ->
 418     returnLvl (ctxt_lvl, expr')
 419
 420   | alreadyLetBound && not worth_type_abstraction
 421   =   -- Process the expression with a new ctxt_lvl, obtained from
 422       -- the free vars of the expression itself
 423     lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' ->
 424     returnLvl (maybe_unTopify expr_lvl, expr')
 425
 426   | otherwise -- This will create a let anyway, even if there is no
 427               -- type variable to abstract, so we try to abstract anyway
 428   = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr
 429                                               `thenLvl` \ final_expr ->
 430     returnLvl (expr_lvl, final_expr)
 431       -- OLD LIE: The body of the let, just a type application, isn't worth floating
 432       --          so pin it with ctxt_lvl
 433       -- The truth: better to give it expr_lvl in case it is pinning
 434       -- something non-trivial which depends on it.
 435   where
 436     fv_list = idSetToList    fvs
 437     tv_list = tyVarSetToList tfvs
 438     expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl
 439     ids_only_lvl    = foldr (maxLvl . idLevel venv)    tOP_LEVEL fv_list
 440     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
 441     lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
 442
 443     will_float_past_lambda =    -- Will escape lambda if let-bound
 444                             ids_only_lvl `ltMajLvl` ctxt_lvl
 445
 446     worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s)
 447                              -- if type abstracted
 448       (ids_only_lvl `ltLvl` tyvars_only_lvl)
 449       && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications
 450
 451     de_ann_expr = deAnnotate expr
 452
 453     is_trivial (App e a)
 454       | notValArg a     = is_trivial e
 455     is_trivial (Var _)  = True
 456     is_trivial _        = False
 457
 458     offending_tyvars = filter offending tv_list
 459     --non_offending_tyvars = filter (not . offending) tv_list
 460     --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars
 461
 462     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 463
 464     manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
 465
 466     maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
 467     maybe_unTopify lvl                                  = lvl
 468         {- ToDo [Andre]: the line above (maybe) should be Level 1 0,
 469         -- so that the let will not go past the *last* lambda if it can
 470         -- generate a space leak. If it is already in major level 0
 471         -- It won't do any harm to give it a Level 1 0.
 472         -- we should do the same test not only for things with level Top,
 473         -- but also for anything that gets a major level 0.
 474            the problem is that
 475            f = \a -> let x = [1..1000]
 476                      in zip a x
 477            ==>
 478            f = let x = [1..1000]
 479                in \a -> zip a x
 480            is just as bad as floating x to the top level.
 481            Notice it would be OK in cases like
 482            f = \a -> let x = [1..1000]
 483                          y = length x
 484                      in a + y
 485            ==>
 486            f = let x = [1..1000]
 487                    y = length x
 488                in \a -> a + y
 489            as x will be gc'd after y is updated.
 490            [We did not hit any problems with the above (Level 0 0) code
 491             in nofib benchmark]
 492         -}
 493 \end{code}
 494
 495 Abstract wrt tyvars, by making it just as if we had seen
 496
 497      let v = /\a1..an. E
 498      in v a1 ... an
 499
 500 instead of simply E. The idea is that v can be freely floated, since it
 501 has no free type variables. Of course, if E has no free type
 502 variables, then we just return E.
 503
 504 \begin{code}
 505 abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
 506   = lvlExpr incd_lvl new_envs expr      `thenLvl` \ expr' ->
 507     newLvlVar poly_ty                   `thenLvl` \ poly_var ->
 508     let
 509        poly_var_rhs     = mkTyLam offending_tyvars expr'
 510        poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
 511        poly_var_app     = mkTyApp (Var poly_var) (mkTyVarTys offending_tyvars)
 512        final_expr       = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
 513     in
 514     returnLvl final_expr
 515   where
 516     poly_ty = mkForAllTys offending_tyvars ty
 517
 518         -- These defns are just like those in the TyLam case of lvlExpr
 519     (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
 520
 521     next lvl tyvar = (lvl1, (tyvar,lvl1))
 522                      where lvl1 = incMinorLvl lvl
 523
 524     new_tenv = growTyVarEnvList tenv tyvar_lvls
 525     new_envs = (venv, new_tenv)
 526 \end{code}
 527
 528 Recursive definitions.  We want to transform
 529
 530         letrec
 531            x1 = e1
 532            ...
 533            xn = en
 534         in
 535         body
 536
 537 to
 538
 539         letrec
 540            x1' = /\ ab -> let D' in e1
 541            ...
 542            xn' = /\ ab -> let D' in en
 543         in
 544         let D in body
 545
 546 where ab are the tyvars pinning the defn further in than it
 547 need be, and D  is a bunch of simple type applications:
 548
 549                 x1_cl = x1' ab
 550                 ...
 551                 xn_cl = xn' ab
 552
 553 The "_cl" indicates that in D, the level numbers on the xi are the context level
 554 number; type applications aren't worth floating.  The D' decls are
 555 similar:
 556
 557                 x1_ll = x1' ab
 558                 ...
 559                 xn_ll = xn' ab
 560
 561 but differ in their level numbers; here the ab are the newly-introduced
 562 type lambdas.
 563
 564 \begin{code}
 565 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
 566   | isTopMajLvl ids_only_lvl   &&               -- Destination = top
 567     not (all canFloatToTop (tys `zip` rhss))    -- Some can't float to top
 568   =     -- Pin it here
 569     let
 570         ids_w_lvls = ids `zip` repeat ctxt_lvl
 571         new_envs       = (growIdEnvList venv ids_w_lvls, tenv)
 572     in
 573     mapLvl (lvlExpr ctxt_lvl new_envs) rhss     `thenLvl` \ rhss' ->
 574     returnLvl (ctxt_lvl, [], rhss')
 575
 576 {- OMITTED; see comments above near isWorthFloatingExpr
 577
 578   | not (any (isWorthFloating True . deAnnotate) rhss)
 579   =     -- Pin it here
 580     mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' ->
 581     returnLvl (ctxt_lvl, [], rhss')
 582
 583 -}
 584
 585   | ids_only_lvl `ltLvl` tyvars_only_lvl
 586   =     -- Abstract wrt tyvars;
 587         -- offending_tyvars is definitely non-empty
 588         -- (I love the ASSERT to check this...  WDP 95/02)
 589     let
 590         -- These defns are just like those in the TyLam case of lvlExpr
 591        (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars
 592
 593        next lvl tyvar = (lvl1, (tyvar,lvl1))
 594                      where lvl1 = incMinorLvl lvl
 595
 596        ids_w_incd_lvl = [(id,incd_lvl) | id <- ids]
 597        new_tenv       = growTyVarEnvList tenv tyvar_lvls
 598        new_venv       = growIdEnvList    venv ids_w_incd_lvl
 599        new_envs       = (new_venv, new_tenv)
 600     in
 601     mapLvl (lvlExpr incd_lvl new_envs) rhss     `thenLvl` \ rhss' ->
 602     mapLvl newLvlVar poly_tys                   `thenLvl` \ poly_vars ->
 603     let
 604         ids_w_poly_vars = ids `zip` poly_vars
 605
 606                 -- The "d_rhss" are the right-hand sides of "D" and "D'"
 607                 -- in the documentation above
 608         d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
 609
 610                 -- "local_binds" are "D'" in the documentation above
 611         local_binds = zipWithEqual NonRec ids_w_incd_lvl d_rhss
 612
 613         poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
 614                         | rhs' <- rhss' -- mkCoLet* requires Core...
 615                         ]
 616
 617         poly_binds  = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss
 618
 619     in
 620     returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
 621         -- The new right-hand sides, just a type application, aren't worth floating
 622         -- so pin it with ctxt_lvl
 623
 624   | otherwise
 625   =     -- Let it float freely
 626     let
 627         ids_w_lvls = ids `zip` repeat expr_lvl
 628         new_envs   = (growIdEnvList venv ids_w_lvls, tenv)
 629     in
 630     mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss  `thenLvl` \ rhss' ->
 631     returnLvl (expr_lvl, [], rhss')
 632
 633   where
 634     tys  = map idType ids
 635
 636     fvs  = unionManyIdSets [freeVarsOf   rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
 637     tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
 638     fv_list = idSetToList fvs
 639     tv_list = tyVarSetToList tfvs
 640
 641     ids_only_lvl    = foldr (maxLvl . idLevel venv)    tOP_LEVEL fv_list
 642     tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list
 643     expr_lvl        = ids_only_lvl `maxLvl` tyvars_only_lvl
 644
 645     offending_tyvars
 646         | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list
 647         | otherwise                            = []
 648
 649     offending_tyvar_tys = mkTyVarTys offending_tyvars
 650     poly_tys = map (mkForAllTys offending_tyvars) tys
 651
 652     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 653 \end{code}
 654
 655
 656 \begin{code}
 657 {- ******** OMITTED NOW
 658
 659 isWorthFloating :: Bool         -- True <=> already let-bound
 660                 -> CoreExpr     -- The expression
 661                 -> Bool
 662
 663 isWorthFloating alreadyLetBound expr
 664
 665   | alreadyLetBound = isWorthFloatingExpr expr
 666
 667   | otherwise       =   -- No point in adding a fresh let-binding for a WHNF, because
 668                         -- floating it isn't beneficial enough.
 669                       isWorthFloatingExpr expr &&
 670                       not (manifestlyWHNF expr || manifestlyBottom expr)
 671 ********** -}
 672
 673 isWorthFloatingExpr :: CoreExpr -> Bool
 674
 675 isWorthFloatingExpr (Var v)     = False
 676 isWorthFloatingExpr (Lit lit)   = False
 677 isWorthFloatingExpr (App e arg)
 678   | notValArg arg               = isWorthFloatingExpr e
 679 isWorthFloatingExpr (Con con as)
 680   | all notValArg as            = False -- Just a type application
 681 isWorthFloatingExpr _           = True
 682
 683 canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
 684
 685 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
 686 canFloatToTop (ty, (FVInfo _ _ MightLeak,    expr)) = isLeakFreeType [] ty
 687
 688 valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
 689 \end{code}
 690
 691
 692
 693 %************************************************************************
 694 %*                                                                      *
 695 \subsection{Help functions}
 696 %*                                                                      *
 697 %************************************************************************
 698
 699 \begin{code}
 700 idLevel :: IdEnv Level -> Id -> Level
 701 idLevel venv v
 702   = case lookupIdEnv venv v of
 703       Just level -> level
 704       Nothing    -> ASSERT(toplevelishId v)
 705                     tOP_LEVEL
 706
 707 tyvarLevel :: TyVarEnv Level -> TyVar -> Level
 708 tyvarLevel tenv tyvar
 709   = case lookupTyVarEnv tenv tyvar of
 710       Just level -> level
 711       Nothing    -> tOP_LEVEL
 712 \end{code}
 713
 714 %************************************************************************
 715 %*                                                                      *
 716 \subsection{Free-To-Level Monad}
 717 %*                                                                      *
 718 %************************************************************************
 719
 720 \begin{code}
 721 type LvlM result = UniqSM result
 722
 723 thenLvl         = thenUs
 724 returnLvl       = returnUs
 725 mapLvl          = mapUs
 726 mapAndUnzipLvl  = mapAndUnzipUs
 727 mapAndUnzip3Lvl = mapAndUnzip3Us
 728 \end{code}
 729
 730 We create a let-binding for `interesting' (non-utterly-trivial)
 731 applications, to give them a fighting chance of being floated.
 732
 733 \begin{code}
 734 newLvlVar :: Type -> LvlM Id
 735
 736 newLvlVar ty us
 737   = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc
 738 \end{code}