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         simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
  29         simplBinder, simplBinders, addLetIdInfo,
  30         substExpr, substTy,
  31
  32         -- Floats
  33         FloatsWith, FloatsWithExpr,
  34         Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
  35         allLifted, wrapFloats, floatBinds,
  36         addAuxiliaryBind,
  37     ) where
  38
  39 #include "HsVersions.h"
  40
  41 import SimplMonad
  42 import Id               ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding )
  43 import IdInfo           ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo,
  44                           arityInfo, setArityInfo, workerInfo, setWorkerInfo,
  45                           unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo,
  46                           unknownArity, workerExists
  47                             )
  48 import CoreSyn
  49 import Unify            ( TypeRefinement )
  50 import Rules            ( RuleBase )
  51 import CoreUtils        ( needsCaseBinding )
  52 import CostCentre       ( CostCentreStack, subsumedCCS )
  53 import Var
  54 import VarEnv
  55 import VarSet           ( isEmptyVarSet )
  56 import OrdList
  57
  58 import qualified CoreSubst      ( Subst, mkSubst, substExpr, substSpec, substWorker )
  59 import qualified Type           ( substTy, substTyVarBndr )
  60
  61 import Type             ( Type, TvSubst(..), TvSubstEnv, composeTvSubst,
  62                           isUnLiftedType, seqType, tyVarsOfType )
  63 import BasicTypes       ( OccInfo(..), isFragileOcc )
  64 import DynFlags         ( SimplifierMode(..) )
  65 import 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 }
 283         -- Why delete?  Consider
 284         --      let x = a*b in (x, \x -> x+3)
 285         -- We add [x |-> a*b] to the substitution, but we must
 286         -- *delete* it from the substitution when going inside
 287         -- the (\x -> ...)!
 288
 289 modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
 290 modifyInScope env@(SimplEnv {seInScope = in_scope}) v v'
 291   = env {seInScope = modifyInScopeSet in_scope v v'}
 292
 293 ---------------------
 294 zapSubstEnv :: SimplEnv -> SimplEnv
 295 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
 296
 297 setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
 298 setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
 299
 300 mkContEx :: SimplEnv -> InExpr -> SimplSR
 301 mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
 302
 303 isEmptySimplSubst :: SimplEnv -> Bool
 304 isEmptySimplSubst (SimplEnv { seTvSubst = tvs, seIdSubst = ids })
 305   = isEmptyVarEnv tvs && isEmptyVarEnv ids
 306
 307 ---------------------
 308 getRules :: SimplEnv -> RuleBase
 309 getRules = seExtRules
 310 \end{code}
 311
 312                 GADT stuff
 313
 314 Given an idempotent substitution, generated by the unifier, use it to
 315 refine the environment
 316
 317 \begin{code}
 318 refineSimplEnv :: SimplEnv -> TypeRefinement -> SimplEnv
 319 -- The TvSubstEnv is the refinement, and it refines OutTyVars into OutTypes
 320 refineSimplEnv env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope })
 321                (refine_tv_subst, all_bound_here)
 322   = env { seTvSubst = composeTvSubst in_scope refine_tv_subst tv_subst,
 323           seInScope = in_scope' }
 324   where
 325     in_scope'
 326         | all_bound_here = in_scope
 327                 -- The tvs are the tyvars bound here.  If only they
 328                 -- are refined, there's no need to do anything
 329         | otherwise = mapInScopeSet refine_id in_scope
 330
 331     refine_id v         -- Only refine its type; any rules will get
 332                         -- refined if they are used (I hope)
 333         | isId v    = setIdType v (Type.substTy refine_subst (idType v))
 334         | otherwise = v
 335     refine_subst = TvSubst in_scope refine_tv_subst
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340                 Substitution of Vars
 341 %*                                                                      *
 342 %************************************************************************
 343
 344
 345 \begin{code}
 346 substId :: SimplEnv -> Id -> SimplSR
 347 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 348   | not (isLocalId v)
 349   = DoneId v NoOccInfo
 350   | otherwise   -- A local Id
 351   = case lookupVarEnv ids v of
 352         Just (DoneId v occ) -> DoneId (refine v) occ
 353         Just res            -> res
 354         Nothing             -> let v' = refine v
 355                                in DoneId v' (idOccInfo v')
 356                 -- We don't put LoopBreakers in the substitution (unless then need
 357                 -- to be cloned for name-clash rasons), so the idOccInfo is
 358                 -- very important!  If isFragileOcc returned True for
 359                 -- loop breakers we could avoid this call, but at the expense
 360                 -- of adding more to the substitution, and building new Ids
 361                 -- a bit more often than really necessary
 362   where
 363         -- Get the most up-to-date thing from the in-scope set
 364         -- Even though it isn't in the substitution, it may be in
 365         -- the in-scope set with a different type (we only use the
 366         -- substitution if the unique changes).
 367     refine v = case lookupInScope in_scope v of
 368                  Just v' -> v'
 369                  Nothing -> WARN( True, ppr v ) v       -- This is an error!
 370 \end{code}
 371
 372
 373 %************************************************************************
 374 %*                                                                      *
 375 \section{Substituting an Id binder}
 376 %*                                                                      *
 377 %************************************************************************
 378
 379
 380 These functions are in the monad only so that they can be made strict via seq.
 381
 382 \begin{code}
 383 simplBinders, simplLamBndrs
 384         :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 385 simplBinders  env bndrs = mapAccumLSmpl simplBinder  env bndrs
 386 simplLamBndrs env bndrs = mapAccumLSmpl simplLamBndr env bndrs
 387
 388 -------------
 389 simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 390 -- Used for lambda and case-bound variables
 391 -- Clone Id if necessary, substitute type
 392 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 393 -- The substitution is extended only if the variable is cloned, because
 394 -- we *don't* need to use it to track occurrence info.
 395 simplBinder env bndr
 396   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
 397                         ; seqTyVar tv `seq` return (env', tv) }
 398   | otherwise     = do  { let (env', id) = substIdBndr env bndr
 399                         ; seqId id `seq` return (env', id) }
 400
 401 -------------
 402 simplLamBndr :: SimplEnv -> Var -> SimplM (SimplEnv, Var)
 403 -- Used for lambda binders.  These sometimes have unfoldings added by
 404 -- the worker/wrapper pass that must be preserved, becuase they can't
 405 -- be reconstructed from context.  For example:
 406 --      f x = case x of (a,b) -> fw a b x
 407 --      fw a b x{=(a,b)} = ...
 408 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
 409 simplLamBndr env bndr
 410   | not (isId bndr && hasSomeUnfolding old_unf) = simplBinder env bndr  -- Normal case
 411   | otherwise                                   = seqId id2 `seq` return (env', id2)
 412   where
 413     old_unf = idUnfolding bndr
 414     (env', id1) = substIdBndr env bndr
 415     id2 = id1 `setIdUnfolding` substUnfolding env old_unf
 416
 417 --------------
 418 substIdBndr :: SimplEnv -> Id   -- Substitition and Id to transform
 419             -> (SimplEnv, Id)   -- Transformed pair
 420
 421 -- Returns with:
 422 --      * Unique changed if necessary
 423 --      * Type substituted
 424 --      * Unfolding zapped
 425 --      * Rules, worker, lbvar info all substituted
 426 --      * Fragile occurrence info zapped
 427 --      * The in-scope set extended with the returned Id
 428 --      * The substitution extended with a DoneId if unique changed
 429 --        In this case, the var in the DoneId is the same as the
 430 --        var returned
 431
 432 substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst})
 433             old_id
 434   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 435            seIdSubst = new_subst }, new_id)
 436   where
 437         -- id1 is cloned if necessary
 438     id1 = uniqAway in_scope old_id
 439
 440         -- id2 has its type zapped
 441     id2 = substIdType env id1
 442
 443         -- new_id has the final IdInfo
 444     subst  = mkCoreSubst env
 445     new_id = maybeModifyIdInfo (substIdInfo subst) id2
 446
 447         -- Extend the substitution if the unique has changed
 448         -- See the notes with substTyVarBndr for the delSubstEnv
 449     new_subst | new_id /= old_id
 450               = extendVarEnv id_subst old_id (DoneId new_id (idOccInfo old_id))
 451               | otherwise
 452               = delVarEnv id_subst old_id
 453 \end{code}
 454
 455
 456 \begin{code}
 457 seqTyVar :: TyVar -> ()
 458 seqTyVar b = b `seq` ()
 459
 460 seqId :: Id -> ()
 461 seqId id = seqType (idType id)  `seq`
 462            idInfo id            `seq`
 463            ()
 464
 465 seqIds :: [Id] -> ()
 466 seqIds []       = ()
 467 seqIds (id:ids) = seqId id `seq` seqIds ids
 468 \end{code}
 469
 470
 471 %************************************************************************
 472 %*                                                                      *
 473                 Let bindings
 474 %*                                                                      *
 475 %************************************************************************
 476
 477 Simplifying let binders
 478 ~~~~~~~~~~~~~~~~~~~~~~~
 479 Rename the binders if necessary,
 480
 481 \begin{code}
 482 simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 483 simplNonRecBndr env id
 484   = do  { let (env1, id1) = substLetIdBndr env id
 485         ; seqId id1 `seq` return (env1, id1) }
 486
 487 ---------------
 488 simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 489 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
 490   = do  { let (env1, ids1) = mapAccumL substLetIdBndr env ids
 491         ; seqIds ids1 `seq` return (env1, ids1) }
 492
 493 ---------------
 494 substLetIdBndr :: SimplEnv -> InBinder  -- Env and binder to transform
 495                -> (SimplEnv, OutBinder)
 496 -- C.f. CoreSubst.substIdBndr
 497 -- Clone Id if necessary, substitute its type
 498 -- Return an Id with completely zapped IdInfo
 499 --      [addLetIdInfo, below, will restore its IdInfo]
 500 -- Augment the subtitution
 501 --      if the unique changed, *or*
 502 --      if there's interesting occurrence info
 503
 504 substLetIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
 505   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 506            seIdSubst = new_subst }, new_id)
 507   where
 508     id1    = uniqAway in_scope old_id
 509     id2    = substIdType env id1
 510     new_id = setIdInfo id2 vanillaIdInfo
 511
 512         -- Extend the substitution if the unique has changed,
 513         -- or there's some useful occurrence information
 514         -- See the notes with substTyVarBndr for the delSubstEnv
 515     occ_info = occInfo (idInfo old_id)
 516     new_subst | new_id /= old_id || isFragileOcc occ_info
 517               = extendVarEnv id_subst old_id (DoneId new_id occ_info)
 518               | otherwise
 519               = delVarEnv id_subst old_id
 520 \end{code}
 521
 522 Add IdInfo back onto a let-bound Id
 523 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 524 We must transfer the IdInfo of the original binder to the new binder.
 525 This is crucial, to preserve
 526         strictness
 527         rules
 528         worker info
 529 etc.  To do this we must apply the current substitution,
 530 which incorporates earlier substitutions in this very letrec group.
 531
 532 NB 1. We do this *before* processing the RHS of the binder, so that
 533 its substituted rules are visible in its own RHS.
 534 This is important.  Manuel found cases where he really, really
 535 wanted a RULE for a recursive function to apply in that function's
 536 own right-hand side.
 537
 538 NB 2: We do not transfer the arity (see Subst.substIdInfo)
 539 The arity of an Id should not be visible
 540 in its own RHS, else we eta-reduce
 541         f = \x -> f x
 542 to
 543         f = f
 544 which isn't sound.  And it makes the arity in f's IdInfo greater than
 545 the manifest arity, which isn't good.
 546 The arity will get added later.
 547
 548 NB 3: It's important that we *do* transer the loop-breaker OccInfo,
 549 because that's what stops the Id getting inlined infinitely, in the body
 550 of the letrec.
 551
 552 NB 4: does no harm for non-recursive bindings
 553
 554 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
 555         rec { f = g
 556               h = ...
 557                 RULE h Int = f
 558         }
 559 Here, we'll do postInlineUnconditionally on f, and we must "see" that
 560 when substituting in h's RULE.
 561
 562 \begin{code}
 563 addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
 564 addLetIdInfo env in_id out_id
 565   = (modifyInScope env out_id out_id, final_id)
 566   where
 567     final_id = out_id `setIdInfo` new_info
 568     subst = mkCoreSubst env
 569     old_info = idInfo in_id
 570     new_info = case substIdInfo subst old_info of
 571                   Nothing       -> old_info
 572                   Just new_info -> new_info
 573
 574 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 575 -- Substitute the
 576 --      rules
 577 --      worker info
 578 -- Zap the unfolding
 579 -- Keep only 'robust' OccInfo
 580 -- Zap Arity
 581 --
 582 -- Seq'ing on the returned IdInfo is enough to cause all the
 583 -- substitutions to happen completely
 584
 585 substIdInfo subst info
 586   | nothing_to_do = Nothing
 587   | otherwise     = Just (info `setOccInfo`       (if keep_occ then old_occ else NoOccInfo)
 588                                `setArityInfo`     (if keep_arity then old_arity else unknownArity)
 589                                `setSpecInfo`      CoreSubst.substSpec   subst old_rules
 590                                `setWorkerInfo`    CoreSubst.substWorker subst old_wrkr
 591                                `setUnfoldingInfo` noUnfolding)
 592                         -- setSpecInfo does a seq
 593                         -- setWorkerInfo does a seq
 594   where
 595     nothing_to_do = keep_occ && keep_arity &&
 596                     isEmptySpecInfo old_rules &&
 597                     not (workerExists old_wrkr) &&
 598                     not (hasUnfolding (unfoldingInfo info))
 599
 600     keep_occ   = not (isFragileOcc old_occ)
 601     keep_arity = old_arity == unknownArity
 602     old_arity = arityInfo info
 603     old_occ   = occInfo info
 604     old_rules = specInfo info
 605     old_wrkr  = workerInfo info
 606
 607 ------------------
 608 substIdType :: SimplEnv -> Id -> Id
 609 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 610   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 611   | otherwise   = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 612                 -- The tyVarsOfType is cheaper than it looks
 613                 -- because we cache the free tyvars of the type
 614                 -- in a Note in the id's type itself
 615   where
 616     old_ty = idType id
 617
 618 ------------------
 619 substUnfolding env NoUnfolding                 = NoUnfolding
 620 substUnfolding env (OtherCon cons)             = OtherCon cons
 621 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
 622 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
 623 \end{code}
 624
 625
 626 %************************************************************************
 627 %*                                                                      *
 628                 Impedence matching to type substitution
 629 %*                                                                      *
 630 %************************************************************************
 631
 632 \begin{code}
 633 substTy :: SimplEnv -> Type -> Type
 634 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
 635   = Type.substTy (TvSubst in_scope tv_env) ty
 636
 637 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 638 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
 639   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 640         (TvSubst in_scope' tv_env', tv')
 641            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 642
 643 -- When substituting in rules etc we can get CoreSubst to do the work
 644 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
 645 -- here.  I think the this will not usually result in a lot of work;
 646 -- the substitutions are typically small, and laziness will avoid work in many cases.
 647
 648 mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
 649 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
 650   = mk_subst tv_env id_env
 651   where
 652     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 653
 654     fiddle (DoneEx e)       = e
 655     fiddle (DoneId v occ)   = Var v
 656     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 657
 658 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
 659 substExpr env expr
 660   | isEmptySimplSubst env = expr
 661   | otherwise             = CoreSubst.substExpr (mkCoreSubst env) expr
 662 \end{code}
 663
 664
 665 %************************************************************************
 666 %*                                                                      *
 667 \subsection{Floats}
 668 %*                                                                      *
 669 %************************************************************************
 670
 671 \begin{code}
 672 type FloatsWithExpr = FloatsWith OutExpr
 673 type FloatsWith a   = (Floats, a)
 674         -- We return something equivalent to (let b in e), but
 675         -- in pieces to avoid the quadratic blowup when floating
 676         -- incrementally.  Comments just before simplExprB in Simplify.lhs
 677
 678 data Floats = Floats (OrdList OutBind)
 679                      InScopeSet         -- Environment "inside" all the floats
 680                      Bool               -- True <=> All bindings are lifted
 681
 682 allLifted :: Floats -> Bool
 683 allLifted (Floats _ _ is_lifted) = is_lifted
 684
 685 wrapFloats :: Floats -> OutExpr -> OutExpr
 686 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
 687
 688 isEmptyFloats :: Floats -> Bool
 689 isEmptyFloats (Floats bs _ _) = isNilOL bs
 690
 691 floatBinds :: Floats -> [OutBind]
 692 floatBinds (Floats bs _ _) = fromOL bs
 693
 694 flattenFloats :: Floats -> Floats
 695 -- Flattens into a single Rec group
 696 flattenFloats (Floats bs is is_lifted)
 697   = ASSERT2( is_lifted, ppr (fromOL bs) )
 698     Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
 699 \end{code}
 700
 701 \begin{code}
 702 emptyFloats :: SimplEnv -> Floats
 703 emptyFloats env = Floats nilOL (getInScope env) True
 704
 705 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
 706 -- A single non-rec float; extend the in-scope set
 707 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
 708                                (extendInScopeSet (getInScope env) var)
 709                                (not (isUnLiftedType (idType var)))
 710
 711 addFloats :: SimplEnv -> Floats
 712           -> (SimplEnv -> SimplM (FloatsWith a))
 713           -> SimplM (FloatsWith a)
 714 addFloats env (Floats b1 is1 l1) thing_inside
 715   | isNilOL b1
 716   = thing_inside env
 717   | otherwise
 718   = thing_inside (setInScopeSet env is1)        `thenSmpl` \ (Floats b2 is2 l2, res) ->
 719     returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
 720
 721 addLetBind :: OutBind -> Floats -> Floats
 722 addLetBind bind (Floats binds in_scope lifted)
 723   = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
 724
 725 is_lifted_bind (Rec _)      = True
 726 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
 727
 728 -- addAuxiliaryBind     * takes already-simplified things (bndr and rhs)
 729 --                      * extends the in-scope env
 730 --                      * assumes it's a let-bindable thing
 731 addAuxiliaryBind :: SimplEnv -> OutBind
 732                  -> (SimplEnv -> SimplM (FloatsWith a))
 733                  -> SimplM (FloatsWith a)
 734         -- Extends the in-scope environment as well as wrapping the bindings
 735 addAuxiliaryBind env bind thing_inside
 736   = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
 737     thing_inside (addNewInScopeIds env (bindersOf bind))        `thenSmpl` \ (floats, x) ->
 738     returnSmpl (addLetBind bind floats, x)
 739 \end{code}
 740
 741