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