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