compiler/simplCore/SimplEnv.lhs

   1 %
   2 o% (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[SimplMonad]{The simplifier Monad}
   5
   6 \begin{code}
   7 module SimplEnv (
   8         InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar,
   9         OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar,
  10         InCoercion, OutCoercion,
  11
  12         -- The simplifier mode
  13         setMode, getMode, updMode,
  14
  15         setEnclosingCC, getEnclosingCC,
  16
  17         -- Environments
  18         SimplEnv(..), StaticEnv, pprSimplEnv,   -- Temp not abstract
  19         mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
  20         zapSubstEnv, setSubstEnv,
  21         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
  22         getSimplRules,
  23
  24         SimplSR(..), mkContEx, substId, lookupRecBndr,
  25
  26         simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
  27         simplBinder, simplBinders, addBndrRules,
  28         substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst,
  29
  30         -- Floats
  31         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
  32         wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
  33         doFloatFromRhs, getFloats
  34     ) where
  35
  36 #include "HsVersions.h"
  37
  38 import SimplMonad
  39 import CoreMonad        ( SimplifierMode(..) )
  40 import IdInfo
  41 import CoreSyn
  42 import CoreUtils
  43 import CostCentre
  44 import Var
  45 import VarEnv
  46 import VarSet
  47 import OrdList
  48 import Id
  49 import MkCore
  50 import TysWiredIn
  51 import qualified CoreSubst
  52 import qualified Type           ( substTy, substTyVarBndr, substTyVar )
  53 import Type hiding              ( substTy, substTyVarBndr, substTyVar )
  54 import Coercion
  55 import BasicTypes
  56 import MonadUtils
  57 import Outputable
  58 import FastString
  59
  60 import Data.List
  61 \end{code}
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection[Simplify-types]{Type declarations}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 type InBndr     = CoreBndr
  71 type InVar      = Var                   -- Not yet cloned
  72 type InId       = Id                    -- Not yet cloned
  73 type InType     = Type                  -- Ditto
  74 type InBind     = CoreBind
  75 type InExpr     = CoreExpr
  76 type InAlt      = CoreAlt
  77 type InArg      = CoreArg
  78 type InCoercion = Coercion
  79
  80 type OutBndr     = CoreBndr
  81 type OutVar      = Var                  -- Cloned
  82 type OutId       = Id                   -- Cloned
  83 type OutTyVar    = TyVar                -- Cloned
  84 type OutType     = Type                 -- Cloned
  85 type OutCoercion = Coercion
  86 type OutBind     = CoreBind
  87 type OutExpr     = CoreExpr
  88 type OutAlt      = CoreAlt
  89 type OutArg      = CoreArg
  90 \end{code}
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsubsection{The @SimplEnv@ type}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98
  99 \begin{code}
 100 data SimplEnv
 101   = SimplEnv {
 102      ----------- Static part of the environment -----------
 103      -- Static in the sense of lexically scoped,
 104      -- wrt the original expression
 105
 106         seMode      :: SimplifierMode,
 107         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 108
 109         -- The current substitution
 110         seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
 111         seIdSubst   :: SimplIdSubst,    -- InId    |--> OutExpr
 112
 113      ----------- Dynamic part of the environment -----------
 114      -- Dynamic in the sense of describing the setup where
 115      -- the expression finally ends up
 116
 117         -- The current set of in-scope variables
 118         -- They are all OutVars, and all bound in this module
 119         seInScope   :: InScopeSet,      -- OutVars only
 120                 -- Includes all variables bound by seFloats
 121         seFloats    :: Floats
 122                 -- See Note [Simplifier floats]
 123     }
 124
 125 type StaticEnv = SimplEnv       -- Just the static part is relevant
 126
 127 pprSimplEnv :: SimplEnv -> SDoc
 128 -- Used for debugging; selective
 129 pprSimplEnv env
 130   = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
 131           ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
 132           ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars)
 133     ]
 134   where
 135    in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
 136    ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
 137              | otherwise = ppr v
 138
 139 type SimplIdSubst = IdEnv SimplSR       -- IdId |--> OutExpr
 140         -- See Note [Extending the Subst] in CoreSubst
 141
 142 data SimplSR
 143   = DoneEx OutExpr              -- Completed term
 144   | DoneId OutId                -- Completed term variable
 145   | ContEx TvSubstEnv           -- A suspended substitution
 146            SimplIdSubst
 147            InExpr
 148
 149 instance Outputable SimplSR where
 150   ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
 151   ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
 152   ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
 153                                 ppr (filter_env tv), ppr (filter_env id) -}]
 154         -- where
 155         -- fvs = exprFreeVars e
 156         -- filter_env env = filterVarEnv_Directly keep env
 157         -- keep uniq _ = uniq `elemUFM_Directly` fvs
 158 \end{code}
 159
 160 Note [SimplEnv invariants]
 161 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 162 seInScope:
 163         The in-scope part of Subst includes *all* in-scope TyVars and Ids
 164         The elements of the set may have better IdInfo than the
 165         occurrences of in-scope Ids, and (more important) they will
 166         have a correctly-substituted type.  So we use a lookup in this
 167         set to replace occurrences
 168
 169         The Ids in the InScopeSet are replete with their Rules,
 170         and as we gather info about the unfolding of an Id, we replace
 171         it in the in-scope set.
 172
 173         The in-scope set is actually a mapping OutVar -> OutVar, and
 174         in case expressions we sometimes bind
 175
 176 seIdSubst:
 177         The substitution is *apply-once* only, because InIds and OutIds can overlap.
 178         For example, we generally omit mappings
 179                 a77 -> a77
 180         from the substitution, when we decide not to clone a77, but it's quite
 181         legitimate to put the mapping in the substitution anyway.
 182
 183         Furthermore, consider
 184                 let x = case k of I# x77 -> ... in
 185                 let y = case k of I# x77 -> ... in ...
 186         and suppose the body is strict in both x and y.  Then the simplifier
 187         will pull the first (case k) to the top; so the second (case k) will
 188         cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
 189         other is an out-Id.
 190
 191         Of course, the substitution *must* applied! Things in its domain
 192         simply aren't necessarily bound in the result.
 193
 194 * substId adds a binding (DoneId new_id) to the substitution if
 195         the Id's unique has changed
 196
 197   Note, though that the substitution isn't necessarily extended
 198   if the type of the Id changes.  Why not?  Because of the next point:
 199
 200 * We *always, always* finish by looking up in the in-scope set
 201   any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
 202   Reason: so that we never finish up with a "old" Id in the result.
 203   An old Id might point to an old unfolding and so on... which gives a space leak.
 204
 205   [The DoneEx and DoneVar hits map to "new" stuff.]
 206
 207 * It follows that substExpr must not do a no-op if the substitution is empty.
 208   substType is free to do so, however.
 209
 210 * When we come to a let-binding (say) we generate new IdInfo, including an
 211   unfolding, attach it to the binder, and add this newly adorned binder to
 212   the in-scope set.  So all subsequent occurrences of the binder will get mapped
 213   to the full-adorned binder, which is also the one put in the binding site.
 214
 215 * The in-scope "set" usually maps x->x; we use it simply for its domain.
 216   But sometimes we have two in-scope Ids that are synomyms, and should
 217   map to the same target:  x->x, y->x.  Notably:
 218         case y of x { ... }
 219   That's why the "set" is actually a VarEnv Var
 220
 221
 222 \begin{code}
 223 mkSimplEnv :: SimplifierMode -> SimplEnv
 224 mkSimplEnv mode
 225   = SimplEnv { seCC = subsumedCCS
 226              , seMode = mode
 227              , seInScope = init_in_scope
 228              , seFloats = emptyFloats
 229              , seTvSubst = emptyVarEnv
 230              , seIdSubst = emptyVarEnv }
 231         -- The top level "enclosing CC" is "SUBSUMED".
 232
 233 init_in_scope :: InScopeSet
 234 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
 235               -- See Note [WildCard binders]
 236 \end{code}
 237
 238 Note [WildCard binders]
 239 ~~~~~~~~~~~~~~~~~~~~~~~
 240 The program to be simplified may have wild binders
 241     case e of wild { p -> ... }
 242 We want to *rename* them away, so that there are no
 243 occurrences of 'wild-id' (with wildCardKey).  The easy
 244 way to do that is to start of with a representative
 245 Id in the in-scope set
 246
 247 There can be be *occurrences* of wild-id.  For example,
 248 MkCore.mkCoreApp transforms
 249    e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }
 250 This is ok provided 'wild' isn't free in 'e', and that's the delicate
 251 thing. Generally, you want to run the simplifier to get rid of the
 252 wild-ids before doing much else.
 253
 254 It's a very dark corner of GHC.  Maybe it should be cleaned up.
 255
 256 \begin{code}
 257 getMode :: SimplEnv -> SimplifierMode
 258 getMode env = seMode env
 259
 260 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
 261 setMode mode env = env { seMode = mode }
 262
 263 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
 264 updMode upd env = env { seMode = upd (seMode env) }
 265
 266 ---------------------
 267 getEnclosingCC :: SimplEnv -> CostCentreStack
 268 getEnclosingCC env = seCC env
 269
 270 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
 271 setEnclosingCC env cc = env {seCC = cc}
 272
 273 ---------------------
 274 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
 275 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
 276   = env {seIdSubst = extendVarEnv subst var res}
 277
 278 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 279 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
 280   = env {seTvSubst = extendVarEnv subst var res}
 281
 282 ---------------------
 283 getInScope :: SimplEnv -> InScopeSet
 284 getInScope env = seInScope env
 285
 286 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 287 setInScopeSet env in_scope = env {seInScope = in_scope}
 288
 289 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
 290 -- Set the in-scope set, and *zap* the floats
 291 setInScope env env_with_scope
 292   = env { seInScope = seInScope env_with_scope,
 293           seFloats = emptyFloats }
 294
 295 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
 296 -- Set the in-scope set *and* the floats
 297 setFloats env env_with_floats
 298   = env { seInScope = seInScope env_with_floats,
 299           seFloats  = seFloats  env_with_floats }
 300
 301 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
 302         -- The new Ids are guaranteed to be freshly allocated
 303 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
 304   = env { seInScope = in_scope `extendInScopeSetList` vs,
 305           seIdSubst = id_subst `delVarEnvList` vs }
 306         -- Why delete?  Consider
 307         --      let x = a*b in (x, \x -> x+3)
 308         -- We add [x |-> a*b] to the substitution, but we must
 309         -- _delete_ it from the substitution when going inside
 310         -- the (\x -> ...)!
 311
 312 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
 313 -- The variable should already be in scope, but
 314 -- replace the existing version with this new one
 315 -- which has more information
 316 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
 317   = env {seInScope = extendInScopeSet in_scope v}
 318
 319 ---------------------
 320 zapSubstEnv :: SimplEnv -> SimplEnv
 321 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
 322
 323 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
 324 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
 325
 326 mkContEx :: SimplEnv -> InExpr -> SimplSR
 327 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
 328 \end{code}
 329
 330
 331
 332 %************************************************************************
 333 %*                                                                      *
 334 \subsection{Floats}
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 Note [Simplifier floats]
 339 ~~~~~~~~~~~~~~~~~~~~~~~~~
 340 The Floats is a bunch of bindings, classified by a FloatFlag.
 341
 342   NonRec x (y:ys)       FltLifted
 343   Rec [(x,rhs)]         FltLifted
 344
 345   NonRec x# (y +# 3)    FltOkSpec       -- Unboxed, but ok-for-spec'n
 346
 347   NonRec x# (a /# b)    FltCareful
 348   NonRec x* (f y)       FltCareful      -- Strict binding; might fail or diverge
 349   NonRec x# (f y)       FltCareful      -- Unboxed binding: might fail or diverge
 350                                         --        (where f :: Int -> Int#)
 351
 352 \begin{code}
 353 data Floats = Floats (OrdList OutBind) FloatFlag
 354         -- See Note [Simplifier floats]
 355
 356 data FloatFlag
 357   = FltLifted   -- All bindings are lifted and lazy
 358                 --  Hence ok to float to top level, or recursive
 359
 360   | FltOkSpec   -- All bindings are FltLifted *or*
 361                 --      strict (perhaps because unlifted,
 362                 --      perhaps because of a strict binder),
 363                 --        *and* ok-for-speculation
 364                 --  Hence ok to float out of the RHS
 365                 --  of a lazy non-recursive let binding
 366                 --  (but not to top level, or into a rec group)
 367
 368   | FltCareful  -- At least one binding is strict (or unlifted)
 369                 --      and not guaranteed cheap
 370                 --      Do not float these bindings out of a lazy let
 371
 372 instance Outputable Floats where
 373   ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
 374
 375 instance Outputable FloatFlag where
 376   ppr FltLifted = ptext (sLit "FltLifted")
 377   ppr FltOkSpec = ptext (sLit "FltOkSpec")
 378   ppr FltCareful = ptext (sLit "FltCareful")
 379
 380 andFF :: FloatFlag -> FloatFlag -> FloatFlag
 381 andFF FltCareful _          = FltCareful
 382 andFF FltOkSpec  FltCareful = FltCareful
 383 andFF FltOkSpec  _          = FltOkSpec
 384 andFF FltLifted  flt        = flt
 385
 386 classifyFF :: CoreBind -> FloatFlag
 387 classifyFF (Rec _) = FltLifted
 388 classifyFF (NonRec bndr rhs)
 389   | not (isStrictId bndr)    = FltLifted
 390   | exprOkForSpeculation rhs = FltOkSpec
 391   | otherwise                = FltCareful
 392
 393 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 394 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
 395   =  not (isNilOL fs) && want_to_float && can_float
 396   where
 397      want_to_float = isTopLevel lvl || exprIsExpandable rhs
 398      can_float = case ff of
 399                    FltLifted  -> True
 400                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
 401                    FltCareful -> isNotTopLevel lvl && isNonRec rec && str
 402 \end{code}
 403
 404
 405 \begin{code}
 406 emptyFloats :: Floats
 407 emptyFloats = Floats nilOL FltLifted
 408
 409 unitFloat :: OutBind -> Floats
 410 -- A single-binding float
 411 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
 412
 413 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 414 -- Add a non-recursive binding and extend the in-scope set
 415 -- The latter is important; the binder may already be in the
 416 -- in-scope set (although it might also have been created with newId)
 417 -- but it may now have more IdInfo
 418 addNonRec env id rhs
 419   = id `seq`   -- This seq forces the Id, and hence its IdInfo,
 420                -- and hence any inner substitutions
 421     env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
 422           seInScope = extendInScopeSet (seInScope env) id }
 423
 424 extendFloats :: SimplEnv -> OutBind -> SimplEnv
 425 -- Add these bindings to the floats, and extend the in-scope env too
 426 extendFloats env bind
 427   = env { seFloats  = seFloats env `addFlts` unitFloat bind,
 428           seInScope = extendInScopeSetList (seInScope env) bndrs }
 429   where
 430     bndrs = bindersOf bind
 431
 432 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
 433 -- Add the floats for env2 to env1;
 434 -- *plus* the in-scope set for env2, which is bigger
 435 -- than that for env1
 436 addFloats env1 env2
 437   = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
 438           seInScope = seInScope env2 }
 439
 440 addFlts :: Floats -> Floats -> Floats
 441 addFlts (Floats bs1 l1) (Floats bs2 l2)
 442   = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
 443
 444 zapFloats :: SimplEnv -> SimplEnv
 445 zapFloats env = env { seFloats = emptyFloats }
 446
 447 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
 448 -- Flattens the floats from env2 into a single Rec group,
 449 -- prepends the floats from env1, and puts the result back in env2
 450 -- This is all very specific to the way recursive bindings are
 451 -- handled; see Simplify.simplRecBind
 452 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
 453   = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
 454     env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
 455
 456 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
 457 wrapFloats env expr = wrapFlts (seFloats env) expr
 458
 459 wrapFlts :: Floats -> OutExpr -> OutExpr
 460 -- Wrap the floats around the expression, using case-binding where necessary
 461 wrapFlts (Floats bs _) body = foldrOL wrap body bs
 462   where
 463     wrap (Rec prs)    body = Let (Rec prs) body
 464     wrap (NonRec b r) body = bindNonRec b r body
 465
 466 getFloats :: SimplEnv -> [CoreBind]
 467 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
 468
 469 isEmptyFloats :: SimplEnv -> Bool
 470 isEmptyFloats env = isEmptyFlts (seFloats env)
 471
 472 isEmptyFlts :: Floats -> Bool
 473 isEmptyFlts (Floats bs _) = isNilOL bs
 474
 475 floatBinds :: Floats -> [OutBind]
 476 floatBinds (Floats bs _) = fromOL bs
 477 \end{code}
 478
 479
 480 %************************************************************************
 481 %*                                                                      *
 482                 Substitution of Vars
 483 %*                                                                      *
 484 %************************************************************************
 485
 486 Note [Global Ids in the substitution]
 487 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 488 We look up even a global (eg imported) Id in the substitution. Consider
 489    case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }
 490 The binder-swap in the occurence analyser will add a binding
 491 for a LocalId version of g (with the same unique though):
 492    case X.g_34 of b { (a,b) ->  let g_34 = b in
 493                                 ... case X.g_34 of { (p,q) -> ...} ... }
 494 So we want to look up the inner X.g_34 in the substitution, where we'll
 495 find that it has been substituted by b.  (Or conceivably cloned.)
 496
 497 \begin{code}
 498 substId :: SimplEnv -> InId -> SimplSR
 499 -- Returns DoneEx only on a non-Var expression
 500 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 501   = case lookupVarEnv ids v of          -- Note [Global Ids in the substitution]
 502         Nothing               -> DoneId (refine in_scope v)
 503         Just (DoneId v)       -> DoneId (refine in_scope v)
 504         Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
 505         Just res              -> res    -- DoneEx non-var, or ContEx
 506   where
 507
 508         -- Get the most up-to-date thing from the in-scope set
 509         -- Even though it isn't in the substitution, it may be in
 510         -- the in-scope set with better IdInfo
 511 refine :: InScopeSet -> Var -> Var
 512 refine in_scope v
 513   | isLocalId v = case lookupInScope in_scope v of
 514                          Just v' -> v'
 515                          Nothing -> WARN( True, ppr v ) v       -- This is an error!
 516   | otherwise = v
 517
 518 lookupRecBndr :: SimplEnv -> InId -> OutId
 519 -- Look up an Id which has been put into the envt by simplRecBndrs,
 520 -- but where we have not yet done its RHS
 521 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 522   = case lookupVarEnv ids v of
 523         Just (DoneId v) -> v
 524         Just _ -> pprPanic "lookupRecBndr" (ppr v)
 525         Nothing -> refine in_scope v
 526 \end{code}
 527
 528
 529 %************************************************************************
 530 %*                                                                      *
 531 \section{Substituting an Id binder}
 532 %*                                                                      *
 533 %************************************************************************
 534
 535
 536 These functions are in the monad only so that they can be made strict via seq.
 537
 538 \begin{code}
 539 simplBinders, simplLamBndrs
 540         :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
 541 simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
 542 simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
 543
 544 -------------
 545 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 546 -- Used for lambda and case-bound variables
 547 -- Clone Id if necessary, substitute type
 548 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 549 -- The substitution is extended only if the variable is cloned, because
 550 -- we *don't* need to use it to track occurrence info.
 551 simplBinder env bndr
 552   | isTyCoVar bndr  = do        { let (env', tv) = substTyVarBndr env bndr
 553                         ; seqTyVar tv `seq` return (env', tv) }
 554   | otherwise     = do  { let (env', id) = substIdBndr env bndr
 555                         ; seqId id `seq` return (env', id) }
 556
 557 -------------
 558 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
 559 -- Used for lambda binders.  These sometimes have unfoldings added by
 560 -- the worker/wrapper pass that must be preserved, because they can't
 561 -- be reconstructed from context.  For example:
 562 --      f x = case x of (a,b) -> fw a b x
 563 --      fw a b x{=(a,b)} = ...
 564 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
 565 simplLamBndr env bndr
 566   | isId bndr && hasSomeUnfolding old_unf = seqId id2 `seq` return (env2, id2)  -- Special case
 567   | otherwise                             = simplBinder env bndr                -- Normal case
 568   where
 569     old_unf = idUnfolding bndr
 570     (env1, id1) = substIdBndr env bndr
 571     id2  = id1 `setIdUnfolding` substUnfolding env old_unf
 572     env2 = modifyInScope env1 id2
 573
 574 ---------------
 575 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 576 -- A non-recursive let binder
 577 simplNonRecBndr env id
 578   = do  { let (env1, id1) = substIdBndr env id
 579         ; seqId id1 `seq` return (env1, id1) }
 580
 581 ---------------
 582 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
 583 -- Recursive let binders
 584 simplRecBndrs env@(SimplEnv {}) ids
 585   = do  { let (env1, ids1) = mapAccumL substIdBndr env ids
 586         ; seqIds ids1 `seq` return env1 }
 587
 588 ---------------
 589 substIdBndr :: SimplEnv
 590             -> InBndr   -- Env and binder to transform
 591             -> (SimplEnv, OutBndr)
 592 -- Clone Id if necessary, substitute its type
 593 -- Return an Id with its
 594 --      * Type substituted
 595 --      * UnfoldingInfo, Rules, WorkerInfo zapped
 596 --      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
 597 --      * Robust info, retained especially arity and demand info,
 598 --         so that they are available to occurrences that occur in an
 599 --         earlier binding of a letrec
 600 --
 601 -- For the robust info, see Note [Arity robustness]
 602 --
 603 -- Augment the substitution  if the unique changed
 604 -- Extend the in-scope set with the new Id
 605 --
 606 -- Similar to CoreSubst.substIdBndr, except that
 607 --      the type of id_subst differs
 608 --      all fragile info is zapped
 609
 610 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
 611                old_id
 612   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 613            seIdSubst = new_subst }, new_id)
 614   where
 615     id1    = uniqAway in_scope old_id
 616     id2    = substIdType env id1
 617     new_id = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding
 618                                         -- and fragile OccInfo
 619
 620         -- Extend the substitution if the unique has changed,
 621         -- or there's some useful occurrence information
 622         -- See the notes with substTyVarBndr for the delSubstEnv
 623     new_subst | new_id /= old_id
 624               = extendVarEnv id_subst old_id (DoneId new_id)
 625               | otherwise
 626               = delVarEnv id_subst old_id
 627 \end{code}
 628
 629 \begin{code}
 630 ------------------------------------
 631 seqTyVar :: TyVar -> ()
 632 seqTyVar b = b `seq` ()
 633
 634 seqId :: Id -> ()
 635 seqId id = seqType (idType id)  `seq`
 636            idInfo id            `seq`
 637            ()
 638
 639 seqIds :: [Id] -> ()
 640 seqIds []       = ()
 641 seqIds (id:ids) = seqId id `seq` seqIds ids
 642 \end{code}
 643
 644
 645 Note [Arity robustness]
 646 ~~~~~~~~~~~~~~~~~~~~~~~
 647 We *do* transfer the arity from from the in_id of a let binding to the
 648 out_id.  This is important, so that the arity of an Id is visible in
 649 its own RHS.  For example:
 650         f = \x. ....g (\y. f y)....
 651 We can eta-reduce the arg to g, becuase f is a value.  But that
 652 needs to be visible.
 653
 654 This interacts with the 'state hack' too:
 655         f :: Bool -> IO Int
 656         f = \x. case x of
 657                   True  -> f y
 658                   False -> \s -> ...
 659 Can we eta-expand f?  Only if we see that f has arity 1, and then we
 660 take advantage of the 'state hack' on the result of
 661 (f y) :: State# -> (State#, Int) to expand the arity one more.
 662
 663 There is a disadvantage though.  Making the arity visible in the RHS
 664 allows us to eta-reduce
 665         f = \x -> f x
 666 to
 667         f = f
 668 which technically is not sound.   This is very much a corner case, so
 669 I'm not worried about it.  Another idea is to ensure that f's arity
 670 never decreases; its arity started as 1, and we should never eta-reduce
 671 below that.
 672
 673
 674 Note [Robust OccInfo]
 675 ~~~~~~~~~~~~~~~~~~~~~
 676 It's important that we *do* retain the loop-breaker OccInfo, because
 677 that's what stops the Id getting inlined infinitely, in the body of
 678 the letrec.
 679
 680
 681 Note [Rules in a letrec]
 682 ~~~~~~~~~~~~~~~~~~~~~~~~
 683 After creating fresh binders for the binders of a letrec, we
 684 substitute the RULES and add them back onto the binders; this is done
 685 *before* processing any of the RHSs.  This is important.  Manuel found
 686 cases where he really, really wanted a RULE for a recursive function
 687 to apply in that function's own right-hand side.
 688
 689 See Note [Loop breaking and RULES] in OccAnal.
 690
 691
 692 \begin{code}
 693 addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
 694 -- Rules are added back in to to the bin
 695 addBndrRules env in_id out_id
 696   | isEmptySpecInfo old_rules = (env, out_id)
 697   | otherwise = (modifyInScope env final_id, final_id)
 698   where
 699     subst     = mkCoreSubst (text "local rules") env
 700     old_rules = idSpecialisation in_id
 701     new_rules = CoreSubst.substSpec subst out_id old_rules
 702     final_id  = out_id `setIdSpecialisation` new_rules
 703 \end{code}
 704
 705
 706 %************************************************************************
 707 %*                                                                      *
 708                 Impedence matching to type substitution
 709 %*                                                                      *
 710 %************************************************************************
 711
 712 \begin{code}
 713 getTvSubst :: SimplEnv -> TvSubst
 714 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
 715   = mkTvSubst in_scope tv_env
 716
 717 substTy :: SimplEnv -> Type -> Type
 718 substTy env ty = Type.substTy (getTvSubst env) ty
 719
 720 substTyVar :: SimplEnv -> TyVar -> Type
 721 substTyVar env tv = Type.substTyVar (getTvSubst env) tv
 722
 723 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 724 substTyVarBndr env tv
 725   = case Type.substTyVarBndr (getTvSubst env) tv of
 726         (TvSubst in_scope' tv_env', tv')
 727            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 728
 729 -- When substituting in rules etc we can get CoreSubst to do the work
 730 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
 731 -- here.  I think the this will not usually result in a lot of work;
 732 -- the substitutions are typically small, and laziness will avoid work in many cases.
 733
 734 mkCoreSubst  :: SDoc -> SimplEnv -> CoreSubst.Subst
 735 mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
 736   = mk_subst tv_env id_env
 737   where
 738     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 739
 740     fiddle (DoneEx e)       = e
 741     fiddle (DoneId v)       = Var v
 742     fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
 743                                                 -- Don't shortcut here
 744
 745 ------------------
 746 substIdType :: SimplEnv -> Id -> Id
 747 substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 748   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 749   | otherwise   = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 750                 -- The tyVarsOfType is cheaper than it looks
 751                 -- because we cache the free tyvars of the type
 752                 -- in a Note in the id's type itself
 753   where
 754     old_ty = idType id
 755
 756 ------------------
 757 substExpr :: SDoc -> SimplEnv -> CoreExpr -> CoreExpr
 758 substExpr doc env
 759   = CoreSubst.substExpr (text "SimplEnv.substExpr1" <+> doc)
 760                         (mkCoreSubst (text "SimplEnv.substExpr2" <+> doc) env)
 761   -- Do *not* short-cut in the case of an empty substitution
 762   -- See Note [SimplEnv invariants]
 763
 764 substUnfolding :: SimplEnv -> Unfolding -> Unfolding
 765 substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
 766   -- Do *not* short-cut in the case of an empty substitution
 767   -- See Note [SimplEnv invariants]
 768 \end{code}
 769