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