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