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