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