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