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