compiler/simplCore/SimplEnv.lhs

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