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