compiler/simplCore/SimplEnv.hs

   1 {-
   2 (c) The AQUA Project, Glasgow University, 1993-1998
   3
   4 \section[SimplMonad]{The simplifier Monad}
   5 -}
   6
   7 {-# LANGUAGE CPP #-}
   8
   9 module SimplEnv (
  10         InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar,
  11         OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar,
  12         InCoercion, OutCoercion,
  13
  14         -- The simplifier mode
  15         setMode, getMode, updMode,
  16
  17         -- Environments
  18         SimplEnv(..), StaticEnv, pprSimplEnv,   -- Temp not abstract
  19         mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
  20         zapSubstEnv, setSubstEnv,
  21         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
  22         getSimplRules,
  23
  24         SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
  25
  26         simplNonRecBndr, simplRecBndrs,
  27         simplBinder, simplBinders,
  28         substTy, substTyVar, getTvSubst,
  29         getCvSubst, substCo, substCoVar,
  30
  31         -- Floats
  32         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
  33         wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,
  34         doFloatFromRhs, getFloatBinds
  35     ) where
  36
  37 #include "HsVersions.h"
  38
  39 import SimplMonad
  40 import CoreMonad        ( SimplifierMode(..) )
  41 import CoreSyn
  42 import CoreUtils
  43 import Var
  44 import VarEnv
  45 import VarSet
  46 import OrdList
  47 import Id
  48 import MkCore                   ( mkWildValBinder )
  49 import TysWiredIn
  50 import qualified Type
  51 import Type hiding              ( substTy, substTyVarBndr, substTyVar )
  52 import qualified Coercion
  53 import Coercion hiding          ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr )
  54 import BasicTypes
  55 import MonadUtils
  56 import Outputable
  57 import FastString
  58 import Util
  59
  60 import Data.List
  61
  62 {-
  63 ************************************************************************
  64 *                                                                      *
  65 \subsection[Simplify-types]{Type declarations}
  66 *                                                                      *
  67 ************************************************************************
  68 -}
  69
  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
  91 {-
  92 ************************************************************************
  93 *                                                                      *
  94 \subsubsection{The @SimplEnv@ type}
  95 *                                                                      *
  96 ************************************************************************
  97 -}
  98
  99 data SimplEnv
 100   = SimplEnv {
 101      ----------- Static part of the environment -----------
 102      -- Static in the sense of lexically scoped,
 103      -- wrt the original expression
 104
 105         seMode      :: SimplifierMode,
 106
 107         -- The current substitution
 108         seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
 109         seCvSubst   :: CvSubstEnv,      -- InCoVar |--> OutCoercion
 110         seIdSubst   :: SimplIdSubst,    -- InId    |--> OutExpr
 111
 112      ----------- Dynamic part of the environment -----------
 113      -- Dynamic in the sense of describing the setup where
 114      -- the expression finally ends up
 115
 116         -- The current set of in-scope variables
 117         -- They are all OutVars, and all bound in this module
 118         seInScope   :: InScopeSet,      -- OutVars only
 119                 -- Includes all variables bound by seFloats
 120         seFloats    :: Floats
 121                 -- See Note [Simplifier floats]
 122     }
 123
 124 type StaticEnv = SimplEnv       -- Just the static part is relevant
 125
 126 pprSimplEnv :: SimplEnv -> SDoc
 127 -- Used for debugging; selective
 128 pprSimplEnv env
 129   = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env),
 130           ptext (sLit "IdSubst:") <+> ppr (seIdSubst env),
 131           ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars)
 132     ]
 133   where
 134    in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
 135    ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
 136              | otherwise = ppr v
 137
 138 type SimplIdSubst = IdEnv SimplSR       -- IdId |--> OutExpr
 139         -- See Note [Extending the Subst] in CoreSubst
 140
 141 data SimplSR
 142   = DoneEx OutExpr              -- Completed term
 143   | DoneId OutId                -- Completed term variable
 144   | ContEx TvSubstEnv           -- A suspended substitution
 145            CvSubstEnv
 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 _cv _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
 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
 178         can overlap.
 179         For example, we generally omit mappings
 180                 a77 -> a77
 181         from the substitution, when we decide not to clone a77, but it's quite
 182         legitimate to put the mapping in the substitution anyway.
 183
 184         Furthermore, consider
 185                 let x = case k of I# x77 -> ... in
 186                 let y = case k of I# x77 -> ... in ...
 187         and suppose the body is strict in both x and y.  Then the simplifier
 188         will pull the first (case k) to the top; so the second (case k) will
 189         cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
 190         other is an out-Id.
 191
 192         Of course, the substitution *must* applied! Things in its domain
 193         simply aren't necessarily bound in the result.
 194
 195 * substId adds a binding (DoneId new_id) to the substitution if
 196         the Id's unique has changed
 197
 198   Note, though that the substitution isn't necessarily extended
 199   if the type of the Id changes.  Why not?  Because of the next point:
 200
 201 * We *always, always* finish by looking up in the in-scope set
 202   any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
 203   Reason: so that we never finish up with a "old" Id in the result.
 204   An old Id might point to an old unfolding and so on... which gives a space
 205   leak.
 206
 207   [The DoneEx and DoneVar hits map to "new" stuff.]
 208
 209 * It follows that substExpr must not do a no-op if the substitution is empty.
 210   substType is free to do so, however.
 211
 212 * When we come to a let-binding (say) we generate new IdInfo, including an
 213   unfolding, attach it to the binder, and add this newly adorned binder to
 214   the in-scope set.  So all subsequent occurrences of the binder will get
 215   mapped to the full-adorned binder, which is also the one put in the
 216   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 mkSimplEnv :: SimplifierMode -> SimplEnv
 226 mkSimplEnv mode
 227   = SimplEnv { seMode = mode
 228              , seInScope = init_in_scope
 229              , seFloats = emptyFloats
 230              , seTvSubst = emptyVarEnv
 231              , seCvSubst = emptyVarEnv
 232              , seIdSubst = emptyVarEnv }
 233         -- The top level "enclosing CC" is "SUBSUMED".
 234
 235 init_in_scope :: InScopeSet
 236 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
 237               -- See Note [WildCard binders]
 238
 239 {-
 240 Note [WildCard binders]
 241 ~~~~~~~~~~~~~~~~~~~~~~~
 242 The program to be simplified may have wild binders
 243     case e of wild { p -> ... }
 244 We want to *rename* them away, so that there are no
 245 occurrences of 'wild-id' (with wildCardKey).  The easy
 246 way to do that is to start of with a representative
 247 Id in the in-scope set
 248
 249 There can be be *occurrences* of wild-id.  For example,
 250 MkCore.mkCoreApp transforms
 251    e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }
 252 This is ok provided 'wild' isn't free in 'e', and that's the delicate
 253 thing. Generally, you want to run the simplifier to get rid of the
 254 wild-ids before doing much else.
 255
 256 It's a very dark corner of GHC.  Maybe it should be cleaned up.
 257 -}
 258
 259 getMode :: SimplEnv -> SimplifierMode
 260 getMode env = seMode env
 261
 262 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
 263 setMode mode env = env { seMode = mode }
 264
 265 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
 266 updMode upd env = env { seMode = upd (seMode env) }
 267
 268 ---------------------
 269 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
 270 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
 271   = ASSERT2( isId var && not (isCoVar var), ppr var )
 272     env {seIdSubst = extendVarEnv subst var res}
 273
 274 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 275 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
 276   = env {seTvSubst = extendVarEnv subst var res}
 277
 278 extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
 279 extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res
 280   = env {seCvSubst = extendVarEnv subst var res}
 281
 282 ---------------------
 283 getInScope :: SimplEnv -> InScopeSet
 284 getInScope env = seInScope env
 285
 286 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 287 setInScopeSet env in_scope = env {seInScope = in_scope}
 288
 289 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
 290 -- Set the in-scope set, and *zap* the floats
 291 setInScope env env_with_scope
 292   = env { seInScope = seInScope env_with_scope,
 293           seFloats = emptyFloats }
 294
 295 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
 296 -- Set the in-scope set *and* the floats
 297 setFloats env env_with_floats
 298   = env { seInScope = seInScope env_with_floats,
 299           seFloats  = seFloats  env_with_floats }
 300
 301 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
 302         -- The new Ids are guaranteed to be freshly allocated
 303 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
 304   = env { seInScope = in_scope `extendInScopeSetList` vs,
 305           seIdSubst = id_subst `delVarEnvList` vs }
 306         -- Why delete?  Consider
 307         --      let x = a*b in (x, \x -> x+3)
 308         -- We add [x |-> a*b] to the substitution, but we must
 309         -- _delete_ it from the substitution when going inside
 310         -- the (\x -> ...)!
 311
 312 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
 313 -- The variable should already be in scope, but
 314 -- replace the existing version with this new one
 315 -- which has more information
 316 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
 317   = env {seInScope = extendInScopeSet in_scope v}
 318
 319 ---------------------
 320 zapSubstEnv :: SimplEnv -> SimplEnv
 321 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
 322
 323 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
 324 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
 325
 326 mkContEx :: SimplEnv -> InExpr -> SimplSR
 327 mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
 328
 329 {-
 330 ************************************************************************
 331 *                                                                      *
 332 \subsection{Floats}
 333 *                                                                      *
 334 ************************************************************************
 335
 336 Note [Simplifier floats]
 337 ~~~~~~~~~~~~~~~~~~~~~~~~~
 338 The Floats is a bunch of bindings, classified by a FloatFlag.
 339
 340 * All of them satisfy the let/app invariant
 341
 342 Examples
 343
 344   NonRec x (y:ys)       FltLifted
 345   Rec [(x,rhs)]         FltLifted
 346
 347   NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?
 348   NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n
 349
 350   NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge
 351
 352 Can't happen:
 353   NonRec x# (a /# b)    -- Might fail; does not satisfy let/app
 354   NonRec x# (f y)       -- Might diverge; does not satisfy let/app
 355 -}
 356
 357 data Floats = Floats (OrdList OutBind) FloatFlag
 358         -- See Note [Simplifier floats]
 359
 360 data FloatFlag
 361   = FltLifted   -- All bindings are lifted and lazy
 362                 --  Hence ok to float to top level, or recursive
 363
 364   | FltOkSpec   -- All bindings are FltLifted *or*
 365                 --      strict (perhaps because unlifted,
 366                 --      perhaps because of a strict binder),
 367                 --        *and* ok-for-speculation
 368                 --  Hence ok to float out of the RHS
 369                 --  of a lazy non-recursive let binding
 370                 --  (but not to top level, or into a rec group)
 371
 372   | FltCareful  -- At least one binding is strict (or unlifted)
 373                 --      and not guaranteed cheap
 374                 --      Do not float these bindings out of a lazy let
 375
 376 instance Outputable Floats where
 377   ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
 378
 379 instance Outputable FloatFlag where
 380   ppr FltLifted = ptext (sLit "FltLifted")
 381   ppr FltOkSpec = ptext (sLit "FltOkSpec")
 382   ppr FltCareful = ptext (sLit "FltCareful")
 383
 384 andFF :: FloatFlag -> FloatFlag -> FloatFlag
 385 andFF FltCareful _          = FltCareful
 386 andFF FltOkSpec  FltCareful = FltCareful
 387 andFF FltOkSpec  _          = FltOkSpec
 388 andFF FltLifted  flt        = flt
 389
 390 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 391 -- If you change this function look also at FloatIn.noFloatFromRhs
 392 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
 393   =  not (isNilOL fs) && want_to_float && can_float
 394   where
 395      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
 396                      -- See Note [Float when cheap or expandable]
 397      can_float = case ff of
 398                    FltLifted  -> True
 399                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
 400                    FltCareful -> isNotTopLevel lvl && isNonRec rec && str
 401
 402 {-
 403 Note [Float when cheap or expandable]
 404 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 405 We want to float a let from a let if the residual RHS is
 406    a) cheap, such as (\x. blah)
 407    b) expandable, such as (f b) if f is CONLIKE
 408 But there are
 409   - cheap things that are not expandable (eg \x. expensive)
 410   - expandable things that are not cheap (eg (f b) where b is CONLIKE)
 411 so we must take the 'or' of the two.
 412 -}
 413
 414 emptyFloats :: Floats
 415 emptyFloats = Floats nilOL FltLifted
 416
 417 unitFloat :: OutBind -> Floats
 418 -- This key function constructs a singleton float with the right form
 419 unitFloat bind = Floats (unitOL bind) (flag bind)
 420   where
 421     flag (Rec {})                = FltLifted
 422     flag (NonRec bndr rhs)
 423       | not (isStrictId bndr)    = FltLifted
 424       | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)
 425       | otherwise                = ASSERT2( not (isUnLiftedType (idType bndr)), ppr bndr )
 426                                    FltCareful
 427       -- Unlifted binders can only be let-bound if exprOkForSpeculation holds
 428
 429 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 430 -- Add a non-recursive binding and extend the in-scope set
 431 -- The latter is important; the binder may already be in the
 432 -- in-scope set (although it might also have been created with newId)
 433 -- but it may now have more IdInfo
 434 addNonRec env id rhs
 435   = id `seq`   -- This seq forces the Id, and hence its IdInfo,
 436                -- and hence any inner substitutions
 437     env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
 438           seInScope = extendInScopeSet (seInScope env) id }
 439
 440 extendFloats :: SimplEnv -> OutBind -> SimplEnv
 441 -- Add these bindings to the floats, and extend the in-scope env too
 442 extendFloats env bind
 443   = env { seFloats  = seFloats env `addFlts` unitFloat bind,
 444           seInScope = extendInScopeSetList (seInScope env) bndrs }
 445   where
 446     bndrs = bindersOf bind
 447
 448 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
 449 -- Add the floats for env2 to env1;
 450 -- *plus* the in-scope set for env2, which is bigger
 451 -- than that for env1
 452 addFloats env1 env2
 453   = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
 454           seInScope = seInScope env2 }
 455
 456 addFlts :: Floats -> Floats -> Floats
 457 addFlts (Floats bs1 l1) (Floats bs2 l2)
 458   = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
 459
 460 zapFloats :: SimplEnv -> SimplEnv
 461 zapFloats env = env { seFloats = emptyFloats }
 462
 463 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
 464 -- Flattens the floats from env2 into a single Rec group,
 465 -- prepends the floats from env1, and puts the result back in env2
 466 -- This is all very specific to the way recursive bindings are
 467 -- handled; see Simplify.simplRecBind
 468 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
 469   = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
 470     env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
 471
 472 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
 473 -- Wrap the floats around the expression; they should all
 474 -- satisfy the let/app invariant, so mkLets should do the job just fine
 475 wrapFloats (SimplEnv {seFloats = Floats bs _}) body
 476   = foldrOL Let body bs
 477
 478 getFloatBinds :: SimplEnv -> [CoreBind]
 479 getFloatBinds (SimplEnv {seFloats = Floats bs _})
 480   = fromOL bs
 481
 482 isEmptyFloats :: SimplEnv -> Bool
 483 isEmptyFloats (SimplEnv {seFloats = Floats bs _})
 484   = isNilOL bs
 485
 486 mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv
 487 mapFloats env@SimplEnv { seFloats = Floats fs ff } fun
 488    = env { seFloats = Floats (mapOL app fs) ff }
 489    where
 490     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
 491     app (Rec bs)     = Rec (map fun bs)
 492
 493 {-
 494 ************************************************************************
 495 *                                                                      *
 496                 Substitution of Vars
 497 *                                                                      *
 498 ************************************************************************
 499
 500 Note [Global Ids in the substitution]
 501 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 502 We look up even a global (eg imported) Id in the substitution. Consider
 503    case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }
 504 The binder-swap in the occurrence analyser will add a binding
 505 for a LocalId version of g (with the same unique though):
 506    case X.g_34 of b { (a,b) ->  let g_34 = b in
 507                                 ... case X.g_34 of { (p,q) -> ...} ... }
 508 So we want to look up the inner X.g_34 in the substitution, where we'll
 509 find that it has been substituted by b.  (Or conceivably cloned.)
 510 -}
 511
 512 substId :: SimplEnv -> InId -> SimplSR
 513 -- Returns DoneEx only on a non-Var expression
 514 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 515   = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]
 516         Nothing               -> DoneId (refineFromInScope in_scope v)
 517         Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)
 518         Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v)
 519         Just res              -> res    -- DoneEx non-var, or ContEx
 520
 521         -- Get the most up-to-date thing from the in-scope set
 522         -- Even though it isn't in the substitution, it may be in
 523         -- the in-scope set with better IdInfo
 524 refineFromInScope :: InScopeSet -> Var -> Var
 525 refineFromInScope in_scope v
 526   | isLocalId v = case lookupInScope in_scope v of
 527                   Just v' -> v'
 528                   Nothing -> WARN( True, ppr v ) v  -- This is an error!
 529   | otherwise = v
 530
 531 lookupRecBndr :: SimplEnv -> InId -> OutId
 532 -- Look up an Id which has been put into the envt by simplRecBndrs,
 533 -- but where we have not yet done its RHS
 534 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 535   = case lookupVarEnv ids v of
 536         Just (DoneId v) -> v
 537         Just _ -> pprPanic "lookupRecBndr" (ppr v)
 538         Nothing -> refineFromInScope in_scope v
 539
 540 {-
 541 ************************************************************************
 542 *                                                                      *
 543 \section{Substituting an Id binder}
 544 *                                                                      *
 545 ************************************************************************
 546
 547
 548 These functions are in the monad only so that they can be made strict via seq.
 549 -}
 550
 551 simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
 552 simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
 553
 554 -------------
 555 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 556 -- Used for lambda and case-bound variables
 557 -- Clone Id if necessary, substitute type
 558 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 559 -- The substitution is extended only if the variable is cloned, because
 560 -- we *don't* need to use it to track occurrence info.
 561 simplBinder env bndr
 562   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
 563                         ; seqTyVar tv `seq` return (env', tv) }
 564   | otherwise     = do  { let (env', id) = substIdBndr env bndr
 565                         ; seqId id `seq` return (env', id) }
 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 -> InBndr -> (SimplEnv, OutBndr)
 583 -- Might be a coercion variable
 584 substIdBndr env bndr
 585   | isCoVar bndr  = substCoVarBndr env bndr
 586   | otherwise     = substNonCoVarIdBndr env bndr
 587
 588 ---------------
 589 substNonCoVarIdBndr
 590    :: SimplEnv
 591    -> InBndr    -- Env and binder to transform
 592    -> (SimplEnv, OutBndr)
 593 -- Clone Id if necessary, substitute its type
 594 -- Return an Id with its
 595 --      * Type substituted
 596 --      * UnfoldingInfo, Rules, WorkerInfo zapped
 597 --      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
 598 --      * Robust info, retained especially arity and demand info,
 599 --         so that they are available to occurrences that occur in an
 600 --         earlier binding of a letrec
 601 --
 602 -- For the robust info, see Note [Arity robustness]
 603 --
 604 -- Augment the substitution  if the unique changed
 605 -- Extend the in-scope set with the new Id
 606 --
 607 -- Similar to CoreSubst.substIdBndr, except that
 608 --      the type of id_subst differs
 609 --      all fragile info is zapped
 610 substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
 611                     old_id
 612   = ASSERT2( not (isCoVar old_id), ppr old_id )
 613     (env { seInScope = in_scope `extendInScopeSet` new_id,
 614            seIdSubst = new_subst }, new_id)
 615   where
 616     id1    = uniqAway in_scope old_id
 617     id2    = substIdType env id1
 618     new_id = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding
 619                                         -- and fragile OccInfo
 620
 621         -- Extend the substitution if the unique has changed,
 622         -- or there's some useful occurrence information
 623         -- See the notes with substTyVarBndr for the delSubstEnv
 624     new_subst | new_id /= old_id
 625               = extendVarEnv id_subst old_id (DoneId new_id)
 626               | otherwise
 627               = delVarEnv id_subst old_id
 628
 629 ------------------------------------
 630 seqTyVar :: TyVar -> ()
 631 seqTyVar b = b `seq` ()
 632
 633 seqId :: Id -> ()
 634 seqId id = seqType (idType id)  `seq`
 635            idInfo id            `seq`
 636            ()
 637
 638 seqIds :: [Id] -> ()
 639 seqIds []       = ()
 640 seqIds (id:ids) = seqId id `seq` seqIds ids
 641
 642 {-
 643 Note [Arity robustness]
 644 ~~~~~~~~~~~~~~~~~~~~~~~
 645 We *do* transfer the arity from from the in_id of a let binding to the
 646 out_id.  This is important, so that the arity of an Id is visible in
 647 its own RHS.  For example:
 648         f = \x. ....g (\y. f y)....
 649 We can eta-reduce the arg to g, because f is a value.  But that
 650 needs to be visible.
 651
 652 This interacts with the 'state hack' too:
 653         f :: Bool -> IO Int
 654         f = \x. case x of
 655                   True  -> f y
 656                   False -> \s -> ...
 657 Can we eta-expand f?  Only if we see that f has arity 1, and then we
 658 take advantage of the 'state hack' on the result of
 659 (f y) :: State# -> (State#, Int) to expand the arity one more.
 660
 661 There is a disadvantage though.  Making the arity visible in the RHS
 662 allows us to eta-reduce
 663         f = \x -> f x
 664 to
 665         f = f
 666 which technically is not sound.   This is very much a corner case, so
 667 I'm not worried about it.  Another idea is to ensure that f's arity
 668 never decreases; its arity started as 1, and we should never eta-reduce
 669 below that.
 670
 671
 672 Note [Robust OccInfo]
 673 ~~~~~~~~~~~~~~~~~~~~~
 674 It's important that we *do* retain the loop-breaker OccInfo, because
 675 that's what stops the Id getting inlined infinitely, in the body of
 676 the letrec.
 677 -}
 678
 679
 680 {-
 681 ************************************************************************
 682 *                                                                      *
 683                 Impedence matching to type substitution
 684 *                                                                      *
 685 ************************************************************************
 686 -}
 687
 688 getTvSubst :: SimplEnv -> TvSubst
 689 getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
 690   = mkTvSubst in_scope tv_env
 691
 692 getCvSubst :: SimplEnv -> CvSubst
 693 getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
 694   = CvSubst in_scope tv_env cv_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 substCoVar :: SimplEnv -> CoVar -> Coercion
 709 substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv
 710
 711 substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
 712 substCoVarBndr env cv
 713   = case Coercion.substCoVarBndr (getCvSubst env) cv of
 714         (CvSubst in_scope' tv_env' cv_env', cv')
 715            -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
 716
 717 substCo :: SimplEnv -> Coercion -> Coercion
 718 substCo env co = Coercion.substCo (getCvSubst env) co
 719
 720 ------------------
 721 substIdType :: SimplEnv -> Id -> Id
 722 substIdType (SimplEnv { seInScope = in_scope,  seTvSubst = tv_env }) id
 723   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 724   | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 725                 -- The tyVarsOfType is cheaper than it looks
 726                 -- because we cache the free tyvars of the type
 727                 -- in a Note in the id's type itself
 728   where
 729     old_ty = idType id