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, addLetIdInfo,
  32         substExpr, 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 Rules
  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      ( Subst, mkSubst, substExpr, substSpec, substWorker )
  54 import qualified Type           ( substTy, substTyVarBndr )
  55 import Type hiding              ( substTy, substTyVarBndr )
  56 import Coercion
  57 import BasicTypes
  58 import DynFlags
  59 import Util
  60 import Outputable
  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  flt        = 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 binds
 388   = env { seFloats  = seFloats env `addFlts` new_floats,
 389           seInScope = extendInScopeSetList (seInScope env) bndrs }
 390   where
 391     bndrs = bindersOfBinds binds
 392     new_floats = Floats (toOL binds)
 393                         (foldr (andFF . classifyFF) FltLifted binds)
 394
 395 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
 396 -- Add the floats for env2 to env1;
 397 -- *plus* the in-scope set for env2, which is bigger
 398 -- than that for env1
 399 addFloats env1 env2
 400   = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
 401           seInScope = seInScope env2 }
 402
 403 addFlts :: Floats -> Floats -> Floats
 404 addFlts (Floats bs1 l1) (Floats bs2 l2)
 405   = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
 406
 407 zapFloats :: SimplEnv -> SimplEnv
 408 zapFloats env = env { seFloats = emptyFloats }
 409
 410 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
 411 -- Flattens the floats from env2 into a single Rec group,
 412 -- prepends the floats from env1, and puts the result back in env2
 413 -- This is all very specific to the way recursive bindings are
 414 -- handled; see Simplify.simplRecBind
 415 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
 416   = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) )
 417     env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
 418
 419 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
 420 wrapFloats env expr = wrapFlts (seFloats env) expr
 421
 422 wrapFlts :: Floats -> OutExpr -> OutExpr
 423 -- Wrap the floats around the expression, using case-binding where necessary
 424 wrapFlts (Floats bs _) body = foldrOL wrap body bs
 425   where
 426     wrap (Rec prs)    body = Let (Rec prs) body
 427     wrap (NonRec b r) body = bindNonRec b r body
 428
 429 getFloats :: SimplEnv -> [CoreBind]
 430 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
 431
 432 isEmptyFloats :: SimplEnv -> Bool
 433 isEmptyFloats env = isEmptyFlts (seFloats env)
 434
 435 isEmptyFlts :: Floats -> Bool
 436 isEmptyFlts (Floats bs _) = isNilOL bs
 437
 438 floatBinds :: Floats -> [OutBind]
 439 floatBinds (Floats bs _) = fromOL bs
 440 \end{code}
 441
 442
 443 %************************************************************************
 444 %*                                                                      *
 445                 Substitution of Vars
 446 %*                                                                      *
 447 %************************************************************************
 448
 449
 450 \begin{code}
 451 substId :: SimplEnv -> Id -> SimplSR
 452 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 453   | not (isLocalId v)
 454   = DoneId v
 455   | otherwise   -- A local Id
 456   = case lookupVarEnv ids v of
 457         Just (DoneId v) -> DoneId (refine in_scope v)
 458         Just res        -> res
 459         Nothing         -> DoneId (refine in_scope v)
 460   where
 461
 462         -- Get the most up-to-date thing from the in-scope set
 463         -- Even though it isn't in the substitution, it may be in
 464         -- the in-scope set with better IdInfo
 465 refine in_scope v = case lookupInScope in_scope v of
 466                          Just v' -> v'
 467                          Nothing -> WARN( True, ppr v ) v       -- This is an error!
 468
 469 lookupRecBndr :: SimplEnv -> Id -> Id
 470 -- Look up an Id which has been put into the envt by simplRecBndrs,
 471 -- but where we have not yet done its RHS
 472 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 473   = case lookupVarEnv ids v of
 474         Just (DoneId v) -> v
 475         Just res        -> pprPanic "lookupRecBndr" (ppr v)
 476         Nothing         -> refine in_scope v
 477 \end{code}
 478
 479
 480 %************************************************************************
 481 %*                                                                      *
 482 \section{Substituting an Id binder}
 483 %*                                                                      *
 484 %************************************************************************
 485
 486
 487 These functions are in the monad only so that they can be made strict via seq.
 488
 489 \begin{code}
 490 simplBinders, simplLamBndrs
 491         :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
 492 simplBinders  env bndrs = mapAccumLSmpl simplBinder  env bndrs
 493 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
 494
 495 -------------
 496 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 497 -- Used for lambda and case-bound variables
 498 -- Clone Id if necessary, substitute type
 499 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 500 -- The substitution is extended only if the variable is cloned, because
 501 -- we *don't* need to use it to track occurrence info.
 502 simplBinder env bndr
 503   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
 504                         ; seqTyVar tv `seq` return (env', tv) }
 505   | otherwise     = do  { let (env', id) = substIdBndr env bndr
 506                         ; seqId id `seq` return (env', id) }
 507
 508 -------------
 509 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
 510 -- Used for lambda binders.  These sometimes have unfoldings added by
 511 -- the worker/wrapper pass that must be preserved, becuase they can't
 512 -- be reconstructed from context.  For example:
 513 --      f x = case x of (a,b) -> fw a b x
 514 --      fw a b x{=(a,b)} = ...
 515 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
 516 simplLamBndr env bndr
 517   | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr  -- Normal case
 518   | otherwise                                   = seqId id2 `seq` return (env', id2)
 519   where
 520     old_unf = idUnfolding bndr
 521     (env', id1) = substIdBndr env bndr
 522     id2 = id1 `setIdUnfolding` substUnfolding env old_unf
 523
 524 --------------
 525 substIdBndr :: SimplEnv -> Id   -- Substitition and Id to transform
 526             -> (SimplEnv, Id)   -- Transformed pair
 527
 528 -- Returns with:
 529 --      * Unique changed if necessary
 530 --      * Type substituted
 531 --      * Unfolding zapped
 532 --      * Rules, worker, lbvar info all substituted
 533 --      * Fragile occurrence info zapped
 534 --      * The in-scope set extended with the returned Id
 535 --      * The substitution extended with a DoneId if unique changed
 536 --        In this case, the var in the DoneId is the same as the
 537 --        var returned
 538 --
 539 -- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs
 540
 541 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
 542             old_id
 543   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 544            seIdSubst = new_subst }, new_id)
 545   where
 546         -- id1 is cloned if necessary
 547     id1 = uniqAway in_scope old_id
 548
 549         -- id2 has its type zapped
 550     id2 = substIdType env id1
 551
 552         -- new_id has the final IdInfo
 553     subst  = mkCoreSubst env
 554     new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
 555
 556         -- Extend the substitution if the unique has changed
 557         -- See the notes with substTyVarBndr for the delSubstEnv
 558         -- Also see Note [Extending the Subst] in CoreSubst
 559     new_subst | new_id /= old_id
 560               = extendVarEnv id_subst old_id (DoneId new_id)
 561               | otherwise
 562               = delVarEnv id_subst old_id
 563 \end{code}
 564
 565 \begin{code}
 566 ------------------------------------
 567 seqTyVar :: TyVar -> ()
 568 seqTyVar b = b `seq` ()
 569
 570 seqId :: Id -> ()
 571 seqId id = seqType (idType id)  `seq`
 572            idInfo id            `seq`
 573            ()
 574
 575 seqIds :: [Id] -> ()
 576 seqIds []       = ()
 577 seqIds (id:ids) = seqId id `seq` seqIds ids
 578 \end{code}
 579
 580 %************************************************************************
 581 %*                                                                      *
 582                 Let bindings
 583 %*                                                                      *
 584 %************************************************************************
 585
 586 Simplifying let binders
 587 ~~~~~~~~~~~~~~~~~~~~~~~
 588 Rename the binders if necessary,
 589
 590 \begin{code}
 591 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 592 simplNonRecBndr env id
 593   = do  { let (env1, id1) = substLetIdBndr env id
 594         ; seqId id1 `seq` return (env1, id1) }
 595
 596 ---------------
 597 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
 598 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
 599   = do  { let (env1, ids1) = mapAccumL substLetIdBndr env ids
 600         ; seqIds ids1 `seq` return env1 }
 601
 602 ---------------
 603 substLetIdBndr :: SimplEnv -> InBndr    -- Env and binder to transform
 604                -> (SimplEnv, OutBndr)
 605 -- C.f. substIdBndr above
 606 -- Clone Id if necessary, substitute its type
 607 -- Return an Id with its fragile info zapped
 608 --      namely, any info that depends on free variables
 609 --      [addLetIdInfo, below, will restore its IdInfo]
 610 --      We want to retain robust info, especially arity and demand info,
 611 --      so that they are available to occurrences that occur in an
 612 --      earlier binding of a letrec
 613 -- Augment the subtitution
 614 --      if the unique changed, *or*
 615 --      if there's interesting occurrence info
 616
 617 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
 618   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 619            seIdSubst = new_subst }, new_id)
 620   where
 621     id1    = uniqAway in_scope old_id
 622     id2    = substIdType env id1
 623
 624     -- We want to get rid of any info that's dependent on free variables,
 625     -- but keep other info (like the arity).
 626     new_id = zapFragileIdInfo id2
 627
 628         -- Extend the substitution if the unique has changed,
 629         -- or there's some useful occurrence information
 630         -- See the notes with substTyVarBndr for the delSubstEnv
 631     new_subst | new_id /= old_id
 632               = extendVarEnv id_subst old_id (DoneId new_id)
 633               | otherwise
 634               = delVarEnv id_subst old_id
 635 \end{code}
 636
 637 Note [Add IdInfo back onto a let-bound Id]
 638 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 639 We must transfer the IdInfo of the original binder to the new binder.
 640 This is crucial, to preserve
 641         strictness
 642         rules
 643         worker info
 644 etc.  To do this we must apply the current substitution,
 645 which incorporates earlier substitutions in this very letrec group.
 646
 647 NB 1. We do this *before* processing the RHS of the binder, so that
 648 its substituted rules are visible in its own RHS.
 649 This is important.  Manuel found cases where he really, really
 650 wanted a RULE for a recursive function to apply in that function's
 651 own right-hand side.
 652
 653 NB 2: ARITY.  We *do* transfer the arity.  This is important, so that
 654 the arity of an Id is visible in its own RHS.  For example:
 655         f = \x. ....g (\y. f y)....
 656 We can eta-reduce the arg to g, becuase f is a value.  But that
 657 needs to be visible.
 658
 659 This interacts with the 'state hack' too:
 660         f :: Bool -> IO Int
 661         f = \x. case x of
 662                   True  -> f y
 663                   False -> \s -> ...
 664 Can we eta-expand f?  Only if we see that f has arity 1, and then we
 665 take advantage of the 'state hack' on the result of
 666 (f y) :: State# -> (State#, Int) to expand the arity one more.
 667
 668 There is a disadvantage though.  Making the arity visible in the RHA
 669 allows us to eta-reduce
 670         f = \x -> f x
 671 to
 672         f = f
 673 which technically is not sound.   This is very much a corner case, so
 674 I'm not worried about it.  Another idea is to ensure that f's arity
 675 never decreases; its arity started as 1, and we should never eta-reduce
 676 below that.
 677
 678 NB 3: OccInfo.  It's important that we *do* transer the loop-breaker
 679 OccInfo, because that's what stops the Id getting inlined infinitely,
 680 in the body of the letrec.
 681
 682 NB 4: does no harm for non-recursive bindings
 683
 684 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
 685         rec { f = g
 686               h = ...
 687                 RULE h Int = f
 688         }
 689 Here, we'll do postInlineUnconditionally on f, and we must "see" that
 690 when substituting in h's RULE.
 691
 692 \begin{code}
 693 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
 694 addLetIdInfo env in_id out_id
 695   = (modifyInScope env out_id final_id, final_id)
 696   where
 697     final_id = out_id `setIdInfo` new_info
 698     subst = mkCoreSubst env
 699     old_info = idInfo in_id
 700     new_info = case substIdInfo subst old_info of
 701                   Nothing       -> old_info
 702                   Just new_info -> new_info
 703
 704 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 705 -- Substitute the
 706 --      rules
 707 --      worker info
 708 -- Zap the unfolding
 709 -- Keep only 'robust' OccInfo
 710 --           arity
 711 --
 712 -- Seq'ing on the returned IdInfo is enough to cause all the
 713 -- substitutions to happen completely
 714
 715 substIdInfo subst info
 716   | nothing_to_do = Nothing
 717   | otherwise     = Just (info `setOccInfo`       (if keep_occ then old_occ else NoOccInfo)
 718                                `setSpecInfo`      CoreSubst.substSpec   subst old_rules
 719                                `setWorkerInfo`    CoreSubst.substWorker subst old_wrkr
 720                                `setUnfoldingInfo` noUnfolding)
 721                         -- setSpecInfo does a seq
 722                         -- setWorkerInfo does a seq
 723   where
 724     nothing_to_do = keep_occ &&
 725                     isEmptySpecInfo old_rules &&
 726                     not (workerExists old_wrkr) &&
 727                     not (hasUnfolding (unfoldingInfo info))
 728
 729     keep_occ  = not (isFragileOcc old_occ)
 730     old_occ   = occInfo info
 731     old_rules = specInfo info
 732     old_wrkr  = workerInfo info
 733
 734 ------------------
 735 substIdType :: SimplEnv -> Id -> Id
 736 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 737   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 738   | otherwise   = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 739                 -- The tyVarsOfType is cheaper than it looks
 740                 -- because we cache the free tyvars of the type
 741                 -- in a Note in the id's type itself
 742   where
 743     old_ty = idType id
 744
 745 ------------------
 746 substUnfolding env NoUnfolding                 = NoUnfolding
 747 substUnfolding env (OtherCon cons)             = OtherCon cons
 748 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
 749 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
 750 \end{code}
 751
 752
 753 %************************************************************************
 754 %*                                                                      *
 755                 Impedence matching to type substitution
 756 %*                                                                      *
 757 %************************************************************************
 758
 759 \begin{code}
 760 substTy :: SimplEnv -> Type -> Type
 761 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
 762   = Type.substTy (TvSubst in_scope tv_env) ty
 763
 764 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 765 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
 766   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 767         (TvSubst in_scope' tv_env', tv')
 768            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 769
 770 -- When substituting in rules etc we can get CoreSubst to do the work
 771 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
 772 -- here.  I think the this will not usually result in a lot of work;
 773 -- the substitutions are typically small, and laziness will avoid work in many cases.
 774
 775 mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
 776 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
 777   = mk_subst tv_env id_env
 778   where
 779     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 780
 781     fiddle (DoneEx e)       = e
 782     fiddle (DoneId v)       = Var v
 783     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 784
 785 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
 786 substExpr env expr
 787   | isEmptySimplSubst env = expr
 788   | otherwise             = CoreSubst.substExpr (mkCoreSubst env) expr
 789 \end{code}
 790