compiler/simplCore/SimplEnv.lhs

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