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 {-# OPTIONS -w #-}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  12 -- for details
  13
  14 module SimplEnv (
  15         InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
  16         OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
  17         InCoercion, OutCoercion,
  18
  19         -- The simplifier mode
  20         setMode, getMode,
  21
  22         -- Switch checker
  23         SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
  24         isAmongSimpl, intSwitchSet, switchIsOn,
  25
  26         setEnclosingCC, getEnclosingCC,
  27
  28         -- Environments
  29         SimplEnv(..), pprSimplEnv,      -- Temp not abstract
  30         mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
  31         zapSubstEnv, setSubstEnv,
  32         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
  33         getRules,
  34
  35         SimplSR(..), mkContEx, substId, lookupRecBndr,
  36
  37         simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
  38         simplBinder, simplBinders, addLetIdInfo,
  39         substExpr, substTy,
  40
  41         -- Floats
  42         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
  43         wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
  44         doFloatFromRhs, getFloats
  45     ) where
  46
  47 #include "HsVersions.h"
  48
  49 import SimplMonad
  50 import IdInfo
  51 import CoreSyn
  52 import Rules
  53 import CoreUtils
  54 import CostCentre
  55 import Var
  56 import VarEnv
  57 import VarSet
  58 import OrdList
  59 import Id
  60 import qualified CoreSubst      ( Subst, mkSubst, substExpr, substSpec, substWorker )
  61 import qualified Type           ( substTy, substTyVarBndr )
  62 import Type hiding              ( substTy, substTyVarBndr )
  63 import Coercion
  64 import BasicTypes
  65 import DynFlags
  66 import Util
  67 import Outputable
  68
  69 import Data.List
  70 \end{code}
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection[Simplify-types]{Type declarations}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 type InBndr     = CoreBndr
  80 type InId       = Id                    -- Not yet cloned
  81 type InType     = Type                  -- Ditto
  82 type InBind     = CoreBind
  83 type InExpr     = CoreExpr
  84 type InAlt      = CoreAlt
  85 type InArg      = CoreArg
  86 type InCoercion = Coercion
  87
  88 type OutBndr     = CoreBndr
  89 type OutId       = Id                   -- Cloned
  90 type OutTyVar    = TyVar                -- Cloned
  91 type OutType     = Type                 -- Cloned
  92 type OutCoercion = Coercion
  93 type OutBind     = CoreBind
  94 type OutExpr     = CoreExpr
  95 type OutAlt      = CoreAlt
  96 type OutArg      = CoreArg
  97 \end{code}
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsubsection{The @SimplEnv@ type}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105
 106 \begin{code}
 107 data SimplEnv
 108   = SimplEnv {
 109         seMode      :: SimplifierMode,
 110         seChkr      :: SwitchChecker,
 111         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 112
 113         -- The current set of in-scope variables
 114         -- They are all OutVars, and all bound in this module
 115         seInScope   :: InScopeSet,      -- OutVars only
 116                 -- Includes all variables bound by seFloats
 117         seFloats    :: Floats,
 118                 -- See Note [Simplifier floats]
 119
 120         -- The current substitution
 121         seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
 122         seIdSubst   :: SimplIdSubst     -- InId    |--> OutExpr
 123
 124     }
 125
 126 pprSimplEnv :: SimplEnv -> SDoc
 127 -- Used for debugging; selective
 128 pprSimplEnv env
 129   = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env),
 130           ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ]
 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 -> SimplEnv
 217 mkSimplEnv mode switches
 218   = SimplEnv { seChkr = switches, seCC = subsumedCCS,
 219                seMode = mode, seInScope = emptyInScopeSet,
 220                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 \end{code}
 299
 300
 301
 302 %************************************************************************
 303 %*                                                                      *
 304 \subsection{Floats}
 305 %*                                                                      *
 306 %************************************************************************
 307
 308 Note [Simplifier floats]
 309 ~~~~~~~~~~~~~~~~~~~~~~~~~
 310 The Floats is a bunch of bindings, classified by a FloatFlag.
 311
 312   NonRec x (y:ys)       FltLifted
 313   Rec [(x,rhs)]         FltLifted
 314
 315   NonRec x# (y +# 3)    FltOkSpec       -- Unboxed, but ok-for-spec'n
 316
 317   NonRec x# (a /# b)    FltCareful
 318   NonRec x* (f y)       FltCareful      -- Strict binding; might fail or diverge
 319   NonRec x# (f y)       FltCareful      -- Unboxed binding: might fail or diverge
 320                                         --        (where f :: Int -> Int#)
 321
 322 \begin{code}
 323 data Floats = Floats (OrdList OutBind) FloatFlag
 324         -- See Note [Simplifier floats]
 325
 326 data FloatFlag
 327   = FltLifted   -- All bindings are lifted and lazy
 328                 --  Hence ok to float to top level, or recursive
 329
 330   | FltOkSpec   -- All bindings are FltLifted *or*
 331                 --      strict (perhaps because unlifted,
 332                 --      perhaps because of a strict binder),
 333                 --        *and* ok-for-speculation
 334                 --  Hence ok to float out of the RHS
 335                 --  of a lazy non-recursive let binding
 336                 --  (but not to top level, or into a rec group)
 337
 338   | FltCareful  -- At least one binding is strict (or unlifted)
 339                 --      and not guaranteed cheap
 340                 --      Do not float these bindings out of a lazy let
 341
 342 instance Outputable Floats where
 343   ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
 344
 345 instance Outputable FloatFlag where
 346   ppr FltLifted = ptext SLIT("FltLifted")
 347   ppr FltOkSpec = ptext SLIT("FltOkSpec")
 348   ppr FltCareful = ptext SLIT("FltCareful")
 349
 350 andFF :: FloatFlag -> FloatFlag -> FloatFlag
 351 andFF FltCareful _          = FltCareful
 352 andFF FltOkSpec  FltCareful = FltCareful
 353 andFF FltOkSpec  flt        = FltOkSpec
 354 andFF FltLifted  flt        = flt
 355
 356 classifyFF :: CoreBind -> FloatFlag
 357 classifyFF (Rec _) = FltLifted
 358 classifyFF (NonRec bndr rhs)
 359   | not (isStrictId bndr)    = FltLifted
 360   | exprOkForSpeculation rhs = FltOkSpec
 361   | otherwise                = FltCareful
 362
 363 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 364 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
 365   =  not (isNilOL fs) && want_to_float && can_float
 366   where
 367      want_to_float = isTopLevel lvl || exprIsCheap rhs
 368      can_float = case ff of
 369                    FltLifted  -> True
 370                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
 371                    FltCareful -> isNotTopLevel lvl && isNonRec rec && str
 372 \end{code}
 373
 374
 375 \begin{code}
 376 emptyFloats :: Floats
 377 emptyFloats = Floats nilOL FltLifted
 378
 379 unitFloat :: OutBind -> Floats
 380 -- A single-binding float
 381 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
 382
 383 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 384 -- Add a non-recursive binding and extend the in-scope set
 385 -- The latter is important; the binder may already be in the
 386 -- in-scope set (although it might also have been created with newId)
 387 -- but it may now have more IdInfo
 388 addNonRec env id rhs
 389   = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
 390           seInScope = extendInScopeSet (seInScope env) id }
 391
 392 extendFloats :: SimplEnv -> [OutBind] -> SimplEnv
 393 -- Add these bindings to the floats, and extend the in-scope env too
 394 extendFloats env binds
 395   = env { seFloats  = seFloats env `addFlts` new_floats,
 396           seInScope = extendInScopeSetList (seInScope env) bndrs }
 397   where
 398     bndrs = bindersOfBinds binds
 399     new_floats = Floats (toOL binds)
 400                         (foldr (andFF . classifyFF) FltLifted binds)
 401
 402 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
 403 -- Add the floats for env2 to env1;
 404 -- *plus* the in-scope set for env2, which is bigger
 405 -- than that for env1
 406 addFloats env1 env2
 407   = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
 408           seInScope = seInScope env2 }
 409
 410 addFlts :: Floats -> Floats -> Floats
 411 addFlts (Floats bs1 l1) (Floats bs2 l2)
 412   = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
 413
 414 zapFloats :: SimplEnv -> SimplEnv
 415 zapFloats env = env { seFloats = emptyFloats }
 416
 417 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
 418 -- Flattens the floats from env2 into a single Rec group,
 419 -- prepends the floats from env1, and puts the result back in env2
 420 -- This is all very specific to the way recursive bindings are
 421 -- handled; see Simplify.simplRecBind
 422 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
 423   = ASSERT2( case ff of { FltLifted -> True; other -> False }, ppr (fromOL bs) )
 424     env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
 425
 426 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
 427 wrapFloats env expr = wrapFlts (seFloats env) expr
 428
 429 wrapFlts :: Floats -> OutExpr -> OutExpr
 430 -- Wrap the floats around the expression, using case-binding where necessary
 431 wrapFlts (Floats bs _) body = foldrOL wrap body bs
 432   where
 433     wrap (Rec prs)    body = Let (Rec prs) body
 434     wrap (NonRec b r) body = bindNonRec b r body
 435
 436 getFloats :: SimplEnv -> [CoreBind]
 437 getFloats (SimplEnv {seFloats = Floats bs _}) = fromOL bs
 438
 439 isEmptyFloats :: SimplEnv -> Bool
 440 isEmptyFloats env = isEmptyFlts (seFloats env)
 441
 442 isEmptyFlts :: Floats -> Bool
 443 isEmptyFlts (Floats bs _) = isNilOL bs
 444
 445 floatBinds :: Floats -> [OutBind]
 446 floatBinds (Floats bs _) = fromOL bs
 447 \end{code}
 448
 449
 450 %************************************************************************
 451 %*                                                                      *
 452                 Substitution of Vars
 453 %*                                                                      *
 454 %************************************************************************
 455
 456
 457 \begin{code}
 458 substId :: SimplEnv -> Id -> SimplSR
 459 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 460   | not (isLocalId v)
 461   = DoneId v
 462   | otherwise   -- A local Id
 463   = case lookupVarEnv ids v of
 464         Just (DoneId v) -> DoneId (refine in_scope v)
 465         Just res        -> res
 466         Nothing         -> DoneId (refine in_scope v)
 467   where
 468
 469         -- Get the most up-to-date thing from the in-scope set
 470         -- Even though it isn't in the substitution, it may be in
 471         -- the in-scope set with better IdInfo
 472 refine in_scope v = case lookupInScope in_scope v of
 473                          Just v' -> v'
 474                          Nothing -> WARN( True, ppr v ) v       -- This is an error!
 475
 476 lookupRecBndr :: SimplEnv -> Id -> Id
 477 -- Look up an Id which has been put into the envt by simplRecBndrs,
 478 -- but where we have not yet done its RHS
 479 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 480   = case lookupVarEnv ids v of
 481         Just (DoneId v) -> v
 482         Just res        -> pprPanic "lookupRecBndr" (ppr v)
 483         Nothing         -> refine in_scope v
 484 \end{code}
 485
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \section{Substituting an Id binder}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493
 494 These functions are in the monad only so that they can be made strict via seq.
 495
 496 \begin{code}
 497 simplBinders, simplLamBndrs
 498         :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
 499 simplBinders  env bndrs = mapAccumLSmpl simplBinder  env bndrs
 500 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
 501
 502 -------------
 503 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 504 -- Used for lambda and case-bound variables
 505 -- Clone Id if necessary, substitute type
 506 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 507 -- The substitution is extended only if the variable is cloned, because
 508 -- we *don't* need to use it to track occurrence info.
 509 simplBinder env bndr
 510   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
 511                         ; seqTyVar tv `seq` return (env', tv) }
 512   | otherwise     = do  { let (env', id) = substIdBndr env bndr
 513                         ; seqId id `seq` return (env', id) }
 514
 515 -------------
 516 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
 517 -- Used for lambda binders.  These sometimes have unfoldings added by
 518 -- the worker/wrapper pass that must be preserved, becuase they can't
 519 -- be reconstructed from context.  For example:
 520 --      f x = case x of (a,b) -> fw a b x
 521 --      fw a b x{=(a,b)} = ...
 522 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
 523 simplLamBndr env bndr
 524   | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr  -- Normal case
 525   | otherwise                                   = seqId id2 `seq` return (env', id2)
 526   where
 527     old_unf = idUnfolding bndr
 528     (env', id1) = substIdBndr env bndr
 529     id2 = id1 `setIdUnfolding` substUnfolding env old_unf
 530
 531 --------------
 532 substIdBndr :: SimplEnv -> Id   -- Substitition and Id to transform
 533             -> (SimplEnv, Id)   -- Transformed pair
 534
 535 -- Returns with:
 536 --      * Unique changed if necessary
 537 --      * Type substituted
 538 --      * Unfolding zapped
 539 --      * Rules, worker, lbvar info all substituted
 540 --      * Fragile occurrence info zapped
 541 --      * The in-scope set extended with the returned Id
 542 --      * The substitution extended with a DoneId if unique changed
 543 --        In this case, the var in the DoneId is the same as the
 544 --        var returned
 545 --
 546 -- Exactly like CoreSubst.substIdBndr, except that the type of id_subst differs
 547
 548 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
 549             old_id
 550   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 551            seIdSubst = new_subst }, new_id)
 552   where
 553         -- id1 is cloned if necessary
 554     id1 = uniqAway in_scope old_id
 555
 556         -- id2 has its type zapped
 557     id2 = substIdType env id1
 558
 559         -- new_id has the final IdInfo
 560     subst  = mkCoreSubst env
 561     new_id = maybeModifyIdInfo (substIdInfo subst (idInfo old_id)) id2
 562
 563         -- Extend the substitution if the unique has changed
 564         -- See the notes with substTyVarBndr for the delSubstEnv
 565         -- Also see Note [Extending the Subst] in CoreSubst
 566     new_subst | new_id /= old_id
 567               = extendVarEnv id_subst old_id (DoneId new_id)
 568               | otherwise
 569               = delVarEnv id_subst old_id
 570 \end{code}
 571
 572 \begin{code}
 573 ------------------------------------
 574 seqTyVar :: TyVar -> ()
 575 seqTyVar b = b `seq` ()
 576
 577 seqId :: Id -> ()
 578 seqId id = seqType (idType id)  `seq`
 579            idInfo id            `seq`
 580            ()
 581
 582 seqIds :: [Id] -> ()
 583 seqIds []       = ()
 584 seqIds (id:ids) = seqId id `seq` seqIds ids
 585 \end{code}
 586
 587 %************************************************************************
 588 %*                                                                      *
 589                 Let bindings
 590 %*                                                                      *
 591 %************************************************************************
 592
 593 Simplifying let binders
 594 ~~~~~~~~~~~~~~~~~~~~~~~
 595 Rename the binders if necessary,
 596
 597 \begin{code}
 598 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 599 simplNonRecBndr env id
 600   = do  { let (env1, id1) = substLetIdBndr env id
 601         ; seqId id1 `seq` return (env1, id1) }
 602
 603 ---------------
 604 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
 605 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
 606   = do  { let (env1, ids1) = mapAccumL substLetIdBndr env ids
 607         ; seqIds ids1 `seq` return env1 }
 608
 609 ---------------
 610 substLetIdBndr :: SimplEnv -> InBndr    -- Env and binder to transform
 611                -> (SimplEnv, OutBndr)
 612 -- C.f. substIdBndr above
 613 -- Clone Id if necessary, substitute its type
 614 -- Return an Id with its fragile info zapped
 615 --      namely, any info that depends on free variables
 616 --      [addLetIdInfo, below, will restore its IdInfo]
 617 --      We want to retain robust info, especially arity and demand info,
 618 --      so that they are available to occurrences that occur in an
 619 --      earlier binding of a letrec
 620 -- Augment the subtitution
 621 --      if the unique changed, *or*
 622 --      if there's interesting occurrence info
 623
 624 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
 625   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 626            seIdSubst = new_subst }, new_id)
 627   where
 628     id1    = uniqAway in_scope old_id
 629     id2    = substIdType env id1
 630
 631     -- We want to get rid of any info that's dependent on free variables,
 632     -- but keep other info (like the arity).
 633     new_id = zapFragileIdInfo id2
 634
 635         -- Extend the substitution if the unique has changed,
 636         -- or there's some useful occurrence information
 637         -- See the notes with substTyVarBndr for the delSubstEnv
 638     new_subst | new_id /= old_id
 639               = extendVarEnv id_subst old_id (DoneId new_id)
 640               | otherwise
 641               = delVarEnv id_subst old_id
 642 \end{code}
 643
 644 Note [Add IdInfo back onto a let-bound Id]
 645 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 646 We must transfer the IdInfo of the original binder to the new binder.
 647 This is crucial, to preserve
 648         strictness
 649         rules
 650         worker info
 651 etc.  To do this we must apply the current substitution,
 652 which incorporates earlier substitutions in this very letrec group.
 653
 654 NB 1. We do this *before* processing the RHS of the binder, so that
 655 its substituted rules are visible in its own RHS.
 656 This is important.  Manuel found cases where he really, really
 657 wanted a RULE for a recursive function to apply in that function's
 658 own right-hand side.
 659
 660 NB 2: ARITY.  We *do* transfer the arity.  This is important, so that
 661 the arity of an Id is visible in its own RHS.  For example:
 662         f = \x. ....g (\y. f y)....
 663 We can eta-reduce the arg to g, becuase f is a value.  But that
 664 needs to be visible.
 665
 666 This interacts with the 'state hack' too:
 667         f :: Bool -> IO Int
 668         f = \x. case x of
 669                   True  -> f y
 670                   False -> \s -> ...
 671 Can we eta-expand f?  Only if we see that f has arity 1, and then we
 672 take advantage of the 'state hack' on the result of
 673 (f y) :: State# -> (State#, Int) to expand the arity one more.
 674
 675 There is a disadvantage though.  Making the arity visible in the RHA
 676 allows us to eta-reduce
 677         f = \x -> f x
 678 to
 679         f = f
 680 which technically is not sound.   This is very much a corner case, so
 681 I'm not worried about it.  Another idea is to ensure that f's arity
 682 never decreases; its arity started as 1, and we should never eta-reduce
 683 below that.
 684
 685 NB 3: OccInfo.  It's important that we *do* transer the loop-breaker
 686 OccInfo, because that's what stops the Id getting inlined infinitely,
 687 in the body of the letrec.
 688
 689 NB 4: does no harm for non-recursive bindings
 690
 691 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
 692         rec { f = g
 693               h = ...
 694                 RULE h Int = f
 695         }
 696 Here, we'll do postInlineUnconditionally on f, and we must "see" that
 697 when substituting in h's RULE.
 698
 699 \begin{code}
 700 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
 701 addLetIdInfo env in_id out_id
 702   = (modifyInScope env out_id final_id, final_id)
 703   where
 704     final_id = out_id `setIdInfo` new_info
 705     subst = mkCoreSubst env
 706     old_info = idInfo in_id
 707     new_info = case substIdInfo subst old_info of
 708                   Nothing       -> old_info
 709                   Just new_info -> new_info
 710
 711 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 712 -- Substitute the
 713 --      rules
 714 --      worker info
 715 -- Zap the unfolding
 716 -- Keep only 'robust' OccInfo
 717 --           arity
 718 --
 719 -- Seq'ing on the returned IdInfo is enough to cause all the
 720 -- substitutions to happen completely
 721
 722 substIdInfo subst info
 723   | nothing_to_do = Nothing
 724   | otherwise     = Just (info `setOccInfo`       (if keep_occ then old_occ else NoOccInfo)
 725                                `setSpecInfo`      CoreSubst.substSpec   subst old_rules
 726                                `setWorkerInfo`    CoreSubst.substWorker subst old_wrkr
 727                                `setUnfoldingInfo` noUnfolding)
 728                         -- setSpecInfo does a seq
 729                         -- setWorkerInfo does a seq
 730   where
 731     nothing_to_do = keep_occ &&
 732                     isEmptySpecInfo old_rules &&
 733                     not (workerExists old_wrkr) &&
 734                     not (hasUnfolding (unfoldingInfo info))
 735
 736     keep_occ  = not (isFragileOcc old_occ)
 737     old_occ   = occInfo info
 738     old_rules = specInfo info
 739     old_wrkr  = workerInfo info
 740
 741 ------------------
 742 substIdType :: SimplEnv -> Id -> Id
 743 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 744   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 745   | otherwise   = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 746                 -- The tyVarsOfType is cheaper than it looks
 747                 -- because we cache the free tyvars of the type
 748                 -- in a Note in the id's type itself
 749   where
 750     old_ty = idType id
 751
 752 ------------------
 753 substUnfolding env NoUnfolding                 = NoUnfolding
 754 substUnfolding env (OtherCon cons)             = OtherCon cons
 755 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
 756 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
 757 \end{code}
 758
 759
 760 %************************************************************************
 761 %*                                                                      *
 762                 Impedence matching to type substitution
 763 %*                                                                      *
 764 %************************************************************************
 765
 766 \begin{code}
 767 substTy :: SimplEnv -> Type -> Type
 768 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
 769   = Type.substTy (TvSubst in_scope tv_env) ty
 770
 771 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 772 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
 773   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 774         (TvSubst in_scope' tv_env', tv')
 775            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 776
 777 -- When substituting in rules etc we can get CoreSubst to do the work
 778 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
 779 -- here.  I think the this will not usually result in a lot of work;
 780 -- the substitutions are typically small, and laziness will avoid work in many cases.
 781
 782 mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
 783 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
 784   = mk_subst tv_env id_env
 785   where
 786     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 787
 788     fiddle (DoneEx e)       = e
 789     fiddle (DoneId v)       = Var v
 790     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 791
 792 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
 793 substExpr env expr
 794   | isEmptySimplSubst env = expr
 795   | otherwise             = CoreSubst.substExpr (mkCoreSubst env) expr
 796 \end{code}
 797