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