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: ARITY.  We *do* transfer the arity.  This is important, so that
 539 the arity of an Id is visible in its own RHS.  For example:
 540         f = \x. ....g (\y. f y)....
 541 We can eta-reduce the arg to g, becuase f is a value.  But that
 542 needs to be visible.
 543
 544 This interacts with the 'state hack' too:
 545         f :: Bool -> IO Int
 546         f = \x. case x of
 547                   True  -> f y
 548                   False -> \s -> ...
 549 Can we eta-expand f?  Only if we see that f has arity 1, and then we
 550 take advantage of the 'state hack' on the result of
 551 (f y) :: State# -> (State#, Int) to expand the arity one more.
 552
 553 There is a disadvantage though.  Making the arity visible in the RHA
 554 allows us to eta-reduce
 555         f = \x -> f x
 556 to
 557         f = f
 558 which technically is not sound.   This is very much a corner case, so
 559 I'm not worried about it.  Another idea is to ensure that f's arity
 560 never decreases; its arity started as 1, and we should never eta-reduce
 561 below that.
 562
 563 NB 3: OccInfo.  It's important that we *do* transer the loop-breaker
 564 OccInfo, because that's what stops the Id getting inlined infinitely,
 565 in the body of the letrec.
 566
 567 NB 4: does no harm for non-recursive bindings
 568
 569 NB 5: we can't do the addLetIdInfo part before *all* the RHSs because
 570         rec { f = g
 571               h = ...
 572                 RULE h Int = f
 573         }
 574 Here, we'll do postInlineUnconditionally on f, and we must "see" that
 575 when substituting in h's RULE.
 576
 577 \begin{code}
 578 addLetIdInfo :: SimplEnv -> InBinder -> OutBinder -> (SimplEnv, OutBinder)
 579 addLetIdInfo env in_id out_id
 580   = (modifyInScope env out_id final_id, final_id)
 581   where
 582     final_id = out_id `setIdInfo` new_info
 583     subst = mkCoreSubst env
 584     old_info = idInfo in_id
 585     new_info = case substIdInfo subst old_info of
 586                   Nothing       -> old_info
 587                   Just new_info -> new_info
 588
 589 substIdInfo :: CoreSubst.Subst -> IdInfo -> Maybe IdInfo
 590 -- Substitute the
 591 --      rules
 592 --      worker info
 593 -- Zap the unfolding
 594 -- Keep only 'robust' OccInfo
 595 --           arity
 596 --
 597 -- Seq'ing on the returned IdInfo is enough to cause all the
 598 -- substitutions to happen completely
 599
 600 substIdInfo subst info
 601   | nothing_to_do = Nothing
 602   | otherwise     = Just (info `setOccInfo`       (if keep_occ then old_occ else NoOccInfo)
 603                                `setSpecInfo`      CoreSubst.substSpec   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     nothing_to_do = keep_occ &&
 610                     isEmptySpecInfo old_rules &&
 611                     not (workerExists old_wrkr) &&
 612                     not (hasUnfolding (unfoldingInfo info))
 613
 614     keep_occ   = not (isFragileOcc old_occ)
 615     old_arity = arityInfo info
 616     old_occ   = occInfo info
 617     old_rules = specInfo info
 618     old_wrkr  = workerInfo info
 619
 620 ------------------
 621 substIdType :: SimplEnv -> Id -> Id
 622 substIdType env@(SimplEnv { seInScope = in_scope,  seTvSubst = tv_env}) id
 623   | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
 624   | otherwise   = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
 625                 -- The tyVarsOfType is cheaper than it looks
 626                 -- because we cache the free tyvars of the type
 627                 -- in a Note in the id's type itself
 628   where
 629     old_ty = idType id
 630
 631 ------------------
 632 substUnfolding env NoUnfolding                 = NoUnfolding
 633 substUnfolding env (OtherCon cons)             = OtherCon cons
 634 substUnfolding env (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr env rhs)
 635 substUnfolding env (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr env rhs) t v w g
 636 \end{code}
 637
 638
 639 %************************************************************************
 640 %*                                                                      *
 641                 Impedence matching to type substitution
 642 %*                                                                      *
 643 %************************************************************************
 644
 645 \begin{code}
 646 substTy :: SimplEnv -> Type -> Type
 647 substTy (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) ty
 648   = Type.substTy (TvSubst in_scope tv_env) ty
 649
 650 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 651 substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) tv
 652   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 653         (TvSubst in_scope' tv_env', tv')
 654            -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
 655
 656 -- When substituting in rules etc we can get CoreSubst to do the work
 657 -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
 658 -- here.  I think the this will not usually result in a lot of work;
 659 -- the substitutions are typically small, and laziness will avoid work in many cases.
 660
 661 mkCoreSubst  :: SimplEnv -> CoreSubst.Subst
 662 mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
 663   = mk_subst tv_env id_env
 664   where
 665     mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
 666
 667     fiddle (DoneEx e)       = e
 668     fiddle (DoneId v occ)   = Var v
 669     fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e
 670
 671 substExpr :: SimplEnv -> CoreExpr -> CoreExpr
 672 substExpr env expr
 673   | isEmptySimplSubst env = expr
 674   | otherwise             = CoreSubst.substExpr (mkCoreSubst env) expr
 675 \end{code}
 676
 677
 678 %************************************************************************
 679 %*                                                                      *
 680 \subsection{Floats}
 681 %*                                                                      *
 682 %************************************************************************
 683
 684 \begin{code}
 685 type FloatsWithExpr = FloatsWith OutExpr
 686 type FloatsWith a   = (Floats, a)
 687         -- We return something equivalent to (let b in e), but
 688         -- in pieces to avoid the quadratic blowup when floating
 689         -- incrementally.  Comments just before simplExprB in Simplify.lhs
 690
 691 data Floats = Floats (OrdList OutBind)
 692                      InScopeSet         -- Environment "inside" all the floats
 693                      Bool               -- True <=> All bindings are lifted
 694
 695 allLifted :: Floats -> Bool
 696 allLifted (Floats _ _ is_lifted) = is_lifted
 697
 698 wrapFloats :: Floats -> OutExpr -> OutExpr
 699 wrapFloats (Floats bs _ _) body = foldrOL Let body bs
 700
 701 isEmptyFloats :: Floats -> Bool
 702 isEmptyFloats (Floats bs _ _) = isNilOL bs
 703
 704 floatBinds :: Floats -> [OutBind]
 705 floatBinds (Floats bs _ _) = fromOL bs
 706
 707 flattenFloats :: Floats -> Floats
 708 -- Flattens into a single Rec group
 709 flattenFloats (Floats bs is is_lifted)
 710   = ASSERT2( is_lifted, ppr (fromOL bs) )
 711     Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
 712 \end{code}
 713
 714 \begin{code}
 715 emptyFloats :: SimplEnv -> Floats
 716 emptyFloats env = Floats nilOL (getInScope env) True
 717
 718 unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
 719 -- A single non-rec float; extend the in-scope set
 720 unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
 721                                (extendInScopeSet (getInScope env) var)
 722                                (not (isUnLiftedType (idType var)))
 723
 724 addFloats :: SimplEnv -> Floats
 725           -> (SimplEnv -> SimplM (FloatsWith a))
 726           -> SimplM (FloatsWith a)
 727 addFloats env (Floats b1 is1 l1) thing_inside
 728   | isNilOL b1
 729   = thing_inside env
 730   | otherwise
 731   = thing_inside (setInScopeSet env is1)        `thenSmpl` \ (Floats b2 is2 l2, res) ->
 732     returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
 733
 734 addLetBind :: OutBind -> Floats -> Floats
 735 addLetBind bind (Floats binds in_scope lifted)
 736   = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
 737
 738 is_lifted_bind (Rec _)      = True
 739 is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
 740
 741 -- addAuxiliaryBind     * takes already-simplified things (bndr and rhs)
 742 --                      * extends the in-scope env
 743 --                      * assumes it's a let-bindable thing
 744 addAuxiliaryBind :: SimplEnv -> OutBind
 745                  -> (SimplEnv -> SimplM (FloatsWith a))
 746                  -> SimplM (FloatsWith a)
 747         -- Extends the in-scope environment as well as wrapping the bindings
 748 addAuxiliaryBind env bind thing_inside
 749   = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
 750     thing_inside (addNewInScopeIds env (bindersOf bind))        `thenSmpl` \ (floats, x) ->
 751     returnSmpl (addLetBind bind floats, x)
 752 \end{code}
 753
 754