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, isOneShotLambda )
  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 && not (all isOneShotLambda bndrs) = incMajorLvl ctxt_lvl
 305                | otherwise                                     = incMinorLvl ctxt_lvl
 306         -- Only bump the major level number if the binders include
 307         -- at least one more-than-one-shot lambda
 308
 309     lvld_bndrs = [(b,incd_lvl) | b <- (bndr:bndrs)]
 310     new_env    = extendLvlEnv env lvld_bndrs
 311
 312     go (_, AnnLam bndr rhs) |  bndr_is_id && isId bndr
 313                             || bndr_is_tyvar && isTyVar bndr
 314                             =  case go rhs of { (bndrs, body) -> (bndr:bndrs, body) }
 315     go body                 = ([], body)
 316
 317 lvlExpr ctxt_lvl env (_, AnnLet bind body)
 318   = lvlBind ctxt_lvl env bind           `thenLvl` \ (binds', new_env) ->
 319     lvlExpr ctxt_lvl new_env body       `thenLvl` \ body' ->
 320     returnLvl (mkLets binds' body')
 321
 322 lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
 323   = lvlMFE ctxt_lvl env expr    `thenLvl` \ expr' ->
 324     mapLvl lvl_alt alts         `thenLvl` \ alts' ->
 325     returnLvl (Case expr' (case_bndr, incd_lvl) alts')
 326   where
 327       expr_type = coreExprType (deAnnotate expr)
 328       incd_lvl  = incMinorLvl ctxt_lvl
 329       alts_env  = extendVarEnv env case_bndr (case_bndr,incd_lvl)
 330
 331       lvl_alt (con, bs, rhs)
 332         = let
 333                 bs'  = [ (b, incd_lvl) | b <- bs ]
 334                 new_env = extendLvlEnv alts_env bs'
 335           in
 336           lvlMFE incd_lvl new_env rhs   `thenLvl` \ rhs' ->
 337           returnLvl (con, bs', rhs')
 338 \end{code}
 339
 340 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 341 the expression, so that it can itself be floated.
 342
 343 \begin{code}
 344 lvlMFE ::  Level                -- Level of innermost enclosing lambda/tylam
 345         -> LevelEnv             -- Level of in-scope names/tyvars
 346         -> CoreExprWithFVs      -- input expression
 347         -> LvlM LevelledExpr    -- Result expression
 348
 349 lvlMFE ctxt_lvl env (_, AnnType ty)
 350   = returnLvl (Type ty)
 351
 352 lvlMFE ctxt_lvl env ann_expr
 353   | isUnLiftedType ty           -- Can't let-bind it
 354   = lvlExpr ctxt_lvl env ann_expr
 355
 356   | otherwise           -- Not primitive type so could be let-bound
 357   = setFloatLevel Nothing {- Not already let-bound -}
 358         ctxt_lvl env ann_expr ty        `thenLvl` \ (final_lvl, expr') ->
 359     returnLvl expr'
 360   where
 361     ty = coreExprType (deAnnotate ann_expr)
 362 \end{code}
 363
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection{Deciding floatability}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 @setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which
 372 are being created as let-bindings
 373
 374 Decision tree:
 375 Let Bound?
 376   YES. -> (a) try abstracting type variables.
 377        If we abstract type variables it will go further, that is, past more
 378        lambdas. same as asking if the level number given by the free
 379        variables is less than the level number given by free variables
 380        and type variables together.
 381        Abstract offending type variables, e.g.
 382        change f ty a b
 383        to let v = /\ty' -> f ty' a b
 384           in v ty
 385        so that v' is not stopped by the level number of ty
 386        tag the original let with its level number
 387        (from its variables and type variables)
 388   NO.  is a WHNF?
 389          YES. -> No point in let binding to float a WHNF.
 390                  Pin (leave) expression here.
 391          NO. -> Will float past a lambda?
 392                 (check using free variables only, not type variables)
 393                   YES. -> do the same as (a) above.
 394                   NO. -> No point in let binding if it is not going anywhere
 395                          Pin (leave) expression here.
 396
 397 \begin{code}
 398 setFloatLevel :: Maybe Id               -- Just id <=> the expression is already let-bound to id
 399                                         -- Nothing <=> it's a possible MFE
 400               -> Level                  -- of context
 401               -> LevelEnv
 402
 403               -> CoreExprWithFVs        -- Original rhs
 404               -> Type                   -- Type of rhs
 405
 406               -> LvlM (Level,           -- Level to attribute to this let-binding
 407                        LevelledExpr)    -- Final rhs
 408
 409 setFloatLevel maybe_let_bound ctxt_lvl env expr@(expr_fvs, _) ty
 410
 411 -- Now deal with (by not floating) trivial non-let-bound expressions
 412 -- which just aren't worth let-binding in order to float.  We always
 413 -- choose to float even trivial let-bound things because it doesn't do
 414 -- any harm, and not floating it may pin something important.  For
 415 -- example
 416 --
 417 --      x = let v = []
 418 --              w = 1:v
 419 --          in ...
 420 --
 421 -- Here, if we don't float v we won't float w, which is Bad News.
 422 -- If this gives any problems we could restrict the idea to things destined
 423 -- for top level.
 424
 425   | not alreadyLetBound
 426     && (expr_is_trivial || expr_is_bottom || not will_float_past_lambda)
 427
 428   =   -- Pin trivial non-let-bound expressions,
 429       -- or ones which aren't going anywhere useful
 430     lvlExpr ctxt_lvl env expr           `thenLvl` \ expr' ->
 431     returnLvl (safe_ctxt_lvl, expr')
 432
 433 {- SDM 7/98
 434 The above case used to read (whnf_or_bottom || not will_float_past_lambda).
 435 It was changed because we really do want to float out constructors if possible:
 436 this can save a great deal of needless allocation inside a loop.  On the other
 437 hand, there's no point floating out nullary constructors and literals, hence
 438 the expr_is_trivial condition.
 439 -}
 440
 441   | alreadyLetBound && not worth_type_abstraction
 442   =   -- Process the expression with a new ctxt_lvl, obtained from
 443       -- the free vars of the expression itself
 444     lvlExpr expr_lvl env expr           `thenLvl` \ expr' ->
 445     returnLvl (safe_expr_lvl, expr')
 446
 447   | otherwise -- This will create a let anyway, even if there is no
 448               -- type variable to abstract, so we try to abstract anyway
 449   = abstractWrtTyVars offending_tyvars ty env lvl_after_ty_abstr expr
 450                                               `thenLvl` \ final_expr ->
 451     returnLvl (safe_expr_lvl, final_expr)
 452       -- OLD LIE: The body of the let, just a type application, isn't worth floating
 453       --          so pin it with ctxt_lvl
 454       -- The truth: better to give it expr_lvl in case it is pinning
 455       -- something non-trivial which depends on it.
 456   where
 457     alreadyLetBound = maybeToBool maybe_let_bound
 458
 459     safe_ctxt_lvl   = unTopify ty ctxt_lvl
 460     safe_expr_lvl   = unTopify ty expr_lvl
 461
 462     fvs                = case maybe_let_bound of
 463                                 Nothing -> expr_fvs
 464                                 Just id -> expr_fvs `unionVarSet` idFreeVars id
 465
 466     ids_only_lvl       = foldVarSet (maxIdLvl    env) tOP_LEVEL fvs
 467     tyvars_only_lvl    = foldVarSet (maxTyVarLvl env) tOP_LEVEL fvs
 468     expr_lvl           = ids_only_lvl `maxLvl` tyvars_only_lvl
 469     lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl
 470
 471         -- Will escape lambda if let-bound
 472     will_float_past_lambda = ids_only_lvl `ltMajLvl` ctxt_lvl
 473
 474          -- Will escape (more) lambda(s)/type lambda(s) if type abstracted
 475     worth_type_abstraction =  (ids_only_lvl `ltLvl` tyvars_only_lvl)
 476                            && not expr_is_trivial        -- Avoids abstracting trivial type applications
 477
 478     offending_tyvars = filter offending_tv (varSetElems fvs)
 479     offending_tv var | isId var  = False
 480                      | otherwise = ids_only_lvl `ltLvl` varLevel env var
 481
 482     expr_is_trivial = exprIsTrivial de_ann_expr
 483     expr_is_bottom  = exprIsBottom  de_ann_expr
 484     de_ann_expr     = deAnnotate expr
 485 \end{code}
 486
 487 Abstract wrt tyvars, by making it just as if we had seen
 488
 489      let v = /\a1..an. E
 490      in v a1 ... an
 491
 492 instead of simply E. The idea is that v can be freely floated, since it
 493 has no free type variables. Of course, if E has no free type
 494 variables, then we just return E.
 495
 496 \begin{code}
 497 abstractWrtTyVars offending_tyvars ty env lvl expr
 498   = lvlExpr incd_lvl new_env expr       `thenLvl` \ expr' ->
 499     newLvlVar poly_ty                   `thenLvl` \ poly_var ->
 500     let
 501        poly_var_rhs     = mkLams tyvar_lvls expr'
 502        poly_var_binding = NonRec (poly_var, lvl) poly_var_rhs
 503        poly_var_app     = mkTyApps (Var poly_var) (mkTyVarTys offending_tyvars)
 504        final_expr       = Let poly_var_binding poly_var_app -- mkCoLet* requires Core
 505     in
 506     returnLvl final_expr
 507   where
 508     poly_ty = mkForAllTys offending_tyvars ty
 509
 510         -- These defns are just like those in the TyLam case of lvlExpr
 511     incd_lvl   = incMinorLvl lvl
 512     tyvar_lvls = [(tv,incd_lvl) | tv <- offending_tyvars]
 513     new_env    = extendLvlEnv env tyvar_lvls
 514 \end{code}
 515
 516 Recursive definitions.  We want to transform
 517
 518         letrec
 519            x1 = e1
 520            ...
 521            xn = en
 522         in
 523         body
 524
 525 to
 526
 527         letrec
 528            x1' = /\ ab -> let D' in e1
 529            ...
 530            xn' = /\ ab -> let D' in en
 531         in
 532         let D in body
 533
 534 where ab are the tyvars pinning the defn further in than it
 535 need be, and D is a bunch of simple type applications:
 536
 537                 x1_cl = x1' ab
 538                 ...
 539                 xn_cl = xn' ab
 540
 541 The "_cl" indicates that in D, the level numbers on the xi are the context level
 542 number; type applications aren't worth floating.  The D' decls are
 543 similar:
 544
 545                 x1_ll = x1' ab
 546                 ...
 547                 xn_ll = xn' ab
 548
 549 but differ in their level numbers; here the ab are the newly-introduced
 550 type lambdas.
 551
 552 \begin{code}
 553 lvlRecBind ctxt_lvl env pairs
 554   | ids_only_lvl `ltLvl` tyvars_only_lvl
 555   =     -- Abstract wrt tyvars;
 556         -- offending_tyvars is definitely non-empty
 557         -- (I love the ASSERT to check this...  WDP 95/02)
 558     let
 559        incd_lvl         = incMinorLvl ids_only_lvl
 560        tyvars_w_rhs_lvl = [(var,incd_lvl) | var <- offending_tyvars]
 561        bndrs_w_rhs_lvl  = [(var,incd_lvl) | var <- bndrs]
 562        rhs_env          = extendLvlEnv env (tyvars_w_rhs_lvl ++ bndrs_w_rhs_lvl)
 563     in
 564     mapLvl (lvlExpr incd_lvl rhs_env) rhss      `thenLvl` \ rhss' ->
 565     mapLvl newLvlVar poly_tys                   `thenLvl` \ poly_vars ->
 566     mapLvl (cloneVar ctxt_lvl) bndrs            `thenLvl` \ new_bndrs ->
 567     let
 568                 -- The "d_rhss" are the right-hand sides of "D" and "D'"
 569                 -- in the documentation above
 570         d_rhss = [ mkTyApps (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
 571
 572                 -- "local_binds" are "D'" in the documentation above
 573         local_binds = zipWithEqual "SetLevels" NonRec bndrs_w_rhs_lvl d_rhss
 574
 575         poly_var_rhss = [ mkLams tyvars_w_rhs_lvl (mkLets local_binds rhs')
 576                         | rhs' <- rhss'
 577                         ]
 578
 579         poly_binds  = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars]
 580                                             poly_var_rhss
 581
 582                 -- The new right-hand sides, just a type application,
 583                 -- aren't worth floating so pin it with ctxt_lvl
 584         bndrs_w_lvl = new_bndrs `zip` repeat ctxt_lvl
 585         new_env     = extendVarEnvList env (bndrs `zip` bndrs_w_lvl)
 586
 587                 -- "d_binds" are the "D" in the documentation above
 588         d_binds = zipWithEqual "SetLevels" NonRec bndrs_w_lvl d_rhss
 589     in
 590     returnLvl (Rec poly_binds : d_binds, new_env)
 591
 592   | otherwise
 593   =     -- Let it float freely
 594     mapLvl (cloneVar ctxt_lvl) bndrs                    `thenLvl` \ new_bndrs ->
 595     let
 596         bndrs_w_lvls = new_bndrs `zip` repeat expr_lvl
 597         new_env      = extendVarEnvList env (bndrs `zip` bndrs_w_lvls)
 598     in
 599     mapLvl (lvlExpr expr_lvl new_env) rhss      `thenLvl` \ rhss' ->
 600     returnLvl ([Rec (bndrs_w_lvls `zip` rhss')], new_env)
 601
 602   where
 603     (bndrs,rhss) = unzip pairs
 604
 605         -- Finding the free vars of the binding group is annoying
 606     bind_fvs        = (unionVarSets (map fst rhss) `unionVarSet` unionVarSets (map idFreeVars bndrs))
 607                       `minusVarSet`
 608                       mkVarSet bndrs
 609
 610     ids_only_lvl    = foldVarSet (maxIdLvl    env) tOP_LEVEL bind_fvs
 611     tyvars_only_lvl = foldVarSet (maxTyVarLvl env) tOP_LEVEL bind_fvs
 612     expr_lvl        = ids_only_lvl `maxLvl` tyvars_only_lvl
 613
 614     offending_tyvars = filter offending_tv (varSetElems bind_fvs)
 615     offending_tv var | isId var  = False
 616                      | otherwise = ids_only_lvl `ltLvl` varLevel env var
 617     offending_tyvar_tys = mkTyVarTys offending_tyvars
 618
 619     tys      = map idType bndrs
 620     poly_tys = map (mkForAllTys offending_tyvars) tys
 621 \end{code}
 622
 623 %************************************************************************
 624 %*                                                                      *
 625 \subsection{Free-To-Level Monad}
 626 %*                                                                      *
 627 %************************************************************************
 628
 629 \begin{code}
 630 type LvlM result = UniqSM result
 631
 632 initLvl         = initUs_
 633 thenLvl         = thenUs
 634 returnLvl       = returnUs
 635 mapLvl          = mapUs
 636 \end{code}
 637
 638 \begin{code}
 639 newLvlVar :: Type -> LvlM Id
 640 newLvlVar ty = getUniqueUs      `thenLvl` \ uniq ->
 641                returnUs (mkSysLocal SLIT("lvl") uniq ty)
 642
 643 cloneVar :: Level -> Id -> LvlM Id
 644 cloneVar Top v = returnUs v     -- Don't clone top level things
 645 cloneVar _ v   = getUniqueUs    `thenLvl` \ uniq ->
 646                  returnUs (setVarUnique v uniq)
 647 \end{code}