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