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