Update Trac ticket URLs to point to GitLab
[ghc.git] / compiler / coreSyn / CoreOpt.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 -}
5
6 {-# LANGUAGE CPP #-}
7 module CoreOpt (
8 -- ** Simple expression optimiser
9 simpleOptPgm, simpleOptExpr, simpleOptExprWith,
10
11 -- ** Join points
12 joinPointBinding_maybe, joinPointBindings_maybe,
13
14 -- ** Predicates on expressions
15 exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,
16
17 -- ** Coercions and casts
18 pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo
19 ) where
20
21 #include "HsVersions.h"
22
23 import GhcPrelude
24
25 import CoreArity( etaExpandToJoinPoint )
26
27 import CoreSyn
28 import CoreSubst
29 import CoreUtils
30 import CoreFVs
31 import MkCore ( FloatBind(..) )
32 import PprCore ( pprCoreBindings, pprRules )
33 import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
34 import Literal ( Literal(LitString) )
35 import Id
36 import Var ( isNonCoVarId )
37 import VarSet
38 import VarEnv
39 import DataCon
40 import Demand( etaExpandStrictSig )
41 import OptCoercion ( optCoercion )
42 import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
43 , isInScope, substTyVarBndr, cloneTyVarBndr )
44 import Coercion hiding ( substCo, substCoVarBndr )
45 import TyCon ( tyConArity )
46 import TysWiredIn
47 import PrelNames
48 import BasicTypes
49 import Module ( Module )
50 import ErrUtils
51 import DynFlags
52 import Outputable
53 import Pair
54 import Util
55 import Maybes ( orElse )
56 import FastString
57 import Data.List
58 import qualified Data.ByteString as BS
59
60 {-
61 ************************************************************************
62 * *
63 The Simple Optimiser
64 * *
65 ************************************************************************
66
67 Note [The simple optimiser]
68 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
69 The simple optimiser is a lightweight, pure (non-monadic) function
70 that rapidly does a lot of simple optimisations, including
71
72 - inlining things that occur just once,
73 or whose RHS turns out to be trivial
74 - beta reduction
75 - case of known constructor
76 - dead code elimination
77
78 It does NOT do any call-site inlining; it only inlines a function if
79 it can do so unconditionally, dropping the binding. It thereby
80 guarantees to leave no un-reduced beta-redexes.
81
82 It is careful to follow the guidance of "Secrets of the GHC inliner",
83 and in particular the pre-inline-unconditionally and
84 post-inline-unconditionally story, to do effective beta reduction on
85 functions called precisely once, without repeatedly optimising the same
86 expression. In fact, the simple optimiser is a good example of this
87 little dance in action; the full Simplifier is a lot more complicated.
88
89 -}
90
91 simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr
92 -- See Note [The simple optimiser]
93 -- Do simple optimisation on an expression
94 -- The optimisation is very straightforward: just
95 -- inline non-recursive bindings that are used only once,
96 -- or where the RHS is trivial
97 --
98 -- We also inline bindings that bind a Eq# box: see
99 -- See Note [Getting the map/coerce RULE to work].
100 --
101 -- Also we convert functions to join points where possible (as
102 -- the occurrence analyser does most of the work anyway).
103 --
104 -- The result is NOT guaranteed occurrence-analysed, because
105 -- in (let x = y in ....) we substitute for x; so y's occ-info
106 -- may change radically
107
108 simpleOptExpr dflags expr
109 = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
110 simpleOptExprWith dflags init_subst expr
111 where
112 init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
113 -- It's potentially important to make a proper in-scope set
114 -- Consider let x = ..y.. in \y. ...x...
115 -- Then we should remember to clone y before substituting
116 -- for x. It's very unlikely to occur, because we probably
117 -- won't *be* substituting for x if it occurs inside a
118 -- lambda.
119 --
120 -- It's a bit painful to call exprFreeVars, because it makes
121 -- three passes instead of two (occ-anal, and go)
122
123 simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr
124 -- See Note [The simple optimiser]
125 simpleOptExprWith dflags subst expr
126 = simple_opt_expr init_env (occurAnalyseExpr expr)
127 where
128 init_env = SOE { soe_dflags = dflags
129 , soe_inl = emptyVarEnv
130 , soe_subst = subst }
131
132 ----------------------
133 simpleOptPgm :: DynFlags -> Module
134 -> CoreProgram -> [CoreRule]
135 -> IO (CoreProgram, [CoreRule])
136 -- See Note [The simple optimiser]
137 simpleOptPgm dflags this_mod binds rules
138 = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
139 (pprCoreBindings occ_anald_binds $$ pprRules rules );
140
141 ; return (reverse binds', rules') }
142 where
143 occ_anald_binds = occurAnalysePgm this_mod
144 (\_ -> True) {- All unfoldings active -}
145 (\_ -> False) {- No rules active -}
146 rules binds
147
148 (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds
149 final_subst = soe_subst final_env
150
151 rules' = substRulesForImportedIds final_subst rules
152 -- We never unconditionally inline into rules,
153 -- hence paying just a substitution
154
155 do_one (env, binds') bind
156 = case simple_opt_bind env bind of
157 (env', Nothing) -> (env', binds')
158 (env', Just bind') -> (env', bind':binds')
159
160 -- In these functions the substitution maps InVar -> OutExpr
161
162 ----------------------
163 type SimpleClo = (SimpleOptEnv, InExpr)
164
165 data SimpleOptEnv
166 = SOE { soe_dflags :: DynFlags
167 , soe_inl :: IdEnv SimpleClo
168 -- Deals with preInlineUnconditionally; things
169 -- that occur exactly once and are inlined
170 -- without having first been simplified
171
172 , soe_subst :: Subst
173 -- Deals with cloning; includes the InScopeSet
174 }
175
176 instance Outputable SimpleOptEnv where
177 ppr (SOE { soe_inl = inl, soe_subst = subst })
178 = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl
179 , text "soe_subst =" <+> ppr subst ]
180 <+> text "}"
181
182 emptyEnv :: DynFlags -> SimpleOptEnv
183 emptyEnv dflags
184 = SOE { soe_dflags = dflags
185 , soe_inl = emptyVarEnv
186 , soe_subst = emptySubst }
187
188 soeZapSubst :: SimpleOptEnv -> SimpleOptEnv
189 soeZapSubst env@(SOE { soe_subst = subst })
190 = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst }
191
192 soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv
193 -- Take in-scope set from env1, and the rest from env2
194 soeSetInScope (SOE { soe_subst = subst1 })
195 env2@(SOE { soe_subst = subst2 })
196 = env2 { soe_subst = setInScope subst2 (substInScope subst1) }
197
198 ---------------
199 simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr
200 simple_opt_clo env (e_env, e)
201 = simple_opt_expr (soeSetInScope env e_env) e
202
203 simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr
204 simple_opt_expr env expr
205 = go expr
206 where
207 subst = soe_subst env
208 in_scope = substInScope subst
209 in_scope_env = (in_scope, simpleUnfoldingFun)
210
211 go (Var v)
212 | Just clo <- lookupVarEnv (soe_inl env) v
213 = simple_opt_clo env clo
214 | otherwise
215 = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v
216
217 go (App e1 e2) = simple_app env e1 [(env,e2)]
218 go (Type ty) = Type (substTy subst ty)
219 go (Coercion co) = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co)
220 go (Lit lit) = Lit lit
221 go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)
222 go (Cast e co) | isReflCo co' = go e
223 | otherwise = Cast (go e) co'
224 where
225 co' = optCoercion (soe_dflags env) (getTCvSubst subst) co
226
227 go (Let bind body) = case simple_opt_bind env bind of
228 (env', Nothing) -> simple_opt_expr env' body
229 (env', Just bind) -> Let bind (simple_opt_expr env' body)
230
231 go lam@(Lam {}) = go_lam env [] lam
232 go (Case e b ty as)
233 -- See Note [Getting the map/coerce RULE to work]
234 | isDeadBinder b
235 , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
236 -- We don't need to be concerned about floats when looking for coerce.
237 , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
238 = case altcon of
239 DEFAULT -> go rhs
240 _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs
241 where
242 (env', mb_prs) = mapAccumL simple_out_bind env $
243 zipEqual "simpleOptExpr" bs es
244
245 -- Note [Getting the map/coerce RULE to work]
246 | isDeadBinder b
247 , [(DEFAULT, _, rhs)] <- as
248 , isCoVarType (varType b)
249 , (Var fun, _args) <- collectArgs e
250 , fun `hasKey` coercibleSCSelIdKey
251 -- without this last check, we get #11230
252 = go rhs
253
254 | otherwise
255 = Case e' b' (substTy subst ty)
256 (map (go_alt env') as)
257 where
258 e' = go e
259 (env', b') = subst_opt_bndr env b
260
261 ----------------------
262 go_alt env (con, bndrs, rhs)
263 = (con, bndrs', simple_opt_expr env' rhs)
264 where
265 (env', bndrs') = subst_opt_bndrs env bndrs
266
267 ----------------------
268 -- go_lam tries eta reduction
269 go_lam env bs' (Lam b e)
270 = go_lam env' (b':bs') e
271 where
272 (env', b') = subst_opt_bndr env b
273 go_lam env bs' e
274 | Just etad_e <- tryEtaReduce bs e' = etad_e
275 | otherwise = mkLams bs e'
276 where
277 bs = reverse bs'
278 e' = simple_opt_expr env e
279
280 ----------------------
281 -- simple_app collects arguments for beta reduction
282 simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr
283
284 simple_app env (Var v) as
285 | Just (env', e) <- lookupVarEnv (soe_inl env) v
286 = simple_app (soeSetInScope env env') e as
287
288 | let unf = idUnfolding v
289 , isCompulsoryUnfolding (idUnfolding v)
290 , isAlwaysActive (idInlineActivation v)
291 -- See Note [Unfold compulsory unfoldings in LHSs]
292 = simple_app (soeZapSubst env) (unfoldingTemplate unf) as
293
294 | otherwise
295 , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v
296 = finish_app env out_fn as
297
298 simple_app env (App e1 e2) as
299 = simple_app env e1 ((env, e2) : as)
300
301 simple_app env (Lam b e) (a:as)
302 = wrapLet mb_pr (simple_app env' e as)
303 where
304 (env', mb_pr) = simple_bind_pair env b Nothing a
305
306 simple_app env (Tick t e) as
307 -- Okay to do "(Tick t e) x ==> Tick t (e x)"?
308 | t `tickishScopesLike` SoftScope
309 = mkTick t $ simple_app env e as
310
311 -- (let x = e in b) a1 .. an => let x = e in (b a1 .. an)
312 -- The let might appear there as a result of inlining
313 -- e.g. let f = let x = e in b
314 -- in f a1 a2
315 -- (#13208)
316 simple_app env (Let bind body) as
317 = case simple_opt_bind env bind of
318 (env', Nothing) -> simple_app env' body as
319 (env', Just bind) -> Let bind (simple_app env' body as)
320
321 simple_app env e as
322 = finish_app env (simple_opt_expr env e) as
323
324 finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr
325 finish_app _ fun []
326 = fun
327 finish_app env fun (arg:args)
328 = finish_app env (App fun (simple_opt_clo env arg)) args
329
330 ----------------------
331 simple_opt_bind :: SimpleOptEnv -> InBind
332 -> (SimpleOptEnv, Maybe OutBind)
333 simple_opt_bind env (NonRec b r)
334 = (env', case mb_pr of
335 Nothing -> Nothing
336 Just (b,r) -> Just (NonRec b r))
337 where
338 (b', r') = joinPointBinding_maybe b r `orElse` (b, r)
339 (env', mb_pr) = simple_bind_pair env b' Nothing (env,r')
340
341 simple_opt_bind env (Rec prs)
342 = (env'', res_bind)
343 where
344 res_bind = Just (Rec (reverse rev_prs'))
345 prs' = joinPointBindings_maybe prs `orElse` prs
346 (env', bndrs') = subst_opt_bndrs env (map fst prs')
347 (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs')
348 do_pr (env, prs) ((b,r), b')
349 = (env', case mb_pr of
350 Just pr -> pr : prs
351 Nothing -> prs)
352 where
353 (env', mb_pr) = simple_bind_pair env b (Just b') (env,r)
354
355 ----------------------
356 simple_bind_pair :: SimpleOptEnv
357 -> InVar -> Maybe OutVar
358 -> SimpleClo
359 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
360 -- (simple_bind_pair subst in_var out_rhs)
361 -- either extends subst with (in_var -> out_rhs)
362 -- or returns Nothing
363 simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
364 in_bndr mb_out_bndr clo@(rhs_env, in_rhs)
365 | Type ty <- in_rhs -- let a::* = TYPE ty in <body>
366 , let out_ty = substTy (soe_subst rhs_env) ty
367 = ASSERT( isTyVar in_bndr )
368 (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
369
370 | Coercion co <- in_rhs
371 , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co
372 = ASSERT( isCoVar in_bndr )
373 (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
374
375 | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
376 -- The previous two guards got rid of tyvars and coercions
377 -- See Note [CoreSyn type and coercion invariant] in CoreSyn
378 pre_inline_unconditionally
379 = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing)
380
381 | otherwise
382 = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
383 occ active stable_unf
384 where
385 stable_unf = isStableUnfolding (idUnfolding in_bndr)
386 active = isAlwaysActive (idInlineActivation in_bndr)
387 occ = idOccInfo in_bndr
388
389 out_rhs | Just join_arity <- isJoinId_maybe in_bndr
390 = simple_join_rhs join_arity
391 | otherwise
392 = simple_opt_clo env clo
393
394 simple_join_rhs join_arity -- See Note [Preserve join-binding arity]
395 = mkLams join_bndrs' (simple_opt_expr env_body join_body)
396 where
397 env0 = soeSetInScope env rhs_env
398 (join_bndrs, join_body) = collectNBinders join_arity in_rhs
399 (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs
400
401 pre_inline_unconditionally :: Bool
402 pre_inline_unconditionally
403 | isExportedId in_bndr = False
404 | stable_unf = False
405 | not active = False -- Note [Inline prag in simplOpt]
406 | not (safe_to_inline occ) = False
407 | otherwise = True
408
409 -- Unconditionally safe to inline
410 safe_to_inline :: OccInfo -> Bool
411 safe_to_inline (IAmALoopBreaker {}) = False
412 safe_to_inline IAmDead = True
413 safe_to_inline occ@(OneOcc {}) = not (occ_in_lam occ)
414 && occ_one_br occ
415 safe_to_inline (ManyOccs {}) = False
416
417 -------------------
418 simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr)
419 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
420 simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)
421 | Type out_ty <- out_rhs
422 = ASSERT( isTyVar in_bndr )
423 (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
424
425 | Coercion out_co <- out_rhs
426 = ASSERT( isCoVar in_bndr )
427 (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)
428
429 | otherwise
430 = simple_out_bind_pair env in_bndr Nothing out_rhs
431 (idOccInfo in_bndr) True False
432
433 -------------------
434 simple_out_bind_pair :: SimpleOptEnv
435 -> InId -> Maybe OutId -> OutExpr
436 -> OccInfo -> Bool -> Bool
437 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))
438 simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
439 occ_info active stable_unf
440 | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr )
441 -- Type and coercion bindings are caught earlier
442 -- See Note [CoreSyn type and coercion invariant]
443 post_inline_unconditionally
444 = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
445 , Nothing)
446
447 | otherwise
448 = ( env', Just (out_bndr, out_rhs) )
449 where
450 (env', bndr1) = case mb_out_bndr of
451 Just out_bndr -> (env, out_bndr)
452 Nothing -> subst_opt_bndr env in_bndr
453 out_bndr = add_info env' in_bndr bndr1
454
455 post_inline_unconditionally :: Bool
456 post_inline_unconditionally
457 | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs]
458 | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally]
459 | not active = False -- in SimplUtils
460 | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline
461 -- because it might be referred to "earlier"
462 | exprIsTrivial out_rhs = True
463 | coercible_hack = True
464 | otherwise = False
465
466 is_loop_breaker = isWeakLoopBreaker occ_info
467
468 -- See Note [Getting the map/coerce RULE to work]
469 coercible_hack | (Var fun, args) <- collectArgs out_rhs
470 , Just dc <- isDataConWorkId_maybe fun
471 , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey
472 = all exprIsTrivial args
473 | otherwise
474 = False
475
476 {- Note [Exported Ids and trivial RHSs]
477 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
478 We obviously do not want to unconditionally inline an Id that is exported.
479 In SimplUtils, Note [Top level and postInlineUnconditionally], we
480 explain why we don't inline /any/ top-level things unconditionally, even
481 trivial ones. But we do here! Why? In the simple optimiser
482
483 * We do no rule rewrites
484 * We do no call-site inlining
485
486 Those differences obviate the reasons for not inlining a trivial rhs,
487 and increase the benefit for doing so. So we unconditionally inline trivial
488 rhss here.
489
490 Note [Preserve join-binding arity]
491 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
492 Be careful /not/ to eta-reduce the RHS of a join point, lest we lose
493 the join-point arity invariant. #15108 was caused by simplifying
494 the RHS with simple_opt_expr, which does eta-reduction. Solution:
495 simplify the RHS of a join point by simplifying under the lambdas
496 (which of course should be there).
497 -}
498
499 ----------------------
500 subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])
501 subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs
502
503 subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)
504 subst_opt_bndr env bndr
505 | isTyVar bndr = (env { soe_subst = subst_tv }, tv')
506 | isCoVar bndr = (env { soe_subst = subst_cv }, cv')
507 | otherwise = subst_opt_id_bndr env bndr
508 where
509 subst = soe_subst env
510 (subst_tv, tv') = substTyVarBndr subst bndr
511 (subst_cv, cv') = substCoVarBndr subst bndr
512
513 subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)
514 -- Nuke all fragile IdInfo, unfolding, and RULES;
515 -- it gets added back later by add_info
516 -- Rather like SimplEnv.substIdBndr
517 --
518 -- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
519 -- carefully does not do) because simplOptExpr invalidates it
520
521 subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id
522 = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id)
523 where
524 Subst in_scope id_subst tv_subst cv_subst = subst
525
526 id1 = uniqAway in_scope old_id
527 id2 = setIdType id1 (substTy subst (idType old_id))
528 new_id = zapFragileIdInfo id2
529 -- Zaps rules, unfolding, and fragile OccInfo
530 -- The unfolding and rules will get added back later, by add_info
531
532 new_in_scope = in_scope `extendInScopeSet` new_id
533
534 no_change = new_id == old_id
535
536 -- Extend the substitution if the unique has changed,
537 -- See the notes with substTyVarBndr for the delSubstEnv
538 new_id_subst
539 | no_change = delVarEnv id_subst old_id
540 | otherwise = extendVarEnv id_subst old_id (Var new_id)
541
542 new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst
543 new_inl = delVarEnv inl old_id
544
545 ----------------------
546 add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar
547 add_info env old_bndr new_bndr
548 | isTyVar old_bndr = new_bndr
549 | otherwise = maybeModifyIdInfo mb_new_info new_bndr
550 where
551 subst = soe_subst env
552 mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
553
554 simpleUnfoldingFun :: IdUnfoldingFun
555 simpleUnfoldingFun id
556 | isAlwaysActive (idInlineActivation id) = idUnfolding id
557 | otherwise = noUnfolding
558
559 wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
560 wrapLet Nothing body = body
561 wrapLet (Just (b,r)) body = Let (NonRec b r) body
562
563 {-
564 Note [Inline prag in simplOpt]
565 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
566 If there's an INLINE/NOINLINE pragma that restricts the phase in
567 which the binder can be inlined, we don't inline here; after all,
568 we don't know what phase we're in. Here's an example
569
570 foo :: Int -> Int -> Int
571 {-# INLINE foo #-}
572 foo m n = inner m
573 where
574 {-# INLINE [1] inner #-}
575 inner m = m+n
576
577 bar :: Int -> Int
578 bar n = foo n 1
579
580 When inlining 'foo' in 'bar' we want the let-binding for 'inner'
581 to remain visible until Phase 1
582
583 Note [Unfold compulsory unfoldings in LHSs]
584 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
585 When the user writes `RULES map coerce = coerce` as a rule, the rule
586 will only ever match if simpleOptExpr replaces coerce by its unfolding
587 on the LHS, because that is the core that the rule matching engine
588 will find. So do that for everything that has a compulsory
589 unfolding. Also see Note [Desugaring coerce as cast] in Desugar.
590
591 However, we don't want to inline 'seq', which happens to also have a
592 compulsory unfolding, so we only do this unfolding only for things
593 that are always-active. See Note [User-defined RULES for seq] in MkId.
594
595 Note [Getting the map/coerce RULE to work]
596 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
597 We wish to allow the "map/coerce" RULE to fire:
598
599 {-# RULES "map/coerce" map coerce = coerce #-}
600
601 The naive core produced for this is
602
603 forall a b (dict :: Coercible * a b).
604 map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'
605
606 where dict' :: Coercible [a] [b]
607 dict' = ...
608
609 This matches literal uses of `map coerce` in code, but that's not what we
610 want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)
611 too. Some of this is addressed by compulsorily unfolding coerce on the LHS,
612 yielding
613
614 forall a b (dict :: Coercible * a b).
615 map @a @b (\(x :: a) -> case dict of
616 MkCoercible (co :: a ~R# b) -> x |> co) = ...
617
618 Getting better. But this isn't exactly what gets produced. This is because
619 Coercible essentially has ~R# as a superclass, and superclasses get eagerly
620 extracted during solving. So we get this:
621
622 forall a b (dict :: Coercible * a b).
623 case Coercible_SCSel @* @a @b dict of
624 _ [Dead] -> map @a @b (\(x :: a) -> case dict of
625 MkCoercible (co :: a ~R# b) -> x |> co) = ...
626
627 Unfortunately, this still abstracts over a Coercible dictionary. We really
628 want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,
629 which transforms the above to (see also Note [Desugaring coerce as cast] in
630 Desugar)
631
632 forall a b (co :: a ~R# b).
633 let dict = MkCoercible @* @a @b co in
634 case Coercible_SCSel @* @a @b dict of
635 _ [Dead] -> map @a @b (\(x :: a) -> case dict of
636 MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...
637
638 Now, we need simpleOptExpr to fix this up. It does so by taking three
639 separate actions:
640 1. Inline certain non-recursive bindings. The choice whether to inline
641 is made in simple_bind_pair. Note the rather specific check for
642 MkCoercible in there.
643
644 2. Stripping case expressions like the Coercible_SCSel one.
645 See the `Case` case of simple_opt_expr's `go` function.
646
647 3. Look for case expressions that unpack something that was
648 just packed and inline them. This is also done in simple_opt_expr's
649 `go` function.
650
651 This is all a fair amount of special-purpose hackery, but it's for
652 a good cause. And it won't hurt other RULES and such that it comes across.
653
654
655 ************************************************************************
656 * *
657 Join points
658 * *
659 ************************************************************************
660 -}
661
662 -- | Returns Just (bndr,rhs) if the binding is a join point:
663 -- If it's a JoinId, just return it
664 -- If it's not yet a JoinId but is always tail-called,
665 -- make it into a JoinId and return it.
666 -- In the latter case, eta-expand the RHS if necessary, to make the
667 -- lambdas explicit, as is required for join points
668 --
669 -- Precondition: the InBndr has been occurrence-analysed,
670 -- so its OccInfo is valid
671 joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
672 joinPointBinding_maybe bndr rhs
673 | not (isId bndr)
674 = Nothing
675
676 | isJoinId bndr
677 = Just (bndr, rhs)
678
679 | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
680 , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
681 , let str_sig = idStrictness bndr
682 str_arity = count isId bndrs -- Strictness demands are for Ids only
683 join_bndr = bndr `asJoinId` join_arity
684 `setIdStrictness` etaExpandStrictSig str_arity str_sig
685 = Just (join_bndr, mkLams bndrs body)
686
687 | otherwise
688 = Nothing
689
690 joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
691 joinPointBindings_maybe bndrs
692 = mapM (uncurry joinPointBinding_maybe) bndrs
693
694
695 {- Note [Strictness and join points]
696 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
697 Suppose we have
698
699 let f = \x. if x>200 then e1 else e1
700
701 and we know that f is strict in x. Then if we subsequently
702 discover that f is an arity-2 join point, we'll eta-expand it to
703
704 let f = \x y. if x>200 then e1 else e1
705
706 and now it's only strict if applied to two arguments. So we should
707 adjust the strictness info.
708
709 A more common case is when
710
711 f = \x. error ".."
712
713 and again its arity increses (#15517)
714 -}
715
716 {- *********************************************************************
717 * *
718 exprIsConApp_maybe
719 * *
720 ************************************************************************
721
722 Note [exprIsConApp_maybe]
723 ~~~~~~~~~~~~~~~~~~~~~~~~~
724 exprIsConApp_maybe is a very important function. There are two principal
725 uses:
726 * case e of { .... }
727 * cls_op e, where cls_op is a class operation
728
729 In both cases you want to know if e is of form (C e1..en) where C is
730 a data constructor.
731
732 However e might not *look* as if
733
734
735 Note [exprIsConApp_maybe on literal strings]
736 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
737 See #9400 and #13317.
738
739 Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core
740 they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or
741 unpackCStringUtf8# when the literal contains multi-byte UTF8 characters.
742
743 For optimizations we want to be able to treat it as a list, so they can be
744 decomposed when used in a case-statement. exprIsConApp_maybe detects those
745 calls to unpackCString# and returns:
746
747 Just (':', [Char], ['a', unpackCString# "bc"]).
748
749 We need to be careful about UTF8 strings here. ""# contains a ByteString, so
750 we must parse it back into a FastString to split off the first character.
751 That way we can treat unpackCString# and unpackCStringUtf8# in the same way.
752
753 We must also be caeful about
754 lvl = "foo"#
755 ...(unpackCString# lvl)...
756 to ensure that we see through the let-binding for 'lvl'. Hence the
757 (exprIsLiteral_maybe .. arg) in the guard before the call to
758 dealWithStringLiteral.
759
760 Note [Push coercions in exprIsConApp_maybe]
761 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
762 In #13025 I found a case where we had
763 op (df @t1 @t2) -- op is a ClassOp
764 where
765 df = (/\a b. K e1 e2) |> g
766
767 To get this to come out we need to simplify on the fly
768 ((/\a b. K e1 e2) |> g) @t1 @t2
769
770 Hence the use of pushCoArgs.
771
772 Note [exprIsConApp_maybe on data constructors with wrappers]
773 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
774 Problem:
775 - some data constructors have wrappers
776 - these wrappers inline late (see MkId Note [Activation for data constructor wrappers])
777 - but we still want case-of-known-constructor to fire early.
778
779 Example:
780 data T = MkT !Int
781 $WMkT n = case n of n' -> MkT n' -- Wrapper for MkT
782 foo x = case $WMkT e of MkT y -> blah
783
784 Here we want the case-of-known-constructor transformation to fire, giving
785 foo x = case e of x' -> let y = x' in blah
786
787 Here's how exprIsConApp_maybe achieves this:
788
789 0. Start with scrutinee = $WMkT e
790
791 1. Inline $WMkT on-the-fly. That's why data-constructor wrappers are marked
792 as expandable. (See CoreUtils.isExpandableApp.) Now we have
793 scrutinee = (\n. case n of n' -> MkT n') e
794
795 2. Beta-reduce the application, generating a floated 'let'.
796 See Note [beta-reduction in exprIsConApp_maybe] below. Now we have
797 scrutinee = case n of n' -> MkT n'
798 with floats {Let n = e}
799
800 3. Float the "case x of x' ->" binding out. Now we have
801 scrutinee = MkT n'
802 with floats {Let n = e; case n of n' ->}
803
804 And now we have a known-constructor MkT that we can return.
805
806 Notice that both (2) and (3) require exprIsConApp_maybe to gather and return
807 a bunch of floats, both let and case bindings.
808
809 Note [beta-reduction in exprIsConApp_maybe]
810 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
811 The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is
812 typically a function. For instance, take the wrapper for MkT in Note
813 [exprIsConApp_maybe on data constructors with wrappers]:
814
815 $WMkT n = case n of { n' -> T n' }
816
817 If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT,
818 it will see
819
820 (\n -> case n of { n' -> T n' }) arg
821
822 In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction.
823
824 We don't want to blindly substitute `arg` in the body of the function, because
825 it duplicates work. We can (and, in fact, used to) substitute `arg` in the body,
826 but only when `arg` is a variable (or something equally work-free).
827
828 But, because of Note [exprIsConApp_maybe on data constructors with wrappers],
829 'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce
830 _always_:
831
832 (\x -> body) arg
833
834 Is transformed into
835
836 let x = arg in body
837
838 Which, effectively, means emitting a float `let x = arg` and recursively
839 analysing the body.
840
841 For newtypes, this strategy requires that their wrappers have compulsory unfoldings.
842 Suppose we have
843 newtype T a b where
844 MkT :: a -> T b a -- Note args swapped
845
846 This defines a worker function MkT, a wrapper function $WMkT, and an axT:
847 $WMkT :: forall a b. a -> T b a
848 $WMkT = /\b a. \(x:a). MkT a b x -- A real binding
849
850 MkT :: forall a b. a -> T a b
851 MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding
852
853 axiom axT :: a ~R# T a b
854
855 Now we are optimising
856 case $WMkT (I# 3) |> sym axT of I# y -> ...
857 we clearly want to simplify this. If $WMkT did not have a compulsory
858 unfolding, we would end up with
859 let a = I#3 in case a of I# y -> ...
860 because in general, we do this on-the-fly beta-reduction
861 (\x. e) blah --> let x = blah in e
862 and then float the the let. (Substitution would risk duplicating 'blah'.)
863
864 But if the case-of-known-constructor doesn't actually fire (i.e.
865 exprIsConApp_maybe does not return Just) then nothing happens, and nothing
866 will happen the next time either.
867
868 See test T16254, which checks the behavior of newtypes.
869 -}
870
871 data ConCont = CC [CoreExpr] Coercion
872 -- Substitution already applied
873
874 -- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument
875 -- expression is a *saturated* constructor application of the form @let b1 in
876 -- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the
877 -- *universally-quantified* type args of 'dc'. Floats can also be (and most
878 -- likely are) single-alternative case expressions. Why does
879 -- 'exprIsConApp_maybe' return floats? We may have to look through lets and
880 -- cases to detect that we are in the presence of a data constructor wrapper. In
881 -- this case, we need to return the lets and cases that we traversed. See Note
882 -- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers
883 -- are unfolded late, but we really want to trigger case-of-known-constructor as
884 -- early as possible. See also Note [Activation for data constructor wrappers]
885 -- in MkId.
886 --
887 -- We also return the incoming InScopeSet, augmented with
888 -- the binders from any [FloatBind] that we return
889 exprIsConApp_maybe :: InScopeEnv -> CoreExpr
890 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
891 exprIsConApp_maybe (in_scope, id_unf) expr
892 = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))
893 where
894 go :: Either InScopeSet Subst
895 -- Left in-scope means "empty substitution"
896 -- Right subst means "apply this substitution to the CoreExpr"
897 -- NB: in the call (go subst floats expr cont)
898 -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont'
899 -> [FloatBind] -> CoreExpr -> ConCont
900 -- Notice that the floats here are in reverse order
901 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
902 go subst floats (Tick t expr) cont
903 | not (tickishIsCode t) = go subst floats expr cont
904
905 go subst floats (Cast expr co1) (CC args co2)
906 | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args
907 -- See Note [Push coercions in exprIsConApp_maybe]
908 = case m_co1' of
909 MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2))
910 MRefl -> go subst floats expr (CC args' co2)
911
912 go subst floats (App fun arg) (CC args co)
913 = go subst floats fun (CC (subst_expr subst arg : args) co)
914
915 go subst floats (Lam bndr body) (CC (arg:args) co)
916 | exprIsTrivial arg -- Don't duplicate stuff!
917 = go (extend subst bndr arg) floats body (CC args co)
918 | otherwise
919 = let (subst', bndr') = subst_bndr subst bndr
920 float = FloatLet (NonRec bndr' arg)
921 in go subst' (float:floats) body (CC args co)
922
923 go subst floats (Let (NonRec bndr rhs) expr) cont
924 = let rhs' = subst_expr subst rhs
925 (subst', bndr') = subst_bndr subst bndr
926 float = FloatLet (NonRec bndr' rhs')
927 in go subst' (float:floats) expr cont
928
929 go subst floats (Case scrut b _ [(con, vars, expr)]) cont
930 = let
931 scrut' = subst_expr subst scrut
932 (subst', b') = subst_bndr subst b
933 (subst'', vars') = subst_bndrs subst' vars
934 float = FloatCase scrut' b' con vars'
935 in
936 go subst'' (float:floats) expr cont
937
938 go (Right sub) floats (Var v) cont
939 = go (Left (substInScope sub))
940 floats
941 (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v)
942 cont
943
944 go (Left in_scope) floats (Var fun) cont@(CC args co)
945
946 | Just con <- isDataConWorkId_maybe fun
947 , count isValArg args == idArity fun
948 = succeedWith in_scope floats $
949 pushCoDataCon con args co
950
951 -- Look through data constructor wrappers: they inline late (See Note
952 -- [Activation for data constructor wrappers]) but we want to do
953 -- case-of-known-constructor optimisation eagerly.
954 | isDataConWrapId fun
955 , let rhs = uf_tmpl (realIdUnfolding fun)
956 = go (Left in_scope) floats rhs cont
957
958 -- Look through dictionary functions; see Note [Unfolding DFuns]
959 | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
960 , bndrs `equalLength` args -- See Note [DFun arity check]
961 , let subst = mkOpenSubst in_scope (bndrs `zip` args)
962 = succeedWith in_scope floats $
963 pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co
964
965 -- Look through unfoldings, but only arity-zero one;
966 -- if arity > 0 we are effectively inlining a function call,
967 -- and that is the business of callSiteInline.
968 -- In practice, without this test, most of the "hits" were
969 -- CPR'd workers getting inlined back into their wrappers,
970 | idArity fun == 0
971 , Just rhs <- expandUnfolding_maybe unfolding
972 , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
973 = go (Left in_scope') floats rhs cont
974
975 -- See Note [exprIsConApp_maybe on literal strings]
976 | (fun `hasKey` unpackCStringIdKey) ||
977 (fun `hasKey` unpackCStringUtf8IdKey)
978 , [arg] <- args
979 , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
980 = succeedWith in_scope floats $
981 dealWithStringLiteral fun str co
982 where
983 unfolding = id_unf fun
984
985 go _ _ _ _ = Nothing
986
987 succeedWith :: InScopeSet -> [FloatBind]
988 -> Maybe (DataCon, [Type], [CoreExpr])
989 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
990 succeedWith in_scope rev_floats x
991 = do { (con, tys, args) <- x
992 ; let floats = reverse rev_floats
993 ; return (in_scope, floats, con, tys, args) }
994
995 ----------------------------
996 -- Operations on the (Either InScopeSet CoreSubst)
997 -- The Left case is wildly dominant
998 subst_co (Left {}) co = co
999 subst_co (Right s) co = CoreSubst.substCo s co
1000
1001 subst_expr (Left {}) e = e
1002 subst_expr (Right s) e = substExpr (text "exprIsConApp2") s e
1003
1004 subst_bndr msubst bndr
1005 = (Right subst', bndr')
1006 where
1007 (subst', bndr') = substBndr subst bndr
1008 subst = case msubst of
1009 Left in_scope -> mkEmptySubst in_scope
1010 Right subst -> subst
1011
1012 subst_bndrs subst bs = mapAccumL subst_bndr subst bs
1013
1014 extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
1015 extend (Right s) v e = Right (extendSubst s v e)
1016
1017
1018 -- See Note [exprIsConApp_maybe on literal strings]
1019 dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
1020 -> Maybe (DataCon, [Type], [CoreExpr])
1021
1022 -- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS
1023 -- turns those into [] automatically, but just in case something else in GHC
1024 -- generates a string literal directly.
1025 dealWithStringLiteral _ str co
1026 | BS.null str
1027 = pushCoDataCon nilDataCon [Type charTy] co
1028
1029 dealWithStringLiteral fun str co
1030 = let strFS = mkFastStringByteString str
1031
1032 char = mkConApp charDataCon [mkCharLit (headFS strFS)]
1033 charTail = bytesFS (tailFS strFS)
1034
1035 -- In singleton strings, just add [] instead of unpackCstring# ""#.
1036 rest = if BS.null charTail
1037 then mkConApp nilDataCon [Type charTy]
1038 else App (Var fun)
1039 (Lit (LitString charTail))
1040
1041 in pushCoDataCon consDataCon [Type charTy, char, rest] co
1042
1043 {-
1044 Note [Unfolding DFuns]
1045 ~~~~~~~~~~~~~~~~~~~~~~
1046 DFuns look like
1047
1048 df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
1049 df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
1050 ($c2 a b d_a d_b)
1051
1052 So to split it up we just need to apply the ops $c1, $c2 etc
1053 to the very same args as the dfun. It takes a little more work
1054 to compute the type arguments to the dictionary constructor.
1055
1056 Note [DFun arity check]
1057 ~~~~~~~~~~~~~~~~~~~~~~~
1058 Here we check that the total number of supplied arguments (inclding
1059 type args) matches what the dfun is expecting. This may be *less*
1060 than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
1061 -}
1062
1063 exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
1064 -- Same deal as exprIsConApp_maybe, but much simpler
1065 -- Nevertheless we do need to look through unfoldings for
1066 -- Integer and string literals, which are vigorously hoisted to top level
1067 -- and not subsequently inlined
1068 exprIsLiteral_maybe env@(_, id_unf) e
1069 = case e of
1070 Lit l -> Just l
1071 Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
1072 Var v | Just rhs <- expandUnfolding_maybe (id_unf v)
1073 -> exprIsLiteral_maybe env rhs
1074 _ -> Nothing
1075
1076 {-
1077 Note [exprIsLambda_maybe]
1078 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1079 exprIsLambda_maybe will, given an expression `e`, try to turn it into the form
1080 `Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through
1081 casts (using the Push rule), and it unfolds function calls if the unfolding
1082 has a greater arity than arguments are present.
1083
1084 Currently, it is used in Rules.match, and is required to make
1085 "map coerce = coerce" match.
1086 -}
1087
1088 exprIsLambda_maybe :: InScopeEnv -> CoreExpr
1089 -> Maybe (Var, CoreExpr,[Tickish Id])
1090 -- See Note [exprIsLambda_maybe]
1091
1092 -- The simple case: It is a lambda already
1093 exprIsLambda_maybe _ (Lam x e)
1094 = Just (x, e, [])
1095
1096 -- Still straightforward: Ticks that we can float out of the way
1097 exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)
1098 | tickishFloatable t
1099 , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e
1100 = Just (x, e, t:ts)
1101
1102 -- Also possible: A casted lambda. Push the coercion inside
1103 exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co)
1104 | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e
1105 -- Only do value lambdas.
1106 -- this implies that x is not in scope in gamma (makes this code simpler)
1107 , not (isTyVar x) && not (isCoVar x)
1108 , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True
1109 , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
1110 , let res = Just (x',e',ts)
1111 = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])
1112 res
1113
1114 -- Another attempt: See if we find a partial unfolding
1115 exprIsLambda_maybe (in_scope_set, id_unf) e
1116 | (Var f, as, ts) <- collectArgsTicks tickishFloatable e
1117 , idArity f > count isValArg as
1118 -- Make sure there is hope to get a lambda
1119 , Just rhs <- expandUnfolding_maybe (id_unf f)
1120 -- Optimize, for beta-reduction
1121 , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as)
1122 -- Recurse, because of possible casts
1123 , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'
1124 , let res = Just (x', e'', ts++ts')
1125 = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])
1126 res
1127
1128 exprIsLambda_maybe _ _e
1129 = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])
1130 Nothing
1131
1132
1133 {- *********************************************************************
1134 * *
1135 The "push rules"
1136 * *
1137 ************************************************************************
1138
1139 Here we implement the "push rules" from FC papers:
1140
1141 * The push-argument rules, where we can move a coercion past an argument.
1142 We have
1143 (fun |> co) arg
1144 and we want to transform it to
1145 (fun arg') |> co'
1146 for some suitable co' and tranformed arg'.
1147
1148 * The PushK rule for data constructors. We have
1149 (K e1 .. en) |> co
1150 and we want to tranform to
1151 (K e1' .. en')
1152 by pushing the coercion into the arguments
1153 -}
1154
1155 pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)
1156 pushCoArgs co [] = return ([], MCo co)
1157 pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg
1158 ; case m_co1 of
1159 MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args
1160 ; return (arg':args', m_co2) }
1161 MRefl -> return (arg':args, MRefl) }
1162
1163 pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)
1164 -- We have (fun |> co) arg, and we want to transform it to
1165 -- (fun arg) |> co
1166 -- This may fail, e.g. if (fun :: N) where N is a newtype
1167 -- C.f. simplCast in Simplify.hs
1168 -- 'co' is always Representational
1169 -- If the returned coercion is Nothing, then it would have been reflexive
1170 pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty
1171 ; return (Type ty', m_co') }
1172 pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co
1173 ; return (val_arg `mkCast` arg_co, m_co') }
1174
1175 pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)
1176 -- We have (fun |> co) @ty
1177 -- Push the coercion through to return
1178 -- (fun @ty') |> co'
1179 -- 'co' is always Representational
1180 -- If the returned coercion is Nothing, then it would have been reflexive;
1181 -- it's faster not to compute it, though.
1182 pushCoTyArg co ty
1183 -- The following is inefficient - don't do `eqType` here, the coercion
1184 -- optimizer will take care of it. See #14737.
1185 -- -- | tyL `eqType` tyR
1186 -- -- = Just (ty, Nothing)
1187
1188 | isReflCo co
1189 = Just (ty, MRefl)
1190
1191 | isForAllTy_ty tyL
1192 = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )
1193 Just (ty `mkCastTy` co1, MCo co2)
1194
1195 | otherwise
1196 = Nothing
1197 where
1198 Pair tyL tyR = coercionKind co
1199 -- co :: tyL ~ tyR
1200 -- tyL = forall (a1 :: k1). ty1
1201 -- tyR = forall (a2 :: k2). ty2
1202
1203 co1 = mkSymCo (mkNthCo Nominal 0 co)
1204 -- co1 :: k2 ~N k1
1205 -- Note that NthCo can extract a Nominal equality between the
1206 -- kinds of the types related by a coercion between forall-types.
1207 -- See the NthCo case in CoreLint.
1208
1209 co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)
1210 -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]
1211 -- Arg of mkInstCo is always nominal, hence mkNomReflCo
1212
1213 pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion)
1214 -- We have (fun |> co) arg
1215 -- Push the coercion through to return
1216 -- (fun (arg |> co_arg)) |> co_res
1217 -- 'co' is always Representational
1218 -- If the second returned Coercion is actually Nothing, then no cast is necessary;
1219 -- the returned coercion would have been reflexive.
1220 pushCoValArg co
1221 -- The following is inefficient - don't do `eqType` here, the coercion
1222 -- optimizer will take care of it. See #14737.
1223 -- -- | tyL `eqType` tyR
1224 -- -- = Just (mkRepReflCo arg, Nothing)
1225
1226 | isReflCo co
1227 = Just (mkRepReflCo arg, MRefl)
1228
1229 | isFunTy tyL
1230 , (co1, co2) <- decomposeFunCo Representational co
1231 -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)
1232 -- then co1 :: tyL1 ~ tyR1
1233 -- co2 :: tyL2 ~ tyR2
1234 = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
1235 Just (mkSymCo co1, MCo co2)
1236
1237 | otherwise
1238 = Nothing
1239 where
1240 arg = funArgTy tyR
1241 Pair tyL tyR = coercionKind co
1242
1243 pushCoercionIntoLambda
1244 :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)
1245 -- This implements the Push rule from the paper on coercions
1246 -- (\x. e) |> co
1247 -- ===>
1248 -- (\x'. e |> co')
1249 pushCoercionIntoLambda in_scope x e co
1250 | ASSERT(not (isTyVar x) && not (isCoVar x)) True
1251 , Pair s1s2 t1t2 <- coercionKind co
1252 , Just (_s1,_s2) <- splitFunTy_maybe s1s2
1253 , Just (t1,_t2) <- splitFunTy_maybe t1t2
1254 = let (co1, co2) = decomposeFunCo Representational co
1255 -- Should we optimize the coercions here?
1256 -- Otherwise they might not match too well
1257 x' = x `setIdType` t1
1258 in_scope' = in_scope `extendInScopeSet` x'
1259 subst = extendIdSubst (mkEmptySubst in_scope')
1260 x
1261 (mkCast (Var x') co1)
1262 in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2)
1263 | otherwise
1264 = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))
1265 Nothing
1266
1267 pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
1268 -> Maybe (DataCon
1269 , [Type] -- Universal type args
1270 , [CoreExpr]) -- All other args incl existentials
1271 -- Implement the KPush reduction rule as described in "Down with kinds"
1272 -- The transformation applies iff we have
1273 -- (C e1 ... en) `cast` co
1274 -- where co :: (T t1 .. tn) ~ to_ty
1275 -- The left-hand one must be a T, because exprIsConApp returned True
1276 -- but the right-hand one might not be. (Though it usually will.)
1277 pushCoDataCon dc dc_args co
1278 | isReflCo co || from_ty `eqType` to_ty -- try cheap test first
1279 , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
1280 = Just (dc, map exprToType univ_ty_args, rest_args)
1281
1282 | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
1283 , to_tc == dataConTyCon dc
1284 -- These two tests can fail; we might see
1285 -- (C x y) `cast` (g :: T a ~ S [a]),
1286 -- where S is a type function. In fact, exprIsConApp
1287 -- will probably not be called in such circumstances,
1288 -- but there's nothing wrong with it
1289
1290 = let
1291 tc_arity = tyConArity to_tc
1292 dc_univ_tyvars = dataConUnivTyVars dc
1293 dc_ex_tcvars = dataConExTyCoVars dc
1294 arg_tys = dataConRepArgTys dc
1295
1296 non_univ_args = dropList dc_univ_tyvars dc_args
1297 (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args
1298
1299 -- Make the "Psi" from the paper
1300 omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc)
1301 (psi_subst, to_ex_arg_tys)
1302 = liftCoSubstWithEx Representational
1303 dc_univ_tyvars
1304 omegas
1305 dc_ex_tcvars
1306 (map exprToType ex_args)
1307
1308 -- Cast the value arguments (which include dictionaries)
1309 new_val_args = zipWith cast_arg arg_tys val_args
1310 cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)
1311
1312 to_ex_args = map Type to_ex_arg_tys
1313
1314 dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars,
1315 ppr arg_tys, ppr dc_args,
1316 ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ]
1317 in
1318 ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )
1319 ASSERT2( equalLength val_args arg_tys, dump_doc )
1320 Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)
1321
1322 | otherwise
1323 = Nothing
1324
1325 where
1326 Pair from_ty to_ty = coercionKind co
1327
1328 collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
1329 -- Collect lambda binders, pushing coercions inside if possible
1330 -- E.g. (\x.e) |> g g :: <Int> -> blah
1331 -- = (\x. e |> Nth 1 g)
1332 --
1333 -- That is,
1334 --
1335 -- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g)
1336 collectBindersPushingCo e
1337 = go [] e
1338 where
1339 -- Peel off lambdas until we hit a cast.
1340 go :: [Var] -> CoreExpr -> ([Var], CoreExpr)
1341 -- The accumulator is in reverse order
1342 go bs (Lam b e) = go (b:bs) e
1343 go bs (Cast e co) = go_c bs e co
1344 go bs e = (reverse bs, e)
1345
1346 -- We are in a cast; peel off casts until we hit a lambda.
1347 go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
1348 -- (go_c bs e c) is same as (go bs e (e |> c))
1349 go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)
1350 go_c bs (Lam b e) co = go_lam bs b e co
1351 go_c bs e co = (reverse bs, mkCast e co)
1352
1353 -- We are in a lambda under a cast; peel off lambdas and build a
1354 -- new coercion for the body.
1355 go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)
1356 -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)
1357 go_lam bs b e co
1358 | isTyVar b
1359 , let Pair tyL tyR = coercionKind co
1360 , ASSERT( isForAllTy_ty tyL )
1361 isForAllTy_ty tyR
1362 , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo]
1363 = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))
1364
1365 | isCoVar b
1366 , let Pair tyL tyR = coercionKind co
1367 , ASSERT( isForAllTy_co tyL )
1368 isForAllTy_co tyR
1369 , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo]
1370 , let cov = mkCoVarCo b
1371 = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov)))
1372
1373 | isId b
1374 , let Pair tyL tyR = coercionKind co
1375 , ASSERT( isFunTy tyL) isFunTy tyR
1376 , (co_arg, co_res) <- decomposeFunCo Representational co
1377 , isReflCo co_arg -- See Note [collectBindersPushingCo]
1378 = go_c (b:bs) e co_res
1379
1380 | otherwise = (reverse bs, mkCast (Lam b e) co)
1381
1382 {- Note [collectBindersPushingCo]
1383 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1384 We just look for coercions of form
1385 <type> -> blah
1386 (and similarly for foralls) to keep this function simple. We could do
1387 more elaborate stuff, but it'd involve substitution etc.
1388 -}