ghc/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, InBinder,
   9         OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
  10
  11         -- The simplifier mode
  12         setMode, getMode,
  13
  14         -- Switch checker
  15         SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
  16         isAmongSimpl, intSwitchSet, switchIsOn,
  17
  18         setEnclosingCC, getEnclosingCC,
  19
  20         -- Environments
  21         SimplEnv, mkSimplEnv, extendIdSubst, extendTvSubst,
  22         zapSubstEnv, setSubstEnv,
  23         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
  24         getRules, refineSimplEnv,
  25
  26         SimplSR(..), mkContEx, substId,
  27
  28         simplLetBndr, simplLetBndrs, simplLamBndr, simplLamBndrs,
  29         simplBinder, simplBinders,
  30         simplIdInfo, substExpr, substTy,
  31
  32         -- Floats
  33         FloatsWith, FloatsWithExpr,
  34         Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
  35         allLifted, wrapFloats, floatBinds,
  36         addAuxiliaryBind,
  37     ) where
  38
  39 #include "HsVersions.h"
  40
  41 import SimplMonad
  42 import Id               ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
  43 import IdInfo           ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
  44                           arityInfo, setArityInfo, workerInfo, setWorkerInfo,
  45                           unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
  46                           unknownArity, workerExists
  47                             )
  48 import CoreSyn
  49 import Unify            ( TypeRefinement )
  50 import Rules            ( RuleBase )
  51 import CoreUtils        ( needsCaseBinding )
  52 import CostCentre       ( CostCentreStack, subsumedCCS )
  53 import Var
  54 import VarEnv
  55 import VarSet           ( isEmptyVarSet )
  56 import OrdList
  57
  58 import qualified CoreSubst      ( Subst, mkSubst, substExpr, substSpec, substWorker )
  59 import qualified Type           ( substTy, substTyVarBndr )
  60
  61 import Type             ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
  62                           isUnLiftedType, seqType, tyVarsOfType )
  63 import BasicTypes       ( OccInfo(..), isFragileOcc )
  64 import DynFlags ( SimplifierMode(..) )
  65 import Outputable
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection[Simplify-types]{Type declarations}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 type InBinder  = 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
  83 type OutBinder  = CoreBndr
  84 type OutId      = Id                    -- Cloned
  85 type OutTyVar   = TyVar                 -- Cloned
  86 type OutType    = Type                  -- Cloned
  87 type OutBind    = CoreBind
  88 type OutExpr    = CoreExpr
  89 type OutAlt     = CoreAlt
  90 type OutArg     = CoreArg
  91 \end{code}
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsubsection{The @SimplEnv@ type}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99
 100 \begin{code}
 101 data SimplEnv
 102   = SimplEnv {
 103         seMode      :: SimplifierMode,
 104         seChkr      :: SwitchChecker,
 105         seCC        :: CostCentreStack, -- The enclosing CCS (when profiling)
 106
 107         -- Rules from other modules
 108         seExtRules  :: RuleBase,
 109
 110         -- The current set of in-scope variables
 111         -- They are all OutVars, and all bound in this module
 112         seInScope   :: InScopeSet,      -- OutVars only
 113
 114         -- The current substitution
 115         seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
 116         seIdSubst   :: SimplIdSubst     -- InId    |--> OutExpr
 117     }
 118
 119 type SimplIdSubst = IdEnv SimplSR       -- IdId |--> OutExpr
 120
 121 data SimplSR
 122   = DoneEx OutExpr              -- Completed term
 123   | DoneId OutId OccInfo        -- Completed term variable, with occurrence info
 124   | ContEx TvSubstEnv           -- A suspended substitution
 125            SimplIdSubst
 126            InExpr
 127 \end{code}
 128
 129
 130 seInScope:
 131         The in-scope part of Subst includes *all* in-scope TyVars and Ids
 132         The elements of the set may have better IdInfo than the
 133         occurrences of in-scope Ids, and (more important) they will
 134         have a correctly-substituted type.  So we use a lookup in this
 135         set to replace occurrences
 136
 137         The Ids in the InScopeSet are replete with their Rules,
 138         and as we gather info about the unfolding of an Id, we replace
 139         it in the in-scope set.
 140
 141         The in-scope set is actually a mapping OutVar -> OutVar, and
 142         in case expressions we sometimes bind
 143
 144 seIdSubst:
 145         The substitution is *apply-once* only, because InIds and OutIds can overlap.
 146         For example, we generally omit mappings
 147                 a77 -> a77
 148         from the substitution, when we decide not to clone a77, but it's quite
 149         legitimate to put the mapping in the substitution anyway.
 150
 151         Indeed, we do so when we want to pass fragile OccInfo to the
 152         occurrences of the variable; we add a substitution
 153                 x77 -> DoneId x77 occ
 154         to record x's occurrence information.]
 155
 156         Furthermore, consider
 157                 let x = case k of I# x77 -> ... in
 158                 let y = case k of I# x77 -> ... in ...
 159         and suppose the body is strict in both x and y.  Then the simplifier
 160         will pull the first (case k) to the top; so the second (case k) will
 161         cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
 162         other is an out-Id.
 163
 164         Of course, the substitution *must* applied! Things in its domain
 165         simply aren't necessarily bound in the result.
 166
 167 * substId adds a binding (DoneId new_id occ) to the substitution if
 168         EITHER the Id's unique has changed
 169         OR     the Id has interesting occurrence information
 170   So in effect you can only get to interesting occurrence information
 171   by looking up the *old* Id; it's not really attached to the new id
 172   at all.
 173
 174   Note, though that the substitution isn't necessarily extended
 175   if the type changes.  Why not?  Because of the next point:
 176
 177 * We *always, always* finish by looking up in the in-scope set
 178   any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
 179   Reason: so that we never finish up with a "old" Id in the result.
 180   An old Id might point to an old unfolding and so on... which gives a space leak.
 181
 182   [The DoneEx and DoneVar hits map to "new" stuff.]
 183
 184 * It follows that substExpr must not do a no-op if the substitution is empty.
 185   substType is free to do so, however.
 186
 187 * When we come to a let-binding (say) we generate new IdInfo, including an
 188   unfolding, attach it to the binder, and add this newly adorned binder to
 189   the in-scope set.  So all subsequent occurrences of the binder will get mapped
 190   to the full-adorned binder, which is also the one put in the binding site.
 191
 192 * The in-scope "set" usually maps x->x; we use it simply for its domain.
 193   But sometimes we have two in-scope Ids that are synomyms, and should
 194   map to the same target:  x->x, y->x.  Notably:
 195         case y of x { ... }
 196   That's why the "set" is actually a VarEnv Var
 197
 198
 199 Note [GADT type refinement]
 200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 201 When we come to a GADT pattern match that refines the in-scope types, we
 202   a) Refine the types of the Ids in the in-scope set, seInScope.
 203      For exmaple, consider
 204         data T a where
 205                 Foo :: T (Bool -> Bool)
 206
 207         (\ (x::T a) (y::a) -> case x of { Foo -> y True }
 208
 209      Technically this is well-typed, but exprType will barf on the
 210      (y True) unless we refine the type on y's occurrence.
 211
 212   b) Refine the range of the type substitution, seTvSubst.
 213      Very similar reason to (a).
 214
 215   NB: we don't refine the range of the SimplIdSubst, because it's always
 216   interpreted relative to the seInScope (see substId)
 217
 218 For (b) we need to be a little careful.  Specifically, we compose the refinement
 219 with the type substitution.  Suppose
 220   The substitution was    [a->b, b->a]
 221   and the refinement was  [b->Int]
 222   Then we want [a->Int, b->a]
 223
 224 But also if
 225   The substitution was    [a->b]
 226   and the refinement was  [b->Int]
 227   Then we want [a->Int, b->Int]
 228         becuase b might be both an InTyVar and OutTyVar
 229
 230
 231 \begin{code}
 232 mkSimplEnv :: SimplifierMode -> SwitchChecker -> RuleBase -> SimplEnv
 233 mkSimplEnv mode switches rules
 234   = SimplEnv { seChkr = switches, seCC = subsumedCCS,
 235                seMode = mode, seInScope = emptyInScopeSet,
 236                seExtRules = rules,
 237                seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv }
 238         -- The top level "enclosing CC" is "SUBSUMED".
 239
 240 ---------------------
 241 getSwitchChecker :: SimplEnv -> SwitchChecker
 242 getSwitchChecker env = seChkr env
 243
 244 ---------------------
 245 getMode :: SimplEnv -> SimplifierMode
 246 getMode env = seMode env
 247
 248 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
 249 setMode mode env = env { seMode = mode }
 250
 251 ---------------------
 252 getEnclosingCC :: SimplEnv -> CostCentreStack
 253 getEnclosingCC env = seCC env
 254
 255 setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
 256 setEnclosingCC env cc = env {seCC = cc}
 257
 258 ---------------------
 259 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
 260 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
 261   = env {seIdSubst = extendVarEnv subst var res}
 262
 263 extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 264 extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
 265   = env {seTvSubst = extendVarEnv subst var res}
 266
 267 ---------------------
 268 getInScope :: SimplEnv -> InScopeSet
 269 getInScope env = seInScope env
 270
 271 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 272 setInScopeSet env in_scope = env {seInScope = in_scope}
 273
 274 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
 275 setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
 276
 277 addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
 278         -- The new Ids are guaranteed to be freshly allocated
 279 addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
 280   = env { seInScope = in_scope `extendInScopeSetList` vs,
 281           seIdSubst = id_subst `delVarEnvList` vs }     -- Why delete?
 282
 283 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
 284 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
 285   = env {seInScope = modifyInScopeSet in_scope v v'}
 286
 287 ---------------------
 288 zapSubstEnv :: SimplEnv -> SimplEnv
 289 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
 290
 291 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
 292 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
 293
 294 mkContEx :: SimplEnv -> InExpr -> SimplSR
 295 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
 296
 297 isEmptySimplSubst :: SimplEnv -> Bool
 298 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
 299   = isEmptyVarEnv tvs && isEmptyVarEnv ids
 300
 301 ---------------------
 302 getRules :: SimplEnv -> RuleBase
 303 getRules = seExtRules
 304 \end{code}
 305
 306                 GADT stuff
 307
 308 Given an idempotent substitution, generated by the unifier, use it to
 309 refine the environment
 310
 311 \begin{code}
 312 refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
 313 -- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
 314 refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
 315                (refine_tv_subst, all_bound_here)
 316   = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
 317           seInScope = in_scope' }
 318   where
 319     in_scope'
 320         | all_bound_here = in_scope
 321                 -- The tvs are the tyvars bound here.  If only they
 322                 -- are refined, there's no need to do anything
 323         | otherwise = mapInScopeSet refine_id in_scope
 324
 325     refine_id v         -- Only refine its type; any rules will get
 326                         -- refined if they are used (I hope)
 327         | isId v    = setIdType v (Type.substTy refine_subst (idType v))
 328         | otherwise = v
 329     refine_subst = TvSubst in_scope refine_tv_subst
 330 \end{code}
 331
 332 %************************************************************************
 333 %*                                                                      *
 334                 Substitution of Vars
 335 %*                                                                      *
 336 %************************************************************************
 337
 338
 339 \begin{code}
 340 substId :: SimplEnv -> Id -> SimplSR
 341 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 342   | not (isLocalId v)
 343   = DoneId v NoOccInfo
 344   | otherwise   -- A local Id
 345   = case lookupVarEnv ids v of
 346         Just (DoneId v occ) -> DoneId (refine v) occ
 347         Just res            -> res
 348         Nothing             -> let v' = refine v
 349                                in DoneId v' (idOccInfo v')
 350                 -- We don't put LoopBreakers in the substitution (unless then need
 351                 -- to be cloned for name-clash rasons), so the idOccInfo is
 352                 -- very important!  If isFragileOcc returned True for
 353                 -- loop breakers we could avoid this call, but at the expense
 354                 -- of adding more to the substitution, and building new Ids
 355                 -- a bit more often than really necessary
 356   where
 357         -- Get the most up-to-date thing from the in-scope set
 358         -- Even though it isn't in the substitution, it may be in
 359         -- the in-scope set with a different type (we only use the
 360         -- substitution if the unique changes).
 361     refine v = case lookupInScope in_scope v of
 362                  Just v' -> v'
 363                  Nothing -> WARN( True, ppr v ) v       -- This is an error!
 364 \end{code}
 365
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \section{Substituting an Id binder}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373
 374 These functions are in the monad only so that they can be made strict via seq.
 375
 376 \begin{code}
 377 simplBinders, simplLamBndrs, simplLetBndrs
 378         :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 379 simplBinders  env bndrs = mapAccumLSmpl simplBinder  env bndrs
 380 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
 381 simplLetBndrs env bndrs = mapAccumLSmpl simplLetBndr env bndrs
 382
 383 -------------
 384 simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 385 -- Used for lambda and case-bound variables
 386 -- Clone Id if necessary, substitute type
 387 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 388 -- The substitution is extended only if the variable is cloned, because
 389 -- we *don't* need to use it to track occurrence info.
 390 simplBinder env bndr
 391   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
 392                         ; seqTyVar tv `seq` return (env', tv) }
 393   | otherwise     = do  { let (env', id) = substIdBndr env bndr
 394                         ; seqId id `seq` return (env', id) }
 395
 396 -------------
 397 simplLetBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
 398 simplLetBndr env id = do { let (env', id') = substLetId env id
 399                          ; seqId id' `seq` return (env', id') }
 400
 401 -------------
 402 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
 403 -- Used for lambda binders.  These sometimes have unfoldings added by
 404 -- the worker/wrapper pass that must be preserved, becuase they can't
 405 -- be reconstructed from context.  For example:
 406 --      f x = case x of (a,b) -> fw a b x
 407 --      fw a b x{=(a,b)} = ...
 408 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
 409 simplLamBndr env bndr
 410   | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr  -- Normal case
 411   | otherwise                                   = seqId id2 `seq` return (env', id2)
 412   where
 413     old_unf = idUnfolding bndr
 414     (env', id1) = substIdBndr env bndr
 415     id2 = id1 `setIdUnfolding` substUnfolding env old_unf
 416
 417 -------------
 418 seqTyVar :: TyVar -> ()
 419 seqTyVar b = b `seq` ()
 420
 421 seqId :: Id -> ()
 422 seqId id = seqType (idType id)  `seq`
 423            idInfo id            `seq`
 424            ()
 425 \end{code}
 426
 427 \begin{code}
 428 substIdBndr :: SimplEnv -> Id   -- Substitition and Id to transform
 429             -> (SimplEnv, Id)   -- Transformed pair
 430
 431 -- Returns with:
 432 --      * Unique changed if necessary
 433 --      * Type substituted
 434 --      * Unfolding zapped
 435 --      * Rules, worker, lbvar info all substituted
 436 --      * Fragile occurrence info zapped
 437 --      * The in-scope set extended with the returned Id
 438 --      * The substitution extended with a DoneId if unique changed
 439 --        In this case, the var in the DoneId is the same as the
 440 --        var returned
 441
 442 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
 443             old_id
 444   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 445            seIdSubst = new_subst }, new_id)
 446   where
 447         -- id1 is cloned if necessary
 448     id1 = uniqAway in_scope old_id
 449
 450         -- id2 has its type zapped
 451     id2 = substIdType env id1
 452
 453         -- new_id has the right IdInfo
 454         -- The lazy-set is because we're in a loop here, with
 455         -- rec_env, when dealing with a mutually-recursive group
 456     new_id = maybeModifyIdInfo (substIdInfo env) id2
 457
 458         -- Extend the substitution if the unique has changed
 459         -- See the notes with substTyVarBndr for the delSubstEnv
 460     new_subst | new_id /= old_id
 461               = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
 462               | otherwise
 463               = delVarEnv id_subst old_id
 464
 465 substLetId :: SimplEnv -> Id -> (SimplEnv, Id)
 466 -- A variant for let-bound Ids
 467 -- Clone Id if necessary
 468 -- Substitute its type
 469 -- Return an Id with completely zapped IdInfo
 470 --      [A subsequent substIdInfo will restore its IdInfo]
 471 -- Augment the subtitution
 472 --      if the unique changed, *or*
 473 --      if there's interesting occurrence info
 474
 475 substLetId env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
 476   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 477            seIdSubst = new_subst }, new_id)
 478   where
 479     old_info = idInfo old_id
 480     id1     = uniqAway in_scope old_id
 481     id2     = substIdType env id1
 482     new_id  = setIdInfo id2 vanillaIdInfo
 483
 484         -- Extend the substitution if the unique has changed,
 485         -- or there's some useful occurrence information
 486         -- See the notes with substTyVarBndr for the delSubstEnv
 487     occ_info = occInfo old_info
 488     new_subst | new_id /= old_id || isFragileOcc occ_info
 489               = extendVarEnv id_subst old_id (DoneId new_id occ_info)
 490               | otherwise
 491               = delVarEnv id_subst old_id
 492 \end{code}
 493
 494
 495 %************************************************************************
 496 %*                                                                      *
 497                 Impedence matching to type substitution
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 \begin{code}
 502 substTy :: SimplEnv -> Type -> Type
 503 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
 504   = Type.substTy (TvSubst in_scope tv_env) ty
 505
 506 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 507 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
 508   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 509         (TvSubst in_scope' tv_env', tv')
 510            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 511
 512 -- When substituting in rules etc we can get CoreSubst to do the work
 513 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
 514 -- here.  I think the this will not usually result in a lot of work;
 515 -- the substitutions are typically small, and laziness will avoid work in many cases.
 516
 517 mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
 518 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
 519   = mk_subst tv_env id_env
 520   where
 521     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 522
 523     fiddle (DoneEx e)       = e
 524     fiddle (DoneId v occ)   = Var v
 525     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 526
 527 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
 528 substExpr env expr
 529   | isEmptySimplSubst env = expr
 530   | otherwise             = CoreSubst.substExpr (mkCoreSubst env) expr
 531 \end{code}
 532
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \section{IdInfo substitution}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540 \begin{code}
 541 simplIdInfo :: SimplEnv -> IdInfo -> IdInfo
 542   -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
 543   -- subsequent to simplLetId having zapped its IdInfo
 544 simplIdInfo env old_info
 545   = case substIdInfo env old_info of
 546         Just new_info -> new_info
 547         Nothing       -> old_info
 548
 549 substIdInfo :: SimplEnv
 550             -> IdInfo
 551             -> Maybe IdInfo
 552 -- Substitute the
 553 --      rules
 554 --      worker info
 555 -- Zap the unfolding
 556 -- Keep only 'robust' OccInfo
 557 -- Zap Arity
 558 --
 559 -- Seq'ing on the returned IdInfo is enough to cause all the
 560 -- substitutions to happen completely
 561
 562 substIdInfo env info
 563   | nothing_to_do = Nothing
 564   | otherwise     = Just (info `setOccInfo`       (if keep_occ then old_occ else NoOccInfo)
 565                                `setArityInfo`     (if keep_arity then old_arity else unknownArity)
 566                                `setSpecInfo`      CoreSubst.substSpec   subst old_rules
 567                                `setWorkerInfo`    CoreSubst.substWorker subst old_wrkr
 568                                `setUnfoldingInfo` noUnfolding)
 569                         -- setSpecInfo does a seq
 570                         -- setWorkerInfo does a seq
 571   where
 572     subst = mkCoreSubst env
 573     nothing_to_do = keep_occ && keep_arity &&
 574                     isEmptySpecInfo old_rules &&
 575                     not (workerExists old_wrkr) &&
 576                     not (hasUnfolding (unfoldingInfo info))
 577
 578     keep_occ   = not (isFragileOcc old_occ)
 579     keep_arity = old_arity == unknownArity
 580     old_arity = arityInfo info
 581     old_occ   = occInfo info
 582     old_rules = specInfo info
 583     old_wrkr  = workerInfo info
 584
 585 ------------------
 586 substIdType :: SimplEnv -> Id -> Id
 587 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 588   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 589   | otherwise   = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 590                 -- The tyVarsOfType is cheaper than it looks
 591                 -- because we cache the free tyvars of the type
 592                 -- in a Note in the id's type itself
 593   where
 594     old_ty = idType id
 595
 596 ------------------
 597 substUnfolding env NoUnfolding                 = NoUnfolding
 598 substUnfolding env (OtherCon cons)             = OtherCon cons
 599 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
 600 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
 601 \end{code}
 602
 603
 604 %************************************************************************
 605 %*                                                                      *
 606 \subsection{Floats}
 607 %*                                                                      *
 608 %************************************************************************
 609
 610 \begin{code}
 611 type FloatsWithExpr = FloatsWith OutExpr
 612 type FloatsWith a   = (Floats, a)
 613         -- We return something equivalent to (let b in e), but
 614         -- in pieces to avoid the quadratic blowup when floating
 615         -- incrementally.  Comments just before simplExprB in Simplify.lhs
 616
 617 data Floats = Floats (OrdList OutBind)
 618                      InScopeSet         -- Environment "inside" all the floats
 619                      Bool               -- True <=> All bindings are lifted
 620
 621 allLifted :: Floats -> Bool
 622 allLifted (Floats _ _ is_lifted) = is_lifted
 623
 624 wrapFloats :: Floats -> OutExpr -> OutExpr
 625 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
 626
 627 isEmptyFloats :: Floats -> Bool
 628 isEmptyFloats (Floats bs _ _) = isNilOL bs
 629
 630 floatBinds :: Floats -> [OutBind]
 631 floatBinds (Floats bs _ _) = fromOL bs
 632
 633 flattenFloats :: Floats -> Floats
 634 -- Flattens into a single Rec group
 635 flattenFloats (Floats bs is is_lifted)
 636   = ASSERT2( is_lifted, ppr (fromOL bs) )
 637     Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
 638 \end{code}
 639
 640 \begin{code}
 641 emptyFloats :: SimplEnv -> Floats
 642 emptyFloats env = Floats nilOL (getInScope env) True
 643
 644 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
 645 -- A single non-rec float; extend the in-scope set
 646 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
 647                                (extendInScopeSet (getInScope env) var)
 648                                (not (isUnLiftedType (idType var)))
 649
 650 addFloats :: SimplEnv -> Floats
 651           -> (SimplEnv -> SimplM (FloatsWith a))
 652           -> SimplM (FloatsWith a)
 653 addFloats env (Floats b1 is1 l1) thing_inside
 654   | isNilOL b1
 655   = thing_inside env
 656   | otherwise
 657   = thing_inside (setInScopeSet env is1)        `thenSmpl` \ (Floats b2 is2 l2, res) ->
 658     returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
 659
 660 addLetBind :: OutBind -> Floats -> Floats
 661 addLetBind bind (Floats binds in_scope lifted)
 662   = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
 663
 664 is_lifted_bind (Rec _)      = True
 665 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
 666
 667 -- addAuxiliaryBind     * takes already-simplified things (bndr and rhs)
 668 --                      * extends the in-scope env
 669 --                      * assumes it's a let-bindable thing
 670 addAuxiliaryBind :: SimplEnv -> OutBind
 671                  -> (SimplEnv -> SimplM (FloatsWith a))
 672                  -> SimplM (FloatsWith a)
 673         -- Extends the in-scope environment as well as wrapping the bindings
 674 addAuxiliaryBind env bind thing_inside
 675   = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
 676     thing_inside (addNewInScopeIds env (bindersOf bind))        `thenSmpl` \ (floats, x) ->
 677     returnSmpl (addLetBind bind floats, x)
 678 \end{code}
 679
 680