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