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