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