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