ghc/compiler/coreSyn/Subst.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 Subst (
   8         -- In-scope set
   9         InScopeSet, emptyInScopeSet, mkInScopeSet,
  10         extendInScopeSet, extendInScopeSetList,
  11         lookupInScope, elemInScopeSet, uniqAway,
  12
  13
  14         -- Substitution stuff
  15         Subst, TyVarSubst, IdSubst,
  16         emptySubst, mkSubst, substEnv, substInScope,
  17         lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList,
  18         zapSubstEnv, setSubstEnv,
  19         setInScope,
  20         extendInScope, extendInScopeList, extendNewInScope, extendNewInScopeList,
  21         isInScope, modifyInScope,
  22
  23         bindSubst, unBindSubst, bindSubstList, unBindSubstList,
  24
  25         -- Binders
  26         simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo,
  27         substAndCloneId, substAndCloneIds, substAndCloneRecIds,
  28
  29         -- Type stuff
  30         mkTyVarSubst, mkTopTyVarSubst,
  31         substTyWith, substTy, substTheta,
  32
  33         -- Expression stuff
  34         substExpr
  35     ) where
  36
  37 #include "HsVersions.h"
  38
  39 import CmdLineOpts      ( opt_PprStyle_Debug )
  40 import CoreSyn          ( Expr(..), Bind(..), Note(..), CoreExpr,
  41                           CoreRules(..), CoreRule(..),
  42                           isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding,
  43                           Unfolding(..)
  44                         )
  45 import CoreFVs          ( exprFreeVars )
  46 import TypeRep          ( Type(..), TyNote(..) )  -- friend
  47 import Type             ( ThetaType, SourceType(..), PredType,
  48                           tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
  49                         )
  50 import VarSet
  51 import VarEnv
  52 import Var              ( setVarUnique, isId, mustHaveLocalBinding )
  53 import Id               ( idType, idInfo, setIdInfo, setIdType,
  54                           idUnfolding, setIdUnfolding,
  55                           idOccInfo, maybeModifyIdInfo )
  56 import IdInfo           ( IdInfo, vanillaIdInfo,
  57                           occInfo, isFragileOcc, setOccInfo,
  58                           specInfo, setSpecInfo,
  59                           unfoldingInfo, setUnfoldingInfo,
  60                           WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
  61                           lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
  62                         )
  63 import BasicTypes       ( OccInfo(..) )
  64 import Unique           ( Unique, Uniquable(..), deriveUnique )
  65 import UniqSet          ( elemUniqSet_Directly )
  66 import UniqSupply       ( UniqSupply, uniqFromSupply, uniqsFromSupply )
  67 import Var              ( Var, Id, TyVar, isTyVar )
  68 import Outputable
  69 import PprCore          ()              -- Instances
  70 import UniqFM           ( ufmToList )   -- Yuk (add a new op to VarEnv)
  71 import Util             ( mapAccumL, foldl2, seqList )
  72 import FastTypes
  73 \end{code}
  74
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection{The in-scope set}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 \begin{code}
  83 data InScopeSet = InScope (VarEnv Var) FastInt
  84         -- The Int# is a kind of hash-value used by uniqAway
  85         -- For example, it might be the size of the set
  86         -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
  87
  88 emptyInScopeSet :: InScopeSet
  89 emptyInScopeSet = InScope emptyVarSet 1#
  90
  91 mkInScopeSet :: VarEnv Var -> InScopeSet
  92 mkInScopeSet in_scope = InScope in_scope 1#
  93
  94 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
  95 extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#)
  96
  97 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
  98 extendInScopeSetList (InScope in_scope n) vs
  99    = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
 100                     (n +# iUnbox (length vs))
 101
 102 modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
 103 -- Exploit the fact that the in-scope "set" is really a map
 104 --      Make old_v map to new_v
 105 modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#)
 106
 107 delInScopeSet :: InScopeSet -> Var -> InScopeSet
 108 delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
 109
 110 elemInScopeSet :: Var -> InScopeSet -> Bool
 111 elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope
 112
 113 lookupInScope :: InScopeSet -> Var -> Var
 114 -- It's important to look for a fixed point
 115 -- When we see (case x of y { I# v -> ... })
 116 -- we add  [x -> y] to the in-scope set (Simplify.simplCaseBinder).
 117 -- When we lookup up an occurrence of x, we map to y, but then
 118 -- we want to look up y in case it has acquired more evaluation information by now.
 119 lookupInScope (InScope in_scope n) v
 120   = go v
 121   where
 122     go v = case lookupVarEnv in_scope v of
 123                 Just v' | v == v'   -> v'       -- Reached a fixed point
 124                         | otherwise -> go v'
 125                 Nothing             -> WARN( mustHaveLocalBinding v, ppr v )
 126                                        v
 127 \end{code}
 128
 129 \begin{code}
 130 uniqAway :: InScopeSet -> Var -> Var
 131 -- (uniqAway in_scope v) finds a unique that is not used in the
 132 -- in-scope set, and gives that to v.  It starts with v's current unique, of course,
 133 -- in the hope that it won't have to change it, nad thereafter uses a combination
 134 -- of that and the hash-code found in the in-scope set
 135 uniqAway (InScope set n) var
 136   | not (var `elemVarSet` set) = var                            -- Nothing to do
 137   | otherwise                  = try 1#
 138   where
 139     orig_unique = getUnique var
 140     try k
 141 #ifdef DEBUG
 142           | k ># 1000#
 143           = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
 144 #endif
 145           | uniq `elemUniqSet_Directly` set = try (k +# 1#)
 146 #ifdef DEBUG
 147           | opt_PprStyle_Debug && k ># 3#
 148           = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n))
 149             setVarUnique var uniq
 150 #endif
 151           | otherwise = setVarUnique var uniq
 152           where
 153             uniq = deriveUnique orig_unique (iBox (n *# k))
 154 \end{code}
 155
 156
 157 %************************************************************************
 158 %*                                                                      *
 159 \subsection{Substitutions}
 160 %*                                                                      *
 161 %************************************************************************
 162
 163 \begin{code}
 164 data Subst = Subst InScopeSet           -- In scope
 165                    SubstEnv             -- Substitution itself
 166         -- INVARIANT 1: The (domain of the) in-scope set is a superset
 167         --              of the free vars of the range of the substitution
 168         --              that might possibly clash with locally-bound variables
 169         --              in the thing being substituted in.
 170         -- This is what lets us deal with name capture properly
 171         -- It's a hard invariant to check...
 172         -- There are various ways of causing it to happen:
 173         --      - arrange that the in-scope set really is all the things in scope
 174         --      - arrange that it's the free vars of the range of the substitution
 175         --      - make it empty because all the free vars of the subst are fresh,
 176         --              and hence can't possibly clash.a
 177         --
 178         -- INVARIANT 2: No variable is both in scope and in the domain of the substitution
 179         --              Equivalently, the substitution is idempotent
 180         --      [Sep 2000: Lies, all lies.  The substitution now does contain
 181         --                 mappings x77 -> DoneId x77 occ
 182         --                 to record x's occurrence information.]
 183         --      [Also watch out: the substitution can contain x77 -> DoneEx (Var x77)
 184         --       Consider let x = case k of I# x77 -> ... in
 185         --                let y = case k of I# x77 -> ... in ...
 186         --       and suppose the body is strict in both x and y.  Then the simplifier
 187         --       will pull the first (case k) to the top; so the second (case k) will
 188         --       cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
 189         --       other is an out-Id. So the substitution is idempotent in the sense
 190         --       that we *must not* repeatedly apply it.]
 191
 192 type IdSubst    = Subst
 193 \end{code}
 194
 195 The general plan about the substitution and in-scope set for Ids is as follows
 196
 197 * substId always adds new_id to the in-scope set.
 198   new_id has a correctly-substituted type, occ info
 199
 200 * substId adds a binding (DoneId new_id occ) to the substitution if
 201         EITHER the Id's unique has changed
 202         OR     the Id has interesting occurrence information
 203   So in effect you can only get to interesting occurrence information
 204   by looking up the *old* Id; it's not really attached to the new id
 205   at all.
 206
 207   Note, though that the substitution isn't necessarily extended
 208   if the type changes.  Why not?  Because of the next point:
 209
 210 * We *always, always* finish by looking up in the in-scope set
 211   any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
 212   Reason: so that we never finish up with a "old" Id in the result.
 213   An old Id might point to an old unfolding and so on... which gives a space leak.
 214
 215   [The DoneEx and DoneVar hits map to "new" stuff.]
 216
 217 * It follows that substExpr must not do a no-op if the substitution is empty.
 218   substType is free to do so, however.
 219
 220 * When we come to a let-binding (say) we generate new IdInfo, including an
 221   unfolding, attach it to the binder, and add this newly adorned binder to
 222   the in-scope set.  So all subsequent occurrences of the binder will get mapped
 223   to the full-adorned binder, which is also the one put in the binding site.
 224
 225 * The in-scope "set" usually maps x->x; we use it simply for its domain.
 226   But sometimes we have two in-scope Ids that are synomyms, and should
 227   map to the same target:  x->x, y->x.  Notably:
 228         case y of x { ... }
 229   That's why the "set" is actually a VarEnv Var
 230
 231
 232 \begin{code}
 233 isEmptySubst :: Subst -> Bool
 234 isEmptySubst (Subst _ env) = isEmptySubstEnv env
 235
 236 emptySubst :: Subst
 237 emptySubst = Subst emptyInScopeSet emptySubstEnv
 238
 239 mkSubst :: InScopeSet -> SubstEnv -> Subst
 240 mkSubst in_scope env = Subst in_scope env
 241
 242 substEnv :: Subst -> SubstEnv
 243 substEnv (Subst _ env) = env
 244
 245 substInScope :: Subst -> InScopeSet
 246 substInScope (Subst in_scope _) = in_scope
 247
 248 zapSubstEnv :: Subst -> Subst
 249 zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv
 250
 251 extendSubst :: Subst -> Var -> SubstResult -> Subst
 252 extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } )
 253                                        Subst in_scope (extendSubstEnv env v r)
 254
 255 extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst
 256 extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r )
 257                                            Subst in_scope (extendSubstEnvList env v r)
 258
 259 lookupSubst :: Subst -> Var -> Maybe SubstResult
 260 lookupSubst (Subst _ env) v = lookupSubstEnv env v
 261
 262 lookupIdSubst :: Subst -> Id -> SubstResult
 263 -- Does the lookup in the in-scope set too
 264 lookupIdSubst (Subst in_scope env) v
 265   = case lookupSubstEnv env v of
 266         Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ
 267         Just res             -> res
 268         Nothing              -> DoneId v' (idOccInfo v')
 269                                 -- We don't use DoneId for LoopBreakers, so the idOccInfo is
 270                                 -- very important!  If isFragileOcc returned True for
 271                                 -- loop breakers we could avoid this call, but at the expense
 272                                 -- of adding more to the substitution, and building new Ids
 273                                 -- in substId a bit more often than really necessary
 274                              where
 275                                     v' = lookupInScope in_scope v
 276
 277 isInScope :: Var -> Subst -> Bool
 278 isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope
 279
 280 modifyInScope :: Subst -> Var -> Var -> Subst
 281 modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env
 282         -- make old_v map to new_v
 283
 284 extendInScope :: Subst -> Var -> Subst
 285         -- Add a new variable as in-scope
 286         -- Remember to delete any existing binding in the substitution!
 287 extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v)
 288                                              (env `delSubstEnv` v)
 289
 290 extendInScopeList :: Subst -> [Var] -> Subst
 291 extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs)
 292                                                   (delSubstEnvList env vs)
 293
 294 -- The "New" variants are guaranteed to be adding freshly-allocated variables
 295 -- It's not clear that the gain (not needing to delete it from the substitution)
 296 -- is worth the extra proof obligation
 297 extendNewInScope :: Subst -> Var -> Subst
 298 extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env
 299
 300 extendNewInScopeList :: Subst -> [Var] -> Subst
 301 extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` vs) env
 302
 303 -------------------------------
 304 bindSubst :: Subst -> Var -> Var -> Subst
 305 -- Extend with a substitution, v1 -> Var v2
 306 -- and extend the in-scopes with v2
 307 bindSubst (Subst in_scope env) old_bndr new_bndr
 308   = Subst (in_scope `extendInScopeSet` new_bndr)
 309           (extendSubstEnv env old_bndr subst_result)
 310   where
 311     subst_result | isId old_bndr = DoneEx (Var new_bndr)
 312                  | otherwise     = DoneTy (TyVarTy new_bndr)
 313
 314 unBindSubst :: Subst -> Var -> Var -> Subst
 315 -- Reverse the effect of bindSubst
 316 -- If old_bndr was already in the substitution, this doesn't quite work
 317 unBindSubst (Subst in_scope env) old_bndr new_bndr
 318   = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr)
 319
 320 -- And the "List" forms
 321 bindSubstList :: Subst -> [Var] -> [Var] -> Subst
 322 bindSubstList subst old_bndrs new_bndrs
 323   = foldl2 bindSubst subst old_bndrs new_bndrs
 324
 325 unBindSubstList :: Subst -> [Var] -> [Var] -> Subst
 326 unBindSubstList subst old_bndrs new_bndrs
 327   = foldl2 unBindSubst subst old_bndrs new_bndrs
 328
 329
 330 -------------------------------
 331 setInScope :: Subst     -- Take env part from here
 332            -> InScopeSet
 333            -> Subst
 334 setInScope (Subst in_scope1 env1) in_scope2
 335   = Subst in_scope2 env1
 336
 337 setSubstEnv :: Subst            -- Take in-scope part from here
 338             -> SubstEnv         -- ... and env part from here
 339             -> Subst
 340 setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2
 341 \end{code}
 342
 343 Pretty printing, for debugging only
 344
 345 \begin{code}
 346 instance Outputable SubstResult where
 347   ppr (DoneEx e)   = ptext SLIT("DoneEx") <+> ppr e
 348   ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v
 349   ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e
 350   ppr (DoneTy t)   = ptext SLIT("DoneTy") <+> ppr t
 351
 352 instance Outputable SubstEnv where
 353   ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se)))))
 354         where
 355            ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr
 356
 357 instance Outputable Subst where
 358   ppr (Subst (InScope in_scope _) se)
 359         =  ptext SLIT("<InScope =") <+> braces   (fsep (map ppr (rngVarEnv in_scope)))
 360         $$ ptext SLIT(" Subst   =") <+> ppr se <> char '>'
 361 \end{code}
 362
 363 %************************************************************************
 364 %*                                                                      *
 365 \subsection{Type substitution}
 366 %*                                                                      *
 367 %************************************************************************
 368
 369 \begin{code}
 370 type TyVarSubst = Subst -- TyVarSubst are expected to have range elements
 371         -- (We could have a variant of Subst, but it doesn't seem worth it.)
 372
 373 -- mkTyVarSubst generates the in-scope set from
 374 -- the types given; but it's just a thunk so with a bit of luck
 375 -- it'll never be evaluated
 376 mkTyVarSubst :: [TyVar] -> [Type] -> Subst
 377 mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys))
 378                                 (zip_ty_env tyvars tys emptySubstEnv)
 379
 380 -- mkTopTyVarSubst is called when doing top-level substitutions.
 381 -- Here we expect that the free vars of the range of the
 382 -- substitution will be empty.
 383 mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
 384 mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
 385
 386 zip_ty_env []       []       env = env
 387 zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
 388         -- There used to be a special case for when
 389         --      ty == TyVarTy tv
 390         -- (a not-uncommon case) in which case the substitution was dropped.
 391         -- But the type-tidier changes the print-name of a type variable without
 392         -- changing the unique, and that led to a bug.   Why?  Pre-tidying, we had
 393         -- a type {Foo t}, where Foo is a one-method class.  So Foo is really a newtype.
 394         -- And it happened that t was the type variable of the class.  Post-tiding,
 395         -- it got turned into {Foo t2}.  The ext-core printer expanded this using
 396         -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,
 397         -- and so generated a rep type mentioning t not t2.
 398         --
 399         -- Simplest fix is to nuke the "optimisation"
 400 \end{code}
 401
 402 substTy works with general Substs, so that it can be called from substExpr too.
 403
 404 \begin{code}
 405 substTyWith :: [TyVar] -> [Type] -> Type -> Type
 406 substTyWith tvs tys = substTy (mkTyVarSubst tvs tys)
 407
 408 substTy :: Subst -> Type  -> Type
 409 substTy subst ty | isEmptySubst subst = ty
 410                  | otherwise          = subst_ty subst ty
 411
 412 substTheta :: TyVarSubst -> ThetaType -> ThetaType
 413 substTheta subst theta
 414   | isEmptySubst subst = theta
 415   | otherwise          = map (substPred subst) theta
 416
 417 substPred :: TyVarSubst -> PredType -> PredType
 418 substPred = substSourceType
 419
 420 substSourceType subst (IParam n ty)     = IParam n (subst_ty subst ty)
 421 substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
 422 substSourceType subst (NType  tc   tys) = NType  tc   (map (subst_ty subst) tys)
 423
 424 subst_ty subst ty
 425    = go ty
 426   where
 427     go (TyConApp tc tys)           = let args = map go tys
 428                                      in  args `seqList` TyConApp tc args
 429
 430     go (SourceTy p)                = SourceTy $! (substSourceType subst p)
 431
 432     go (NoteTy (SynNote ty1) ty2)  = NoteTy (SynNote $! (go ty1)) $! (go ty2)
 433     go (NoteTy (FTVNote _) ty2)    = go ty2             -- Discard the free tyvar note
 434
 435     go (FunTy arg res)             = (FunTy $! (go arg)) $! (go res)
 436     go (AppTy fun arg)             = mkAppTy (go fun) $! (go arg)
 437     go ty@(TyVarTy tv)             = case (lookupSubst subst tv) of
 438                                         Nothing            -> ty
 439                                         Just (DoneTy ty')  -> ty'
 440
 441     go (ForAllTy tv ty)            = case substTyVar subst tv of
 442                                         (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
 443
 444     go (UsageTy u ty)              = mkUTy (go u) $! (go ty)
 445 \end{code}
 446
 447 Here is where we invent a new binder if necessary.
 448
 449 \begin{code}
 450 substTyVar :: Subst -> TyVar -> (Subst, TyVar)
 451 substTyVar subst@(Subst in_scope env) old_var
 452   | old_var == new_var  -- No need to clone
 453                         -- But we *must* zap any current substitution for the variable.
 454                         --  For example:
 455                         --      (\x.e) with id_subst = [x |-> e']
 456                         -- Here we must simply zap the substitution for x
 457                         --
 458                         -- The new_id isn't cloned, but it may have a different type
 459                         -- etc, so we must return it, not the old id
 460   = (Subst (in_scope `extendInScopeSet` new_var)
 461            (delSubstEnv env old_var),
 462      new_var)
 463
 464   | otherwise   -- The new binder is in scope so
 465                 -- we'd better rename it away from the in-scope variables
 466                 -- Extending the substitution to do this renaming also
 467                 -- has the (correct) effect of discarding any existing
 468                 -- substitution for that variable
 469   = (Subst (in_scope `extendInScopeSet` new_var)
 470            (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))),
 471      new_var)
 472   where
 473     new_var = uniqAway in_scope old_var
 474         -- The uniqAway part makes sure the new variable is not already in scope
 475 \end{code}
 476
 477
 478 %************************************************************************
 479 %*                                                                      *
 480 \section{Expression substitution}
 481 %*                                                                      *
 482 %************************************************************************
 483
 484 This expression substituter deals correctly with name capture.
 485
 486 BUT NOTE that substExpr silently discards the
 487         unfolding, and
 488         spec env
 489 IdInfo attached to any binders in the expression.  It's quite
 490 tricky to do them 'right' in the case of mutually recursive bindings,
 491 and so far has proved unnecessary.
 492
 493 \begin{code}
 494 substExpr :: Subst -> CoreExpr -> CoreExpr
 495 substExpr subst expr
 496         -- NB: we do not do a no-op when the substitution is empty,
 497         -- because we always want to substitute the variables in the
 498         -- in-scope set for their occurrences.  Why?
 499         --      (a) because they may contain more information
 500         --      (b) because leaving an un-substituted Id might cause
 501         --          a space leak (its unfolding might point to an old version
 502         --          of its right hand side).
 503
 504   = go expr
 505   where
 506     go (Var v) = -- See the notes at the top, with the Subst data type declaration
 507                  case lookupIdSubst subst v of
 508
 509                     ContEx env' e' -> substExpr (setSubstEnv subst env') e'
 510                     DoneId v _     -> Var v
 511                     DoneEx e'      -> e'
 512
 513     go (Type ty)      = Type (go_ty ty)
 514     go (Lit lit)      = Lit lit
 515     go (App fun arg)  = App (go fun) (go arg)
 516     go (Note note e)  = Note (go_note note) (go e)
 517
 518     go (Lam bndr body) = Lam bndr' (substExpr subst' body)
 519                        where
 520                          (subst', bndr') = substBndr subst bndr
 521
 522     go (Let (NonRec bndr rhs) body) = Let (NonRec bndr' (go rhs)) (substExpr subst' body)
 523                                     where
 524                                       (subst', bndr') = substBndr subst bndr
 525
 526     go (Let (Rec pairs) body) = Let (Rec pairs') (substExpr subst' body)
 527                               where
 528                                 (subst', bndrs') = substRecIds subst (map fst pairs)
 529                                 pairs'  = bndrs' `zip` rhss'
 530                                 rhss'   = map (substExpr subst' . snd) pairs
 531
 532     go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts)
 533                               where
 534                                 (subst', bndr') = substBndr subst bndr
 535
 536     go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)
 537                                  where
 538                                    (subst', bndrs') = substBndrs subst bndrs
 539
 540     go_note (Coerce ty1 ty2) = Coerce (go_ty ty1) (go_ty ty2)
 541     go_note note             = note
 542
 543     go_ty ty = substTy subst ty
 544
 545 \end{code}
 546
 547
 548 %************************************************************************
 549 %*                                                                      *
 550 \section{Substituting an Id binder}
 551 %*                                                                      *
 552 %************************************************************************
 553
 554 \begin{code}
 555 -- simplBndr and simplLetId are used by the simplifier
 556
 557 simplBndr :: Subst -> Var -> (Subst, Var)
 558 -- Used for lambda and case-bound variables
 559 -- Clone Id if necessary, substitute type
 560 -- Return with IdInfo already substituted, but (fragile) occurrence info zapped
 561 -- The substitution is extended only if the variable is cloned, because
 562 -- we *don't* need to use it to track occurrence info.
 563 simplBndr subst bndr
 564   | isTyVar bndr  = substTyVar subst bndr
 565   | otherwise     = subst_id isFragileOcc subst subst bndr
 566
 567 simplBndrs :: Subst -> [Var] -> (Subst, [Var])
 568 simplBndrs subst bndrs = mapAccumL simplBndr subst bndrs
 569
 570 simplLamBndr :: Subst -> Var -> (Subst, Var)
 571 -- Used for lambda binders.  These sometimes have unfoldings added by
 572 -- the worker/wrapper pass that must be preserved, becuase they can't
 573 -- be reconstructed from context.  For example:
 574 --      f x = case x of (a,b) -> fw a b x
 575 --      fw a b x{=(a,b)} = ...
 576 -- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
 577 simplLamBndr subst bndr
 578   | not (isId bndr && hasSomeUnfolding old_unf)
 579   = simplBndr subst bndr        -- Normal case
 580   | otherwise
 581   = (subst', bndr' `setIdUnfolding` substUnfolding subst old_unf)
 582   where
 583     old_unf = idUnfolding bndr
 584     (subst', bndr') = subst_id isFragileOcc subst subst bndr
 585
 586
 587 simplLetId :: Subst -> Id -> (Subst, Id)
 588 -- Clone Id if necessary
 589 -- Substitute its type
 590 -- Return an Id with completely zapped IdInfo
 591 --      [A subsequent substIdInfo will restore its IdInfo]
 592 -- Augment the subtitution
 593 --      if the unique changed, *or*
 594 --      if there's interesting occurrence info
 595
 596 simplLetId subst@(Subst in_scope env) old_id
 597   = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
 598   where
 599     old_info = idInfo old_id
 600     id1     = uniqAway in_scope old_id
 601     id2     = substIdType subst id1
 602     new_id  = setIdInfo id2 vanillaIdInfo
 603
 604         -- Extend the substitution if the unique has changed,
 605         -- or there's some useful occurrence information
 606         -- See the notes with substTyVar for the delSubstEnv
 607     occ_info = occInfo old_info
 608     new_env | new_id /= old_id || isFragileOcc occ_info
 609             = extendSubstEnv env old_id (DoneId new_id occ_info)
 610             | otherwise
 611             = delSubstEnv env old_id
 612
 613 simplIdInfo :: Subst -> IdInfo -> Id -> Id
 614   -- Used by the simplifier to compute new IdInfo for a let(rec) binder,
 615   -- subsequent to simplLetId having zapped its IdInfo
 616 simplIdInfo subst old_info bndr
 617   = case substIdInfo subst isFragileOcc old_info of
 618         Just new_info -> bndr `setIdInfo` new_info
 619         Nothing       -> bndr `setIdInfo` old_info
 620 \end{code}
 621
 622 \begin{code}
 623 -- substBndr and friends are used when doing expression substitution only
 624 -- In this case we can *preserve* occurrence information, and indeed we *want*
 625 -- to do so else lose useful occ info in rules.  Hence the calls to
 626 -- simpl_id with keepOccInfo
 627
 628 substBndr :: Subst -> Var -> (Subst, Var)
 629 substBndr subst bndr
 630   | isTyVar bndr  = substTyVar subst bndr
 631   | otherwise     = subst_id keepOccInfo subst subst bndr
 632
 633 substBndrs :: Subst -> [Var] -> (Subst, [Var])
 634 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
 635
 636 substRecIds :: Subst -> [Id] -> (Subst, [Id])
 637 -- Substitute a mutually recursive group
 638 substRecIds subst bndrs
 639   = (new_subst, new_bndrs)
 640   where
 641         -- Here's the reason we need to pass rec_subst to subst_id
 642     (new_subst, new_bndrs) = mapAccumL (subst_id keepOccInfo new_subst) subst bndrs
 643
 644 keepOccInfo occ = False -- Never fragile
 645 \end{code}
 646
 647
 648 \begin{code}
 649 subst_id :: (OccInfo -> Bool)   -- True <=> the OccInfo is fragile
 650          -> Subst               -- Substitution to use for the IdInfo
 651          -> Subst -> Id         -- Substitition and Id to transform
 652          -> (Subst, Id)         -- Transformed pair
 653
 654 -- Returns with:
 655 --      * Unique changed if necessary
 656 --      * Type substituted
 657 --      * Unfolding zapped
 658 --      * Rules, worker, lbvar info all substituted
 659 --      * Occurrence info zapped if is_fragile_occ returns True
 660 --      * The in-scope set extended with the returned Id
 661 --      * The substitution extended with a DoneId if unique changed
 662 --        In this case, the var in the DoneId is the same as the
 663 --        var returned
 664
 665 subst_id is_fragile_occ rec_subst subst@(Subst in_scope env) old_id
 666   = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
 667   where
 668         -- id1 is cloned if necessary
 669     id1 = uniqAway in_scope old_id
 670
 671         -- id2 has its type zapped
 672     id2 = substIdType subst id1
 673
 674         -- new_id has the right IdInfo
 675         -- The lazy-set is because we're in a loop here, with
 676         -- rec_subst, when dealing with a mutually-recursive group
 677     new_id = maybeModifyIdInfo (substIdInfo rec_subst is_fragile_occ) id2
 678
 679         -- Extend the substitution if the unique has changed
 680         -- See the notes with substTyVar for the delSubstEnv
 681     new_env | new_id /= old_id
 682             = extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id))
 683             | otherwise
 684             = delSubstEnv env old_id
 685 \end{code}
 686
 687 Now a variant that unconditionally allocates a new unique.
 688 It also unconditionally zaps the OccInfo.
 689
 690 \begin{code}
 691 subst_clone_id :: Subst                 -- Substitution to use (lazily) for the rules and worker
 692                -> Subst -> (Id, Unique) -- Substitition and Id to transform
 693                -> (Subst, Id)           -- Transformed pair
 694
 695 subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq)
 696   = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id)
 697   where
 698     id1  = setVarUnique old_id uniq
 699     id2  = substIdType subst id1
 700
 701     new_id  = maybeModifyIdInfo (substIdInfo rec_subst isFragileOcc) id2
 702     new_env = extendSubstEnv env old_id (DoneId new_id NoOccInfo)
 703
 704 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
 705 substAndCloneIds subst us ids
 706   = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
 707
 708 substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
 709 substAndCloneRecIds subst us ids
 710   = (subst', ids')
 711   where
 712     (subst', ids') = mapAccumL (subst_clone_id subst') subst
 713                                (ids `zip` uniqsFromSupply us)
 714
 715 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
 716 substAndCloneId subst@(Subst in_scope env) us old_id
 717   = subst_clone_id subst subst (old_id, uniqFromSupply us)
 718 \end{code}
 719
 720
 721 %************************************************************************
 722 %*                                                                      *
 723 \section{IdInfo substitution}
 724 %*                                                                      *
 725 %************************************************************************
 726
 727 \begin{code}
 728 substIdInfo :: Subst
 729             -> (OccInfo -> Bool)        -- True <=> zap the occurrence info
 730             -> IdInfo
 731             -> Maybe IdInfo
 732 -- Substitute the
 733 --      rules
 734 --      worker info
 735 --      LBVar info
 736 -- Zap the unfolding
 737 -- Zap the occ info if instructed to do so
 738 --
 739 -- Seq'ing on the returned IdInfo is enough to cause all the
 740 -- substitutions to happen completely
 741
 742 substIdInfo subst is_fragile_occ info
 743   | nothing_to_do = Nothing
 744   | otherwise     = Just (info `setOccInfo`       (if zap_occ then NoOccInfo else old_occ)
 745                                `setSpecInfo`      substRules  subst old_rules
 746                                `setWorkerInfo`    substWorker subst old_wrkr
 747                                `setLBVarInfo`     substLBVar  subst old_lbv
 748                                `setUnfoldingInfo` noUnfolding)
 749                         -- setSpecInfo does a seq
 750                         -- setWorkerInfo does a seq
 751   where
 752     nothing_to_do = not zap_occ &&
 753                     isEmptyCoreRules old_rules &&
 754                     not (workerExists old_wrkr) &&
 755                     hasNoLBVarInfo old_lbv &&
 756                     not (hasUnfolding (unfoldingInfo info))
 757
 758     zap_occ   = is_fragile_occ old_occ
 759     old_occ   = occInfo info
 760     old_rules = specInfo info
 761     old_wrkr  = workerInfo info
 762     old_lbv   = lbvarInfo info
 763
 764 ------------------
 765 substIdType :: Subst -> Id -> Id
 766 substIdType subst@(Subst in_scope env) id
 767   |  noTypeSubst env || isEmptyVarSet (tyVarsOfType old_ty) = id
 768   | otherwise                                               = setIdType id (substTy subst old_ty)
 769                 -- The tyVarsOfType is cheaper than it looks
 770                 -- because we cache the free tyvars of the type
 771                 -- in a Note in the id's type itself
 772   where
 773     old_ty = idType id
 774
 775 ------------------
 776 substWorker :: Subst -> WorkerInfo -> WorkerInfo
 777         -- Seq'ing on the returned WorkerInfo is enough to cause all the
 778         -- substitutions to happen completely
 779
 780 substWorker subst NoWorker
 781   = NoWorker
 782 substWorker subst (HasWorker w a)
 783   = case lookupIdSubst subst w of
 784         (DoneId w1 _)     -> HasWorker w1 a
 785         (DoneEx (Var w1)) -> HasWorker w1 a
 786         (DoneEx other)    -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
 787                                   NoWorker      -- Worker has got substituted away altogether
 788         (ContEx se1 e)    -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
 789                                   NoWorker      -- Ditto
 790
 791 ------------------
 792 substUnfolding subst NoUnfolding                 = NoUnfolding
 793 substUnfolding subst (OtherCon cons)             = OtherCon cons
 794 substUnfolding subst (CompulsoryUnfolding rhs)   = CompulsoryUnfolding (substExpr subst rhs)
 795 substUnfolding subst (CoreUnfolding rhs t v w g) = CoreUnfolding (substExpr subst rhs) t v w g
 796
 797 ------------------
 798 substRules :: Subst -> CoreRules -> CoreRules
 799         -- Seq'ing on the returned CoreRules is enough to cause all the
 800         -- substitutions to happen completely
 801
 802 substRules subst rules
 803  | isEmptySubst subst = rules
 804
 805 substRules subst (Rules rules rhs_fvs)
 806   = seqRules new_rules `seq` new_rules
 807   where
 808     new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
 809
 810     do_subst rule@(BuiltinRule _ _) = rule
 811     do_subst (Rule name act tpl_vars lhs_args rhs)
 812         = Rule name act tpl_vars'
 813                (map (substExpr subst') lhs_args)
 814                (substExpr subst' rhs)
 815         where
 816           (subst', tpl_vars') = substBndrs subst tpl_vars
 817
 818 ------------------
 819 substVarSet subst fvs
 820   = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
 821   where
 822     subst_fv subst fv = case lookupIdSubst subst fv of
 823                             DoneId fv' _    -> unitVarSet fv'
 824                             DoneEx expr     -> exprFreeVars expr
 825                             DoneTy ty       -> tyVarsOfType ty
 826                             ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
 827
 828 ------------------
 829 substLBVar subst NoLBVarInfo    = NoLBVarInfo
 830 substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1
 831                                 where
 832                                   ty1 = substTy subst ty
 833 \end{code}