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