ghc/compiler/coreSyn/CoreUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreUtils]{Utility functions on @Core@ syntax}
   5
   6 \begin{code}
   7 module CoreUtils (
   8         IdSubst, SubstCoreExpr(..),
   9
  10         coreExprType, coreAltsType, exprFreeVars, exprSomeFreeVars,
  11
  12         exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
  13         FormSummary(..), mkFormSummary, whnfOrBottom,
  14         cheapEqExpr,
  15
  16         substExpr, substId, substIds,
  17         idSpecVars, idFreeVars
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 import {-# SOURCE #-} CoreUnfold        ( noUnfolding, hasUnfolding )
  23
  24 import CoreSyn
  25 import PprCore          ()      -- Instances only
  26 import Var              ( IdOrTyVar, isId, isTyVar )
  27 import VarSet
  28 import VarEnv
  29 import Name             ( isLocallyDefined )
  30 import Const            ( Con(..), isWHNFCon, conIsTrivial, conIsCheap )
  31 import Id               ( Id, idType, setIdType, idUnique, idAppIsBottom,
  32                           getIdArity, idFreeTyVars,
  33                           getIdSpecialisation, setIdSpecialisation,
  34                           getInlinePragma, setInlinePragma,
  35                           getIdUnfolding, setIdUnfolding
  36                         )
  37 import IdInfo           ( arityLowerBound, InlinePragInfo(..) )
  38 import SpecEnv          ( emptySpecEnv, specEnvToList, isEmptySpecEnv )
  39 import CostCentre       ( CostCentre )
  40 import Const            ( Con, conType )
  41 import Type             ( Type, TyVarSubst, mkFunTy, mkForAllTy,
  42                           splitFunTy_maybe, applyTys, tyVarsOfType, tyVarsOfTypes,
  43                           fullSubstTy, substTyVar )
  44 import Unique           ( buildIdKey, augmentIdKey )
  45 import Util             ( zipWithEqual, mapAccumL )
  46 import Outputable
  47 import TysPrim          ( alphaTy )     -- Debgging only
  48 \end{code}
  49
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection{Substitutions}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 \begin{code}
  58 type IdSubst = IdEnv SubstCoreExpr              -- Maps Ids to SubstCoreExpr
  59
  60 data SubstCoreExpr
  61   = Done    CoreExpr                    -- No more substitution needed
  62   | SubstMe CoreExpr TyVarSubst IdSubst -- A suspended substitution
  63 \end{code}
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsection{Find the type of a Core atom/expression}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 \begin{code}
  72 coreExprType :: CoreExpr -> Type
  73
  74 coreExprType (Var var)              = idType var
  75 coreExprType (Let _ body)           = coreExprType body
  76 coreExprType (Case _ _ alts)        = coreAltsType alts
  77 coreExprType (Note (Coerce ty _) e) = ty
  78 coreExprType (Note other_note e)    = coreExprType e
  79 coreExprType e@(Con con args)       = applyTypeToArgs e (conType con) args
  80
  81 coreExprType (Lam binder expr)
  82   | isId binder    = idType binder `mkFunTy` coreExprType expr
  83   | isTyVar binder = mkForAllTy binder (coreExprType expr)
  84
  85 coreExprType e@(App _ _)
  86   = case collectArgs e of
  87         (fun, args) -> applyTypeToArgs e (coreExprType fun) args
  88
  89 coreExprType other = pprTrace "coreExprType" (ppr other) alphaTy
  90
  91 coreAltsType :: [CoreAlt] -> Type
  92 coreAltsType ((_,_,rhs) : _) = coreExprType rhs
  93 \end{code}
  94
  95 \begin{code}
  96 -- The "e" argument is just for debugging
  97
  98 applyTypeToArgs e op_ty [] = op_ty
  99
 100 applyTypeToArgs e op_ty (Type ty : args)
 101   =     -- Accumulate type arguments so we can instantiate all at once
 102     applyTypeToArgs e (applyTys op_ty tys) rest_args
 103   where
 104     (tys, rest_args)        = go [ty] args
 105     go tys (Type ty : args) = go (ty:tys) args
 106     go tys rest_args        = (reverse tys, rest_args)
 107
 108 applyTypeToArgs e op_ty (other_arg : args)
 109   = case (splitFunTy_maybe op_ty) of
 110         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 111         Nothing -> pprPanic "applyTypeToArgs" (ppr e)
 112 \end{code}
 113
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection{Figuring out things about expressions}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 data FormSummary
 123   = VarForm             -- Expression is a variable (or scc var, etc)
 124   | ValueForm           -- Expression is a value: i.e. a value-lambda,constructor, or literal
 125   | BottomForm          -- Expression is guaranteed to be bottom. We're more gung
 126                         -- ho about inlining such things, because it can't waste work
 127   | OtherForm           -- Anything else
 128
 129 instance Outputable FormSummary where
 130    ppr VarForm    = ptext SLIT("Var")
 131    ppr ValueForm  = ptext SLIT("Value")
 132    ppr BottomForm = ptext SLIT("Bot")
 133    ppr OtherForm  = ptext SLIT("Other")
 134
 135 whnfOrBottom :: FormSummary -> Bool
 136 whnfOrBottom VarForm    = True
 137 whnfOrBottom ValueForm  = True
 138 whnfOrBottom BottomForm = True
 139 whnfOrBottom OtherForm  = False
 140 \end{code}
 141
 142 \begin{code}
 143 mkFormSummary :: CoreExpr -> FormSummary
 144 mkFormSummary expr
 145   = go (0::Int) expr    -- The "n" is the number of *value* arguments so far
 146   where
 147     go n (Con con _) | isWHNFCon con = ValueForm
 148                      | otherwise     = OtherForm
 149
 150     go n (Note _ e)         = go n e
 151
 152     go n (Let (NonRec b r) e) | exprIsTrivial r = go n e        -- let f = f' alpha in (f,g)
 153                                                                 -- should be treated as a value
 154     go n (Let _ e)    = OtherForm
 155     go n (Case _ _ _) = OtherForm
 156
 157     go 0 (Lam x e) | isId x    = ValueForm      -- NB: \x.bottom /= bottom!
 158                    | otherwise = go 0 e
 159     go n (Lam x e) | isId x    = go (n-1) e     -- Applied lambda
 160                    | otherwise = go n e
 161
 162     go n (App fun (Type _)) = go n fun          -- Ignore type args
 163     go n (App fun arg)      = go (n+1) fun
 164
 165     go n (Var f) | idAppIsBottom f n = BottomForm
 166     go 0 (Var f)                     = VarForm
 167     go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
 168                  | otherwise                          = OtherForm
 169 \end{code}
 170
 171 @exprIsTrivial@ is true of expressions we are unconditionally
 172                 happy to duplicate; simple variables and constants,
 173                 and type applications.
 174
 175 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 176                 cost in space, but without duplicating any work.
 177
 178
 179 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 180
 181
 182 \begin{code}
 183 exprIsTrivial (Type _)       = True
 184 exprIsTrivial (Var v)        = True
 185 exprIsTrivial (App e arg)    = isTypeArg arg && exprIsTrivial e
 186 exprIsTrivial (Note _ e)     = exprIsTrivial e
 187 exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
 188 exprIsTrivial (Lam b body)   | isTyVar b = exprIsTrivial body
 189 exprIsTrivial other          = False
 190 \end{code}
 191
 192
 193 \begin{code}
 194 exprIsDupable (Type _)       = True
 195 exprIsDupable (Con con args) = conIsCheap con &&
 196                                all exprIsDupable args &&
 197                                valArgCount args <= dupAppSize
 198
 199 exprIsDupable (Note _ e)     = exprIsDupable e
 200 exprIsDupable expr           = case collectArgs expr of
 201                                   (Var v, args) -> n_val_args == 0 ||
 202                                                    (n_val_args < fun_arity &&
 203                                                     all exprIsDupable args &&
 204                                                     n_val_args <= dupAppSize)
 205                                                 where
 206                                                    n_val_args = valArgCount args
 207                                                    fun_arity = arityLowerBound (getIdArity v)
 208
 209                                   _             -> False
 210
 211 dupAppSize :: Int
 212 dupAppSize = 4          -- Size of application we are prepared to duplicate
 213 \end{code}
 214
 215 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 216 it is obviously in weak head normal form, or is cheap to get to WHNF.
 217 [Note that that's not the same as exprIsDupable; an expression might be
 218 big, and hence not dupable, but still cheap.]
 219 By ``cheap'' we mean a computation we're willing to push inside a lambda
 220 in order to bring a couple of lambdas together.  That might mean it gets
 221 evaluated more than once, instead of being shared.  The main examples of things
 222 which aren't WHNF but are ``cheap'' are:
 223
 224   *     case e of
 225           pi -> ei
 226
 227         where e, and all the ei are cheap; and
 228
 229   *     let x = e
 230         in b
 231
 232         where e and b are cheap; and
 233
 234   *     op x1 ... xn
 235
 236         where op is a cheap primitive operator
 237
 238 \begin{code}
 239 exprIsCheap :: CoreExpr -> Bool
 240 exprIsCheap (Type _)            = True
 241 exprIsCheap (Var _)             = True
 242 exprIsCheap (Con con args)      = conIsCheap con && all exprIsCheap args
 243 exprIsCheap (Note _ e)          = exprIsCheap e
 244 exprIsCheap (Lam x e)           = if isId x then True else exprIsCheap e
 245 exprIsCheap (Let bind body)     = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
 246 exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
 247                                   all (\(_,_,rhs) -> exprIsCheap rhs) alts
 248
 249 exprIsCheap other_expr   -- look for manifest partial application
 250   = case collectArgs other_expr of
 251
 252       (Var f, args) |  idAppIsBottom f (length args)
 253                     -> True     -- Application of a function which
 254                                 -- always gives bottom; we treat this as
 255                                 -- a WHNF, because it certainly doesn't
 256                                 -- need to be shared!
 257
 258       (Var f, args) ->
 259                 let
 260                     num_val_args = valArgCount args
 261                 in
 262                 num_val_args == 0 ||    -- Just a type application of
 263                                         -- a variable (f t1 t2 t3)
 264                                         -- counts as WHNF
 265                 num_val_args < arityLowerBound (getIdArity f)
 266
 267       _ -> False
 268 \end{code}
 269
 270
 271 \begin{code}
 272 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 273 exprIsBottom e = go 0 e
 274                where
 275                 -- n is the number of args
 276                  go n (Note _ e)   = go n e
 277                  go n (Let _ e)    = go n e
 278                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 279                  go n (App e _)    = go (n+1) e
 280                  go n (Var v)      = idAppIsBottom v n
 281                  go n (Con _ _)    = False
 282                  go n (Lam _ _)    = False
 283 \end{code}
 284
 285 exprIsWHNF reports True for head normal forms.  Note that does not necessarily
 286 mean *normal* forms; constructors might have non-trivial argument expressions, for
 287 example.  We use a let binding for WHNFs, rather than a case binding, even if it's
 288 used strictly.  We try to expose WHNFs by floating lets out of the RHS of lets.
 289
 290 We treat applications of buildId and augmentId as honorary WHNFs, because we
 291 want them to get exposed
 292
 293 \begin{code}
 294 exprIsWHNF :: CoreExpr -> Bool  -- True => Variable, value-lambda, constructor, PAP
 295 exprIsWHNF (Type ty)          = True    -- Types are honorary WHNFs; we don't mind
 296                                         -- copying them
 297 exprIsWHNF (Var v)            = True
 298 exprIsWHNF (Lam b e)          = isId b || exprIsWHNF e
 299 exprIsWHNF (Note _ e)         = exprIsWHNF e
 300 exprIsWHNF (Let _ e)          = False
 301 exprIsWHNF (Case _ _ _)       = False
 302 exprIsWHNF (Con con _)        = isWHNFCon con
 303 exprIsWHNF e@(App _ _)        = case collectArgs e of
 304                                   (Var v, args) -> n_val_args == 0 ||
 305                                                    fun_arity > n_val_args ||
 306                                                    v_uniq == buildIdKey ||
 307                                                    v_uniq == augmentIdKey
 308                                                 where
 309                                                    n_val_args = valArgCount args
 310                                                    fun_arity  = arityLowerBound (getIdArity v)
 311                                                    v_uniq     = idUnique v
 312
 313                                   _             -> False
 314 \end{code}
 315
 316 @cheapEqExpr@ is a cheap equality test which bales out fast!
 317         True  => definitely equal
 318         False => may or may not be equal
 319
 320 \begin{code}
 321 cheapEqExpr :: Expr b -> Expr b -> Bool
 322
 323 cheapEqExpr (Var v1) (Var v2) = v1==v2
 324 cheapEqExpr (Con con1 args1) (Con con2 args2)
 325   = con1 == con2 &&
 326     and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
 327
 328 cheapEqExpr (App f1 a1) (App f2 a2)
 329   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 330
 331 cheapEqExpr (Type t1) (Type t2) = t1 == t2
 332
 333 cheapEqExpr _ _ = False
 334 \end{code}
 335
 336
 337 %************************************************************************
 338 %*                                                                      *
 339 \section{Finding the free variables of an expression}
 340 %*                                                                      *
 341 %************************************************************************
 342
 343 This function simply finds the free variables of an expression.
 344 So far as type variables are concerned, it only finds tyvars that are
 345
 346         * free in type arguments,
 347         * free in the type of a binder,
 348
 349 but not those that are free in the type of variable occurrence.
 350
 351 \begin{code}
 352 exprFreeVars :: CoreExpr -> IdOrTyVarSet        -- Find all locally-defined free Ids or tyvars
 353 exprFreeVars = exprSomeFreeVars isLocallyDefined
 354
 355 exprSomeFreeVars :: InterestingVarFun   -- Says which Vars are interesting
 356                 -> CoreExpr
 357                 -> IdOrTyVarSet
 358 exprSomeFreeVars fv_cand e = expr_fvs e fv_cand emptyVarSet
 359
 360 type InterestingVarFun = IdOrTyVar -> Bool      -- True <=> interesting
 361 \end{code}
 362
 363
 364 \begin{code}
 365 type FV = InterestingVarFun
 366           -> IdOrTyVarSet       -- In scope
 367           -> IdOrTyVarSet       -- Free vars
 368
 369 union :: FV -> FV -> FV
 370 union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
 371
 372 noVars :: FV
 373 noVars fv_cand in_scope = emptyVarSet
 374
 375 oneVar :: IdOrTyVar -> FV
 376 oneVar var fv_cand in_scope
 377   | keep_it fv_cand in_scope var = unitVarSet var
 378   | otherwise                    = emptyVarSet
 379
 380 someVars :: IdOrTyVarSet -> FV
 381 someVars vars fv_cand in_scope
 382   = filterVarSet (keep_it fv_cand in_scope) vars
 383
 384 keep_it fv_cand in_scope var
 385   | var `elemVarSet` in_scope = False
 386   | fv_cand var               = True
 387   | otherwise                 = False
 388
 389
 390 addBndr :: CoreBndr -> FV -> FV
 391 addBndr bndr fv fv_cand in_scope
 392   | isId bndr = inside_fvs `unionVarSet` someVars (idFreeVars bndr) fv_cand in_scope
 393   | otherwise = inside_fvs
 394   where
 395     inside_fvs = fv fv_cand (in_scope `extendVarSet` bndr)
 396
 397 addBndrs :: [CoreBndr] -> FV -> FV
 398 addBndrs bndrs fv = foldr addBndr fv bndrs
 399 \end{code}
 400
 401
 402 \begin{code}
 403 expr_fvs :: CoreExpr -> FV
 404
 405 expr_fvs (Type ty)       = someVars (tyVarsOfType ty)
 406 expr_fvs (Var var)       = oneVar var
 407 expr_fvs (Con con args)  = foldr (union . expr_fvs) noVars args
 408 expr_fvs (Note _ expr)   = expr_fvs expr
 409 expr_fvs (App fun arg)   = expr_fvs fun `union` expr_fvs arg
 410 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
 411
 412 expr_fvs (Case scrut bndr alts)
 413   = expr_fvs scrut `union` addBndr bndr (foldr (union. alt_fvs) noVars alts)
 414   where
 415     alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)
 416
 417 expr_fvs (Let (NonRec bndr rhs) body)
 418   = expr_fvs rhs `union` addBndr bndr (expr_fvs body)
 419
 420 expr_fvs (Let (Rec pairs) body)
 421   = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss)
 422   where
 423     (bndrs,rhss) = unzip pairs
 424 \end{code}
 425
 426
 427 Given an Id, idSpecVars returns all its specialisations.
 428 We extract these from its SpecEnv.
 429 This is used by the occurrence analyser and free-var finder;
 430 we regard an Id's specialisations as free in the Id's definition.
 431
 432 \begin{code}
 433 idSpecVars :: Id -> IdOrTyVarSet
 434 idSpecVars id
 435   = foldr (unionVarSet . spec_item_fvs)
 436           emptyVarSet
 437           (specEnvToList (getIdSpecialisation id))
 438   where
 439     spec_item_fvs (tyvars, tys, rhs) = foldl delVarSet
 440                                              (tyVarsOfTypes tys `unionVarSet` exprFreeVars rhs)
 441                                              tyvars
 442
 443 idFreeVars :: Id -> IdOrTyVarSet
 444 idFreeVars id = idSpecVars id `unionVarSet` idFreeTyVars id
 445 \end{code}
 446
 447
 448 %************************************************************************
 449 %*                                                                      *
 450 \section{Substitution}
 451 %*                                                                      *
 452 %************************************************************************
 453
 454 This expression substituter deals correctly with name capture, much
 455 like Type.substTy.
 456
 457 BUT NOTE that substExpr silently discards the
 458         unfolding, and
 459         spec env
 460 IdInfo attached to any binders in the expression.  It's quite
 461 tricky to do them 'right' in the case of mutually recursive bindings,
 462 and so far has proved unnecessary.
 463
 464 \begin{code}
 465 substExpr :: TyVarSubst -> IdSubst      -- Substitution
 466           -> IdOrTyVarSet               -- Superset of in-scope
 467           -> CoreExpr
 468           -> CoreExpr
 469
 470 substExpr te ve in_scope expr = subst_expr (te, ve, in_scope) expr
 471
 472 subst_expr env@(te, ve, in_scope) expr
 473   = go expr
 474   where
 475     go (Var v) = case lookupVarEnv ve v of
 476                         Just (Done e')
 477                                 -> e'
 478
 479                         Just (SubstMe e' te' ve')
 480                                 -> subst_expr (te', ve', in_scope) e'
 481
 482                         Nothing -> case lookupVarSet in_scope v of
 483                                         Just v' -> Var v'
 484                                         Nothing -> Var v
 485                         -- NB: we look up in the in_scope set because the variable
 486                         -- there may have more info. In particular, when substExpr
 487                         -- is called from the simplifier, the type inside the *occurrences*
 488                         -- of a variable may not be right; we should replace it with the
 489                         -- binder, from the in_scope set.
 490
 491     go (Type ty)      = Type (go_ty ty)
 492     go (Con con args) = Con con (map go args)
 493     go (App fun arg)  = App (go fun) (go arg)
 494     go (Note note e)  = Note (go_note note) (go e)
 495
 496     go (Lam bndr body) = Lam bndr' (subst_expr env' body)
 497                        where
 498                          (env', bndr') = go_bndr env bndr
 499
 500     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (subst_expr env' body)
 501                                     where
 502                                       (env', bndr') = go_bndr env bndr
 503
 504     go (Let (Rec pairs) body) = Let (Rec pairs') (subst_expr env' body)
 505                               where
 506                                 (ve', in_scope', _, bndrs')
 507                                    = substIds clone_fn te ve in_scope undefined (map fst pairs)
 508                                 env'    = (te, ve', in_scope')
 509                                 pairs'  = bndrs' `zip` rhss'
 510                                 rhss'   = map (subst_expr env' . snd) pairs
 511
 512     go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt env') alts)
 513                               where
 514                                 (env', bndr') = go_bndr env bndr
 515
 516     go_alt env (con, bndrs, rhs) = (con, bndrs', subst_expr env' rhs)
 517                                  where
 518                                    (env', bndrs') = mapAccumL go_bndr env bndrs
 519
 520     go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
 521     go_note note             = note
 522
 523     go_ty ty = fullSubstTy te in_scope ty
 524
 525     go_bndr (te, ve, in_scope) bndr
 526         | isTyVar bndr
 527         = case substTyVar te in_scope bndr of
 528                 (te', in_scope', bndr') -> ((te', ve, in_scope'), bndr')
 529
 530         | otherwise
 531         = case substId clone_fn te ve in_scope undefined bndr of
 532                 (ve', in_scope', _, bndr') -> ((te, ve', in_scope'), bndr')
 533
 534
 535     clone_fn in_scope _ bndr
 536                 | bndr `elemVarSet` in_scope = Just (uniqAway in_scope bndr, undefined)
 537                 | otherwise                  = Nothing
 538
 539 \end{code}
 540
 541 Substituting in binders is a rather tricky part of the whole compiler.
 542
 543 \begin{code}
 544 substIds :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id))        -- Cloner
 545          -> TyVarSubst -> IdSubst -> IdOrTyVarSet       -- Usual stuff
 546          -> us                                          -- Unique supply
 547          -> [Id]
 548          -> (IdSubst, IdOrTyVarSet,                     -- New id_subst, in_scope
 549              us,                                        -- New unique supply
 550              [Id])
 551
 552 substIds clone_fn ty_subst id_subst in_scope us []
 553   = (id_subst, in_scope, us, [])
 554
 555 substIds clone_fn ty_subst id_subst in_scope us (id:ids)
 556   = case (substId clone_fn ty_subst id_subst in_scope us id) of {
 557         (id_subst', in_scope', us', id') ->
 558
 559     case (substIds clone_fn ty_subst id_subst' in_scope' us' ids) of {
 560         (id_subst'', in_scope'', us'', ids') ->
 561
 562     (id_subst'', in_scope'', us'', id':ids')
 563     }}
 564
 565
 566 substId :: (IdOrTyVarSet -> us -> Id -> Maybe (us, Id)) -- Cloner
 567         -> TyVarSubst -> IdSubst -> IdOrTyVarSet        -- Usual stuff
 568         -> us                                           -- Unique supply
 569         -> Id
 570         -> (IdSubst, IdOrTyVarSet,                      -- New id_subst, in_scope
 571             us,                                         -- New unique supply
 572             Id)
 573
 574 -- Returns an Id with empty unfolding and spec-env.
 575 -- It's up to the caller to sort these out.
 576
 577 substId clone_fn
 578         ty_subst id_subst in_scope
 579         us id
 580   | old_id_will_do
 581                 -- No need to clone, but we *must* zap any current substitution
 582                 -- for the variable.  For example:
 583                 --      (\x.e) with id_subst = [x |-> e']
 584                 -- Here we must simply zap the substitution for x
 585   = (delVarEnv id_subst id, extendVarSet in_scope id, us, id)
 586
 587   | otherwise
 588   = (extendVarEnv id_subst id (Done (Var new_id)),
 589      extendVarSet in_scope new_id,
 590      new_us,
 591      new_id)
 592   where
 593     id_ty          = idType id
 594     old_id_will_do = old1 && old2 && old3 && {-old4 && -}not cloned
 595
 596        -- id1 has its type zapped
 597     (id1,old1) |  isEmptyVarEnv ty_subst
 598                || isEmptyVarSet (tyVarsOfType id_ty) = (id, True)
 599                | otherwise                           = (setIdType id ty', False)
 600
 601     ty' = fullSubstTy ty_subst in_scope id_ty
 602
 603         -- id2 has its SpecEnv zapped
 604         -- It's filled in later by Simplify.simplPrags
 605     (id2,old2) | isEmptySpecEnv spec_env = (id1, True)
 606                | otherwise               = (setIdSpecialisation id1 emptySpecEnv, False)
 607     spec_env  = getIdSpecialisation id
 608
 609         -- id3 has its Unfolding zapped
 610         -- This is very important; occasionally a let-bound binder is used
 611         -- as a binder in some lambda, in which case its unfolding is utterly
 612         -- bogus.  Also the unfolding uses old binders so if we left it we'd
 613         -- have to substitute it. Much better simply to give the Id a new
 614         -- unfolding each time, which is what the simplifier does.
 615     (id3,old3) | hasUnfolding (getIdUnfolding id) = (id2 `setIdUnfolding` noUnfolding, False)
 616                | otherwise                        = (id2, True)
 617
 618         -- new_id is cloned if necessary
 619     (new_us, new_id, cloned) = case clone_fn in_scope us id3 of
 620                                   Nothing         -> (us,  id3, False)
 621                                   Just (us', id') -> (us', id', True)
 622
 623         -- new_id_bndr has its Inline info neutered.  We must forget about whether it
 624         -- was marked safe-to-inline, because that isn't necessarily true in
 625         -- the simplified expression.  We do this for the *binder* which will
 626         -- be used at the binding site, but we *dont* do it for new_id, which
 627         -- is put into the in_scope env.  Why not?  Because the in_scope env
 628         -- carries down the occurrence information to usage sites!
 629         --
 630         -- Net result: post-simplification, occurrences may have over-optimistic
 631         -- occurrence info, but binders won't.
 632 {-    (new_id_bndr, old4)
 633         = case getInlinePragma id of
 634                 ICanSafelyBeINLINEd _ _ -> (setInlinePragma new_id NoInlinePragInfo, False)
 635                 other                   -> (new_id, True)
 636 -}
 637 \end{code}
 638
 639
 640
 641
 642