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