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