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