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