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