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