ghc/compiler/simplCore/SetLevels.lhs

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