compiler/coreSyn/CoreSubst.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Utility functions on @Core@ syntax
   7
   8 \begin{code}
   9 module CoreSubst (
  10         -- * Main data types
  11         Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
  12
  13         -- ** Substituting into expressions and related types
  14         deShadowBinds, substSpec, substRulesForImportedIds,
  15         substTy, substExpr, substExprSC, substBind, substBindSC,
  16         substUnfolding, substUnfoldingSC,
  17         substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
  18
  19         -- ** Operations on substitutions
  20         emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
  21         extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
  22         extendSubst, extendSubstList, zapSubstEnv,
  23         extendInScope, extendInScopeList, extendInScopeIds,
  24         isInScope,
  25
  26         -- ** Substituting and cloning binders
  27         substBndr, substBndrs, substRecBndrs,
  28         cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
  29
  30         -- ** Simple expression optimiser
  31         simpleOptExpr
  32     ) where
  33
  34 #include "HsVersions.h"
  35
  36 import CoreSyn
  37 import CoreFVs
  38 import CoreUtils
  39 import OccurAnal( occurAnalyseExpr )
  40
  41 import qualified Type
  42 import Type     ( Type, TvSubst(..), TvSubstEnv )
  43 import OptCoercion ( optCoercion )
  44 import VarSet
  45 import VarEnv
  46 import Id
  47 import Name     ( Name )
  48 import Var      ( Var, TyVar, setVarUnique )
  49 import IdInfo
  50 import Unique
  51 import UniqSupply
  52 import Maybes
  53 import BasicTypes ( isAlwaysActive )
  54 import Outputable
  55 import PprCore          ()              -- Instances
  56 import FastString
  57
  58 import Data.List
  59 \end{code}
  60
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsection{Substitutions}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 \begin{code}
  69 -- | A substitution environment, containing both 'Id' and 'TyVar' substitutions.
  70 --
  71 -- Some invariants apply to how you use the substitution:
  72 --
  73 -- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/
  74 -- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the
  75 -- substitution range that might possibly clash with locally-bound variables in the thing being substituted in.
  76 --
  77 -- 2. #apply_once# You may apply the substitution only /once/
  78 --
  79 -- There are various ways of setting up the in-scope set such that the first of these invariants hold:
  80 --
  81 -- * Arrange that the in-scope set really is all the things in scope
  82 --
  83 -- * Arrange that it's the free vars of the range of the substitution
  84 --
  85 -- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash
  86 data Subst
  87   = Subst InScopeSet  -- Variables in in scope (both Ids and TyVars) /after/
  88                       -- applying the substitution
  89           IdSubstEnv  -- Substitution for Ids
  90           TvSubstEnv  -- Substitution for TyVars
  91
  92         -- INVARIANT 1: See #in_scope_invariant#
  93         -- This is what lets us deal with name capture properly
  94         -- It's a hard invariant to check...
  95         --
  96         -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with
  97         --              Types.TvSubstEnv
  98         --
  99         -- INVARIANT 3: See Note [Extending the Subst]
 100 \end{code}
 101
 102 Note [Extending the Subst]
 103 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 104 For a core Subst, which binds Ids as well, we make a different choice for Ids
 105 than we do for TyVars.
 106
 107 For TyVars, see Note [Extending the TvSubst] with Type.TvSubstEnv
 108
 109 For Ids, we have a different invariant
 110         The IdSubstEnv is extended *only* when the Unique on an Id changes
 111         Otherwise, we just extend the InScopeSet
 112
 113 In consequence:
 114
 115 * In substIdBndr, we extend the IdSubstEnv only when the unique changes
 116
 117 * If the TvSubstEnv and IdSubstEnv are both empty, substExpr does nothing
 118   (Note that the above rule for substIdBndr maintains this property.  If
 119    the incoming envts are both empty, then substituting the type and
 120    IdInfo can't change anything.)
 121
 122 * In lookupIdSubst, we *must* look up the Id in the in-scope set, because
 123   it may contain non-trivial changes.  Example:
 124         (/\a. \x:a. ...x...) Int
 125   We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change
 126   so we only extend the in-scope set.  Then we must look up in the in-scope
 127   set when we find the occurrence of x.
 128
 129 * The requirement to look up the Id in the in-scope set means that we
 130   must NOT take no-op short cut in the case the substitution is empty.
 131   We must still look up every Id in the in-scope set.
 132
 133 * (However, we don't need to do so for expressions found in the IdSubst
 134   itself, whose range is assumed to be correct wrt the in-scope set.)
 135
 136 Why do we make a different choice for the IdSubstEnv than the TvSubstEnv?
 137
 138 * For Ids, we change the IdInfo all the time (e.g. deleting the
 139   unfolding), and adding it back later, so using the TyVar convention
 140   would entail extending the substitution almost all the time
 141
 142 * The simplifier wants to look up in the in-scope set anyway, in case it
 143   can see a better unfolding from an enclosing case expression
 144
 145 * For TyVars, only coercion variables can possibly change, and they are
 146   easy to spot
 147
 148 \begin{code}
 149 -- | An environment for substituting for 'Id's
 150 type IdSubstEnv = IdEnv CoreExpr
 151
 152 ----------------------------
 153 isEmptySubst :: Subst -> Bool
 154 isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
 155
 156 emptySubst :: Subst
 157 emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
 158
 159 mkEmptySubst :: InScopeSet -> Subst
 160 mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
 161
 162 mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst
 163 mkSubst in_scope tvs ids = Subst in_scope ids tvs
 164
 165 -- getTvSubst :: Subst -> TvSubst
 166 -- getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
 167
 168 -- getTvSubstEnv :: Subst -> TvSubstEnv
 169 -- getTvSubstEnv (Subst _ _ tv_env) = tv_env
 170 --
 171 -- setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
 172 -- setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
 173
 174 -- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
 175 substInScope :: Subst -> InScopeSet
 176 substInScope (Subst in_scope _ _) = in_scope
 177
 178 -- | Remove all substitutions for 'Id's and 'Var's that might have been built up
 179 -- while preserving the in-scope set
 180 zapSubstEnv :: Subst -> Subst
 181 zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
 182
 183 -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
 184 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
 185 extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
 186 -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
 187 extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
 188
 189 -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
 190 extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
 191 extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
 192
 193 -- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is
 194 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
 195 extendTvSubst :: Subst -> TyVar -> Type -> Subst
 196 extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r)
 197
 198 -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
 199 extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
 200 extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
 201
 202 -- | Add a substitution for a 'TyVar' or 'Id' as appropriate to the 'Var' being added. See also
 203 -- 'extendIdSubst' and 'extendTvSubst'
 204 extendSubst :: Subst -> Var -> CoreArg -> Subst
 205 extendSubst (Subst in_scope ids tvs) tv (Type ty)
 206   = ASSERT( isTyVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
 207 extendSubst (Subst in_scope ids tvs) id expr
 208   = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs
 209
 210 -- | Add a substitution for a 'TyVar' or 'Id' as appropriate to all the 'Var's being added. See also 'extendSubst'
 211 extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst
 212 extendSubstList subst []              = subst
 213 extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
 214
 215 -- | Find the substitution for an 'Id' in the 'Subst'
 216 lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
 217 lookupIdSubst doc (Subst in_scope ids _) v
 218   | not (isLocalId v) = Var v
 219   | Just e  <- lookupVarEnv ids       v = e
 220   | Just v' <- lookupInScope in_scope v = Var v'
 221         -- Vital! See Note [Extending the Subst]
 222   | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope $$ doc)
 223                 Var v
 224
 225 -- | Find the substitution for a 'TyVar' in the 'Subst'
 226 lookupTvSubst :: Subst -> TyVar -> Type
 227 lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
 228
 229 -- | Simultaneously substitute for a bunch of variables
 230 --   No left-right shadowing
 231 --   ie the substitution for   (\x \y. e) a1 a2
 232 --      so neither x nor y scope over a1 a2
 233 mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
 234 mkOpenSubst in_scope pairs = Subst in_scope
 235                                    (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
 236                                    (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
 237
 238 ------------------------------
 239 isInScope :: Var -> Subst -> Bool
 240 isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
 241
 242 -- | Add the 'Var' to the in-scope set: as a side effect, removes any existing substitutions for it
 243 extendInScope :: Subst -> Var -> Subst
 244 extendInScope (Subst in_scope ids tvs) v
 245   = Subst (in_scope `extendInScopeSet` v)
 246           (ids `delVarEnv` v) (tvs `delVarEnv` v)
 247
 248 -- | Add the 'Var's to the in-scope set: see also 'extendInScope'
 249 extendInScopeList :: Subst -> [Var] -> Subst
 250 extendInScopeList (Subst in_scope ids tvs) vs
 251   = Subst (in_scope `extendInScopeSetList` vs)
 252           (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs)
 253
 254 -- | Optimized version of 'extendInScopeList' that can be used if you are certain
 255 -- all the things being added are 'Id's and hence none are 'TyVar's
 256 extendInScopeIds :: Subst -> [Id] -> Subst
 257 extendInScopeIds (Subst in_scope ids tvs) vs
 258   = Subst (in_scope `extendInScopeSetList` vs)
 259           (ids `delVarEnvList` vs) tvs
 260 \end{code}
 261
 262 Pretty printing, for debugging only
 263
 264 \begin{code}
 265 instance Outputable Subst where
 266   ppr (Subst in_scope ids tvs)
 267         =  ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
 268         $$ ptext (sLit " IdSubst   =") <+> ppr ids
 269         $$ ptext (sLit " TvSubst   =") <+> ppr tvs
 270          <> char '>'
 271 \end{code}
 272
 273
 274 %************************************************************************
 275 %*                                                                      *
 276         Substituting expressions
 277 %*                                                                      *
 278 %************************************************************************
 279
 280 \begin{code}
 281 -- | Apply a substititon to an entire 'CoreExpr'. Rememeber, you may only
 282 -- apply the substitution /once/: see "CoreSubst#apply_once"
 283 --
 284 -- Do *not* attempt to short-cut in the case of an empty substitution!
 285 -- See Note [Extending the Subst]
 286 substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr
 287 substExprSC _doc subst orig_expr
 288   | isEmptySubst subst = orig_expr
 289   | otherwise          = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $
 290                          subst_expr subst orig_expr
 291
 292 substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr
 293 substExpr _doc subst orig_expr = subst_expr subst orig_expr
 294
 295 subst_expr :: Subst -> CoreExpr -> CoreExpr
 296 subst_expr subst expr
 297   = go expr
 298   where
 299     go (Var v)         = lookupIdSubst (text "subst_expr") subst v
 300     go (Type ty)       = Type (substTy subst ty)
 301     go (Lit lit)       = Lit lit
 302     go (App fun arg)   = App (go fun) (go arg)
 303     go (Note note e)   = Note (go_note note) (go e)
 304     go (Cast e co)     = Cast (go e) (optCoercion (getTvSubst subst) co)
 305         -- Optimise coercions as we go; this is good, for example
 306         -- in the RHS of rules, which are only substituted in
 307
 308     go (Lam bndr body) = Lam bndr' (subst_expr subst' body)
 309                        where
 310                          (subst', bndr') = substBndr subst bndr
 311
 312     go (Let bind body) = Let bind' (subst_expr subst' body)
 313                        where
 314                          (subst', bind') = substBind subst bind
 315
 316     go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)
 317                                  where
 318                                  (subst', bndr') = substBndr subst bndr
 319
 320     go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr subst' rhs)
 321                                  where
 322                                    (subst', bndrs') = substBndrs subst bndrs
 323
 324     go_note note             = note
 325
 326 -- | Apply a substititon to an entire 'CoreBind', additionally returning an updated 'Subst'
 327 -- that should be used by subsequent substitutons.
 328 substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind)
 329
 330 substBindSC subst bind    -- Short-cut if the substitution is empty
 331   | not (isEmptySubst subst)
 332   = substBind subst bind
 333   | otherwise
 334   = case bind of
 335        NonRec bndr rhs -> (subst', NonRec bndr' rhs)
 336           where
 337             (subst', bndr') = substBndr subst bndr
 338        Rec pairs -> (subst', Rec (bndrs' `zip` rhss'))
 339           where
 340             (bndrs, rhss)    = unzip pairs
 341             (subst', bndrs') = substRecBndrs subst bndrs
 342             rhss' | isEmptySubst subst' = rhss
 343                   | otherwise           = map (subst_expr subst') rhss
 344
 345 substBind subst (NonRec bndr rhs) = (subst', NonRec bndr' (subst_expr subst rhs))
 346                                   where
 347                                     (subst', bndr') = substBndr subst bndr
 348
 349 substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss'))
 350                             where
 351                                 (bndrs, rhss)    = unzip pairs
 352                                 (subst', bndrs') = substRecBndrs subst bndrs
 353                                 rhss' = map (subst_expr subst') rhss
 354 \end{code}
 355
 356 \begin{code}
 357 -- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply
 358 -- by running over the bindings with an empty substitution, becuase substitution
 359 -- returns a result that has no-shadowing guaranteed.
 360 --
 361 -- (Actually, within a single /type/ there might still be shadowing, because
 362 -- 'substTy' is a no-op for the empty substitution, but that's probably OK.)
 363 --
 364 -- [Aug 09] This function is not used in GHC at the moment, but seems so
 365 --          short and simple that I'm going to leave it here
 366 deShadowBinds :: [CoreBind] -> [CoreBind]
 367 deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
 368 \end{code}
 369
 370
 371 %************************************************************************
 372 %*                                                                      *
 373         Substituting binders
 374 %*                                                                      *
 375 %************************************************************************
 376
 377 Remember that substBndr and friends are used when doing expression
 378 substitution only.  Their only business is substitution, so they
 379 preserve all IdInfo (suitably substituted).  For example, we *want* to
 380 preserve occ info in rules.
 381
 382 \begin{code}
 383 -- | Substitutes a 'Var' for another one according to the 'Subst' given, returning
 384 -- the result and an updated 'Subst' that should be used by subsequent substitutons.
 385 -- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
 386 substBndr :: Subst -> Var -> (Subst, Var)
 387 substBndr subst bndr
 388   | isTyVar bndr  = substTyVarBndr subst bndr
 389   | otherwise     = substIdBndr (text "var-bndr") subst subst bndr
 390
 391 -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
 392 substBndrs :: Subst -> [Var] -> (Subst, [Var])
 393 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
 394
 395 -- | Substitute in a mutually recursive group of 'Id's
 396 substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
 397 substRecBndrs subst bndrs
 398   = (new_subst, new_bndrs)
 399   where         -- Here's the reason we need to pass rec_subst to subst_id
 400     (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs
 401 \end{code}
 402
 403
 404 \begin{code}
 405 substIdBndr :: SDoc
 406             -> Subst            -- ^ Substitution to use for the IdInfo
 407             -> Subst -> Id      -- ^ Substitition and Id to transform
 408             -> (Subst, Id)      -- ^ Transformed pair
 409                                 -- NB: unfolding may be zapped
 410
 411 substIdBndr _doc rec_subst subst@(Subst in_scope env tvs) old_id
 412   = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
 413     (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
 414   where
 415     id1 = uniqAway in_scope old_id      -- id1 is cloned if necessary
 416     id2 | no_type_change = id1
 417         | otherwise      = setIdType id1 (substTy subst old_ty)
 418
 419     old_ty = idType old_id
 420     no_type_change = isEmptyVarEnv tvs ||
 421                      isEmptyVarSet (Type.tyVarsOfType old_ty)
 422
 423         -- new_id has the right IdInfo
 424         -- The lazy-set is because we're in a loop here, with
 425         -- rec_subst, when dealing with a mutually-recursive group
 426     new_id = maybeModifyIdInfo mb_new_info id2
 427     mb_new_info = substIdInfo rec_subst id2 (idInfo id2)
 428         -- NB: unfolding info may be zapped
 429
 430         -- Extend the substitution if the unique has changed
 431         -- See the notes with substTyVarBndr for the delVarEnv
 432     new_env | no_change = delVarEnv env old_id
 433             | otherwise = extendVarEnv env old_id (Var new_id)
 434
 435     no_change = id1 == old_id
 436         -- See Note [Extending the Subst]
 437         -- it's /not/ necessary to check mb_new_info and no_type_change
 438 \end{code}
 439
 440 Now a variant that unconditionally allocates a new unique.
 441 It also unconditionally zaps the OccInfo.
 442
 443 \begin{code}
 444 -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for
 445 -- each variable in its output.  It substitutes the IdInfo though.
 446 cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)
 447 cloneIdBndr subst us old_id
 448   = clone_id subst subst (old_id, uniqFromSupply us)
 449
 450 -- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final
 451 -- substitution from left to right
 452 cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
 453 cloneIdBndrs subst us ids
 454   = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)
 455
 456 -- | Clone a mutually recursive group of 'Id's
 457 cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
 458 cloneRecIdBndrs subst us ids
 459   = (subst', ids')
 460   where
 461     (subst', ids') = mapAccumL (clone_id subst') subst
 462                                (ids `zip` uniqsFromSupply us)
 463
 464 -- Just like substIdBndr, except that it always makes a new unique
 465 -- It is given the unique to use
 466 clone_id    :: Subst                    -- Substitution for the IdInfo
 467             -> Subst -> (Id, Unique)    -- Substitition and Id to transform
 468             -> (Subst, Id)              -- Transformed pair
 469
 470 clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
 471   = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
 472   where
 473     id1     = setVarUnique old_id uniq
 474     id2     = substIdType subst id1
 475     new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
 476     new_env = extendVarEnv env old_id (Var new_id)
 477 \end{code}
 478
 479
 480 %************************************************************************
 481 %*                                                                      *
 482                 Types
 483 %*                                                                      *
 484 %************************************************************************
 485
 486 For types we just call the corresponding function in Type, but we have
 487 to repackage the substitution, from a Subst to a TvSubst
 488
 489 \begin{code}
 490 substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
 491 substTyVarBndr (Subst in_scope id_env tv_env) tv
 492   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
 493         (TvSubst in_scope' tv_env', tv')
 494            -> (Subst in_scope' id_env tv_env', tv')
 495
 496 -- | See 'Type.substTy'
 497 substTy :: Subst -> Type -> Type
 498 substTy subst ty = Type.substTy (getTvSubst subst) ty
 499
 500 getTvSubst :: Subst -> TvSubst
 501 getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
 502 \end{code}
 503
 504
 505 %************************************************************************
 506 %*                                                                      *
 507 \section{IdInfo substitution}
 508 %*                                                                      *
 509 %************************************************************************
 510
 511 \begin{code}
 512 substIdType :: Subst -> Id -> Id
 513 substIdType subst@(Subst _ _ tv_env) id
 514   | isEmptyVarEnv tv_env || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
 515   | otherwise   = setIdType id (substTy subst old_ty)
 516                 -- The tyVarsOfType is cheaper than it looks
 517                 -- because we cache the free tyvars of the type
 518                 -- in a Note in the id's type itself
 519   where
 520     old_ty = idType id
 521
 522 ------------------
 523 -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
 524 -- Always zaps the unfolding, to save substitution work
 525 substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
 526 substIdInfo subst new_id info
 527   | nothing_to_do = Nothing
 528   | otherwise     = Just (info `setSpecInfo`      substSpec subst new_id old_rules
 529                                `setUnfoldingInfo` substUnfolding subst old_unf)
 530   where
 531     old_rules     = specInfo info
 532     old_unf       = unfoldingInfo info
 533     nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
 534
 535
 536 ------------------
 537 -- | Substitutes for the 'Id's within an unfolding
 538 substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding
 539         -- Seq'ing on the returned Unfolding is enough to cause
 540         -- all the substitutions to happen completely
 541
 542 substUnfoldingSC subst unf       -- Short-cut version
 543   | isEmptySubst subst = unf
 544   | otherwise          = substUnfolding subst unf
 545
 546 substUnfolding subst (DFunUnfolding ar con args)
 547   = DFunUnfolding ar con (map (substExpr (text "dfun-unf") subst) args)
 548
 549 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
 550         -- Retain an InlineRule!
 551   | not (isInlineRuleSource src)  -- Always zap a CoreUnfolding, to save substitution work
 552   = NoUnfolding
 553   | otherwise                     -- But keep an InlineRule!
 554   = seqExpr new_tmpl `seq`
 555     new_src `seq`
 556     unf { uf_tmpl = new_tmpl, uf_src = new_src }
 557   where
 558     new_tmpl = substExpr (text "subst-unf") subst tmpl
 559     new_src  = substUnfoldingSource subst src
 560
 561 substUnfolding _ unf = unf      -- NoUnfolding, OtherCon
 562
 563 -------------------
 564 substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
 565 substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
 566   | Just wkr_expr <- lookupVarEnv ids wkr
 567   = case wkr_expr of
 568       Var w1 -> InlineWrapper w1
 569       _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
 570                 --             <+> ifPprDebug (equals <+> ppr wkr_expr) )
 571                               -- Note [Worker inlining]
 572                 InlineRule    -- It's not a wrapper any more, but still inline it!
 573
 574   | Just w1  <- lookupInScope in_scope wkr = InlineWrapper w1
 575   | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
 576                 -- This can legitimately happen.  The worker has been inlined and
 577                 -- dropped as dead code, because we don't treat the UnfoldingSource
 578                 -- as an "occurrence".
 579                 -- Note [Worker inlining]
 580                 InlineRule
 581
 582 substUnfoldingSource _ src = src
 583
 584 ------------------
 585 substIdOcc :: Subst -> Id -> Id
 586 -- These Ids should not be substituted to non-Ids
 587 substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
 588                         Var v' -> v'
 589                         other  -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
 590
 591 ------------------
 592 -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
 593 substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
 594 substSpec subst new_id (SpecInfo rules rhs_fvs)
 595   = seqSpecInfo new_spec `seq` new_spec
 596   where
 597     subst_ru_fn = const (idName new_id)
 598     new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
 599                          (substVarSet subst rhs_fvs)
 600
 601 ------------------
 602 substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
 603 substRulesForImportedIds subst rules
 604   = map (substRule subst (\name -> name)) rules
 605
 606 ------------------
 607 substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
 608
 609 -- The subst_ru_fn argument is applied to substitute the ru_fn field
 610 -- of the rule:
 611 --    - Rules for *imported* Ids never change ru_fn
 612 --    - Rules for *local* Ids are in the IdInfo for that Id,
 613 --      and the ru_fn field is simply replaced by the new name
 614 --      of the Id
 615
 616 substRule _ _ rule@(BuiltinRule {}) = rule
 617 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
 618                                        , ru_fn = fn_name, ru_rhs = rhs })
 619   = rule { ru_bndrs = bndrs',
 620            ru_fn    = subst_ru_fn fn_name,
 621            ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
 622            ru_rhs   = substExpr (text "subst-rule" <+> ppr fn_name) subst' rhs }
 623   where
 624     (subst', bndrs') = substBndrs subst bndrs
 625
 626 ------------------
 627 substVarSet :: Subst -> VarSet -> VarSet
 628 substVarSet subst fvs
 629   = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
 630   where
 631     subst_fv subst fv
 632         | isId fv   = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
 633         | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
 634 \end{code}
 635
 636 Note [Worker inlining]
 637 ~~~~~~~~~~~~~~~~~~~~~~
 638 A worker can get sustituted away entirely.
 639         - it might be trivial
 640         - it might simply be very small
 641 We do not treat an InlWrapper as an 'occurrence' in the occurence
 642 analyser, so it's possible that the worker is not even in scope any more.
 643
 644 In all all these cases we simply drop the special case, returning to
 645 InlVanilla.  The WARN is just so I can see if it happens a lot.
 646
 647
 648 %************************************************************************
 649 %*                                                                      *
 650         The Very Simple Optimiser
 651 %*                                                                      *
 652 %************************************************************************
 653
 654 \begin{code}
 655 simpleOptExpr :: CoreExpr -> CoreExpr
 656 -- Do simple optimisation on an expression
 657 -- The optimisation is very straightforward: just
 658 -- inline non-recursive bindings that are used only once,
 659 -- or where the RHS is trivial
 660 --
 661 -- The result is NOT guaranteed occurence-analysed, becuase
 662 -- in  (let x = y in ....) we substitute for x; so y's occ-info
 663 -- may change radically
 664
 665 simpleOptExpr expr
 666   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
 667     go init_subst (occurAnalyseExpr expr)
 668   where
 669     init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
 670         -- It's potentially important to make a proper in-scope set
 671         -- Consider  let x = ..y.. in \y. ...x...
 672         -- Then we should remember to clone y before substituting
 673         -- for x.  It's very unlikely to occur, because we probably
 674         -- won't *be* substituting for x if it occurs inside a
 675         -- lambda.
 676         --
 677         -- It's a bit painful to call exprFreeVars, because it makes
 678         -- three passes instead of two (occ-anal, and go)
 679
 680     go subst (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
 681     go subst (App e1 e2)      = App (go subst e1) (go subst e2)
 682     go subst (Type ty)        = Type (substTy subst ty)
 683     go _     (Lit lit)        = Lit lit
 684     go subst (Note note e)    = Note note (go subst e)
 685     go subst (Cast e co)      = Cast (go subst e) (substTy subst co)
 686     go subst (Let bind body)  = go_let subst bind body
 687     go subst (Lam bndr body)  = Lam bndr' (go subst' body)
 688                               where
 689                                 (subst', bndr') = substBndr subst bndr
 690
 691     go subst (Case e b ty as) = Case (go subst e) b'
 692                                      (substTy subst ty)
 693                                      (map (go_alt subst') as)
 694                               where
 695                                  (subst', b') = substBndr subst b
 696
 697
 698     ----------------------
 699     go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
 700                                  where
 701                                    (subst', bndrs') = substBndrs subst bndrs
 702
 703     ----------------------
 704     go_let subst (Rec prs) body
 705       = Let (Rec (reverse rev_prs')) (go subst'' body)
 706       where
 707         (subst', bndrs')    = substRecBndrs subst (map fst prs)
 708         (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
 709         do_pr (subst, prs) ((b,r), b') = case go_bind subst b r of
 710                                            Left subst' -> (subst', prs)
 711                                            Right r'    -> (subst,  (b',r'):prs)
 712
 713     go_let subst (NonRec b r) body
 714       = case go_bind subst b r of
 715           Left subst' -> go subst' body
 716           Right r'    -> Let (NonRec b' r') (go subst' body)
 717                       where
 718                          (subst', b') = substBndr subst b
 719
 720
 721     ----------------------
 722     go_bind :: Subst -> Var -> CoreExpr -> Either Subst CoreExpr
 723         -- (go_bind subst old_var old_rhs)
 724         --   either extends subst with (old_var -> new_rhs)
 725         --   or     return new_rhs for a binding new_var = new_rhs
 726     go_bind subst b r
 727       | Type ty <- r
 728       , isTyVar b       -- let a::* = TYPE ty in <body>
 729       = Left (extendTvSubst subst b (substTy subst ty))
 730
 731       | isId b          -- let x = e in <body>
 732       , safe_to_inline (idOccInfo b) || exprIsTrivial r'
 733       , isAlwaysActive (idInlineActivation b)   -- Note [Inline prag in simplOpt]
 734       = Left (extendIdSubst subst b r')
 735
 736       | otherwise
 737       = Right r'
 738       where
 739         r' = go subst r
 740
 741     ----------------------
 742         -- Unconditionally safe to inline
 743     safe_to_inline :: OccInfo -> Bool
 744     safe_to_inline IAmDead                  = True
 745     safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
 746     safe_to_inline (IAmALoopBreaker {})     = False
 747     safe_to_inline NoOccInfo                = False
 748 \end{code}
 749
 750 Note [Inline prag in simplOpt]
 751 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 752 If there's an INLINE/NOINLINE pragma that restricts the phase in
 753 which the binder can be inlined, we don't inline here; after all,
 754 we don't know what phase we're in.  Here's an example
 755
 756   foo :: Int -> Int -> Int
 757   {-# INLINE foo #-}
 758   foo m n = inner m
 759      where
 760        {-# INLINE [1] inner #-}
 761        inner m = m+n
 762
 763   bar :: Int -> Int
 764   bar n = foo n 1
 765
 766 When inlining 'foo' in 'bar' we want the let-binding for 'inner'
 767 to remain visible until Phase 1