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