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