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