compiler/simplCore/SimplEnv.lhs

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