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