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