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