Rename FV related functions
[ghc.git] / compiler / coreSyn / CoreSubst.hs
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
9 {-# LANGUAGE CPP #-}
10 module CoreSubst (
11 -- * Main data types
12 Subst(..), -- Implementation exported for supercompiler's Renaming.hs only
13 TvSubstEnv, IdSubstEnv, InScopeSet,
14
15 -- ** Substituting into expressions and related types
16 deShadowBinds, substSpec, substRulesForImportedIds,
17 substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
18 substUnfolding, substUnfoldingSC,
19 lookupIdSubst, lookupTCvSubst, substIdOcc,
20 substTickish, substDVarSet,
21
22 -- ** Operations on substitutions
23 emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
24 extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,
25 extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
26 addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,
27 isInScope, setInScope,
28 delBndr, delBndrs,
29
30 -- ** Substituting and cloning binders
31 substBndr, substBndrs, substRecBndrs,
32 cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
33
34 -- ** Simple expression optimiser
35 simpleOptPgm, simpleOptExpr, simpleOptExprWith,
36 exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
37 ) where
38
39 #include "HsVersions.h"
40
41 import CoreSyn
42 import CoreFVs
43 import CoreSeq
44 import CoreUtils
45 import Literal ( Literal(MachStr) )
46 import qualified Data.ByteString as BS
47 import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
48
49 import qualified Type
50 import qualified Coercion
51
52 -- We are defining local versions
53 import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
54 , isInScope, substTyVarBndr, cloneTyVarBndr )
55 import Coercion hiding ( substCo, substCoVarBndr )
56
57 import TyCon ( tyConArity )
58 import DataCon
59 import PrelNames
60 import OptCoercion ( optCoercion )
61 import PprCore ( pprCoreBindings, pprRules )
62 import Module ( Module )
63 import VarSet
64 import VarEnv
65 import Id
66 import Name ( Name )
67 import Var
68 import IdInfo
69 import UniqSupply
70 import Maybes
71 import ErrUtils
72 import DynFlags
73 import BasicTypes ( isAlwaysActive )
74 import Util
75 import Pair
76 import Outputable
77 import PprCore () -- Instances
78 import FastString
79
80 import Data.List
81
82 import TysWiredIn
83
84 {-
85 ************************************************************************
86 * *
87 \subsection{Substitutions}
88 * *
89 ************************************************************************
90 -}
91
92 -- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar'
93 -- substitutions.
94 --
95 -- Some invariants apply to how you use the substitution:
96 --
97 -- 1. #in_scope_invariant# The in-scope set contains at least those 'Id's and 'TyVar's that will be in scope /after/
98 -- applying the substitution to a term. Precisely, the in-scope set must be a superset of the free vars of the
99 -- substitution range that might possibly clash with locally-bound variables in the thing being substituted in.
100 --
101 -- 2. #apply_once# You may apply the substitution only /once/
102 --
103 -- There are various ways of setting up the in-scope set such that the first of these invariants hold:
104 --
105 -- * Arrange that the in-scope set really is all the things in scope
106 --
107 -- * Arrange that it's the free vars of the range of the substitution
108 --
109 -- * Make it empty, if you know that all the free vars of the substitution are fresh, and hence can't possibly clash
110 data Subst
111 = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/
112 -- applying the substitution
113 IdSubstEnv -- Substitution from NcIds to CoreExprs
114 TvSubstEnv -- Substitution from TyVars to Types
115 CvSubstEnv -- Substitution from CoVars to Coercions
116
117 -- INVARIANT 1: See #in_scope_invariant#
118 -- This is what lets us deal with name capture properly
119 -- It's a hard invariant to check...
120 --
121 -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with
122 -- Types.TvSubstEnv
123 --
124 -- INVARIANT 3: See Note [Extending the Subst]
125
126 {-
127 Note [Extending the Subst]
128 ~~~~~~~~~~~~~~~~~~~~~~~~~~
129 For a core Subst, which binds Ids as well, we make a different choice for Ids
130 than we do for TyVars.
131
132 For TyVars, see Note [Extending the TCvSubst] with Type.TvSubstEnv
133
134 For Ids, we have a different invariant
135 The IdSubstEnv is extended *only* when the Unique on an Id changes
136 Otherwise, we just extend the InScopeSet
137
138 In consequence:
139
140 * If all subst envs are empty, substExpr would be a
141 no-op, so substExprSC ("short cut") does nothing.
142
143 However, substExpr still goes ahead and substitutes. Reason: we may
144 want to replace existing Ids with new ones from the in-scope set, to
145 avoid space leaks.
146
147 * In substIdBndr, we extend the IdSubstEnv only when the unique changes
148
149 * If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,
150 substExpr does nothing (Note that the above rule for substIdBndr
151 maintains this property. If the incoming envts are both empty, then
152 substituting the type and IdInfo can't change anything.)
153
154 * In lookupIdSubst, we *must* look up the Id in the in-scope set, because
155 it may contain non-trivial changes. Example:
156 (/\a. \x:a. ...x...) Int
157 We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change
158 so we only extend the in-scope set. Then we must look up in the in-scope
159 set when we find the occurrence of x.
160
161 * The requirement to look up the Id in the in-scope set means that we
162 must NOT take no-op short cut when the IdSubst is empty.
163 We must still look up every Id in the in-scope set.
164
165 * (However, we don't need to do so for expressions found in the IdSubst
166 itself, whose range is assumed to be correct wrt the in-scope set.)
167
168 Why do we make a different choice for the IdSubstEnv than the
169 TvSubstEnv and CvSubstEnv?
170
171 * For Ids, we change the IdInfo all the time (e.g. deleting the
172 unfolding), and adding it back later, so using the TyVar convention
173 would entail extending the substitution almost all the time
174
175 * The simplifier wants to look up in the in-scope set anyway, in case it
176 can see a better unfolding from an enclosing case expression
177
178 * For TyVars, only coercion variables can possibly change, and they are
179 easy to spot
180 -}
181
182 -- | An environment for substituting for 'Id's
183 type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions
184
185 ----------------------------
186 isEmptySubst :: Subst -> Bool
187 isEmptySubst (Subst _ id_env tv_env cv_env)
188 = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
189
190 emptySubst :: Subst
191 emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv
192
193 mkEmptySubst :: InScopeSet -> Subst
194 mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
195
196 mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
197 mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
198
199 -- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
200 substInScope :: Subst -> InScopeSet
201 substInScope (Subst in_scope _ _ _) = in_scope
202
203 -- | Remove all substitutions for 'Id's and 'Var's that might have been built up
204 -- while preserving the in-scope set
205 zapSubstEnv :: Subst -> Subst
206 zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
207
208 -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
209 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
210 extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
211 -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
212 extendIdSubst (Subst in_scope ids tvs cvs) v r
213 = ASSERT2( isNonCoVarId v, ppr v $$ ppr r )
214 Subst in_scope (extendVarEnv ids v r) tvs cvs
215
216 -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
217 extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
218 extendIdSubstList (Subst in_scope ids tvs cvs) prs
219 = ASSERT( all (isNonCoVarId . fst) prs )
220 Subst in_scope (extendVarEnvList ids prs) tvs cvs
221
222 -- | Add a substitution for a 'TyVar' to the 'Subst'
223 -- The 'TyVar' *must* be a real TyVar, and not a CoVar
224 -- You must ensure that the in-scope set is such that
225 -- the "CoreSubst#in_scope_invariant" is true after extending
226 -- the substitution like this.
227 extendTvSubst :: Subst -> TyVar -> Type -> Subst
228 extendTvSubst (Subst in_scope ids tvs cvs) tv ty
229 = ASSERT( isTyVar tv )
230 Subst in_scope ids (extendVarEnv tvs tv ty) cvs
231
232 -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
233 extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
234 extendTvSubstList subst vrs
235 = foldl' extend subst vrs
236 where
237 extend subst (v, r) = extendTvSubst subst v r
238
239 -- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is
240 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
241 extendCvSubst :: Subst -> CoVar -> Coercion -> Subst
242 extendCvSubst (Subst in_scope ids tvs cvs) v r
243 = ASSERT( isCoVar v )
244 Subst in_scope ids tvs (extendVarEnv cvs v r)
245
246 -- | Add a substitution appropriate to the thing being substituted
247 -- (whether an expression, type, or coercion). See also
248 -- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst'
249 extendSubst :: Subst -> Var -> CoreArg -> Subst
250 extendSubst subst var arg
251 = case arg of
252 Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty
253 Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co
254 _ -> ASSERT( isId var ) extendIdSubst subst var arg
255
256 extendSubstWithVar :: Subst -> Var -> Var -> Subst
257 extendSubstWithVar subst v1 v2
258 | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)
259 | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)
260 | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2)
261
262 -- | Add a substitution as appropriate to each of the terms being
263 -- substituted (whether expressions, types, or coercions). See also
264 -- 'extendSubst'.
265 extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst
266 extendSubstList subst [] = subst
267 extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
268
269 -- | Find the substitution for an 'Id' in the 'Subst'
270 lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
271 lookupIdSubst doc (Subst in_scope ids _ _) v
272 | not (isLocalId v) = Var v
273 | Just e <- lookupVarEnv ids v = e
274 | Just v' <- lookupInScope in_scope v = Var v'
275 -- Vital! See Note [Extending the Subst]
276 | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v
277 $$ ppr in_scope)
278 Var v
279
280 -- | Find the substitution for a 'TyVar' in the 'Subst'
281 lookupTCvSubst :: Subst -> TyVar -> Type
282 lookupTCvSubst (Subst _ _ tvs cvs) v
283 | isTyVar v
284 = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
285 | otherwise
286 = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v
287
288 delBndr :: Subst -> Var -> Subst
289 delBndr (Subst in_scope ids tvs cvs) v
290 | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
291 | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs
292 | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs
293
294 delBndrs :: Subst -> [Var] -> Subst
295 delBndrs (Subst in_scope ids tvs cvs) vs
296 = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
297 -- Easiest thing is just delete all from all!
298
299 -- | Simultaneously substitute for a bunch of variables
300 -- No left-right shadowing
301 -- ie the substitution for (\x \y. e) a1 a2
302 -- so neither x nor y scope over a1 a2
303 mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
304 mkOpenSubst in_scope pairs = Subst in_scope
305 (mkVarEnv [(id,e) | (id, e) <- pairs, isId id])
306 (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
307 (mkVarEnv [(v,co) | (v, Coercion co) <- pairs])
308
309 ------------------------------
310 isInScope :: Var -> Subst -> Bool
311 isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
312
313 -- | Add the 'Var' to the in-scope set, but do not remove
314 -- any existing substitutions for it
315 addInScopeSet :: Subst -> VarSet -> Subst
316 addInScopeSet (Subst in_scope ids tvs cvs) vs
317 = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs
318
319 -- | Add the 'Var' to the in-scope set: as a side effect,
320 -- and remove any existing substitutions for it
321 extendInScope :: Subst -> Var -> Subst
322 extendInScope (Subst in_scope ids tvs cvs) v
323 = Subst (in_scope `extendInScopeSet` v)
324 (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
325
326 -- | Add the 'Var's to the in-scope set: see also 'extendInScope'
327 extendInScopeList :: Subst -> [Var] -> Subst
328 extendInScopeList (Subst in_scope ids tvs cvs) vs
329 = Subst (in_scope `extendInScopeSetList` vs)
330 (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
331
332 -- | Optimized version of 'extendInScopeList' that can be used if you are certain
333 -- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
334 extendInScopeIds :: Subst -> [Id] -> Subst
335 extendInScopeIds (Subst in_scope ids tvs cvs) vs
336 = Subst (in_scope `extendInScopeSetList` vs)
337 (ids `delVarEnvList` vs) tvs cvs
338
339 setInScope :: Subst -> InScopeSet -> Subst
340 setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
341
342 -- Pretty printing, for debugging only
343
344 instance Outputable Subst where
345 ppr (Subst in_scope ids tvs cvs)
346 = text "<InScope =" <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
347 $$ text " IdSubst =" <+> ppr ids
348 $$ text " TvSubst =" <+> ppr tvs
349 $$ text " CvSubst =" <+> ppr cvs
350 <> char '>'
351
352 {-
353 ************************************************************************
354 * *
355 Substituting expressions
356 * *
357 ************************************************************************
358 -}
359
360 -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only
361 -- apply the substitution /once/: see "CoreSubst#apply_once"
362 --
363 -- Do *not* attempt to short-cut in the case of an empty substitution!
364 -- See Note [Extending the Subst]
365 substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr
366 substExprSC doc subst orig_expr
367 | isEmptySubst subst = orig_expr
368 | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $
369 subst_expr doc subst orig_expr
370
371 substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr
372 substExpr doc subst orig_expr = subst_expr doc subst orig_expr
373
374 subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr
375 subst_expr doc subst expr
376 = go expr
377 where
378 go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v
379 go (Type ty) = Type (substTy subst ty)
380 go (Coercion co) = Coercion (substCo subst co)
381 go (Lit lit) = Lit lit
382 go (App fun arg) = App (go fun) (go arg)
383 go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
384 go (Cast e co) = Cast (go e) (substCo subst co)
385 -- Do not optimise even identity coercions
386 -- Reason: substitution applies to the LHS of RULES, and
387 -- if you "optimise" an identity coercion, you may
388 -- lose a binder. We optimise the LHS of rules at
389 -- construction time
390
391 go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body)
392 where
393 (subst', bndr') = substBndr subst bndr
394
395 go (Let bind body) = Let bind' (subst_expr doc subst' body)
396 where
397 (subst', bind') = substBind subst bind
398
399 go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)
400 where
401 (subst', bndr') = substBndr subst bndr
402
403 go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs)
404 where
405 (subst', bndrs') = substBndrs subst bndrs
406
407 -- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst'
408 -- that should be used by subsequent substitutions.
409 substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind)
410
411 substBindSC subst bind -- Short-cut if the substitution is empty
412 | not (isEmptySubst subst)
413 = substBind subst bind
414 | otherwise
415 = case bind of
416 NonRec bndr rhs -> (subst', NonRec bndr' rhs)
417 where
418 (subst', bndr') = substBndr subst bndr
419 Rec pairs -> (subst', Rec (bndrs' `zip` rhss'))
420 where
421 (bndrs, rhss) = unzip pairs
422 (subst', bndrs') = substRecBndrs subst bndrs
423 rhss' | isEmptySubst subst'
424 = rhss
425 | otherwise
426 = map (subst_expr (text "substBindSC") subst') rhss
427
428 substBind subst (NonRec bndr rhs)
429 = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs))
430 where
431 (subst', bndr') = substBndr subst bndr
432
433 substBind subst (Rec pairs)
434 = (subst', Rec (bndrs' `zip` rhss'))
435 where
436 (bndrs, rhss) = unzip pairs
437 (subst', bndrs') = substRecBndrs subst bndrs
438 rhss' = map (subst_expr (text "substBind") subst') rhss
439
440 -- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply
441 -- by running over the bindings with an empty substitution, because substitution
442 -- returns a result that has no-shadowing guaranteed.
443 --
444 -- (Actually, within a single /type/ there might still be shadowing, because
445 -- 'substTy' is a no-op for the empty substitution, but that's probably OK.)
446 --
447 -- [Aug 09] This function is not used in GHC at the moment, but seems so
448 -- short and simple that I'm going to leave it here
449 deShadowBinds :: CoreProgram -> CoreProgram
450 deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
451
452 {-
453 ************************************************************************
454 * *
455 Substituting binders
456 * *
457 ************************************************************************
458
459 Remember that substBndr and friends are used when doing expression
460 substitution only. Their only business is substitution, so they
461 preserve all IdInfo (suitably substituted). For example, we *want* to
462 preserve occ info in rules.
463 -}
464
465 -- | Substitutes a 'Var' for another one according to the 'Subst' given, returning
466 -- the result and an updated 'Subst' that should be used by subsequent substitutions.
467 -- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
468 substBndr :: Subst -> Var -> (Subst, Var)
469 substBndr subst bndr
470 | isTyVar bndr = substTyVarBndr subst bndr
471 | isCoVar bndr = substCoVarBndr subst bndr
472 | otherwise = substIdBndr (text "var-bndr") subst subst bndr
473
474 -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
475 substBndrs :: Subst -> [Var] -> (Subst, [Var])
476 substBndrs subst bndrs = mapAccumL substBndr subst bndrs
477
478 -- | Substitute in a mutually recursive group of 'Id's
479 substRecBndrs :: Subst -> [Id] -> (Subst, [Id])
480 substRecBndrs subst bndrs
481 = (new_subst, new_bndrs)
482 where -- Here's the reason we need to pass rec_subst to subst_id
483 (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs
484
485 substIdBndr :: SDoc
486 -> Subst -- ^ Substitution to use for the IdInfo
487 -> Subst -> Id -- ^ Substitution and Id to transform
488 -> (Subst, Id) -- ^ Transformed pair
489 -- NB: unfolding may be zapped
490
491 substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
492 = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
493 (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
494 where
495 id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
496 id2 | no_type_change = id1
497 | otherwise = setIdType id1 (substTy subst old_ty)
498
499 old_ty = idType old_id
500 no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) ||
501 isEmptyVarSet (tyCoVarsOfType old_ty)
502
503 -- new_id has the right IdInfo
504 -- The lazy-set is because we're in a loop here, with
505 -- rec_subst, when dealing with a mutually-recursive group
506 new_id = maybeModifyIdInfo mb_new_info id2
507 mb_new_info = substIdInfo rec_subst id2 (idInfo id2)
508 -- NB: unfolding info may be zapped
509
510 -- Extend the substitution if the unique has changed
511 -- See the notes with substTyVarBndr for the delVarEnv
512 new_env | no_change = delVarEnv env old_id
513 | otherwise = extendVarEnv env old_id (Var new_id)
514
515 no_change = id1 == old_id
516 -- See Note [Extending the Subst]
517 -- it's /not/ necessary to check mb_new_info and no_type_change
518
519 {-
520 Now a variant that unconditionally allocates a new unique.
521 It also unconditionally zaps the OccInfo.
522 -}
523
524 -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for
525 -- each variable in its output. It substitutes the IdInfo though.
526 cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)
527 cloneIdBndr subst us old_id
528 = clone_id subst subst (old_id, uniqFromSupply us)
529
530 -- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final
531 -- substitution from left to right
532 cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
533 cloneIdBndrs subst us ids
534 = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)
535
536 cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])
537 -- Works for all kinds of variables (typically case binders)
538 -- not just Ids
539 cloneBndrs subst us vs
540 = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)
541
542 cloneBndr :: Subst -> Unique -> Var -> (Subst, Var)
543 cloneBndr subst uniq v
544 | isTyVar v = cloneTyVarBndr subst v uniq
545 | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too
546
547 -- | Clone a mutually recursive group of 'Id's
548 cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
549 cloneRecIdBndrs subst us ids
550 = (subst', ids')
551 where
552 (subst', ids') = mapAccumL (clone_id subst') subst
553 (ids `zip` uniqsFromSupply us)
554
555 -- Just like substIdBndr, except that it always makes a new unique
556 -- It is given the unique to use
557 clone_id :: Subst -- Substitution for the IdInfo
558 -> Subst -> (Id, Unique) -- Substitution and Id to transform
559 -> (Subst, Id) -- Transformed pair
560
561 clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
562 = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)
563 where
564 id1 = setVarUnique old_id uniq
565 id2 = substIdType subst id1
566 new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
567 (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))
568 | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs)
569
570 {-
571 ************************************************************************
572 * *
573 Types and Coercions
574 * *
575 ************************************************************************
576
577 For types and coercions we just call the corresponding functions in
578 Type and Coercion, but we have to repackage the substitution, from a
579 Subst to a TCvSubst.
580 -}
581
582 substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
583 substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
584 = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of
585 (TCvSubst in_scope' tv_env' cv_env', tv')
586 -> (Subst in_scope' id_env tv_env' cv_env', tv')
587
588 cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar)
589 cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq
590 = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of
591 (TCvSubst in_scope' tv_env' cv_env', tv')
592 -> (Subst in_scope' id_env tv_env' cv_env', tv')
593
594 substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)
595 substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv
596 = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of
597 (TCvSubst in_scope' tv_env' cv_env', cv')
598 -> (Subst in_scope' id_env tv_env' cv_env', cv')
599
600 -- | See 'Type.substTy'
601 substTy :: Subst -> Type -> Type
602 substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty
603
604 getTCvSubst :: Subst -> TCvSubst
605 getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv
606
607 -- | See 'Coercion.substCo'
608 substCo :: Subst -> Coercion -> Coercion
609 substCo subst co = Coercion.substCo (getTCvSubst subst) co
610
611 {-
612 ************************************************************************
613 * *
614 \section{IdInfo substitution}
615 * *
616 ************************************************************************
617 -}
618
619 substIdType :: Subst -> Id -> Id
620 substIdType subst@(Subst _ _ tv_env cv_env) id
621 | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (tyCoVarsOfType old_ty) = id
622 | otherwise = setIdType id (substTy subst old_ty)
623 -- The tyCoVarsOfType is cheaper than it looks
624 -- because we cache the free tyvars of the type
625 -- in a Note in the id's type itself
626 where
627 old_ty = idType id
628
629 ------------------
630 -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
631 substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
632 substIdInfo subst new_id info
633 | nothing_to_do = Nothing
634 | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules
635 `setUnfoldingInfo` substUnfolding subst old_unf)
636 where
637 old_rules = ruleInfo info
638 old_unf = unfoldingInfo info
639 nothing_to_do = isEmptyRuleInfo old_rules && isClosedUnfolding old_unf
640
641
642 ------------------
643 -- | Substitutes for the 'Id's within an unfolding
644 substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding
645 -- Seq'ing on the returned Unfolding is enough to cause
646 -- all the substitutions to happen completely
647
648 substUnfoldingSC subst unf -- Short-cut version
649 | isEmptySubst subst = unf
650 | otherwise = substUnfolding subst unf
651
652 substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
653 = df { df_bndrs = bndrs', df_args = args' }
654 where
655 (subst',bndrs') = substBndrs subst bndrs
656 args' = map (substExpr (text "subst-unf:dfun") subst') args
657
658 substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
659 -- Retain an InlineRule!
660 | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work
661 = NoUnfolding
662 | otherwise -- But keep a stable one!
663 = seqExpr new_tmpl `seq`
664 unf { uf_tmpl = new_tmpl }
665 where
666 new_tmpl = substExpr (text "subst-unf") subst tmpl
667
668 substUnfolding _ unf = unf -- NoUnfolding, OtherCon
669
670 ------------------
671 substIdOcc :: Subst -> Id -> Id
672 -- These Ids should not be substituted to non-Ids
673 substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
674 Var v' -> v'
675 other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])
676
677 ------------------
678 -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
679 substSpec :: Subst -> Id -> RuleInfo -> RuleInfo
680 substSpec subst new_id (RuleInfo rules rhs_fvs)
681 = seqRuleInfo new_spec `seq` new_spec
682 where
683 subst_ru_fn = const (idName new_id)
684 new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules)
685 (substDVarSet subst rhs_fvs)
686
687 ------------------
688 substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
689 substRulesForImportedIds subst rules
690 = map (substRule subst not_needed) rules
691 where
692 not_needed name = pprPanic "substRulesForImportedIds" (ppr name)
693
694 ------------------
695 substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
696
697 -- The subst_ru_fn argument is applied to substitute the ru_fn field
698 -- of the rule:
699 -- - Rules for *imported* Ids never change ru_fn
700 -- - Rules for *local* Ids are in the IdInfo for that Id,
701 -- and the ru_fn field is simply replaced by the new name
702 -- of the Id
703 substRule _ _ rule@(BuiltinRule {}) = rule
704 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
705 , ru_fn = fn_name, ru_rhs = rhs
706 , ru_local = is_local })
707 = rule { ru_bndrs = bndrs'
708 , ru_fn = if is_local
709 then subst_ru_fn fn_name
710 else fn_name
711 , ru_args = map (substExpr doc subst') args
712 , ru_rhs = substExpr (text "foo") subst' rhs }
713 -- Do NOT optimise the RHS (previously we did simplOptExpr here)
714 -- See Note [Substitute lazily]
715 where
716 doc = text "subst-rule" <+> ppr fn_name
717 (subst', bndrs') = substBndrs subst bndrs
718
719 ------------------
720 substVects :: Subst -> [CoreVect] -> [CoreVect]
721 substVects subst = map (substVect subst)
722
723 ------------------
724 substVect :: Subst -> CoreVect -> CoreVect
725 substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs)
726 substVect _subst vd@(NoVect _) = vd
727 substVect _subst vd@(VectType _ _ _) = vd
728 substVect _subst vd@(VectClass _) = vd
729 substVect _subst vd@(VectInst _) = vd
730
731 ------------------
732 substDVarSet :: Subst -> DVarSet -> DVarSet
733 substDVarSet subst fvs
734 = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs
735 where
736 subst_fv subst fv acc
737 | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc
738 | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc
739
740 ------------------
741 substTickish :: Subst -> Tickish Id -> Tickish Id
742 substTickish subst (Breakpoint n ids)
743 = Breakpoint n (map do_one ids)
744 where
745 do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst
746 substTickish _subst other = other
747
748 {- Note [Substitute lazily]
749 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
750 The functions that substitute over IdInfo must be pretty lazy, because
751 they are knot-tied by substRecBndrs.
752
753 One case in point was Trac #10627 in which a rule for a function 'f'
754 referred to 'f' (at a differnet type) on the RHS. But instead of just
755 substituting in the rhs of the rule, we were calling simpleOptExpr, which
756 looked at the idInfo for 'f'; result <<loop>>.
757
758 In any case we don't need to optimise the RHS of rules, or unfoldings,
759 because the simplifier will do that.
760
761
762 Note [substTickish]
763 ~~~~~~~~~~~~~~~~~~~~~~
764 A Breakpoint contains a list of Ids. What happens if we ever want to
765 substitute an expression for one of these Ids?
766
767 First, we ensure that we only ever substitute trivial expressions for
768 these Ids, by marking them as NoOccInfo in the occurrence analyser.
769 Then, when substituting for the Id, we unwrap any type applications
770 and abstractions to get back to an Id, with getIdFromTrivialExpr.
771
772 Second, we have to ensure that we never try to substitute a literal
773 for an Id in a breakpoint. We ensure this by never storing an Id with
774 an unlifted type in a Breakpoint - see Coverage.mkTickish.
775 Breakpoints can't handle free variables with unlifted types anyway.
776 -}
777
778 {-
779 Note [Worker inlining]
780 ~~~~~~~~~~~~~~~~~~~~~~
781 A worker can get sustituted away entirely.
782 - it might be trivial
783 - it might simply be very small
784 We do not treat an InlWrapper as an 'occurrence' in the occurrence
785 analyser, so it's possible that the worker is not even in scope any more.
786
787 In all all these cases we simply drop the special case, returning to
788 InlVanilla. The WARN is just so I can see if it happens a lot.
789
790
791 ************************************************************************
792 * *
793 The Very Simple Optimiser
794 * *
795 ************************************************************************
796
797 Note [Getting the map/coerce RULE to work]
798 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
799 We wish to allow the "map/coerce" RULE to fire:
800
801 {-# RULES "map/coerce" map coerce = coerce #-}
802
803 The naive core produced for this is
804
805 forall a b (dict :: Coercible * a b).
806 map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'
807
808 where dict' :: Coercible [a] [b]
809 dict' = ...
810
811 This matches literal uses of `map coerce` in code, but that's not what we
812 want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)
813 too. Some of this is addressed by compulsorily unfolding coerce on the LHS,
814 yielding
815
816 forall a b (dict :: Coercible * a b).
817 map @a @b (\(x :: a) -> case dict of
818 MkCoercible (co :: a ~R# b) -> x |> co) = ...
819
820 Getting better. But this isn't exactly what gets produced. This is because
821 Coercible essentially has ~R# as a superclass, and superclasses get eagerly
822 extracted during solving. So we get this:
823
824 forall a b (dict :: Coercible * a b).
825 case Coercible_SCSel @* @a @b dict of
826 _ [Dead] -> map @a @b (\(x :: a) -> case dict of
827 MkCoercible (co :: a ~R# b) -> x |> co) = ...
828
829 Unfortunately, this still abstracts over a Coercible dictionary. We really
830 want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,
831 which transforms the above to (see also Note [Desugaring coerce as cast] in
832 Desugar)
833
834 forall a b (co :: a ~R# b).
835 let dict = MkCoercible @* @a @b co in
836 case Coercible_SCSel @* @a @b dict of
837 _ [Dead] -> map @a @b (\(x :: a) -> case dict of
838 MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...
839
840 Now, we need simpleOptExpr to fix this up. It does so by taking three
841 separate actions:
842 1. Inline certain non-recursive bindings. The choice whether to inline
843 is made in maybe_substitute. Note the rather specific check for
844 MkCoercible in there.
845
846 2. Stripping case expressions like the Coercible_SCSel one.
847 See the `Case` case of simple_opt_expr's `go` function.
848
849 3. Look for case expressions that unpack something that was
850 just packed and inline them. This is also done in simple_opt_expr's
851 `go` function.
852
853 This is all a fair amount of special-purpose hackery, but it's for
854 a good cause. And it won't hurt other RULES and such that it comes across.
855
856 -}
857
858 simpleOptExpr :: CoreExpr -> CoreExpr
859 -- Do simple optimisation on an expression
860 -- The optimisation is very straightforward: just
861 -- inline non-recursive bindings that are used only once,
862 -- or where the RHS is trivial
863 --
864 -- We also inline bindings that bind a Eq# box: see
865 -- See Note [Getting the map/coerce RULE to work].
866 --
867 -- The result is NOT guaranteed occurrence-analysed, because
868 -- in (let x = y in ....) we substitute for x; so y's occ-info
869 -- may change radically
870
871 simpleOptExpr expr
872 = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
873 simpleOptExprWith init_subst expr
874 where
875 init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
876 -- It's potentially important to make a proper in-scope set
877 -- Consider let x = ..y.. in \y. ...x...
878 -- Then we should remember to clone y before substituting
879 -- for x. It's very unlikely to occur, because we probably
880 -- won't *be* substituting for x if it occurs inside a
881 -- lambda.
882 --
883 -- It's a bit painful to call exprFreeVars, because it makes
884 -- three passes instead of two (occ-anal, and go)
885
886 simpleOptExprWith :: Subst -> InExpr -> OutExpr
887 simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
888
889 ----------------------
890 simpleOptPgm :: DynFlags -> Module
891 -> CoreProgram -> [CoreRule] -> [CoreVect]
892 -> IO (CoreProgram, [CoreRule], [CoreVect])
893 simpleOptPgm dflags this_mod binds rules vects
894 = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
895 (pprCoreBindings occ_anald_binds $$ pprRules rules );
896
897 ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
898 where
899 occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
900 rules vects emptyVarEnv binds
901 (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
902
903 do_one (subst, binds') bind
904 = case simple_opt_bind subst bind of
905 (subst', Nothing) -> (subst', binds')
906 (subst', Just bind') -> (subst', bind':binds')
907
908 ----------------------
909 type InVar = Var
910 type OutVar = Var
911 type InId = Id
912 type OutId = Id
913 type InExpr = CoreExpr
914 type OutExpr = CoreExpr
915
916 -- In these functions the substitution maps InVar -> OutExpr
917
918 ----------------------
919 simple_opt_expr :: Subst -> InExpr -> OutExpr
920 simple_opt_expr subst expr
921 = go expr
922 where
923 in_scope_env = (substInScope subst, simpleUnfoldingFun)
924
925 go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v
926 go (App e1 e2) = simple_app subst e1 [go e2]
927 go (Type ty) = Type (substTy subst ty)
928 go (Coercion co) = Coercion (optCoercion (getTCvSubst subst) co)
929 go (Lit lit) = Lit lit
930 go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
931 go (Cast e co) | isReflCo co' = go e
932 | otherwise = Cast (go e) co'
933 where
934 co' = optCoercion (getTCvSubst subst) co
935
936 go (Let bind body) = case simple_opt_bind subst bind of
937 (subst', Nothing) -> simple_opt_expr subst' body
938 (subst', Just bind) -> Let bind (simple_opt_expr subst' body)
939
940 go lam@(Lam {}) = go_lam [] subst lam
941 go (Case e b ty as)
942 -- See Note [Getting the map/coerce RULE to work]
943 | isDeadBinder b
944 , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
945 , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
946 = case altcon of
947 DEFAULT -> go rhs
948 _ -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs
949 where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst
950 (zipEqual "simpleOptExpr" bs es)
951
952 -- Note [Getting the map/coerce RULE to work]
953 | isDeadBinder b
954 , [(DEFAULT, _, rhs)] <- as
955 , isCoercionType (varType b)
956 , (Var fun, _args) <- collectArgs e
957 , fun `hasKey` coercibleSCSelIdKey
958 -- without this last check, we get #11230
959 = go rhs
960
961 | otherwise
962 = Case e' b' (substTy subst ty)
963 (map (go_alt subst') as)
964 where
965 e' = go e
966 (subst', b') = subst_opt_bndr subst b
967
968 ----------------------
969 go_alt subst (con, bndrs, rhs)
970 = (con, bndrs', simple_opt_expr subst' rhs)
971 where
972 (subst', bndrs') = subst_opt_bndrs subst bndrs
973
974 ----------------------
975 -- go_lam tries eta reduction
976 go_lam bs' subst (Lam b e)
977 = go_lam (b':bs') subst' e
978 where
979 (subst', b') = subst_opt_bndr subst b
980 go_lam bs' subst e
981 | Just etad_e <- tryEtaReduce bs e' = etad_e
982 | otherwise = mkLams bs e'
983 where
984 bs = reverse bs'
985 e' = simple_opt_expr subst e
986
987 ----------------------
988 -- simple_app collects arguments for beta reduction
989 simple_app :: Subst -> InExpr -> [OutExpr] -> CoreExpr
990 simple_app subst (App e1 e2) as
991 = simple_app subst e1 (simple_opt_expr subst e2 : as)
992 simple_app subst (Lam b e) (a:as)
993 = case maybe_substitute subst b a of
994 Just ext_subst -> simple_app ext_subst e as
995 Nothing -> Let (NonRec b2 a) (simple_app subst' e as)
996 where
997 (subst', b') = subst_opt_bndr subst b
998 b2 = add_info subst' b b'
999 simple_app subst (Var v) as
1000 | isCompulsoryUnfolding (idUnfolding v)
1001 , isAlwaysActive (idInlineActivation v)
1002 -- See Note [Unfold compulsory unfoldings in LHSs]
1003 = simple_app subst (unfoldingTemplate (idUnfolding v)) as
1004 simple_app subst (Tick t e) as
1005 -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
1006 | t `tickishScopesLike` SoftScope
1007 = mkTick t $ simple_app subst e as
1008 simple_app subst e as
1009 = foldl App (simple_opt_expr subst e) as
1010
1011 ----------------------
1012 simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
1013 simple_opt_bind s b -- Can add trace stuff here
1014 = simple_opt_bind' s b
1015
1016 simple_opt_bind' subst (Rec prs)
1017 = (subst'', res_bind)
1018 where
1019 res_bind = Just (Rec (reverse rev_prs'))
1020 (subst', bndrs') = subst_opt_bndrs subst (map fst prs)
1021 (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
1022 do_pr (subst, prs) ((b,r), b')
1023 = case maybe_substitute subst b r2 of
1024 Just subst' -> (subst', prs)
1025 Nothing -> (subst, (b2,r2):prs)
1026 where
1027 b2 = add_info subst b b'
1028 r2 = simple_opt_expr subst r
1029
1030 simple_opt_bind' subst (NonRec b r)
1031 = simple_opt_out_bind subst (b, simple_opt_expr subst r)
1032
1033 ----------------------
1034 simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind)
1035 simple_opt_out_bind subst (b, r')
1036 | Just ext_subst <- maybe_substitute subst b r'
1037 = (ext_subst, Nothing)
1038 | otherwise
1039 = (subst', Just (NonRec b2 r'))
1040 where
1041 (subst', b') = subst_opt_bndr subst b
1042 b2 = add_info subst' b b'
1043
1044 ----------------------
1045 maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst
1046 -- (maybe_substitute subst in_var out_rhs)
1047 -- either extends subst with (in_var -> out_rhs)
1048 -- or returns Nothing
1049 maybe_substitute subst b r
1050 | Type ty <- r -- let a::* = TYPE ty in <body>
1051 = ASSERT( isTyVar b )
1052 Just (extendTvSubst subst b ty)
1053
1054 | Coercion co <- r
1055 = ASSERT( isCoVar b )
1056 Just (extendCvSubst subst b co)
1057
1058 | isId b -- let x = e in <body>
1059 , not (isCoVar b) -- See Note [Do not inline CoVars unconditionally]
1060 -- in SimplUtils
1061 , safe_to_inline (idOccInfo b)
1062 , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt]
1063 , not (isStableUnfolding (idUnfolding b))
1064 , not (isExportedId b)
1065 , not (isUnliftedType (idType b)) || exprOkForSpeculation r
1066 = Just (extendIdSubst subst b r)
1067
1068 | otherwise
1069 = Nothing
1070 where
1071 -- Unconditionally safe to inline
1072 safe_to_inline :: OccInfo -> Bool
1073 safe_to_inline (IAmALoopBreaker {}) = False
1074 safe_to_inline IAmDead = True
1075 safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || trivial
1076 safe_to_inline NoOccInfo = trivial
1077
1078 trivial | exprIsTrivial r = True
1079 | (Var fun, args) <- collectArgs r
1080 , Just dc <- isDataConWorkId_maybe fun
1081 , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey
1082 , all exprIsTrivial args = True
1083 -- See Note [Getting the map/coerce RULE to work]
1084 | otherwise = False
1085
1086 ----------------------
1087 subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
1088 subst_opt_bndr subst bndr
1089 | isTyVar bndr = substTyVarBndr subst bndr
1090 | isCoVar bndr = substCoVarBndr subst bndr
1091 | otherwise = subst_opt_id_bndr subst bndr
1092
1093 subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
1094 -- Nuke all fragile IdInfo, unfolding, and RULES;
1095 -- it gets added back later by add_info
1096 -- Rather like SimplEnv.substIdBndr
1097 --
1098 -- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
1099 -- carefully does not do) because simplOptExpr invalidates it
1100
1101 subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
1102 = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id)
1103 where
1104 id1 = uniqAway in_scope old_id
1105 id2 = setIdType id1 (substTy subst (idType old_id))
1106 new_id = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
1107 -- and fragile OccInfo
1108 new_in_scope = in_scope `extendInScopeSet` new_id
1109
1110 -- Extend the substitution if the unique has changed,
1111 -- or there's some useful occurrence information
1112 -- See the notes with substTyVarBndr for the delSubstEnv
1113 new_id_subst | new_id /= old_id
1114 = extendVarEnv id_subst old_id (Var new_id)
1115 | otherwise
1116 = delVarEnv id_subst old_id
1117
1118 ----------------------
1119 subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar])
1120 subst_opt_bndrs subst bndrs
1121 = mapAccumL subst_opt_bndr subst bndrs
1122
1123 ----------------------
1124 add_info :: Subst -> InVar -> OutVar -> OutVar
1125 add_info subst old_bndr new_bndr
1126 | isTyVar old_bndr = new_bndr
1127 | otherwise = maybeModifyIdInfo mb_new_info new_bndr
1128 where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
1129
1130 simpleUnfoldingFun :: IdUnfoldingFun
1131 simpleUnfoldingFun id
1132 | isAlwaysActive (idInlineActivation id) = idUnfolding id
1133 | otherwise = noUnfolding
1134
1135 {-
1136 Note [Inline prag in simplOpt]
1137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1138 If there's an INLINE/NOINLINE pragma that restricts the phase in
1139 which the binder can be inlined, we don't inline here; after all,
1140 we don't know what phase we're in. Here's an example
1141
1142 foo :: Int -> Int -> Int
1143 {-# INLINE foo #-}
1144 foo m n = inner m
1145 where
1146 {-# INLINE [1] inner #-}
1147 inner m = m+n
1148
1149 bar :: Int -> Int
1150 bar n = foo n 1
1151
1152 When inlining 'foo' in 'bar' we want the let-binding for 'inner'
1153 to remain visible until Phase 1
1154
1155 Note [Unfold compulsory unfoldings in LHSs]
1156 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1157 When the user writes `RULES map coerce = coerce` as a rule, the rule
1158 will only ever match if simpleOptExpr replaces coerce by its unfolding
1159 on the LHS, because that is the core that the rule matching engine
1160 will find. So do that for everything that has a compulsory
1161 unfolding. Also see Note [Desugaring coerce as cast] in Desugar.
1162
1163 However, we don't want to inline 'seq', which happens to also have a
1164 compulsory unfolding, so we only do this unfolding only for things
1165 that are always-active. See Note [User-defined RULES for seq] in MkId.
1166
1167
1168 ************************************************************************
1169 * *
1170 exprIsConApp_maybe
1171 * *
1172 ************************************************************************
1173
1174 Note [exprIsConApp_maybe]
1175 ~~~~~~~~~~~~~~~~~~~~~~~~~
1176 exprIsConApp_maybe is a very important function. There are two principal
1177 uses:
1178 * case e of { .... }
1179 * cls_op e, where cls_op is a class operation
1180
1181 In both cases you want to know if e is of form (C e1..en) where C is
1182 a data constructor.
1183
1184 However e might not *look* as if
1185
1186
1187 Note [exprIsConApp_maybe on literal strings]
1188 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1189 See #9400.
1190
1191 Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core
1192 they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or
1193 unpackCStringUtf8# when the literal contains multi-byte UTF8 characters.
1194
1195 For optimizations we want to be able to treat it as a list, so they can be
1196 decomposed when used in a case-statement. exprIsConApp_maybe detects those
1197 calls to unpackCString# and returns:
1198
1199 Just (':', [Char], ['a', unpackCString# "bc"]).
1200
1201 We need to be careful about UTF8 strings here. ""# contains a ByteString, so
1202 we must parse it back into a FastString to split off the first character.
1203 That way we can treat unpackCString# and unpackCStringUtf8# in the same way.
1204 -}
1205
1206 data ConCont = CC [CoreExpr] Coercion
1207 -- Substitution already applied
1208
1209 -- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
1210 -- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
1211 -- where t1..tk are the *universally-qantified* type args of 'dc'
1212 exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
1213 exprIsConApp_maybe (in_scope, id_unf) expr
1214 = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr)))
1215 where
1216 go :: Either InScopeSet Subst
1217 -> CoreExpr -> ConCont
1218 -> Maybe (DataCon, [Type], [CoreExpr])
1219 go subst (Tick t expr) cont
1220 | not (tickishIsCode t) = go subst expr cont
1221 go subst (Cast expr co1) (CC [] co2)
1222 = go subst expr (CC [] (subst_co subst co1 `mkTransCo` co2))
1223 go subst (App fun arg) (CC args co)
1224 = go subst fun (CC (subst_arg subst arg : args) co)
1225 go subst (Lam var body) (CC (arg:args) co)
1226 | exprIsTrivial arg -- Don't duplicate stuff!
1227 = go (extend subst var arg) body (CC args co)
1228 go (Right sub) (Var v) cont
1229 = go (Left (substInScope sub))
1230 (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v)
1231 cont
1232
1233 go (Left in_scope) (Var fun) cont@(CC args co)
1234
1235 | Just con <- isDataConWorkId_maybe fun
1236 , count isValArg args == idArity fun
1237 = dealWithCoercion co con args
1238
1239 -- Look through dictionary functions; see Note [Unfolding DFuns]
1240 | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
1241 , bndrs `equalLength` args -- See Note [DFun arity check]
1242 , let subst = mkOpenSubst in_scope (bndrs `zip` args)
1243 = dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args)
1244
1245 -- Look through unfoldings, but only arity-zero one;
1246 -- if arity > 0 we are effectively inlining a function call,
1247 -- and that is the business of callSiteInline.
1248 -- In practice, without this test, most of the "hits" were
1249 -- CPR'd workers getting inlined back into their wrappers,
1250 | idArity fun == 0
1251 , Just rhs <- expandUnfolding_maybe unfolding
1252 , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
1253 = go (Left in_scope') rhs cont
1254
1255 | (fun `hasKey` unpackCStringIdKey)
1256 || (fun `hasKey` unpackCStringUtf8IdKey)
1257 , [Lit (MachStr str)] <- args
1258 = dealWithStringLiteral fun str co
1259 where
1260 unfolding = id_unf fun
1261
1262 go _ _ _ = Nothing
1263
1264 ----------------------------
1265 -- Operations on the (Either InScopeSet CoreSubst)
1266 -- The Left case is wildly dominant
1267 subst_co (Left {}) co = co
1268 subst_co (Right s) co = CoreSubst.substCo s co
1269
1270 subst_arg (Left {}) e = e
1271 subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e
1272
1273 extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
1274 extend (Right s) v e = Right (extendSubst s v e)
1275
1276 -- See Note [exprIsConApp_maybe on literal strings]
1277 dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
1278 -> Maybe (DataCon, [Type], [CoreExpr])
1279
1280 -- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS
1281 -- turns those into [] automatically, but just in case something else in GHC
1282 -- generates a string literal directly.
1283 dealWithStringLiteral _ str co
1284 | BS.null str
1285 = dealWithCoercion co nilDataCon [Type charTy]
1286
1287 dealWithStringLiteral fun str co
1288 = let strFS = mkFastStringByteString str
1289
1290 char = mkConApp charDataCon [mkCharLit (headFS strFS)]
1291 charTail = fastStringToByteString (tailFS strFS)
1292
1293 -- In singleton strings, just add [] instead of unpackCstring# ""#.
1294 rest = if BS.null charTail
1295 then mkConApp nilDataCon [Type charTy]
1296 else App (Var fun)
1297 (Lit (MachStr charTail))
1298
1299 in dealWithCoercion co consDataCon [Type charTy, char, rest]
1300
1301 dealWithCoercion :: Coercion -> DataCon -> [CoreExpr]
1302 -> Maybe (DataCon, [Type], [CoreExpr])
1303 dealWithCoercion co dc dc_args
1304 | isReflCo co || from_ty `eqType` to_ty -- try cheap test first
1305 , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
1306 = Just (dc, map exprToType univ_ty_args, rest_args)
1307
1308 | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
1309 , to_tc == dataConTyCon dc
1310 -- These two tests can fail; we might see
1311 -- (C x y) `cast` (g :: T a ~ S [a]),
1312 -- where S is a type function. In fact, exprIsConApp
1313 -- will probably not be called in such circumstances,
1314 -- but there't nothing wrong with it
1315
1316 = -- Here we do the KPush reduction rule as described in "Down with kinds"
1317 -- The transformation applies iff we have
1318 -- (C e1 ... en) `cast` co
1319 -- where co :: (T t1 .. tn) ~ to_ty
1320 -- The left-hand one must be a T, because exprIsConApp returned True
1321 -- but the right-hand one might not be. (Though it usually will.)
1322 let
1323 tc_arity = tyConArity to_tc
1324 dc_univ_tyvars = dataConUnivTyVars dc
1325 dc_ex_tyvars = dataConExTyVars dc
1326 arg_tys = dataConRepArgTys dc
1327
1328 non_univ_args = dropList dc_univ_tyvars dc_args
1329 (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args
1330
1331 -- Make the "Psi" from the paper
1332 omegas = decomposeCo tc_arity co
1333 (psi_subst, to_ex_arg_tys)
1334 = liftCoSubstWithEx Representational
1335 dc_univ_tyvars
1336 omegas
1337 dc_ex_tyvars
1338 (map exprToType ex_args)
1339
1340 -- Cast the value arguments (which include dictionaries)
1341 new_val_args = zipWith cast_arg arg_tys val_args
1342 cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)
1343
1344 to_ex_args = map Type to_ex_arg_tys
1345
1346 dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars,
1347 ppr arg_tys, ppr dc_args,
1348 ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ]
1349 in
1350 ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )
1351 ASSERT2( equalLength val_args arg_tys, dump_doc )
1352 Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)
1353
1354 | otherwise
1355 = Nothing
1356
1357 where
1358 Pair from_ty to_ty = coercionKind co
1359
1360
1361 {-
1362 Note [Unfolding DFuns]
1363 ~~~~~~~~~~~~~~~~~~~~~~
1364 DFuns look like
1365
1366 df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
1367 df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
1368 ($c2 a b d_a d_b)
1369
1370 So to split it up we just need to apply the ops $c1, $c2 etc
1371 to the very same args as the dfun. It takes a little more work
1372 to compute the type arguments to the dictionary constructor.
1373
1374 Note [DFun arity check]
1375 ~~~~~~~~~~~~~~~~~~~~~~~
1376 Here we check that the total number of supplied arguments (inclding
1377 type args) matches what the dfun is expecting. This may be *less*
1378 than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
1379 -}
1380
1381 exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
1382 -- Same deal as exprIsConApp_maybe, but much simpler
1383 -- Nevertheless we do need to look through unfoldings for
1384 -- Integer literals, which are vigorously hoisted to top level
1385 -- and not subsequently inlined
1386 exprIsLiteral_maybe env@(_, id_unf) e
1387 = case e of
1388 Lit l -> Just l
1389 Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
1390 Var v | Just rhs <- expandUnfolding_maybe (id_unf v)
1391 -> exprIsLiteral_maybe env rhs
1392 _ -> Nothing
1393
1394 {-
1395 Note [exprIsLambda_maybe]
1396 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1397 exprIsLambda_maybe will, given an expression `e`, try to turn it into the form
1398 `Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through
1399 casts (using the Push rule), and it unfolds function calls if the unfolding
1400 has a greater arity than arguments are present.
1401
1402 Currently, it is used in Rules.match, and is required to make
1403 "map coerce = coerce" match.
1404 -}
1405
1406 exprIsLambda_maybe :: InScopeEnv -> CoreExpr
1407 -> Maybe (Var, CoreExpr,[Tickish Id])
1408 -- See Note [exprIsLambda_maybe]
1409
1410 -- The simple case: It is a lambda already
1411 exprIsLambda_maybe _ (Lam x e)
1412 = Just (x, e, [])
1413
1414 -- Still straightforward: Ticks that we can float out of the way
1415 exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
1416 | tickishFloatable t
1417 , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
1418 = Just (x, e, t:ts)
1419
1420 -- Also possible: A casted lambda. Push the coercion inside
1421 exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
1422 | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
1423 -- Only do value lambdas.
1424 -- this implies that x is not in scope in gamma (makes this code simpler)
1425 , not (isTyVar x) && not (isCoVar x)
1426 , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
1427 , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
1428 , let res = Just (x',e',ts)
1429 = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
1430 res
1431
1432 -- Another attempt: See if we find a partial unfolding
1433 exprIsLambda_maybe (in_scope_set, id_unf) e
1434 | (Var f, as, ts) <- collectArgsTicks tickishFloatable e
1435 , idArity f > length (filter isValArg as)
1436 -- Make sure there is hope to get a lambda
1437 , Just rhs <- expandUnfolding_maybe (id_unf f)
1438 -- Optimize, for beta-reduction
1439 , let e' = simpleOptExprWith (mkEmptySubst in_scope_set) (rhs `mkApps` as)
1440 -- Recurse, because of possible casts
1441 , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
1442 , let res = Just (x', e'', ts++ts')
1443 = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
1444 res
1445
1446 exprIsLambda_maybe _ _e
1447 = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
1448 Nothing
1449
1450
1451 pushCoercionIntoLambda
1452 :: InScopeSet -> Var -> CoreExpr -> Coercion -> Maybe (Var, CoreExpr)
1453 pushCoercionIntoLambda in_scope x e co
1454 -- This implements the Push rule from the paper on coercions
1455 -- Compare with simplCast in Simplify
1456 | ASSERT(not (isTyVar x) && not (isCoVar x)) True
1457 , Pair s1s2 t1t2 <- coercionKind co
1458 , Just (_s1,_s2) <- splitFunTy_maybe s1s2
1459 , Just (t1,_t2) <- splitFunTy_maybe t1t2
1460 = let [co1, co2] = decomposeCo 2 co
1461 -- Should we optimize the coercions here?
1462 -- Otherwise they might not match too well
1463 x' = x `setIdType` t1
1464 in_scope' = in_scope `extendInScopeSet` x'
1465 subst = extendIdSubst (mkEmptySubst in_scope')
1466 x
1467 (mkCast (Var x') co1)
1468 in Just (x', subst_expr (text "pushCoercionIntoLambda") subst e `mkCast` co2)
1469 | otherwise
1470 = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))
1471 Nothing