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