compiler/simplCore/SimplEnv.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[SimplMonad]{The simplifier Monad}
   5
   6 \begin{code}
   7 module SimplEnv (
   8         InId, InBind, InExpr, InAlt, InArg, InType, InBndr,
   9         OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr,
  10         InCoercion, OutCoercion,
  11
  12         -- The simplifier mode
  13         setMode, getMode,
  14
  15         -- Switch checker
  16         SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
  17         isAmongSimpl, intSwitchSet, switchIsOn,
  18
  19         setEnclosingCC, getEnclosingCC,
  20
  21         -- Environments
  22         SimplEnv(..), pprSimplEnv,      -- Temp not abstract
  23         mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
  24         zapSubstEnv, setSubstEnv,
  25         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
  26         getRules,
  27
  28         SimplSR(..), mkContEx, substId, lookupRecBndr,
  29
  30         simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
  31         simplBinder, simplBinders, addLetIdInfo,
  32         substExpr, substTy,
  33
  34         -- Floats
  35         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
  36         wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats,
  37         doFloatFromRhs, getFloats
  38     ) where
  39
  40 #include "HsVersions.h"
  41
  42 import SimplMonad
  43 import IdInfo
  44 import CoreSyn
  45 import Rules
  46 import CoreUtils
  47 import CostCentre
  48 import Var
  49 import VarEnv
  50 import VarSet
  51 import OrdList
  52 import Id
  53 import qualified CoreSubst      ( Subst, mkSubst, substExpr, substSpec, substWorker )
  54 import qualified Type           ( substTy, substTyVarBndr )
  55 import Type hiding              ( substTy, substTyVarBndr )
  56 import Coercion
  57 import BasicTypes
  58 import DynFlags
  59 import Util
  60 import Outputable
  61 \end{code}
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection[Simplify-types]{Type declarations}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 type InBndr     = CoreBndr
  71 type InId       = Id                    -- Not yet cloned
  72 type InType     = Type                  -- Ditto
  73 type InBind     = CoreBind
  74 type InExpr     = CoreExpr
  75 type InAlt      = CoreAlt
  76 type InArg      = CoreArg
  77 type InCoercion = Coercion
  78
  79 type OutBndr     = CoreBndr
  80 type OutId       = Id                   -- Cloned
  81 type OutTyVar    = TyVar                -- Cloned
  82 type OutType     = Type                 -- Cloned
  83 type OutCoercion = Coercion
  84 type OutBind     = CoreBind
  85 type OutExpr     = CoreExpr
  86 type OutAlt      = CoreAlt
  87 type OutArg      = CoreArg
  88 \end{code}
  89
  90 %************************************************************************
  91 %*                                                                      *
  92 \subsubsection{The @SimplEnv@ type}
  93 %*                                                                      *
  94 %************************************************************************
  95
  96
  97 \begin{code}
  98 data SimplEnv
  99   = SimplEnv {
 100         seMode      :: SimplifierMode,
 101         seChkr      :: SwitchChecker,
 102         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 103
 104         -- The current set of in-scope variables
 105         -- They are all OutVars, and all bound in this module
 106         seInScope   :: InScopeSet,      -- OutVars only
 107                 -- Includes all variables bound by seFloats
 108         seFloats    :: Floats,
 109                 -- See Note [Simplifier floats]
 110
 111         -- The current substitution
 112         seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
 113         seIdSubst   :: SimplIdSubst     -- InId    |--> OutExpr
 114
 115     }
 116
 117 pprSimplEnv :: SimplEnv -> SDoc
 118 -- Used for debugging; selective
 119 pprSimplEnv env
 120   = vcat [ptext SLIT("TvSubst:") <+> ppr (seTvSubst env),
 121           ptext SLIT("IdSubst:") <+> ppr (seIdSubst env) ]
 122
 123 type SimplIdSubst = IdEnv SimplSR       -- IdId |--> OutExpr
 124         -- See Note [Extending the Subst] in CoreSubst
 125
 126 data SimplSR
 127   = DoneEx OutExpr              -- Completed term
 128   | DoneId OutId                -- Completed term variable
 129   | ContEx TvSubstEnv           -- A suspended substitution
 130            SimplIdSubst
 131            InExpr
 132
 133 instance Outputable SimplSR where
 134   ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e
 135   ppr (DoneId v) = ptext SLIT("DoneId") <+> ppr v
 136   ppr (ContEx tv id e) = vcat [ptext SLIT("ContEx") <+> ppr e {-,
 137                                 ppr (filter_env tv), ppr (filter_env id) -}]
 138         -- where
 139         -- fvs = exprFreeVars e
 140         -- filter_env env = filterVarEnv_Directly keep env
 141         -- keep uniq _ = uniq `elemUFM_Directly` fvs
 142 \end{code}
 143
 144
 145 seInScope:
 146         The in-scope part of Subst includes *all* in-scope TyVars and Ids
 147         The elements of the set may have better IdInfo than the
 148         occurrences of in-scope Ids, and (more important) they will
 149         have a correctly-substituted type.  So we use a lookup in this
 150         set to replace occurrences
 151
 152         The Ids in the InScopeSet are replete with their Rules,
 153         and as we gather info about the unfolding of an Id, we replace
 154         it in the in-scope set.
 155
 156         The in-scope set is actually a mapping OutVar -> OutVar, and
 157         in case expressions we sometimes bind
 158
 159 seIdSubst:
 160         The substitution is *apply-once* only, because InIds and OutIds can overlap.
 161         For example, we generally omit mappings
 162                 a77 -> a77
 163         from the substitution, when we decide not to clone a77, but it's quite
 164         legitimate to put the mapping in the substitution anyway.
 165
 166         Furthermore, consider
 167                 let x = case k of I# x77 -> ... in
 168                 let y = case k of I# x77 -> ... in ...
 169         and suppose the body is strict in both x and y.  Then the simplifier
 170         will pull the first (case k) to the top; so the second (case k) will
 171         cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
 172         other is an out-Id.
 173
 174         Of course, the substitution *must* applied! Things in its domain
 175         simply aren't necessarily bound in the result.
 176
 177 * substId adds a binding (DoneId new_id) to the substitution if
 178         the Id's unique has changed
 179
 180
 181   Note, though that the substitution isn't necessarily extended
 182   if the type changes.  Why not?  Because of the next point:
 183
 184 * We *always, always* finish by looking up in the in-scope set
 185   any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
 186   Reason: so that we never finish up with a "old" Id in the result.
 187   An old Id might point to an old unfolding and so on... which gives a space leak.
 188
 189   [The DoneEx and DoneVar hits map to "new" stuff.]
 190
 191 * It follows that substExpr must not do a no-op if the substitution is empty.
 192   substType is free to do so, however.
 193
 194 * When we come to a let-binding (say) we generate new IdInfo, including an
 195   unfolding, attach it to the binder, and add this newly adorned binder to
 196   the in-scope set.  So all subsequent occurrences of the binder will get mapped
 197   to the full-adorned binder, which is also the one put in the binding site.
 198
 199 * The in-scope "set" usually maps x->x; we use it simply for its domain.
 200   But sometimes we have two in-scope Ids that are synomyms, and should
 201   map to the same target:  x->x, y->x.  Notably:
 202         case y of x { ... }
 203   That's why the "set" is actually a VarEnv Var
 204
 205
 206 \begin{code}
 207 mkSimplEnv :: SimplifierMode -> SwitchChecker -> SimplEnv
 208 mkSimplEnv mode switches
 209   = SimplEnv { seChkr = switches, seCC = subsumedCCS,
 210                seMode = mode, seInScope = emptyInScopeSet,
 211                seFloats = emptyFloats,
 212                seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
 213         -- The top level "enclosing CC" is "SUBSUMED".
 214
 215 ---------------------
 216 getSwitchChecker :: SimplEnv -> SwitchChecker
 217 getSwitchChecker env = seChkr env
 218
 219 ---------------------
 220 getMode :: SimplEnv -> SimplifierMode
 221 getMode env = seMode env
 222
 223 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
 224 setMode mode env = env { seMode = mode }
 225
 226 ---------------------
 227 getEnclosingCC :: SimplEnv -> CostCentreStack
 228 getEnclosingCC env = seCC env
 229
 230 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
 231 setEnclosingCC env cc = env {seCC = cc}
 232
 233 ---------------------
 234 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
 235 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
 236   = env {seIdSubst = extendVarEnv subst var res}
 237
 238 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 239 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
 240   = env {seTvSubst = extendVarEnv subst var res}
 241
 242 ---------------------
 243 getInScope :: SimplEnv -> InScopeSet
 244 getInScope env = seInScope env
 245
 246 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 247 setInScopeSet env in_scope = env {seInScope = in_scope}
 248
 249 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
 250 -- Set the in-scope set, and *zap* the floats
 251 setInScope env env_with_scope
 252   = env { seInScope = seInScope env_with_scope,
 253           seFloats = emptyFloats }
 254
 255 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
 256 -- Set the in-scope set *and* the floats
 257 setFloats env env_with_floats
 258   = env { seInScope = seInScope env_with_floats,
 259           seFloats  = seFloats  env_with_floats }
 260
 261 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
 262         -- The new Ids are guaranteed to be freshly allocated
 263 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
 264   = env { seInScope = in_scope `extendInScopeSetList` vs,
 265           seIdSubst = id_subst `delVarEnvList` vs }
 266         -- Why delete?  Consider
 267         --      let x = a*b in (x, \x -> x+3)
 268         -- We add [x |-> a*b] to the substitution, but we must
 269         -- *delete* it from the substitution when going inside
 270         -- the (\x -> ...)!
 271
 272 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
 273 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
 274   = env {seInScope = modifyInScopeSet in_scope v v'}
 275
 276 ---------------------
 277 zapSubstEnv :: SimplEnv -> SimplEnv
 278 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
 279
 280 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
 281 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
 282
 283 mkContEx :: SimplEnv -> InExpr -> SimplSR
 284 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
 285
 286 isEmptySimplSubst :: SimplEnv -> Bool
 287 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
 288   = isEmptyVarEnv tvs && isEmptyVarEnv ids
 289 \end{code}
 290
 291
 292
 293 %************************************************************************
 294 %*                                                                      *
 295 \subsection{Floats}
 296 %*                                                                      *
 297 %************************************************************************
 298
 299 Note [Simplifier floats]
 300 ~~~~~~~~~~~~~~~~~~~~~~~~~
 301 The Floats is a bunch of bindings, classified by a FloatFlag.
 302
 303   NonRec x (y:ys)       FltLifted
 304   Rec [(x,rhs)]         FltLifted
 305
 306   NonRec x# (y +# 3)    FltOkSpec       -- Unboxed, but ok-for-spec'n
 307
 308   NonRec x# (a /# b)    FltCareful
 309   NonRec x* (f y)       FltCareful      -- Strict binding; might fail or diverge
 310   NonRec x# (f y)       FltCareful      -- Unboxed binding: might fail or diverge
 311                                         --        (where f :: Int -> Int#)
 312
 313 \begin{code}
 314 data Floats = Floats (OrdList OutBind) FloatFlag
 315         -- See Note [Simplifier floats]
 316
 317 data FloatFlag
 318   = FltLifted   -- All bindings are lifted and lazy
 319                 --  Hence ok to float to top level, or recursive
 320
 321   | FltOkSpec   -- All bindings are FltLifted *or*
 322                 --      strict (perhaps because unlifted,
 323                 --      perhaps because of a strict binder),
 324                 --        *and* ok-for-speculation
 325                 --  Hence ok to float out of the RHS
 326                 --  of a lazy non-recursive let binding
 327                 --  (but not to top level, or into a rec group)
 328
 329   | FltCareful  -- At least one binding is strict (or unlifted)
 330                 --      and not guaranteed cheap
 331                 --      Do not float these bindings out of a lazy let
 332
 333 instance Outputable Floats where
 334   ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
 335
 336 instance Outputable FloatFlag where
 337   ppr FltLifted = ptext SLIT("FltLifted")
 338   ppr FltOkSpec = ptext SLIT("FltOkSpec")
 339   ppr FltCareful = ptext SLIT("FltCareful")
 340
 341 andFF :: FloatFlag -> FloatFlag -> FloatFlag
 342 andFF FltCareful _          = FltCareful
 343 andFF FltOkSpec  FltCareful = FltCareful
 344 andFF FltOkSpec  flt        = FltOkSpec
 345 andFF FltLifted  flt        = flt
 346
 347 classifyFF :: CoreBind -> FloatFlag
 348 classifyFF (Rec _) = FltLifted
 349 classifyFF (NonRec bndr rhs)
 350   | not (isStrictId bndr)    = FltLifted
 351   | exprOkForSpeculation rhs = FltOkSpec
 352   | otherwise                = FltCareful
 353
 354 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 355 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
 356   =  not (isNilOL fs) && want_to_float && can_float
 357   where
 358      want_to_float = isTopLevel lvl || exprIsCheap rhs
 359      can_float = case ff of
 360                    FltLifted  -> True
 361                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
 362                    FltCareful -> isNotTopLevel lvl && isNonRec rec && str
 363 \end{code}
 364
 365
 366 \begin{code}
 367 emptyFloats :: Floats
 368 emptyFloats = Floats nilOL FltLifted
 369
 370 unitFloat :: OutBind -> Floats
 371 -- A single-binding float
 372 unitFloat bind = Floats (unitOL bind) (classifyFF bind)
 373
 374 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 375 -- Add a non-recursive binding and extend the in-scope set
 376 -- The latter is important; the binder may already be in the
 377 -- in-scope set (although it might also have been created with newId)
 378 -- but it may now have more IdInfo
 379 addNonRec env id rhs
 380   = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
 381           seInScope = extendInScopeSet (seInScope env) id }
 382
 383 extendFloats :: SimplEnv -> [OutBind] -> SimplEnv
 384 -- Add these bindings to the floats, and extend the in-scope env too
 385 extendFloats env binds
 386   = env { seFloats  = seFloats env `addFlts` new_floats,
 387           seInScope = extendInScopeSetList (seInScope env) bndrs }
 388   where
 389     bndrs = bindersOfBinds binds
 390     new_floats = Floats (toOL binds)
 391                         (foldr (andFF . classifyFF) FltLifted binds)
 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 its fragile info zapped
 606 --      namely, any info that depends on free variables
 607 --      [addLetIdInfo, below, will restore its IdInfo]
 608 --      We want to retain robust info, especially arity and demand info,
 609 --      so that they are available to occurrences that occur in an
 610 --      earlier binding of a letrec
 611 -- Augment the subtitution
 612 --      if the unique changed, *or*
 613 --      if there's interesting occurrence info
 614
 615 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
 616   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 617            seIdSubst = new_subst }, new_id)
 618   where
 619     id1    = uniqAway in_scope old_id
 620     id2    = substIdType env id1
 621
 622     -- We want to get rid of any info that's dependent on free variables,
 623     -- but keep other info (like the arity).
 624     new_id = zapFragileIdInfo id2
 625
 626         -- Extend the substitution if the unique has changed,
 627         -- or there's some useful occurrence information
 628         -- See the notes with substTyVarBndr for the delSubstEnv
 629     new_subst | new_id /= old_id
 630               = extendVarEnv id_subst old_id (DoneId new_id)
 631               | otherwise
 632               = delVarEnv id_subst old_id
 633 \end{code}
 634
 635 Note [Add IdInfo back onto a let-bound Id]
 636 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 637 We must transfer the IdInfo of the original binder to the new binder.
 638 This is crucial, to preserve
 639         strictness
 640         rules
 641         worker info
 642 etc.  To do this we must apply the current substitution,
 643 which incorporates earlier substitutions in this very letrec group.
 644
 645 NB 1. We do this *before* processing the RHS of the binder, so that
 646 its substituted rules are visible in its own RHS.
 647 This is important.  Manuel found cases where he really, really
 648 wanted a RULE for a recursive function to apply in that function's
 649 own right-hand side.
 650
 651 NB 2: ARITY.  We *do* transfer the arity.  This is important, so that
 652 the arity of an Id is visible in its own RHS.  For example:
 653         f = \x. ....g (\y. f y)....
 654 We can eta-reduce the arg to g, becuase f is a value.  But that
 655 needs to be visible.
 656
 657 This interacts with the 'state hack' too:
 658         f :: Bool -> IO Int
 659         f = \x. case x of
 660                   True  -> f y
 661                   False -> \s -> ...
 662 Can we eta-expand f?  Only if we see that f has arity 1, and then we
 663 take advantage of the 'state hack' on the result of
 664 (f y) :: State# -> (State#, Int) to expand the arity one more.
 665
 666 There is a disadvantage though.  Making the arity visible in the RHA
 667 allows us to eta-reduce
 668         f = \x -> f x
 669 to
 670         f = f
 671 which technically is not sound.   This is very much a corner case, so
 672 I'm not worried about it.  Another idea is to ensure that f's arity
 673 never decreases; its arity started as 1, and we should never eta-reduce
 674 below that.
 675
 676 NB 3: OccInfo.  It's important that we *do* transer the loop-breaker
 677 OccInfo, because that's what stops the Id getting inlined infinitely,
 678 in the body of the letrec.
 679
 680 NB 4: does no harm for non-recursive bindings
 681
 682 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
 683         rec { f = g
 684               h = ...
 685                 RULE h Int = f
 686         }
 687 Here, we'll do postInlineUnconditionally on f, and we must "see" that
 688 when substituting in h's RULE.
 689
 690 \begin{code}
 691 addLetIdInfo :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
 692 addLetIdInfo env in_id out_id
 693   = (modifyInScope env out_id final_id, final_id)
 694   where
 695     final_id = out_id `setIdInfo` new_info
 696     subst = mkCoreSubst env
 697     old_info = idInfo in_id
 698     new_info = case substIdInfo subst old_info of
 699                   Nothing       -> old_info
 700                   Just new_info -> new_info
 701
 702 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 703 -- Substitute the
 704 --      rules
 705 --      worker info
 706 -- Zap the unfolding
 707 -- Keep only 'robust' OccInfo
 708 --           arity
 709 --
 710 -- Seq'ing on the returned IdInfo is enough to cause all the
 711 -- substitutions to happen completely
 712
 713 substIdInfo subst info
 714   | nothing_to_do = Nothing
 715   | otherwise     = Just (info `setOccInfo`       (if keep_occ then old_occ else NoOccInfo)
 716                                `setSpecInfo`      CoreSubst.substSpec   subst old_rules
 717                                `setWorkerInfo`    CoreSubst.substWorker subst old_wrkr
 718                                `setUnfoldingInfo` noUnfolding)
 719                         -- setSpecInfo does a seq
 720                         -- setWorkerInfo does a seq
 721   where
 722     nothing_to_do = keep_occ &&
 723                     isEmptySpecInfo old_rules &&
 724                     not (workerExists old_wrkr) &&
 725                     not (hasUnfolding (unfoldingInfo info))
 726
 727     keep_occ  = not (isFragileOcc old_occ)
 728     old_occ   = occInfo info
 729     old_rules = specInfo info
 730     old_wrkr  = workerInfo info
 731
 732 ------------------
 733 substIdType :: SimplEnv -> Id -> Id
 734 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 735   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 736   | otherwise   = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 737                 -- The tyVarsOfType is cheaper than it looks
 738                 -- because we cache the free tyvars of the type
 739                 -- in a Note in the id's type itself
 740   where
 741     old_ty = idType id
 742
 743 ------------------
 744 substUnfolding env NoUnfolding                 = NoUnfolding
 745 substUnfolding env (OtherCon cons)             = OtherCon cons
 746 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
 747 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
 748 \end{code}
 749
 750
 751 %************************************************************************
 752 %*                                                                      *
 753                 Impedence matching to type substitution
 754 %*                                                                      *
 755 %************************************************************************
 756
 757 \begin{code}
 758 substTy :: SimplEnv -> Type -> Type
 759 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
 760   = Type.substTy (TvSubst in_scope tv_env) ty
 761
 762 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 763 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
 764   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 765         (TvSubst in_scope' tv_env', tv')
 766            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 767
 768 -- When substituting in rules etc we can get CoreSubst to do the work
 769 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
 770 -- here.  I think the this will not usually result in a lot of work;
 771 -- the substitutions are typically small, and laziness will avoid work in many cases.
 772
 773 mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
 774 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
 775   = mk_subst tv_env id_env
 776   where
 777     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 778
 779     fiddle (DoneEx e)       = e
 780     fiddle (DoneId v)       = Var v
 781     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 782
 783 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
 784 substExpr env expr
 785   | isEmptySimplSubst env = expr
 786   | otherwise             = CoreSubst.substExpr (mkCoreSubst env) expr
 787 \end{code}
 788