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