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 * In the expression
  26         case x of wild { p -> ...wild... }
  27   we substitute x for wild in the RHS of the case alternatives:
  28         case x of wild { p -> ...x... }
  29   This means that a sub-expression involving x is not "trapped" inside the RHS.
  30   And it's not inconvenient because we already have a substitution.
  31
  32 \begin{code}
  33 module SetLevels (
  34         setLevels,
  35
  36         Level(..), tOP_LEVEL,
  37
  38         incMinorLvl, ltMajLvl, ltLvl, isTopLvl
  39     ) where
  40
  41 #include "HsVersions.h"
  42
  43 import CoreSyn
  44
  45 import CoreUtils        ( coreExprType, exprIsTrivial, exprIsBottom )
  46 import CoreFVs          -- all of it
  47 import Id               ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo,
  48                           getIdSpecialisation, getIdWorkerInfo
  49                         )
  50 import IdInfo           ( workerExists )
  51 import Var              ( IdOrTyVar, Var, TyVar, setVarUnique )
  52 import VarEnv
  53 import Subst
  54 import VarSet
  55 import Name             ( getOccName )
  56 import OccName          ( occNameUserString )
  57 import Type             ( isUnLiftedType, mkTyVarTy, mkForAllTys, Type )
  58 import BasicTypes       ( TopLevelFlag(..) )
  59 import VarSet
  60 import VarEnv
  61 import UniqSupply
  62 import Maybes           ( maybeToBool )
  63 import Util             ( zipWithEqual, zipEqual )
  64 import Outputable
  65 import List             ( nub )
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection{Level numbers}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 data Level = Level Int  -- Level number of enclosing lambdas
  76                    Int  -- Number of big-lambda and/or case expressions between
  77                         -- here and the nearest enclosing lambda
  78 \end{code}
  79
  80 The {\em level number} on a (type-)lambda-bound variable is the
  81 nesting depth of the (type-)lambda which binds it.  The outermost lambda
  82 has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
  83
  84 On an expression, it's the maximum level number of its free
  85 (type-)variables.  On a let(rec)-bound variable, it's the level of its
  86 RHS.  On a case-bound variable, it's the number of enclosing lambdas.
  87
  88 Top-level variables: level~0.  Those bound on the RHS of a top-level
  89 definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
  90 as ``subscripts'')...
  91 \begin{verbatim}
  92 a_0 = let  b_? = ...  in
  93            x_1 = ... b ... in ...
  94 \end{verbatim}
  95
  96 The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
  97 That's meant to be the level number of the enclosing binder in the
  98 final (floated) program.  If the level number of a sub-expression is
  99 less than that of the context, then it might be worth let-binding the
 100 sub-expression so that it will indeed float. This context level starts
 101 at @Level 0 0@.
 102
 103 \begin{code}
 104 type LevelledExpr  = TaggedExpr Level
 105 type LevelledArg   = TaggedArg  Level
 106 type LevelledBind  = TaggedBind Level
 107
 108 tOP_LEVEL = Level 0 0
 109
 110 incMajorLvl :: Level -> Level
 111 incMajorLvl (Level major minor) = Level (major+1) 0
 112
 113 incMinorLvl :: Level -> Level
 114 incMinorLvl (Level major minor) = Level major (minor+1)
 115
 116 maxLvl :: Level -> Level -> Level
 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 (Level maj1 min1) (Level maj2 min2)
 123   = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
 124
 125 ltMajLvl :: Level -> Level -> Bool
 126     -- Tells if one level belongs to a difft *lambda* level to another
 127 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
 128
 129 isTopLvl :: Level -> Bool
 130 isTopLvl (Level 0 0) = True
 131 isTopLvl other       = False
 132
 133 instance Outputable Level where
 134   ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
 135 \end{code}
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection{Main level-setting code}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 \begin{code}
 144 setLevels :: [CoreBind]
 145           -> UniqSupply
 146           -> [LevelledBind]
 147
 148 setLevels binds us
 149   = initLvl us (do_them binds)
 150   where
 151     -- "do_them"'s main business is to thread the monad along
 152     -- It gives each top binding the same empty envt, because
 153     -- things unbound in the envt have level number zero implicitly
 154     do_them :: [CoreBind] -> LvlM [LevelledBind]
 155
 156     do_them [] = returnLvl []
 157     do_them (b:bs)
 158       = lvlTopBind b    `thenLvl` \ (lvld_bind, _) ->
 159         do_them bs      `thenLvl` \ lvld_binds ->
 160         returnLvl (lvld_bind : lvld_binds)
 161
 162 lvlTopBind (NonRec binder rhs)
 163   = lvlBind TopLevel tOP_LEVEL initialEnv (AnnNonRec binder (freeVars rhs))
 164                                         -- Rhs can have no free vars!
 165
 166 lvlTopBind (Rec pairs)
 167   = lvlBind TopLevel tOP_LEVEL initialEnv (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs])
 168 \end{code}
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Setting expression levels}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 lvlExpr :: Level                -- ctxt_lvl: Level of enclosing expression
 178         -> LevelEnv             -- Level of in-scope names/tyvars
 179         -> CoreExprWithFVs      -- input expression
 180         -> LvlM LevelledExpr    -- Result expression
 181 \end{code}
 182
 183 The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
 184 binder.  Here's an example
 185
 186         v = \x -> ...\y -> let r = case (..x..) of
 187                                         ..x..
 188                            in ..
 189
 190 When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
 191 the level of @r@, even though it's inside a level-2 @\y@.  It's
 192 important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
 193 don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
 194 --- because it isn't a *maximal* free expression.
 195
 196 If there were another lambda in @r@'s rhs, it would get level-2 as well.
 197
 198 \begin{code}
 199 lvlExpr _ _ (_, AnnType ty) = returnLvl (Type ty)
 200 lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)
 201
 202 lvlExpr ctxt_lvl env (_, AnnCon con args)
 203   = mapLvl (lvlExpr ctxt_lvl env) args  `thenLvl` \ args' ->
 204     returnLvl (Con con args')
 205
 206 lvlExpr ctxt_lvl env (_, AnnApp fun arg)
 207   = lvlExpr ctxt_lvl env fun            `thenLvl` \ fun' ->
 208     lvlMFE  False ctxt_lvl env arg      `thenLvl` \ arg' ->
 209     returnLvl (App fun' arg')
 210
 211 lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr)
 212         -- Don't float anything out of an InlineMe
 213   = lvlExpr tOP_LEVEL env expr          `thenLvl` \ expr' ->
 214     returnLvl (Note InlineMe expr')
 215
 216 lvlExpr ctxt_lvl env (_, AnnNote note expr)
 217   = lvlExpr ctxt_lvl env expr           `thenLvl` \ expr' ->
 218     returnLvl (Note note expr')
 219
 220 -- We don't split adjacent lambdas.  That is, given
 221 --      \x y -> (x+1,y)
 222 -- we don't float to give
 223 --      \x -> let v = x+y in \y -> (v,y)
 224 -- Why not?  Because partial applications are fairly rare, and splitting
 225 -- lambdas makes them more expensive.
 226
 227 lvlExpr ctxt_lvl env expr@(_, AnnLam bndr rhs)
 228   = go (incMinorLvl ctxt_lvl) env False {- Havn't bumped major level in this group -} expr
 229   where
 230     go lvl env bumped_major (_, AnnLam bndr body)
 231       = go new_lvl new_env new_bumped_major body        `thenLvl` \ new_body ->
 232         returnLvl (Lam lvld_bndr new_body)
 233       where
 234         -- Go to the next major level if this is a value binder,
 235         -- and we havn't already gone to the next level (one jump per group)
 236         -- and it isn't a one-shot lambda
 237         (new_lvl, new_bumped_major)
 238           | isId bndr &&
 239             not bumped_major &&
 240             not (isOneShotLambda bndr) = (incMajorLvl ctxt_lvl, True)
 241           | otherwise                  = (lvl,                 bumped_major)
 242         new_env   = extendLvlEnv env [lvld_bndr]
 243         lvld_bndr = (bndr, new_lvl)
 244
 245         -- Ignore notes, because we don't want to split
 246         -- a lambda like this (\x -> coerce t (\s -> ...))
 247         -- This happens quite a bit in state-transformer programs
 248     go lvl env bumped_major (_, AnnNote note body)
 249       = go lvl env bumped_major body                    `thenLvl` \ new_body ->
 250         returnLvl (Note note new_body)
 251
 252     go lvl env bumped_major body
 253       = lvlMFE True lvl env body
 254
 255
 256 lvlExpr ctxt_lvl env (_, AnnLet bind body)
 257   = lvlBind NotTopLevel ctxt_lvl env bind       `thenLvl` \ (bind', new_env) ->
 258     lvlExpr ctxt_lvl new_env body               `thenLvl` \ body' ->
 259     returnLvl (Let bind' body')
 260
 261 lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
 262   = lvlMFE True ctxt_lvl env expr       `thenLvl` \ expr' ->
 263     let
 264         alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl
 265     in
 266     mapLvl (lvl_alt alts_env) alts      `thenLvl` \ alts' ->
 267     returnLvl (Case expr' (case_bndr, incd_lvl) alts')
 268   where
 269       expr_type = coreExprType (deAnnotate expr)
 270       incd_lvl  = incMinorLvl ctxt_lvl
 271
 272       lvl_alt alts_env (con, bs, rhs)
 273         = lvlMFE True incd_lvl new_env rhs      `thenLvl` \ rhs' ->
 274           returnLvl (con, bs', rhs')
 275         where
 276           bs'     = [ (b, incd_lvl) | b <- bs ]
 277           new_env = extendLvlEnv alts_env bs'
 278 \end{code}
 279
 280 @lvlMFE@ is just like @lvlExpr@, except that it might let-bind
 281 the expression, so that it can itself be floated.
 282
 283 \begin{code}
 284 lvlMFE ::  Bool                 -- True <=> strict context [body of case or let]
 285         -> Level                -- Level of innermost enclosing lambda/tylam
 286         -> LevelEnv             -- Level of in-scope names/tyvars
 287         -> CoreExprWithFVs      -- input expression
 288         -> LvlM LevelledExpr    -- Result expression
 289
 290 lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
 291   = returnLvl (Type ty)
 292
 293 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
 294   |  isUnLiftedType ty                          -- Can't let-bind it
 295   || not (dest_lvl `ltMajLvl` ctxt_lvl)         -- Does not escape a value lambda
 296         -- A decision to float entails let-binding this thing, and we only do
 297         -- that if we'll escape a value lambda.  I considered doing it if it
 298         -- would make the thing go to top level, but I found things like
 299         --      concat = /\ a -> foldr ..a.. (++) []
 300         -- was getting turned into
 301         --      concat = /\ a -> lvl a
 302         --      lvl    = /\ a -> foldr ..a.. (++) []
 303         -- which is pretty stupid.  So for now at least, I don't let-bind things
 304         -- simply because they could go to top level.
 305   || exprIsTrivial expr                         -- Is trivial
 306   || (strict_ctxt && exprIsBottom expr)         -- Strict context and is bottom
 307   =     -- Don't float it out
 308     lvlExpr ctxt_lvl env ann_expr
 309
 310   | otherwise   -- Float it out!
 311   = lvlExpr expr_lvl expr_env ann_expr          `thenLvl` \ expr' ->
 312     newLvlVar "lvl" (mkForAllTys tyvars ty)     `thenLvl` \ var ->
 313     returnLvl (Let (NonRec (var,dest_lvl) (mkLams tyvars_w_lvls expr'))
 314                    (mkTyVarApps var tyvars))
 315   where
 316     expr     = deAnnotate ann_expr
 317     ty       = coreExprType expr
 318     dest_lvl = destLevel env fvs
 319     (tyvars, tyvars_w_lvls, expr_lvl) = abstractTyVars dest_lvl env fvs
 320     expr_env = extendLvlEnv env tyvars_w_lvls
 321 \end{code}
 322
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsection{Bindings}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 The binding stuff works for top level too.
 331
 332 \begin{code}
 333 lvlBind :: TopLevelFlag         -- Used solely to decide whether to clone
 334         -> Level                -- Context level; might be Top even for bindings nested in the RHS
 335                                 -- of a top level binding
 336         -> LevelEnv
 337         -> CoreBindWithFVs
 338         -> LvlM (LevelledBind, LevelEnv)
 339
 340 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
 341   | null tyvars
 342   =     -- No type abstraction; clone existing binder
 343     lvlExpr rhs_lvl rhs_env rhs                 `thenLvl` \ rhs' ->
 344     cloneVar top_lvl env bndr dest_lvl          `thenLvl` \ (env', bndr') ->
 345     returnLvl (NonRec (bndr', dest_lvl) rhs', env')
 346
 347   | otherwise
 348   = -- Yes, type abstraction; create a new binder, extend substitution, etc
 349     WARN( workerExists (getIdWorkerInfo bndr)
 350           || not (isEmptyCoreRules (getIdSpecialisation bndr)),
 351           text "lvlBind: discarding info on" <+> ppr bndr )
 352
 353     lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env rhs      `thenLvl` \ rhs' ->
 354     new_poly_bndr tyvars bndr                           `thenLvl` \ bndr' ->
 355     let
 356         env' = extendPolyLvlEnv env dest_lvl tyvars [(bndr, bndr')]
 357     in
 358     returnLvl (NonRec (bndr', dest_lvl) rhs', env')
 359
 360   where
 361     bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr
 362
 363     dest_lvl | isUnLiftedType (idType bndr) = destLevel env bind_fvs `maxLvl` Level 1 0
 364              | otherwise                    = destLevel env bind_fvs
 365         -- Hack alert!  We do have some unlifted bindings, for cheap primops, and
 366         -- it is ok to float them out; but not to the top level.  If they would otherwise
 367         -- go to the top level, we pin them inside the topmost lambda
 368
 369     (tyvars, tyvars_w_lvls, rhs_lvl) = abstractTyVars dest_lvl env bind_fvs
 370     rhs_env = extendLvlEnv env tyvars_w_lvls
 371 \end{code}
 372
 373
 374 \begin{code}
 375 lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
 376   | null tyvars
 377   = cloneVars top_lvl env bndrs dest_lvl        `thenLvl` \ (new_env, new_bndrs) ->
 378     mapLvl (lvlExpr rhs_lvl new_env) rhss       `thenLvl` \ new_rhss ->
 379     returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
 380
 381   | otherwise
 382   = mapLvl (new_poly_bndr tyvars) bndrs         `thenLvl` \ new_bndrs ->
 383     let
 384         new_env = extendPolyLvlEnv env dest_lvl tyvars (bndrs `zip` new_bndrs)
 385         rhs_env = extendLvlEnv new_env tyvars_w_lvls
 386    in
 387     mapLvl (lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env) rhss    `thenLvl` \ new_rhss ->
 388     returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
 389
 390   where
 391     (bndrs,rhss) = unzip pairs
 392
 393         -- Finding the free vars of the binding group is annoying
 394     bind_fvs        = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs
 395                                     | (bndr, (rhs_fvs,_)) <- pairs])
 396                       `minusVarSet`
 397                       mkVarSet bndrs
 398
 399     dest_lvl        = destLevel env bind_fvs
 400
 401     (tyvars, tyvars_w_lvls, rhs_lvl) = abstractTyVars dest_lvl env bind_fvs
 402
 403 ----------------------------------------------------
 404 -- Three help functons Stuff for the type-abstraction case
 405
 406 new_poly_bndr tyvars bndr
 407   = newLvlVar ("poly_" ++ occNameUserString (getOccName bndr))
 408               (mkForAllTys tyvars (idType bndr))
 409
 410 lvl_poly_rhs tyvars_w_lvls rhs_lvl rhs_env rhs
 411  = lvlExpr rhs_lvl rhs_env rhs  `thenLvl` \ rhs' ->
 412    returnLvl (mkLams tyvars_w_lvls rhs')
 413 \end{code}
 414
 415
 416 %************************************************************************
 417 %*                                                                      *
 418 \subsection{Deciding floatability}
 419 %*                                                                      *
 420 %************************************************************************
 421
 422 \begin{code}
 423 abstractTyVars :: Level -> LevelEnv -> VarSet
 424                -> ([TyVar], [(TyVar,Level)], Level)
 425         -- Find the tyvars whose level is higher than the supplied level
 426         -- There should be no Ids with this property
 427 abstractTyVars lvl env fvs
 428   | null tyvars = ([], [], lvl)         -- Don't increment level
 429
 430   | otherwise
 431   = ASSERT( not (any bad fv_list) )
 432     (tyvars, tyvars_w_lvls, incd_lvl)
 433   where
 434     bad v   = isId v && lvl `ltLvl` varLevel env v
 435     fv_list = varSetElems fvs
 436     tyvars  = nub [tv | v <- fv_list, tv <- tvs_of v, abstract_tv tv]
 437
 438         -- If f is free in the exression, and f maps to poly_f a b c in the
 439         -- current substitution, then we must report a b c as candidate type
 440         -- variables
 441     tvs_of v | isId v    = lookupTyVars env v
 442              | otherwise = [v]
 443
 444     abstract_tv var | isId var  = False
 445                     | otherwise = lvl `ltLvl` varLevel env var
 446
 447         -- These defns are just like those in the TyLam case of lvlExpr
 448     incd_lvl      = incMinorLvl lvl
 449     tyvars_w_lvls = [(tv,incd_lvl) | tv <- tyvars]
 450
 451
 452   -- Destintion level is the max Id level of the expression
 453   -- (We'll abstract the type variables, if any.)
 454 destLevel :: LevelEnv -> VarSet -> Level
 455 destLevel env fvs = foldVarSet (maxIdLvl env) tOP_LEVEL fvs
 456
 457 maxIdLvl :: LevelEnv -> IdOrTyVar -> Level -> Level
 458 maxIdLvl (lvl_env,_,_) var lvl | isTyVar var = lvl
 459                                | otherwise   = case lookupVarEnv lvl_env var of
 460                                                   Just lvl' -> maxLvl lvl' lvl
 461                                                   Nothing   -> lvl
 462 \end{code}
 463
 464
 465 %************************************************************************
 466 %*                                                                      *
 467 \subsection{Free-To-Level Monad}
 468 %*                                                                      *
 469 %************************************************************************
 470
 471 \begin{code}
 472 type LevelEnv = (VarEnv Level, SubstEnv, IdEnv ([TyVar], LevelledExpr))
 473         -- We clone let-bound variables so that they are still
 474         -- distinct when floated out; hence the SubstEnv/IdEnv.
 475         -- We also use these envs when making a variable polymorphic
 476         -- because we want to float it out past a big lambda.
 477         --
 478         -- The two Envs always implement the same mapping, but the
 479         -- SubstEnv maps to CoreExpr and the IdEnv to LevelledExpr
 480         -- Since the range is always a variable or type application,
 481         -- there is never any difference between the two, but sadly
 482         -- the types differ.  The SubstEnv is used when substituting in
 483         -- a variable's IdInfo; the IdEnv when we find a Var.
 484         --
 485         -- In addition the IdEnv records a list of tyvars free in the
 486         -- type application, just so we don't have to call freeVars on
 487         -- the type application repeatedly.
 488         --
 489         -- The domain of the both envs is *pre-cloned* Ids, though
 490
 491 initialEnv :: LevelEnv
 492 initialEnv = (emptyVarEnv, emptySubstEnv, emptyVarEnv)
 493
 494 extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
 495         -- Used when *not* cloning
 496 extendLvlEnv (lvl_env, subst_env, id_env) prs
 497   = (foldl add lvl_env prs, subst_env, id_env)
 498   where
 499     add env (v,l) = extendVarEnv env v l
 500
 501 -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can
 502 extendCaseBndrLvlEnv (lvl_env, subst_env, id_env) scrut case_bndr lvl
 503   = case scrut of
 504         Var v -> (new_lvl_env, extendSubstEnv subst_env case_bndr (DoneEx (Var v)),
 505                                extendVarEnv   id_env    case_bndr ([], scrut))
 506         other -> (new_lvl_env, subst_env, id_env)
 507   where
 508     new_lvl_env = extendVarEnv lvl_env case_bndr lvl
 509
 510 extendPolyLvlEnv (lvl_env, subst_env, id_env) dest_lvl tyvars bndr_pairs
 511   = (foldl add_lvl lvl_env bndr_pairs,
 512      foldl add_subst subst_env bndr_pairs,
 513      foldl add_id    id_env    bndr_pairs)
 514   where
 515      add_lvl   env (v,_ ) = extendVarEnv   env v dest_lvl
 516      add_subst env (v,v') = extendSubstEnv env v (DoneEx (mkTyVarApps v' tyvars))
 517      add_id    env (v,v') = extendVarEnv   env v (tyvars, mkTyVarApps v' tyvars)
 518
 519 varLevel :: LevelEnv -> IdOrTyVar -> Level
 520 varLevel (lvl_env, _, _) v
 521   = case lookupVarEnv lvl_env v of
 522       Just level -> level
 523       Nothing    -> tOP_LEVEL
 524
 525 lookupVar :: LevelEnv -> Id -> LevelledExpr
 526 lookupVar (_, _, id_env) v = case lookupVarEnv id_env v of
 527                                Just (_, expr) -> expr
 528                                other          -> Var v
 529
 530 lookupTyVars :: LevelEnv -> Id -> [TyVar]
 531 lookupTyVars (_, _, id_env) v = case lookupVarEnv id_env v of
 532                                   Just (tyvars, _) -> tyvars
 533                                   Nothing          -> []
 534 \end{code}
 535
 536 \begin{code}
 537 type LvlM result = UniqSM result
 538
 539 initLvl         = initUs_
 540 thenLvl         = thenUs
 541 returnLvl       = returnUs
 542 mapLvl          = mapUs
 543 \end{code}
 544
 545 \begin{code}
 546 newLvlVar :: String -> Type -> LvlM Id
 547 newLvlVar str ty = getUniqueUs  `thenLvl` \ uniq ->
 548                    returnUs (mkSysLocal (_PK_ str) uniq ty)
 549
 550 -- The deeply tiresome thing is that we have to apply the substitution
 551 -- to the rules inside each Id.  Grr.  But it matters.
 552
 553 cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id)
 554 cloneVar TopLevel env v lvl
 555   = returnUs (env, v)   -- Don't clone top level things
 556 cloneVar NotTopLevel (lvl_env, subst_env, id_env) v lvl
 557   = getUniqueUs `thenLvl` \ uniq ->
 558     let
 559       subst      = mkSubst emptyVarSet subst_env
 560       v'         = setVarUnique v uniq
 561       v''        = modifyIdInfo (\info -> substIdInfo subst info info) v'
 562       subst_env' = extendSubstEnv subst_env v (DoneEx (Var v''))
 563       id_env'    = extendVarEnv   id_env v ([], Var v'')
 564       lvl_env'   = extendVarEnv   lvl_env v lvl
 565     in
 566     returnUs ((lvl_env', subst_env', id_env'), v'')
 567
 568 cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id])
 569 cloneVars TopLevel env vs lvl
 570   = returnUs (env, vs)  -- Don't clone top level things
 571 cloneVars NotTopLevel (lvl_env, subst_env, id_env) vs lvl
 572   = getUniquesUs (length vs)    `thenLvl` \ uniqs ->
 573     let
 574       subst      = mkSubst emptyVarSet subst_env'
 575       vs'        = zipWith setVarUnique vs uniqs
 576       vs''       = map (modifyIdInfo (\info -> substIdInfo subst info info)) vs'
 577       subst_env' = extendSubstEnvList subst_env vs [DoneEx (Var v'') | v'' <- vs'']
 578       id_env'    = extendVarEnvList id_env (vs `zip` [([], Var v') | v' <- vs''])
 579       lvl_env'   = extendVarEnvList lvl_env (vs `zip` repeat lvl)
 580     in
 581     returnUs ((lvl_env', subst_env', id_env'), vs'')
 582
 583 mkTyVarApps var tyvars = foldl (\e tv -> App e (Type (mkTyVarTy tv)))
 584                                (Var var) tyvars
 585 \end{code}