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