ghc/compiler/simplCore/SetLevels.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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 module SetLevels (
  14         setLevels,
  15
  16         Level(..), tOP_LEVEL,
  17
  18         incMinorLvl, ltMajLvl, ltLvl, isTopLvl
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 import CoreSyn
  24
  25 import CoreUtils        ( coreExprType, exprIsTrivial, idFreeVars, exprIsBottom
  26                         )
  27 import FreeVars         -- all of it
  28 import Id               ( Id, idType, mkSysLocal )
  29 import Var              ( IdOrTyVar )
  30 import VarEnv
  31 import VarSet
  32 import Type             ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
  33 import VarSet
  34 import VarEnv
  35 import UniqSupply       ( initUs_, thenUs, returnUs, mapUs, mapAndUnzipUs, getUniqueUs,
  36                           mapAndUnzip3Us, UniqSM, UniqSupply )
  37 import Maybes           ( maybeToBool )
  38 import Util             ( zipWithEqual, zipEqual )
  39 import Outputable
  40
  41 isLeakFreeType x y = False -- safe option; ToDo
  42 \end{code}
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection{Level numbers}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 \begin{code}
  51 data Level
  52   = Top         -- Means *really* the top level; short for (Level 0 0).
  53   | Level   Int -- Level number of enclosing lambdas
  54             Int -- Number of big-lambda and/or case expressions between
  55                 -- here and the nearest enclosing lambda
  56 \end{code}
  57
  58 The {\em level number} on a (type-)lambda-bound variable is the
  59 nesting depth of the (type-)lambda which binds it.  The outermost lambda
  60 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
  61
  62 On an expression, it's the maximum level number of its free
  63 (type-)variables.  On a let(rec)-bound variable, it's the level of its
  64 RHS.  On a case-bound variable, it's the number of enclosing lambdas.
  65
  66 Top-level variables: level~0.  Those bound on the RHS of a top-level
  67 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
  68 as ``subscripts'')...
  69 \begin{verbatim}
  70 a_0 = let  b_? = ...  in
  71            x_1 = ... b ... in ...
  72 \end{verbatim}
  73
  74 Level 0 0 will make something get floated to a top-level "equals",
  75 @Top@ makes it go right to the top.
  76
  77 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
  78 That's meant to be the level number of the enclosing binder in the
  79 final (floated) program.  If the level number of a sub-expression is
  80 less than that of the context, then it might be worth let-binding the
  81 sub-expression so that it will indeed float. This context level starts
  82 at @Level 0 0@; it is never @Top@.
  83
  84 \begin{code}
  85 type LevelledExpr  = TaggedExpr Level
  86 type LevelledArg   = TaggedArg  Level
  87 type LevelledBind  = TaggedBind Level
  88
  89 tOP_LEVEL = Top
  90
  91 incMajorLvl :: Level -> Level
  92 incMajorLvl Top                 = Level 1 0
  93 incMajorLvl (Level major minor) = Level (major+1) 0
  94
  95 incMinorLvl :: Level -> Level
  96 incMinorLvl Top                 = Level 0 1
  97 incMinorLvl (Level major minor) = Level major (minor+1)
  98
  99 maxLvl :: Level -> Level -> Level
 100 maxLvl Top l2 = l2
 101 maxLvl l1 Top = l1
 102 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2)
 103   | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
 104   | otherwise                                      = l2
 105
 106 ltLvl :: Level -> Level -> Bool
 107 ltLvl l1                Top               = False
 108 ltLvl Top               (Level _ _)       = True
 109 ltLvl (Level maj1 min1) (Level maj2 min2)
 110   = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
 111
 112 ltMajLvl :: Level -> Level -> Bool
 113     -- Tells if one level belongs to a difft *lambda* level to another
 114 ltMajLvl l1             Top            = False
 115 ltMajLvl Top            (Level 0 _)    = False
 116 ltMajLvl Top            (Level _ _)    = True
 117 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
 118
 119 isTopLvl :: Level -> Bool
 120 isTopLvl Top   = True
 121 isTopLvl other = False
 122
 123 isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level
 124 isTopMajLvl Top           = True
 125 isTopMajLvl (Level maj _) = maj == 0
 126
 127 instance Outputable Level where
 128   ppr Top             = ptext SLIT("<Top>")
 129   ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
 130 \end{code}
 131
 132 \begin{code}
 133 type LevelEnv = VarEnv Level
 134
 135 varLevel :: LevelEnv -> IdOrTyVar -> Level
 136 varLevel env v
 137   = case lookupVarEnv env v of
 138       Just level -> level
 139       Nothing    -> tOP_LEVEL
 140
 141 maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
 142 maxIdLvl env var lvl | isTyVar var = lvl
 143                      | otherwise   = case lookupVarEnv env var of
 144                                         Just lvl' -> maxLvl lvl' lvl
 145                                         Nothing   -> lvl
 146
 147 maxTyVarLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
 148 maxTyVarLvl env var lvl | isId var  = lvl
 149                         | otherwise = case lookupVarEnv env var of
 150                                         Just lvl' -> maxLvl lvl' lvl
 151                                         Nothing   -> lvl
 152 \end{code}
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection{Main level-setting code}
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 \begin{code}
 161 setLevels :: [CoreBind]
 162           -> UniqSupply
 163           -> [LevelledBind]
 164
 165 setLevels binds us
 166   = initLvl us (do_them binds)
 167   where
 168     -- "do_them"'s main business is to thread the monad along
 169     -- It gives each top binding the same empty envt, because
 170     -- things unbound in the envt have level number zero implicitly
 171     do_them :: [CoreBind] -> LvlM [LevelledBind]
 172
 173     do_them [] = returnLvl []
 174     do_them (b:bs)
 175       = lvlTopBind b    `thenLvl` \ (lvld_bind, _) ->
 176         do_them bs      `thenLvl` \ lvld_binds ->
 177         returnLvl (lvld_bind ++ lvld_binds)
 178
 179 initialEnv = emptyVarEnv
 180
 181 lvlTopBind (NonRec binder rhs)
 182   = lvlBind Top initialEnv (AnnNonRec binder (freeVars rhs))
 183                                         -- Rhs can have no free vars!
 184
 185 lvlTopBind (Rec pairs)
 186   = lvlBind Top initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
 187 \end{code}
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection{Bindings}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 The binding stuff works for top level too.
 196
 197 \begin{code}
 198 lvlBind :: Level
 199         -> LevelEnv
 200         -> CoreBindWithFVs
 201         -> LvlM ([LevelledBind], LevelEnv)
 202
 203 lvlBind ctxt_lvl env (AnnNonRec name rhs)
 204   = setFloatLevel (Just name) ctxt_lvl env rhs ty       `thenLvl` \ (final_lvl, rhs') ->
 205     let
 206         new_env = extendVarEnv env name final_lvl
 207     in
 208     returnLvl ([NonRec (name, final_lvl) rhs'], new_env)
 209   where
 210     ty = idType name
 211
 212
 213 lvlBind ctxt_lvl env (AnnRec pairs)
 214   = decideRecFloatLevel ctxt_lvl env binders rhss       `thenLvl` \ (final_lvl, extra_binds, rhss') ->
 215     let
 216         binders_w_lvls = binders `zip` repeat final_lvl
 217         new_env        = extendVarEnvList env binders_w_lvls
 218     in
 219     returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_env)
 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         -> LevelEnv             -- 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 _ _ (_, AnnType ty) = returnLvl (Type ty)
 256 lvlExpr _ _ (_, AnnVar v)   = returnLvl (Var v)
 257
 258 lvlExpr ctxt_lvl env (_, AnnCon con args)
 259   = mapLvl (lvlExpr ctxt_lvl env) args  `thenLvl` \ args' ->
 260     returnLvl (Con con args')
 261
 262 lvlExpr ctxt_lvl env (_, AnnApp fun arg)
 263   = lvlExpr ctxt_lvl env fun            `thenLvl` \ fun' ->
 264     lvlMFE  ctxt_lvl env arg            `thenLvl` \ arg' ->
 265     returnLvl (App fun' arg')
 266
 267 lvlExpr ctxt_lvl env (_, AnnNote note expr)
 268   = lvlExpr ctxt_lvl env expr           `thenLvl` \ expr' ->
 269     returnLvl (Note note expr')
 270
 271 -- We don't split adjacent lambdas.  That is, given
 272 --      \x y -> (x+1,y)
 273 -- we don't float to give
 274 --      \x -> let v = x+y in \y -> (v,y)
 275 -- Why not?  Because partial applications are fairly rare, and splitting
 276 -- lambdas makes them more expensive.
 277
 278 lvlExpr ctxt_lvl env (_, AnnLam bndr rhs)
 279   = lvlMFE incd_lvl new_env body        `thenLvl` \ body' ->
 280     returnLvl (mkLams lvld_bndrs body')
 281   where
 282     bndr_is_id    = isId bndr
 283     bndr_is_tyvar = isTyVar bndr
 284     (bndrs, body) = go rhs
 285
 286     incd_lvl   | bndr_is_id = incMajorLvl ctxt_lvl
 287                | otherwise  = incMinorLvl ctxt_lvl
 288     lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
 289     new_env    = extendVarEnvList env lvld_bndrs
 290
 291     go (_, AnnLam bndr rhs) |  bndr_is_id && isId bndr
 292                             || bndr_is_tyvar && isTyVar bndr
 293                             =  case go rhs of { (bndrs, body) -> (bndr:bndrs, body) }
 294     go body                 = ([], body)
 295
 296 lvlExpr ctxt_lvl env (_, AnnLet bind body)
 297   = lvlBind ctxt_lvl env bind           `thenLvl` \ (binds', new_env) ->
 298     lvlExpr ctxt_lvl new_env body       `thenLvl` \ body' ->
 299     returnLvl (mkLets binds' body')
 300
 301 lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
 302   = lvlMFE ctxt_lvl env expr    `thenLvl` \ expr' ->
 303     mapLvl lvl_alt alts         `thenLvl` \ alts' ->
 304     returnLvl (Case expr' (case_bndr, incd_lvl) alts')
 305   where
 306       expr_type = coreExprType (deAnnotate expr)
 307       incd_lvl  = incMinorLvl ctxt_lvl
 308       alts_env  = extendVarEnv env case_bndr incd_lvl
 309
 310       lvl_alt (con, bs, rhs)
 311         = let
 312                 bs'  = [ (b, incd_lvl) | b <- bs ]
 313                 new_env = extendVarEnvList alts_env bs'
 314           in
 315           lvlMFE incd_lvl new_env rhs   `thenLvl` \ rhs' ->
 316           returnLvl (con, bs', rhs')
 317 \end{code}
 318
 319 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 320 the expression, so that it can itself be floated.
 321
 322 \begin{code}
 323 lvlMFE ::  Level                -- Level of innermost enclosing lambda/tylam
 324         -> LevelEnv             -- Level of in-scope names/tyvars
 325         -> CoreExprWithFVs      -- input expression
 326         -> LvlM LevelledExpr    -- Result expression
 327
 328 lvlMFE ctxt_lvl env (_, AnnType ty)
 329   = returnLvl (Type ty)
 330
 331 lvlMFE ctxt_lvl env ann_expr
 332   | isUnLiftedType ty           -- Can't let-bind it
 333   = lvlExpr ctxt_lvl env ann_expr
 334
 335   | otherwise           -- Not primitive type so could be let-bound
 336   = setFloatLevel Nothing {- Not already let-bound -}
 337         ctxt_lvl env ann_expr ty        `thenLvl` \ (final_lvl, expr') ->
 338     returnLvl expr'
 339   where
 340     ty = coreExprType (deAnnotate ann_expr)
 341 \end{code}
 342
 343
 344 %************************************************************************
 345 %*                                                                      *
 346 \subsection{Deciding floatability}
 347 %*                                                                      *
 348 %************************************************************************
 349
 350 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
 351 are being created as let-bindings
 352
 353 Decision tree:
 354 Let Bound?
 355   YES. -> (a) try abstracting type variables.
 356        If we abstract type variables it will go further, that is, past more
 357        lambdas. same as asking if the level number given by the free
 358        variables is less than the level number given by free variables
 359        and type variables together.
 360        Abstract offending type variables, e.g.
 361        change f ty a b
 362        to let v = /\ty' -> f ty' a b
 363           in v ty
 364        so that v' is not stopped by the level number of ty
 365        tag the original let with its level number
 366        (from its variables and type variables)
 367   NO.  is a WHNF?
 368          YES. -> No point in let binding to float a WHNF.
 369                  Pin (leave) expression here.
 370          NO. -> Will float past a lambda?
 371                 (check using free variables only, not type variables)
 372                   YES. -> do the same as (a) above.
 373                   NO. -> No point in let binding if it is not going anywhere
 374                          Pin (leave) expression here.
 375
 376 \begin{code}
 377 setFloatLevel :: Maybe Id               -- Just id <=> the expression is already let-bound to id
 378                                         -- Nothing <=> it's a possible MFE
 379               -> Level                  -- of context
 380               -> LevelEnv
 381
 382               -> CoreExprWithFVs        -- Original rhs
 383               -> Type                   -- Type of rhs
 384
 385               -> LvlM (Level,           -- Level to attribute to this let-binding
 386                        LevelledExpr)    -- Final rhs
 387
 388 setFloatLevel maybe_let_bound ctxt_lvl env expr@(expr_fvs, _) ty
 389
 390 -- Now deal with (by not floating) trivial non-let-bound expressions
 391 -- which just aren't worth let-binding in order to float.  We always
 392 -- choose to float even trivial let-bound things because it doesn't do
 393 -- any harm, and not floating it may pin something important.  For
 394 -- example
 395 --
 396 --      x = let v = []
 397 --              w = 1:v
 398 --          in ...
 399 --
 400 -- Here, if we don't float v we won't float w, which is Bad News.
 401 -- If this gives any problems we could restrict the idea to things destined
 402 -- for top level.
 403
 404   | not alreadyLetBound
 405     && (expr_is_trivial || expr_is_bottom || not will_float_past_lambda)
 406   =   -- Pin trivial non-let-bound expressions,
 407       -- or ones which aren't going anywhere useful
 408     lvlExpr ctxt_lvl env expr           `thenLvl` \ expr' ->
 409     returnLvl (ctxt_lvl, expr')
 410
 411 {- SDM 7/98
 412 The above case used to read (whnf_or_bottom || not will_float_past_lambda).
 413 It was changed because we really do want to float out constructors if possible:
 414 this can save a great deal of needless allocation inside a loop.  On the other
 415 hand, there's no point floating out nullary constructors and literals, hence
 416 the expr_is_trivial condition.
 417 -}
 418
 419   | alreadyLetBound && not worth_type_abstraction
 420   =   -- Process the expression with a new ctxt_lvl, obtained from
 421       -- the free vars of the expression itself
 422     lvlExpr expr_lvl env expr           `thenLvl` \ expr' ->
 423     returnLvl (expr_lvl, expr')
 424
 425   | otherwise -- This will create a let anyway, even if there is no
 426               -- type variable to abstract, so we try to abstract anyway
 427   = abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr
 428                                               `thenLvl` \ final_expr ->
 429     returnLvl (expr_lvl, final_expr)
 430       -- OLD LIE: The body of the let, just a type application, isn't worth floating
 431       --          so pin it with ctxt_lvl
 432       -- The truth: better to give it expr_lvl in case it is pinning
 433       -- something non-trivial which depends on it.
 434   where
 435     alreadyLetBound = maybeToBool maybe_let_bound
 436
 437     fvs                = case maybe_let_bound of
 438                                 Nothing -> expr_fvs
 439                                 Just id -> expr_fvs `unionVarSet` idFreeVars id
 440
 441     ids_only_lvl       = foldVarSet (maxIdLvl    env) tOP_LEVEL fvs
 442     tyvars_only_lvl    = foldVarSet (maxTyVarLvl env) tOP_LEVEL fvs
 443     expr_lvl           = ids_only_lvl `maxLvl` tyvars_only_lvl
 444     lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
 445
 446         -- Will escape lambda if let-bound
 447     will_float_past_lambda = ids_only_lvl `ltMajLvl` ctxt_lvl
 448
 449          -- Will escape (more) lambda(s)/type lambda(s) if type abstracted
 450     worth_type_abstraction =  (ids_only_lvl `ltLvl` tyvars_only_lvl)
 451                            && not expr_is_trivial        -- Avoids abstracting trivial type applications
 452
 453     offending_tyvars = filter offending_tv (varSetElems fvs)
 454     offending_tv var | isId var  = False
 455                      | otherwise = ids_only_lvl `ltLvl` varLevel env var
 456
 457     expr_is_trivial = exprIsTrivial de_ann_expr
 458     expr_is_bottom  = exprIsBottom  de_ann_expr
 459     de_ann_expr     = deAnnotate expr
 460 \end{code}
 461
 462 Abstract wrt tyvars, by making it just as if we had seen
 463
 464      let v = /\a1..an. E
 465      in v a1 ... an
 466
 467 instead of simply E. The idea is that v can be freely floated, since it
 468 has no free type variables. Of course, if E has no free type
 469 variables, then we just return E.
 470
 471 \begin{code}
 472 abstractWrtTyVars offending_tyvars ty env lvl expr
 473   = lvlExpr incd_lvl new_env expr       `thenLvl` \ expr' ->
 474     newLvlVar poly_ty                   `thenLvl` \ poly_var ->
 475     let
 476        poly_var_rhs     = mkLams tyvar_lvls expr'
 477        poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
 478        poly_var_app     = mkTyApps (Var poly_var) (mkTyVarTys offending_tyvars)
 479        final_expr       = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
 480     in
 481     returnLvl final_expr
 482   where
 483     poly_ty = mkForAllTys offending_tyvars ty
 484
 485         -- These defns are just like those in the TyLam case of lvlExpr
 486     incd_lvl   = incMinorLvl lvl
 487     tyvar_lvls = [(tv,incd_lvl) | tv <- offending_tyvars]
 488     new_env    = extendVarEnvList env tyvar_lvls
 489 \end{code}
 490
 491 Recursive definitions.  We want to transform
 492
 493         letrec
 494            x1 = e1
 495            ...
 496            xn = en
 497         in
 498         body
 499
 500 to
 501
 502         letrec
 503            x1' = /\ ab -> let D' in e1
 504            ...
 505            xn' = /\ ab -> let D' in en
 506         in
 507         let D in body
 508
 509 where ab are the tyvars pinning the defn further in than it
 510 need be, and D  is a bunch of simple type applications:
 511
 512                 x1_cl = x1' ab
 513                 ...
 514                 xn_cl = xn' ab
 515
 516 The "_cl" indicates that in D, the level numbers on the xi are the context level
 517 number; type applications aren't worth floating.  The D' decls are
 518 similar:
 519
 520                 x1_ll = x1' ab
 521                 ...
 522                 xn_ll = xn' ab
 523
 524 but differ in their level numbers; here the ab are the newly-introduced
 525 type lambdas.
 526
 527 \begin{code}
 528 decideRecFloatLevel ctxt_lvl env ids rhss
 529   | ids_only_lvl `ltLvl` tyvars_only_lvl
 530   =     -- Abstract wrt tyvars;
 531         -- offending_tyvars is definitely non-empty
 532         -- (I love the ASSERT to check this...  WDP 95/02)
 533     let
 534        incd_lvl     = incMinorLvl ids_only_lvl
 535        tyvars_w_lvl = [(var,incd_lvl) | var <- offending_tyvars]
 536        ids_w_lvl    = [(var,incd_lvl) | var <- ids]
 537        new_env      = extendVarEnvList env (tyvars_w_lvl ++ ids_w_lvl)
 538     in
 539     mapLvl (lvlExpr incd_lvl new_env) rhss      `thenLvl` \ rhss' ->
 540     mapLvl newLvlVar poly_tys                   `thenLvl` \ poly_vars ->
 541     let
 542         ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
 543
 544                 -- The "d_rhss" are the right-hand sides of "D" and "D'"
 545                 -- in the documentation above
 546         d_rhss = [ mkTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
 547
 548                 -- "local_binds" are "D'" in the documentation above
 549         local_binds = zipWithEqual "SetLevels" NonRec ids_w_lvl d_rhss
 550
 551         poly_var_rhss = [ mkLams tyvars_w_lvl (mkLets local_binds rhs')
 552                         | rhs' <- rhss'
 553                         ]
 554
 555         poly_binds  = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
 556                                             poly_var_rhss
 557
 558     in
 559     returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
 560         -- The new right-hand sides, just a type application, aren't worth floating
 561         -- so pin it with ctxt_lvl
 562
 563   | otherwise
 564   =     -- Let it float freely
 565     let
 566         ids_w_lvls = ids `zip` repeat expr_lvl
 567         new_env   = extendVarEnvList env ids_w_lvls
 568     in
 569     mapLvl (lvlExpr expr_lvl new_env) rhss      `thenLvl` \ rhss' ->
 570     returnLvl (expr_lvl, [], rhss')
 571
 572   where
 573         -- Finding the free vars of the binding group is annoying
 574     bind_fvs        = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars ids))
 575                       `minusVarSet`
 576                       mkVarSet ids
 577
 578     ids_only_lvl    = foldVarSet (maxIdLvl    env) tOP_LEVEL bind_fvs
 579     tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL bind_fvs
 580     expr_lvl        = ids_only_lvl `maxLvl` tyvars_only_lvl
 581
 582     offending_tyvars = filter offending_tv (varSetElems bind_fvs)
 583     offending_tv var | isId var  = False
 584                      | otherwise = ids_only_lvl `ltLvl` varLevel env var
 585     offending_tyvar_tys = mkTyVarTys offending_tyvars
 586
 587     tys                 = map idType ids
 588     poly_tys            = map (mkForAllTys offending_tyvars) tys
 589 \end{code}
 590
 591 %************************************************************************
 592 %*                                                                      *
 593 \subsection{Free-To-Level Monad}
 594 %*                                                                      *
 595 %************************************************************************
 596
 597 \begin{code}
 598 type LvlM result = UniqSM result
 599
 600 initLvl         = initUs_
 601 thenLvl         = thenUs
 602 returnLvl       = returnUs
 603 mapLvl          = mapUs
 604 mapAndUnzipLvl  = mapAndUnzipUs
 605 mapAndUnzip3Lvl = mapAndUnzip3Us
 606 \end{code}
 607
 608 We create a let-binding for `interesting' (non-utterly-trivial)
 609 applications, to give them a fighting chance of being floated.
 610
 611 \begin{code}
 612 newLvlVar :: Type -> LvlM Id
 613 newLvlVar ty = getUniqueUs      `thenLvl` \ uniq ->
 614                returnUs (mkSysLocal SLIT("lvl") uniq ty)
 615 \end{code}