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