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