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