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,
  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, and substitute their IdInfo,
 480 and re-attach it.  The resulting binders therefore have all
 481 their RULES, which is important in a mutually recursive group
 482
 483 We must transfer the IdInfo of the original binder to the new binder.
 484 This is crucial, to preserve
 485         strictness
 486         rules
 487         worker info
 488 etc.  To do this we must apply the current substitution,
 489 which incorporates earlier substitutions in this very letrec group.
 490
 491 NB 1. We do this *before* processing the RHS of the binder, so that
 492 its substituted rules are visible in its own RHS.
 493 This is important.  Manuel found cases where he really, really
 494 wanted a RULE for a recursive function to apply in that function's
 495 own right-hand side.
 496
 497 NB 2: We do not transfer the arity (see Subst.substIdInfo)
 498 The arity of an Id should not be visible
 499 in its own RHS, else we eta-reduce
 500         f = \x -> f x
 501 to
 502         f = f
 503 which isn't sound.  And it makes the arity in f's IdInfo greater than
 504 the manifest arity, which isn't good.
 505 The arity will get added later.
 506
 507 NB 3: It's important that we *do* transer the loop-breaker OccInfo,
 508 because that's what stops the Id getting inlined infinitely, in the body
 509 of the letrec.
 510
 511 NB 4: does no harm for non-recursive bindings
 512
 513 \begin{code}
 514 simplNonRecBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
 515 simplNonRecBndr env id
 516   = do  { let subst = mkCoreSubst env
 517               (env1, id1) = substLetIdBndr subst env id
 518         ; seqId id1 `seq` return (env1, id1) }
 519
 520 ---------------
 521 simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
 522 simplRecBndrs env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) ids
 523   = do  { let   -- Notice the knot here; we need the result to make
 524                 -- a substitution for the IdInfo.  c.f. CoreSubst.substIdBndr
 525                (env1, ids1) = mapAccumL (substLetIdBndr subst) env ids
 526                subst = mkCoreSubst env1
 527         ; seqIds ids1 `seq` return (env1, ids1) }
 528
 529 ---------------
 530 substLetIdBndr :: CoreSubst.Subst       -- Substitution to use for the IdInfo (knot-tied)
 531                -> SimplEnv -> InBinder  -- Env and binder to transform
 532                -> (SimplEnv, OutBinder)
 533 -- C.f. CoreSubst.substIdBndr
 534 -- Clone Id if necessary, substitute its type
 535 -- Return an Id with completely zapped IdInfo
 536 --      [A subsequent substIdInfo will restore its IdInfo]
 537 -- Augment the subtitution
 538 --      if the unique changed, *or*
 539 --      if there's interesting occurrence info
 540 --
 541 -- The difference between SimplEnv.substIdBndr above is
 542 --      a) the rec_subst
 543 --      b) the hackish "interesting occ info" part (due to vanish)
 544
 545 substLetIdBndr rec_subst env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) old_id
 546   = (env { seInScope = in_scope `extendInScopeSet` new_id,
 547            seIdSubst = new_subst }, new_id)
 548   where
 549     id1    = uniqAway in_scope old_id
 550     id2    = substIdType env id1
 551     new_id = maybeModifyIdInfo (substIdInfo rec_subst) id2
 552
 553         -- Extend the substitution if the unique has changed,
 554         -- or there's some useful occurrence information
 555         -- See the notes with substTyVarBndr for the delSubstEnv
 556     occ_info = occInfo (idInfo old_id)
 557     new_subst | new_id /= old_id || isFragileOcc occ_info
 558               = extendVarEnv id_subst old_id (DoneId new_id occ_info)
 559               | otherwise
 560               = delVarEnv id_subst old_id
 561
 562 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 563 -- Substitute the
 564 --      rules
 565 --      worker info
 566 -- Zap the unfolding
 567 -- Keep only 'robust' OccInfo
 568 -- Zap Arity
 569 --
 570 -- Seq'ing on the returned IdInfo is enough to cause all the
 571 -- substitutions to happen completely
 572
 573 substIdInfo subst info
 574   | nothing_to_do = Nothing
 575   | otherwise     = Just (info `setOccInfo`       (if keep_occ then old_occ else NoOccInfo)
 576                                `setArityInfo`     (if keep_arity then old_arity else unknownArity)
 577                                `setSpecInfo`      CoreSubst.substSpec   subst old_rules
 578                                `setWorkerInfo`    CoreSubst.substWorker subst old_wrkr
 579                                `setUnfoldingInfo` noUnfolding)
 580                         -- setSpecInfo does a seq
 581                         -- setWorkerInfo does a seq
 582   where
 583     nothing_to_do = keep_occ && keep_arity &&
 584                     isEmptySpecInfo old_rules &&
 585                     not (workerExists old_wrkr) &&
 586                     not (hasUnfolding (unfoldingInfo info))
 587
 588     keep_occ   = not (isFragileOcc old_occ)
 589     keep_arity = old_arity == unknownArity
 590     old_arity = arityInfo info
 591     old_occ   = occInfo info
 592     old_rules = specInfo info
 593     old_wrkr  = workerInfo info
 594
 595 ------------------
 596 substIdType :: SimplEnv -> Id -> Id
 597 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 598   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 599   | otherwise   = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 600                 -- The tyVarsOfType is cheaper than it looks
 601                 -- because we cache the free tyvars of the type
 602                 -- in a Note in the id's type itself
 603   where
 604     old_ty = idType id
 605
 606 ------------------
 607 substUnfolding env NoUnfolding                 = NoUnfolding
 608 substUnfolding env (OtherCon cons)             = OtherCon cons
 609 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
 610 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
 611 \end{code}
 612
 613
 614 %************************************************************************
 615 %*                                                                      *
 616                 Impedence matching to type substitution
 617 %*                                                                      *
 618 %************************************************************************
 619
 620 \begin{code}
 621 substTy :: SimplEnv -> Type -> Type
 622 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
 623   = Type.substTy (TvSubst in_scope tv_env) ty
 624
 625 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 626 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
 627   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 628         (TvSubst in_scope' tv_env', tv')
 629            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 630
 631 -- When substituting in rules etc we can get CoreSubst to do the work
 632 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
 633 -- here.  I think the this will not usually result in a lot of work;
 634 -- the substitutions are typically small, and laziness will avoid work in many cases.
 635
 636 mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
 637 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
 638   = mk_subst tv_env id_env
 639   where
 640     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 641
 642     fiddle (DoneEx e)       = e
 643     fiddle (DoneId v occ)   = Var v
 644     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 645
 646 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
 647 substExpr env expr
 648   | isEmptySimplSubst env = expr
 649   | otherwise             = CoreSubst.substExpr (mkCoreSubst env) expr
 650 \end{code}
 651
 652
 653 %************************************************************************
 654 %*                                                                      *
 655 \subsection{Floats}
 656 %*                                                                      *
 657 %************************************************************************
 658
 659 \begin{code}
 660 type FloatsWithExpr = FloatsWith OutExpr
 661 type FloatsWith a   = (Floats, a)
 662         -- We return something equivalent to (let b in e), but
 663         -- in pieces to avoid the quadratic blowup when floating
 664         -- incrementally.  Comments just before simplExprB in Simplify.lhs
 665
 666 data Floats = Floats (OrdList OutBind)
 667                      InScopeSet         -- Environment "inside" all the floats
 668                      Bool               -- True <=> All bindings are lifted
 669
 670 allLifted :: Floats -> Bool
 671 allLifted (Floats _ _ is_lifted) = is_lifted
 672
 673 wrapFloats :: Floats -> OutExpr -> OutExpr
 674 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
 675
 676 isEmptyFloats :: Floats -> Bool
 677 isEmptyFloats (Floats bs _ _) = isNilOL bs
 678
 679 floatBinds :: Floats -> [OutBind]
 680 floatBinds (Floats bs _ _) = fromOL bs
 681
 682 flattenFloats :: Floats -> Floats
 683 -- Flattens into a single Rec group
 684 flattenFloats (Floats bs is is_lifted)
 685   = ASSERT2( is_lifted, ppr (fromOL bs) )
 686     Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
 687 \end{code}
 688
 689 \begin{code}
 690 emptyFloats :: SimplEnv -> Floats
 691 emptyFloats env = Floats nilOL (getInScope env) True
 692
 693 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
 694 -- A single non-rec float; extend the in-scope set
 695 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
 696                                (extendInScopeSet (getInScope env) var)
 697                                (not (isUnLiftedType (idType var)))
 698
 699 addFloats :: SimplEnv -> Floats
 700           -> (SimplEnv -> SimplM (FloatsWith a))
 701           -> SimplM (FloatsWith a)
 702 addFloats env (Floats b1 is1 l1) thing_inside
 703   | isNilOL b1
 704   = thing_inside env
 705   | otherwise
 706   = thing_inside (setInScopeSet env is1)        `thenSmpl` \ (Floats b2 is2 l2, res) ->
 707     returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
 708
 709 addLetBind :: OutBind -> Floats -> Floats
 710 addLetBind bind (Floats binds in_scope lifted)
 711   = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
 712
 713 is_lifted_bind (Rec _)      = True
 714 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
 715
 716 -- addAuxiliaryBind     * takes already-simplified things (bndr and rhs)
 717 --                      * extends the in-scope env
 718 --                      * assumes it's a let-bindable thing
 719 addAuxiliaryBind :: SimplEnv -> OutBind
 720                  -> (SimplEnv -> SimplM (FloatsWith a))
 721                  -> SimplM (FloatsWith a)
 722         -- Extends the in-scope environment as well as wrapping the bindings
 723 addAuxiliaryBind env bind thing_inside
 724   = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
 725     thing_inside (addNewInScopeIds env (bindersOf bind))        `thenSmpl` \ (floats, x) ->
 726     returnSmpl (addLetBind bind floats, x)
 727 \end{code}
 728
 729