ghc/compiler/simplCore/SetLevels.lhs

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