compiler/simplCore/SimplEnv.hs

   1 {-
   2 (c) The AQUA Project, Glasgow University, 1993-1998
   3
   4 \section[SimplMonad]{The simplifier Monad}
   5 -}
   6
   7 {-# LANGUAGE CPP #-}
   8
   9 module SimplEnv (
  10         InId, InBind, InExpr, InAlt, InArg, InType, InBndr, InVar,
  11         OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBndr, OutVar,
  12         InCoercion, OutCoercion,
  13
  14         -- The simplifier mode
  15         setMode, getMode, updMode,
  16
  17         -- Environments
  18         SimplEnv(..), StaticEnv, pprSimplEnv,   -- Temp not abstract
  19         mkSimplEnv, extendIdSubst, SimplEnv.extendTCvSubst,
  20         zapSubstEnv, setSubstEnv,
  21         getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
  22         getSimplRules,
  23
  24         SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
  25
  26         simplNonRecBndr, simplRecBndrs,
  27         simplBinder, simplBinders,
  28         substTy, substTyVar, getTCvSubst,
  29         substCo, substCoVar,
  30
  31         -- Floats
  32         Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
  33         wrapFloats, setFloats, zapFloats, addRecFloats, mapFloats,
  34         doFloatFromRhs, getFloatBinds
  35     ) where
  36
  37 #include "HsVersions.h"
  38
  39 import SimplMonad
  40 import CoreMonad        ( SimplifierMode(..) )
  41 import CoreSyn
  42 import CoreUtils
  43 import Var
  44 import VarEnv
  45 import VarSet
  46 import OrdList
  47 import Id
  48 import MkCore                   ( mkWildValBinder )
  49 import TysWiredIn
  50 import qualified Type
  51 import Type hiding              ( substTy, substTyVar, substTyVarBndr )
  52 import qualified Coercion
  53 import Coercion hiding          ( substCo, substCoVar, substCoVarBndr )
  54 import BasicTypes
  55 import MonadUtils
  56 import Outputable
  57 import Util
  58
  59 import Data.List
  60
  61 {-
  62 ************************************************************************
  63 *                                                                      *
  64 \subsection[Simplify-types]{Type declarations}
  65 *                                                                      *
  66 ************************************************************************
  67 -}
  68
  69 type InBndr     = CoreBndr
  70 type InVar      = Var                   -- Not yet cloned
  71 type InId       = Id                    -- Not yet cloned
  72 type InType     = Type                  -- Ditto
  73 type InBind     = CoreBind
  74 type InExpr     = CoreExpr
  75 type InAlt      = CoreAlt
  76 type InArg      = CoreArg
  77 type InCoercion = Coercion
  78
  79 type OutBndr     = CoreBndr
  80 type OutVar      = Var                  -- Cloned
  81 type OutId       = Id                   -- Cloned
  82 type OutTyVar    = TyVar                -- Cloned
  83 type OutType     = Type                 -- Cloned
  84 type OutCoercion = Coercion
  85 type OutBind     = CoreBind
  86 type OutExpr     = CoreExpr
  87 type OutAlt      = CoreAlt
  88 type OutArg      = CoreArg
  89
  90 {-
  91 ************************************************************************
  92 *                                                                      *
  93 \subsubsection{The @SimplEnv@ type}
  94 *                                                                      *
  95 ************************************************************************
  96 -}
  97
  98 data SimplEnv
  99   = SimplEnv {
 100      ----------- Static part of the environment -----------
 101      -- Static in the sense of lexically scoped,
 102      -- wrt the original expression
 103
 104         seMode      :: SimplifierMode,
 105
 106         -- The current substitution
 107         seTvSubst   :: TvSubstEnv,      -- InTyVar |--> OutType
 108         seCvSubst   :: CvSubstEnv,      -- InCoVar |--> OutCoercion
 109         seIdSubst   :: SimplIdSubst,    -- InId    |--> OutExpr
 110
 111      ----------- Dynamic part of the environment -----------
 112      -- Dynamic in the sense of describing the setup where
 113      -- the expression finally ends up
 114
 115         -- The current set of in-scope variables
 116         -- They are all OutVars, and all bound in this module
 117         seInScope   :: InScopeSet,      -- OutVars only
 118                 -- Includes all variables bound by seFloats
 119         seFloats    :: Floats
 120                 -- See Note [Simplifier floats]
 121     }
 122
 123 type StaticEnv = SimplEnv       -- Just the static part is relevant
 124
 125 pprSimplEnv :: SimplEnv -> SDoc
 126 -- Used for debugging; selective
 127 pprSimplEnv env
 128   = vcat [text "TvSubst:" <+> ppr (seTvSubst env),
 129           text "CvSubst:" <+> ppr (seCvSubst env),
 130           text "IdSubst:" <+> ppr (seIdSubst env),
 131           text "InScope:" <+> vcat (map ppr_one in_scope_vars)
 132     ]
 133   where
 134    in_scope_vars = varEnvElts (getInScopeVars (seInScope env))
 135    ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
 136              | otherwise = ppr v
 137
 138 type SimplIdSubst = IdEnv SimplSR       -- IdId |--> OutExpr
 139         -- See Note [Extending the Subst] in CoreSubst
 140
 141 data SimplSR
 142   = DoneEx OutExpr              -- Completed term
 143   | DoneId OutId                -- Completed term variable
 144   | ContEx TvSubstEnv           -- A suspended substitution
 145            CvSubstEnv
 146            SimplIdSubst
 147            InExpr
 148
 149 instance Outputable SimplSR where
 150   ppr (DoneEx e) = text "DoneEx" <+> ppr e
 151   ppr (DoneId v) = text "DoneId" <+> ppr v
 152   ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
 153                                 ppr (filter_env tv), ppr (filter_env id) -}]
 154         -- where
 155         -- fvs = exprFreeVars e
 156         -- filter_env env = filterVarEnv_Directly keep env
 157         -- keep uniq _ = uniq `elemUFM_Directly` fvs
 158
 159 {-
 160 Note [SimplEnv invariants]
 161 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 162 seInScope:
 163         The in-scope part of Subst includes *all* in-scope TyVars and Ids
 164         The elements of the set may have better IdInfo than the
 165         occurrences of in-scope Ids, and (more important) they will
 166         have a correctly-substituted type.  So we use a lookup in this
 167         set to replace occurrences
 168
 169         The Ids in the InScopeSet are replete with their Rules,
 170         and as we gather info about the unfolding of an Id, we replace
 171         it in the in-scope set.
 172
 173         The in-scope set is actually a mapping OutVar -> OutVar, and
 174         in case expressions we sometimes bind
 175
 176 seIdSubst:
 177         The substitution is *apply-once* only, because InIds and OutIds
 178         can overlap.
 179         For example, we generally omit mappings
 180                 a77 -> a77
 181         from the substitution, when we decide not to clone a77, but it's quite
 182         legitimate to put the mapping in the substitution anyway.
 183
 184         Furthermore, consider
 185                 let x = case k of I# x77 -> ... in
 186                 let y = case k of I# x77 -> ... in ...
 187         and suppose the body is strict in both x and y.  Then the simplifier
 188         will pull the first (case k) to the top; so the second (case k) will
 189         cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
 190         other is an out-Id.
 191
 192         Of course, the substitution *must* applied! Things in its domain
 193         simply aren't necessarily bound in the result.
 194
 195 * substId adds a binding (DoneId new_id) to the substitution if
 196         the Id's unique has changed
 197
 198   Note, though that the substitution isn't necessarily extended
 199   if the type of the Id changes.  Why not?  Because of the next point:
 200
 201 * We *always, always* finish by looking up in the in-scope set
 202   any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
 203   Reason: so that we never finish up with a "old" Id in the result.
 204   An old Id might point to an old unfolding and so on... which gives a space
 205   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
 215   mapped to the full-adorned binder, which is also the one put in the
 216   binding site.
 217
 218 * The in-scope "set" usually maps x->x; we use it simply for its domain.
 219   But sometimes we have two in-scope Ids that are synomyms, and should
 220   map to the same target:  x->x, y->x.  Notably:
 221         case y of x { ... }
 222   That's why the "set" is actually a VarEnv Var
 223 -}
 224
 225 mkSimplEnv :: SimplifierMode -> SimplEnv
 226 mkSimplEnv mode
 227   = SimplEnv { seMode = mode
 228              , seInScope = init_in_scope
 229              , seFloats = emptyFloats
 230              , seTvSubst = emptyVarEnv
 231              , seCvSubst = emptyVarEnv
 232              , seIdSubst = emptyVarEnv }
 233         -- The top level "enclosing CC" is "SUBSUMED".
 234
 235 init_in_scope :: InScopeSet
 236 init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
 237               -- See Note [WildCard binders]
 238
 239 {-
 240 Note [WildCard binders]
 241 ~~~~~~~~~~~~~~~~~~~~~~~
 242 The program to be simplified may have wild binders
 243     case e of wild { p -> ... }
 244 We want to *rename* them away, so that there are no
 245 occurrences of 'wild-id' (with wildCardKey).  The easy
 246 way to do that is to start of with a representative
 247 Id in the in-scope set
 248
 249 There can be be *occurrences* of wild-id.  For example,
 250 MkCore.mkCoreApp transforms
 251    e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }
 252 This is ok provided 'wild' isn't free in 'e', and that's the delicate
 253 thing. Generally, you want to run the simplifier to get rid of the
 254 wild-ids before doing much else.
 255
 256 It's a very dark corner of GHC.  Maybe it should be cleaned up.
 257 -}
 258
 259 getMode :: SimplEnv -> SimplifierMode
 260 getMode env = seMode env
 261
 262 setMode :: SimplifierMode -> SimplEnv -> SimplEnv
 263 setMode mode env = env { seMode = mode }
 264
 265 updMode :: (SimplifierMode -> SimplifierMode) -> SimplEnv -> SimplEnv
 266 updMode upd env = env { seMode = upd (seMode env) }
 267
 268 ---------------------
 269 extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
 270 extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
 271   = ASSERT2( isId var && not (isCoVar var), ppr var )
 272     env {seIdSubst = extendVarEnv subst var res}
 273
 274 extendTCvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
 275 extendTCvSubst env@(SimplEnv {seTvSubst = tsubst, seCvSubst = csubst}) var res
 276   | isTyVar var
 277   = env {seTvSubst = extendVarEnv tsubst var res}
 278   | Just co <- isCoercionTy_maybe res
 279   = env {seCvSubst = extendVarEnv csubst var co}
 280   | otherwise
 281   = pprPanic "SimplEnv.extendTCvSubst" (ppr res)
 282
 283 ---------------------
 284 getInScope :: SimplEnv -> InScopeSet
 285 getInScope env = seInScope env
 286
 287 setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
 288 setInScopeSet env in_scope = env {seInScope = in_scope}
 289
 290 setInScope :: SimplEnv -> SimplEnv -> SimplEnv
 291 -- Set the in-scope set, and *zap* the floats
 292 setInScope env env_with_scope
 293   = env { seInScope = seInScope env_with_scope,
 294           seFloats = emptyFloats }
 295
 296 setFloats :: SimplEnv -> SimplEnv -> SimplEnv
 297 -- Set the in-scope set *and* the floats
 298 setFloats env env_with_floats
 299   = env { seInScope = seInScope env_with_floats,
 300           seFloats  = seFloats  env_with_floats }
 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 }
 307         -- Why delete?  Consider
 308         --      let x = a*b in (x, \x -> x+3)
 309         -- We add [x |-> a*b] to the substitution, but we must
 310         -- _delete_ it from the substitution when going inside
 311         -- the (\x -> ...)!
 312
 313 modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
 314 -- The variable should already be in scope, but
 315 -- replace the existing version with this new one
 316 -- which has more information
 317 modifyInScope env@(SimplEnv {seInScope = in_scope}) v
 318   = env {seInScope = extendInScopeSet in_scope v}
 319
 320 ---------------------
 321 zapSubstEnv :: SimplEnv -> SimplEnv
 322 zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
 323
 324 setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
 325 setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
 326
 327 mkContEx :: SimplEnv -> InExpr -> SimplSR
 328 mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
 329
 330 {-
 331 ************************************************************************
 332 *                                                                      *
 333 \subsection{Floats}
 334 *                                                                      *
 335 ************************************************************************
 336
 337 Note [Simplifier floats]
 338 ~~~~~~~~~~~~~~~~~~~~~~~~~
 339 The Floats is a bunch of bindings, classified by a FloatFlag.
 340
 341 * All of them satisfy the let/app invariant
 342
 343 Examples
 344
 345   NonRec x (y:ys)       FltLifted
 346   Rec [(x,rhs)]         FltLifted
 347
 348   NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?
 349   NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n
 350
 351   NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge
 352
 353 Can't happen:
 354   NonRec x# (a /# b)    -- Might fail; does not satisfy let/app
 355   NonRec x# (f y)       -- Might diverge; does not satisfy let/app
 356 -}
 357
 358 data Floats = Floats (OrdList OutBind) FloatFlag
 359         -- See Note [Simplifier floats]
 360
 361 data FloatFlag
 362   = FltLifted   -- All bindings are lifted and lazy
 363                 --  Hence ok to float to top level, or recursive
 364
 365   | FltOkSpec   -- All bindings are FltLifted *or*
 366                 --      strict (perhaps because unlifted,
 367                 --      perhaps because of a strict binder),
 368                 --        *and* ok-for-speculation
 369                 --  Hence ok to float out of the RHS
 370                 --  of a lazy non-recursive let binding
 371                 --  (but not to top level, or into a rec group)
 372
 373   | FltCareful  -- At least one binding is strict (or unlifted)
 374                 --      and not guaranteed cheap
 375                 --      Do not float these bindings out of a lazy let
 376
 377 instance Outputable Floats where
 378   ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds)
 379
 380 instance Outputable FloatFlag where
 381   ppr FltLifted = text "FltLifted"
 382   ppr FltOkSpec = text "FltOkSpec"
 383   ppr FltCareful = text "FltCareful"
 384
 385 andFF :: FloatFlag -> FloatFlag -> FloatFlag
 386 andFF FltCareful _          = FltCareful
 387 andFF FltOkSpec  FltCareful = FltCareful
 388 andFF FltOkSpec  _          = FltOkSpec
 389 andFF FltLifted  flt        = flt
 390
 391 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
 392 -- If you change this function look also at FloatIn.noFloatFromRhs
 393 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
 394   =  not (isNilOL fs) && want_to_float && can_float
 395   where
 396      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
 397                      -- See Note [Float when cheap or expandable]
 398      can_float = case ff of
 399                    FltLifted  -> True
 400                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
 401                    FltCareful -> isNotTopLevel lvl && isNonRec rec && str
 402
 403 {-
 404 Note [Float when cheap or expandable]
 405 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 406 We want to float a let from a let if the residual RHS is
 407    a) cheap, such as (\x. blah)
 408    b) expandable, such as (f b) if f is CONLIKE
 409 But there are
 410   - cheap things that are not expandable (eg \x. expensive)
 411   - expandable things that are not cheap (eg (f b) where b is CONLIKE)
 412 so we must take the 'or' of the two.
 413 -}
 414
 415 emptyFloats :: Floats
 416 emptyFloats = Floats nilOL FltLifted
 417
 418 unitFloat :: OutBind -> Floats
 419 -- This key function constructs a singleton float with the right form
 420 unitFloat bind = Floats (unitOL bind) (flag bind)
 421   where
 422     flag (Rec {})                = FltLifted
 423     flag (NonRec bndr rhs)
 424       | not (isStrictId bndr)    = FltLifted
 425       | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)
 426       | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
 427                                    FltCareful
 428       -- Unlifted binders can only be let-bound if exprOkForSpeculation holds
 429
 430 addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 431 -- Add a non-recursive binding and extend the in-scope set
 432 -- The latter is important; the binder may already be in the
 433 -- in-scope set (although it might also have been created with newId)
 434 -- but it may now have more IdInfo
 435 addNonRec env id rhs
 436   = id `seq`   -- This seq forces the Id, and hence its IdInfo,
 437                -- and hence any inner substitutions
 438     env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs),
 439           seInScope = extendInScopeSet (seInScope env) id }
 440
 441 extendFloats :: SimplEnv -> OutBind -> SimplEnv
 442 -- Add these bindings to the floats, and extend the in-scope env too
 443 extendFloats env bind
 444   = env { seFloats  = seFloats env `addFlts` unitFloat bind,
 445           seInScope = extendInScopeSetList (seInScope env) bndrs }
 446   where
 447     bndrs = bindersOf bind
 448
 449 addFloats :: SimplEnv -> SimplEnv -> SimplEnv
 450 -- Add the floats for env2 to env1;
 451 -- *plus* the in-scope set for env2, which is bigger
 452 -- than that for env1
 453 addFloats env1 env2
 454   = env1 {seFloats = seFloats env1 `addFlts` seFloats env2,
 455           seInScope = seInScope env2 }
 456
 457 addFlts :: Floats -> Floats -> Floats
 458 addFlts (Floats bs1 l1) (Floats bs2 l2)
 459   = Floats (bs1 `appOL` bs2) (l1 `andFF` l2)
 460
 461 zapFloats :: SimplEnv -> SimplEnv
 462 zapFloats env = env { seFloats = emptyFloats }
 463
 464 addRecFloats :: SimplEnv -> SimplEnv -> SimplEnv
 465 -- Flattens the floats from env2 into a single Rec group,
 466 -- prepends the floats from env1, and puts the result back in env2
 467 -- This is all very specific to the way recursive bindings are
 468 -- handled; see Simplify.simplRecBind
 469 addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff})
 470   = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
 471     env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))}
 472
 473 wrapFloats :: SimplEnv -> OutExpr -> OutExpr
 474 -- Wrap the floats around the expression; they should all
 475 -- satisfy the let/app invariant, so mkLets should do the job just fine
 476 wrapFloats (SimplEnv {seFloats = Floats bs _}) body
 477   = foldrOL Let body bs
 478
 479 getFloatBinds :: SimplEnv -> [CoreBind]
 480 getFloatBinds (SimplEnv {seFloats = Floats bs _})
 481   = fromOL bs
 482
 483 isEmptyFloats :: SimplEnv -> Bool
 484 isEmptyFloats (SimplEnv {seFloats = Floats bs _})
 485   = isNilOL bs
 486
 487 mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv
 488 mapFloats env@SimplEnv { seFloats = Floats fs ff } fun
 489    = env { seFloats = Floats (mapOL app fs) ff }
 490    where
 491     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
 492     app (Rec bs)     = Rec (map fun bs)
 493
 494 {-
 495 ************************************************************************
 496 *                                                                      *
 497                 Substitution of Vars
 498 *                                                                      *
 499 ************************************************************************
 500
 501 Note [Global Ids in the substitution]
 502 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 503 We look up even a global (eg imported) Id in the substitution. Consider
 504    case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }
 505 The binder-swap in the occurrence analyser will add a binding
 506 for a LocalId version of g (with the same unique though):
 507    case X.g_34 of b { (a,b) ->  let g_34 = b in
 508                                 ... case X.g_34 of { (p,q) -> ...} ... }
 509 So we want to look up the inner X.g_34 in the substitution, where we'll
 510 find that it has been substituted by b.  (Or conceivably cloned.)
 511 -}
 512
 513 substId :: SimplEnv -> InId -> SimplSR
 514 -- Returns DoneEx only on a non-Var expression
 515 substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 516   = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]
 517         Nothing               -> DoneId (refineFromInScope in_scope v)
 518         Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)
 519         Just (DoneEx (Var v)) -> DoneId (refineFromInScope in_scope v)
 520         Just res              -> res    -- DoneEx non-var, or ContEx
 521
 522         -- Get the most up-to-date thing from the in-scope set
 523         -- Even though it isn't in the substitution, it may be in
 524         -- the in-scope set with better IdInfo
 525 refineFromInScope :: InScopeSet -> Var -> Var
 526 refineFromInScope in_scope v
 527   | isLocalId v = case lookupInScope in_scope v of
 528                   Just v' -> v'
 529                   Nothing -> WARN( True, ppr v ) v  -- This is an error!
 530   | otherwise = v
 531
 532 lookupRecBndr :: SimplEnv -> InId -> OutId
 533 -- Look up an Id which has been put into the envt by simplRecBndrs,
 534 -- but where we have not yet done its RHS
 535 lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
 536   = case lookupVarEnv ids v of
 537         Just (DoneId v) -> v
 538         Just _ -> pprPanic "lookupRecBndr" (ppr v)
 539         Nothing -> refineFromInScope in_scope v
 540
 541 {-
 542 ************************************************************************
 543 *                                                                      *
 544 \section{Substituting an Id binder}
 545 *                                                                      *
 546 ************************************************************************
 547
 548
 549 These functions are in the monad only so that they can be made strict via seq.
 550 -}
 551
 552 simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
 553 simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
 554
 555 -------------
 556 simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 557 -- Used for lambda and case-bound variables
 558 -- Clone Id if necessary, substitute type
 559 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 560 -- The substitution is extended only if the variable is cloned, because
 561 -- we *don't* need to use it to track occurrence info.
 562 simplBinder env bndr
 563   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
 564                         ; seqTyVar tv `seq` return (env', tv) }
 565   | otherwise     = do  { let (env', id) = substIdBndr env bndr
 566                         ; seqId id `seq` return (env', id) }
 567
 568 ---------------
 569 simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 570 -- A non-recursive let binder
 571 simplNonRecBndr env id
 572   = do  { let (env1, id1) = substIdBndr env id
 573         ; seqId id1 `seq` return (env1, id1) }
 574
 575 ---------------
 576 simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
 577 -- Recursive let binders
 578 simplRecBndrs env@(SimplEnv {}) ids
 579   = do  { let (env1, ids1) = mapAccumL substIdBndr env ids
 580         ; seqIds ids1 `seq` return env1 }
 581
 582 ---------------
 583 substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
 584 -- Might be a coercion variable
 585 substIdBndr env bndr
 586   | isCoVar bndr  = substCoVarBndr env bndr
 587   | otherwise     = substNonCoVarIdBndr env bndr
 588
 589 ---------------
 590 substNonCoVarIdBndr
 591    :: SimplEnv
 592    -> InBndr    -- Env and binder to transform
 593    -> (SimplEnv, OutBndr)
 594 -- Clone Id if necessary, substitute its type
 595 -- Return an Id with its
 596 --      * Type substituted
 597 --      * UnfoldingInfo, Rules, WorkerInfo zapped
 598 --      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
 599 --      * Robust info, retained especially arity and demand info,
 600 --         so that they are available to occurrences that occur in an
 601 --         earlier binding of a letrec
 602 --
 603 -- For the robust info, see Note [Arity robustness]
 604 --
 605 -- Augment the substitution  if the unique changed
 606 -- Extend the in-scope set with the new Id
 607 --
 608 -- Similar to CoreSubst.substIdBndr, except that
 609 --      the type of id_subst differs
 610 --      all fragile info is zapped
 611 substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
 612                     old_id
 613   = ASSERT2( not (isCoVar old_id), ppr old_id )
 614     (env { seInScope = in_scope `extendInScopeSet` new_id,
 615            seIdSubst = new_subst }, new_id)
 616   where
 617     id1    = uniqAway in_scope old_id
 618     id2    = substIdType env id1
 619     new_id = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding
 620                                         -- and fragile OccInfo
 621
 622         -- Extend the substitution if the unique has changed,
 623         -- or there's some useful occurrence information
 624         -- See the notes with substTyVarBndr for the delSubstEnv
 625     new_subst | new_id /= old_id
 626               = extendVarEnv id_subst old_id (DoneId new_id)
 627               | otherwise
 628               = delVarEnv id_subst old_id
 629
 630 ------------------------------------
 631 seqTyVar :: TyVar -> ()
 632 seqTyVar b = b `seq` ()
 633
 634 seqId :: Id -> ()
 635 seqId id = seqType (idType id)  `seq`
 636            idInfo id            `seq`
 637            ()
 638
 639 seqIds :: [Id] -> ()
 640 seqIds []       = ()
 641 seqIds (id:ids) = seqId id `seq` seqIds ids
 642
 643 {-
 644 Note [Arity robustness]
 645 ~~~~~~~~~~~~~~~~~~~~~~~
 646 We *do* transfer the arity from from the in_id of a let binding to the
 647 out_id.  This is important, so that the arity of an Id is visible in
 648 its own RHS.  For example:
 649         f = \x. ....g (\y. f y)....
 650 We can eta-reduce the arg to g, because f is a value.  But that
 651 needs to be visible.
 652
 653 This interacts with the 'state hack' too:
 654         f :: Bool -> IO Int
 655         f = \x. case x of
 656                   True  -> f y
 657                   False -> \s -> ...
 658 Can we eta-expand f?  Only if we see that f has arity 1, and then we
 659 take advantage of the 'state hack' on the result of
 660 (f y) :: State# -> (State#, Int) to expand the arity one more.
 661
 662 There is a disadvantage though.  Making the arity visible in the RHS
 663 allows us to eta-reduce
 664         f = \x -> f x
 665 to
 666         f = f
 667 which technically is not sound.   This is very much a corner case, so
 668 I'm not worried about it.  Another idea is to ensure that f's arity
 669 never decreases; its arity started as 1, and we should never eta-reduce
 670 below that.
 671
 672
 673 Note [Robust OccInfo]
 674 ~~~~~~~~~~~~~~~~~~~~~
 675 It's important that we *do* retain the loop-breaker OccInfo, because
 676 that's what stops the Id getting inlined infinitely, in the body of
 677 the letrec.
 678 -}
 679
 680
 681 {-
 682 ************************************************************************
 683 *                                                                      *
 684                 Impedence matching to type substitution
 685 *                                                                      *
 686 ************************************************************************
 687 -}
 688
 689 getTCvSubst :: SimplEnv -> TCvSubst
 690 getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
 691   = mkTCvSubst in_scope (tv_env, cv_env)
 692
 693 substTy :: SimplEnv -> Type -> Type
 694 substTy env ty = Type.substTy (getTCvSubst env) ty
 695
 696 substTyVar :: SimplEnv -> TyVar -> Type
 697 substTyVar env tv = Type.substTyVar (getTCvSubst env) tv
 698
 699 substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
 700 substTyVarBndr env tv
 701   = case Type.substTyVarBndr (getTCvSubst env) tv of
 702         (TCvSubst in_scope' tv_env' cv_env', tv')
 703            -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')
 704
 705 substCoVar :: SimplEnv -> CoVar -> Coercion
 706 substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv
 707
 708 substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
 709 substCoVarBndr env cv
 710   = case Coercion.substCoVarBndr (getTCvSubst env) cv of
 711         (TCvSubst in_scope' tv_env' cv_env', cv')
 712            -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
 713
 714 substCo :: SimplEnv -> Coercion -> Coercion
 715 substCo env co = Coercion.substCo (getTCvSubst env) co
 716
 717 ------------------
 718 substIdType :: SimplEnv -> Id -> Id
 719 substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id
 720   |  (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)
 721   || isEmptyVarSet (tyCoVarsOfType old_ty)
 722   = id
 723   | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)
 724                 -- The tyCoVarsOfType is cheaper than it looks
 725                 -- because we cache the free tyvars of the type
 726                 -- in a Note in the id's type itself
 727   where
 728     old_ty = idType id