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