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