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