ghc/compiler/coreSyn/Subst.lhs

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