Use lengthIs and friends in more places
[ghc.git] / compiler / simplCore / CallArity.hs
1 --
2 -- Copyright (c) 2014 Joachim Breitner
3 --
4
5 module CallArity
6 ( callArityAnalProgram
7 , callArityRHS -- for testing
8 ) where
9
10 import VarSet
11 import VarEnv
12 import DynFlags ( DynFlags )
13
14 import BasicTypes
15 import CoreSyn
16 import Id
17 import CoreArity ( typeArity )
18 import CoreUtils ( exprIsCheap, exprIsTrivial )
19 import UnVarGraph
20 import Demand
21 import Util
22
23 import Control.Arrow ( first, second )
24
25
26 {-
27 %************************************************************************
28 %* *
29 Call Arity Analysis
30 %* *
31 %************************************************************************
32
33 Note [Call Arity: The goal]
34 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
35
36 The goal of this analysis is to find out if we can eta-expand a local function,
37 based on how it is being called. The motivating example is this code,
38 which comes up when we implement foldl using foldr, and do list fusion:
39
40 let go = \x -> let d = case ... of
41 False -> go (x+1)
42 True -> id
43 in \z -> d (x + z)
44 in go 1 0
45
46 If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of
47 partial function applications, which would be bad.
48
49 The function `go` has a type of arity two, but only one lambda is manifest.
50 Furthermore, an analysis that only looks at the RHS of go cannot be sufficient
51 to eta-expand go: If `go` is ever called with one argument (and the result used
52 multiple times), we would be doing the work in `...` multiple times.
53
54 So `callArityAnalProgram` looks at the whole let expression to figure out if
55 all calls are nice, i.e. have a high enough arity. It then stores the result in
56 the `calledArity` field of the `IdInfo` of `go`, which the next simplifier
57 phase will eta-expand.
58
59 The specification of the `calledArity` field is:
60
61 No work will be lost if you eta-expand me to the arity in `calledArity`.
62
63 What we want to know for a variable
64 -----------------------------------
65
66 For every let-bound variable we'd like to know:
67 1. A lower bound on the arity of all calls to the variable, and
68 2. whether the variable is being called at most once or possible multiple
69 times.
70
71 It is always ok to lower the arity, or pretend that there are multiple calls.
72 In particular, "Minimum arity 0 and possible called multiple times" is always
73 correct.
74
75
76 What we want to know from an expression
77 ---------------------------------------
78
79 In order to obtain that information for variables, we analyze expression and
80 obtain bits of information:
81
82 I. The arity analysis:
83 For every variable, whether it is absent, or called,
84 and if called, which what arity.
85
86 II. The Co-Called analysis:
87 For every two variables, whether there is a possibility that both are being
88 called.
89 We obtain as a special case: For every variables, whether there is a
90 possibility that it is being called twice.
91
92 For efficiency reasons, we gather this information only for a set of
93 *interesting variables*, to avoid spending time on, e.g., variables from pattern matches.
94
95 The two analysis are not completely independent, as a higher arity can improve
96 the information about what variables are being called once or multiple times.
97
98 Note [Analysis I: The arity analysis]
99 ------------------------------------
100
101 The arity analysis is quite straight forward: The information about an
102 expression is an
103 VarEnv Arity
104 where absent variables are bound to Nothing and otherwise to a lower bound to
105 their arity.
106
107 When we analyze an expression, we analyze it with a given context arity.
108 Lambdas decrease and applications increase the incoming arity. Analysizing a
109 variable will put that arity in the environment. In lets or cases all the
110 results from the various subexpressions are lubed, which takes the point-wise
111 minimum (considering Nothing an infinity).
112
113
114 Note [Analysis II: The Co-Called analysis]
115 ------------------------------------------
116
117 The second part is more sophisticated. For reasons explained below, it is not
118 sufficient to simply know how often an expression evaluates a variable. Instead
119 we need to know which variables are possibly called together.
120
121 The data structure here is an undirected graph of variables, which is provided
122 by the abstract
123 UnVarGraph
124
125 It is safe to return a larger graph, i.e. one with more edges. The worst case
126 (i.e. the least useful and always correct result) is the complete graph on all
127 free variables, which means that anything can be called together with anything
128 (including itself).
129
130 Notation for the following:
131 C(e) is the co-called result for e.
132 G₁∪G₂ is the union of two graphs
133 fv is the set of free variables (conveniently the domain of the arity analysis result)
134 S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ }
135 S² is the complete graph on the set of variables S, S² = S×S
136 C'(e) is a variant for bound expression:
137 If e is called at most once, or it is and stays a thunk (after the analysis),
138 it is simply C(e). Otherwise, the expression can be called multiple times
139 and we return (fv e)²
140
141 The interesting cases of the analysis:
142 * Var v:
143 No other variables are being called.
144 Return {} (the empty graph)
145 * Lambda v e, under arity 0:
146 This means that e can be evaluated many times and we cannot get
147 any useful co-call information.
148 Return (fv e)²
149 * Case alternatives alt₁,alt₂,...:
150 Only one can be execuded, so
151 Return (alt₁ ∪ alt₂ ∪...)
152 * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂:
153 We get the results from both sides, with the argument evaluated at most once.
154 Additionally, anything called by e₁ can possibly be called with anything
155 from e₂.
156 Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂)
157 * App e₁ x:
158 As this is already in A-normal form, CorePrep will not separately lambda
159 bind (and hence share) x. So we conservatively assume multiple calls to x here
160 Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)}
161 * Let v = rhs in body:
162 In addition to the results from the subexpressions, add all co-calls from
163 everything that the body calls together with v to everthing that is called
164 by v.
165 Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}
166 * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body
167 Tricky.
168 We assume that it is really mutually recursive, i.e. that every variable
169 calls one of the others, and that this is strongly connected (otherwise we
170 return an over-approximation, so that's ok), see note [Recursion and fixpointing].
171
172 Let V = {v₁,...vₙ}.
173 Assume that the vs have been analysed with an incoming demand and
174 cardinality consistent with the final result (this is the fixed-pointing).
175 Again we can use the results from all subexpressions.
176 In addition, for every variable vᵢ, we need to find out what it is called
177 with (call this set Sᵢ). There are two cases:
178 * If vᵢ is a function, we need to go through all right-hand-sides and bodies,
179 and collect every variable that is called together with any variable from V:
180 Sᵢ = {v' | j ∈ {1,...,n}, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }
181 * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to
182 exclude it from this set:
183 Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }
184 Finally, combine all this:
185 Return: C(body) ∪
186 C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪
187 (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ)
188
189 Using the result: Eta-Expansion
190 -------------------------------
191
192 We use the result of these two analyses to decide whether we can eta-expand the
193 rhs of a let-bound variable.
194
195 If the variable is already a function (exprIsCheap), and all calls to the
196 variables have a higher arity than the current manifest arity (i.e. the number
197 of lambdas), expand.
198
199 If the variable is a thunk we must be careful: Eta-Expansion will prevent
200 sharing of work, so this is only safe if there is at most one call to the
201 function. Therefore, we check whether {v,v} ∈ G.
202
203 Example:
204
205 let n = case .. of .. -- A thunk!
206 in n 0 + n 1
207
208 vs.
209
210 let n = case .. of ..
211 in case .. of T -> n 0
212 F -> n 1
213
214 We are only allowed to eta-expand `n` if it is going to be called at most
215 once in the body of the outer let. So we need to know, for each variable
216 individually, that it is going to be called at most once.
217
218
219 Why the co-call graph?
220 ----------------------
221
222 Why is it not sufficient to simply remember which variables are called once and
223 which are called multiple times? It would be in the previous example, but consider
224
225 let n = case .. of ..
226 in case .. of
227 True -> let go = \y -> case .. of
228 True -> go (y + n 1)
229 False > n
230 in go 1
231 False -> n
232
233 vs.
234
235 let n = case .. of ..
236 in case .. of
237 True -> let go = \y -> case .. of
238 True -> go (y+1)
239 False > n
240 in go 1
241 False -> n
242
243 In both cases, the body and the rhs of the inner let call n at most once.
244 But only in the second case that holds for the whole expression! The
245 crucial difference is that in the first case, the rhs of `go` can call
246 *both* `go` and `n`, and hence can call `n` multiple times as it recurses,
247 while in the second case find out that `go` and `n` are not called together.
248
249
250 Why co-call information for functions?
251 --------------------------------------
252
253 Although for eta-expansion we need the information only for thunks, we still
254 need to know whether functions are being called once or multiple times, and
255 together with what other functions.
256
257 Example:
258
259 let n = case .. of ..
260 f x = n (x+1)
261 in f 1 + f 2
262
263 vs.
264
265 let n = case .. of ..
266 f x = n (x+1)
267 in case .. of T -> f 0
268 F -> f 1
269
270 Here, the body of f calls n exactly once, but f itself is being called
271 multiple times, so eta-expansion is not allowed.
272
273
274 Note [Analysis type signature]
275 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
276
277 The work-hourse of the analysis is the function `callArityAnal`, with the
278 following type:
279
280 type CallArityRes = (UnVarGraph, VarEnv Arity)
281 callArityAnal ::
282 Arity -> -- The arity this expression is called with
283 VarSet -> -- The set of interesting variables
284 CoreExpr -> -- The expression to analyse
285 (CallArityRes, CoreExpr)
286
287 and the following specification:
288
289 ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr
290
291 <=>
292
293 Assume the expression `expr` is being passed `arity` arguments. Then it holds that
294 * The domain of `callArityEnv` is a subset of `interestingIds`.
295 * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`
296 is absent, i.e. not called at all.
297 * Every call from `expr` to a variable bound to n in `callArityEnv` has at
298 least n value arguments.
299 * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,
300 then in no execution of `expr` both are being called.
301 Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.
302
303
304 Note [Which variables are interesting]
305 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
306
307 The analysis would quickly become prohibitive expensive if we would analyse all
308 variables; for most variables we simply do not care about how often they are
309 called, i.e. variables bound in a pattern match. So interesting are variables that are
310 * top-level or let bound
311 * and possibly functions (typeArity > 0)
312
313 Note [Taking boring variables into account]
314 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
315
316 If we decide that the variable bound in `let x = e1 in e2` is not interesting,
317 the analysis of `e2` will not report anything about `x`. To ensure that
318 `callArityBind` does still do the right thing we have to take that into account
319 everytime we would be lookup up `x` in the analysis result of `e2`.
320 * Instead of calling lookupCallArityRes, we return (0, True), indicating
321 that this variable might be called many times with no arguments.
322 * Instead of checking `calledWith x`, we assume that everything can be called
323 with it.
324 * In the recursive case, when calclulating the `cross_calls`, if there is
325 any boring variable in the recursive group, we ignore all co-call-results
326 and directly go to a very conservative assumption.
327
328 The last point has the nice side effect that the relatively expensive
329 integration of co-call results in a recursive groups is often skipped. This
330 helped to avoid the compile time blowup in some real-world code with large
331 recursive groups (#10293).
332
333 Note [Recursion and fixpointing]
334 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
335
336 For a mutually recursive let, we begin by
337 1. analysing the body, using the same incoming arity as for the whole expression.
338 2. Then we iterate, memoizing for each of the bound variables the last
339 analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.
340 3. We combine the analysis result from the body and the memoized results for
341 the arguments (if already present).
342 4. For each variable, we find out the incoming arity and whether it is called
343 once, based on the the current analysis result. If this differs from the
344 memoized results, we re-analyse the rhs and update the memoized table.
345 5. If nothing had to be reanalyzed, we are done.
346 Otherwise, repeat from step 3.
347
348
349 Note [Thunks in recursive groups]
350 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
351
352 We never eta-expand a thunk in a recursive group, on the grounds that if it is
353 part of a recursive group, then it will be called multipe times.
354
355 This is not necessarily true, e.g. it would be safe to eta-expand t2 (but not
356 t1) in the following code:
357
358 let go x = t1
359 t1 = if ... then t2 else ...
360 t2 = if ... then go 1 else ...
361 in go 0
362
363 Detecting this would require finding out what variables are only ever called
364 from thunks. While this is certainly possible, we yet have to see this to be
365 relevant in the wild.
366
367
368 Note [Analysing top-level binds]
369 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
370
371 We can eta-expand top-level-binds if they are not exported, as we see all calls
372 to them. The plan is as follows: Treat the top-level binds as nested lets around
373 a body representing “all external calls”, which returns a pessimistic
374 CallArityRes (the co-call graph is the complete graph, all arityies 0).
375
376 Note [Trimming arity]
377 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
378
379 In the Call Arity papers, we are working on an untyped lambda calculus with no
380 other id annotations, where eta-expansion is always possible. But this is not
381 the case for Core!
382 1. We need to ensure the invariant
383 callArity e <= typeArity (exprType e)
384 for the same reasons that exprArity needs this invariant (see Note
385 [exprArity invariant] in CoreArity).
386
387 If we are not doing that, a too-high arity annotation will be stored with
388 the id, confusing the simplifier later on.
389
390 2. Eta-expanding a right hand side might invalidate existing annotations. In
391 particular, if an id has a strictness annotation of <...><...>b, then
392 passing two arguments to it will definitely bottom out, so the simplifier
393 will throw away additional parameters. This conflicts with Call Arity! So
394 we ensure that we never eta-expand such a value beyond the number of
395 arguments mentioned in the strictness signature.
396 See #10176 for a real-world-example.
397
398 Note [What is a thunk]
399 ~~~~~~~~~~~~~~~~~~~~~~
400
401 Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a
402 thunk, not eta-expanded, to avoid losing any sharing. This is also how the
403 published papers on Call Arity describe it.
404
405 In practice, there are thunks that do a just little work, such as
406 pattern-matching on a variable, and the benefits of eta-expansion likely
407 oughtweigh the cost of doing that repeatedly. Therefore, this implementation of
408 Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.
409
410 Note [Call Arity and Join Points]
411 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
412
413 The Call Arity analysis does not care about join points, and treats them just
414 like normal functions. This is ok.
415
416 The analysis *could* make use of the fact that join points are always evaluated
417 in the same context as the join-binding they are defined in and are always
418 one-shot, and handle join points separately, as suggested in
419 https://ghc.haskell.org/trac/ghc/ticket/13479#comment:10.
420 This *might* be more efficient (for example, join points would not have to be
421 considered interesting variables), but it would also add redundant code. So for
422 now we do not do that.
423
424 The simplifier never eta-expands join points (it instead pushes extra arguments from
425 an eta-expanded context into the join point’s RHS), so the call arity
426 annotation on join points is not actually used. As it would be equally valid
427 (though less efficient) to eta-expand join points, this is the simplifier's
428 choice, and hence Call Arity sets the call arity for join points as well.
429 -}
430
431 -- Main entry point
432
433 callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram
434 callArityAnalProgram _dflags binds = binds'
435 where
436 (_, binds') = callArityTopLvl [] emptyVarSet binds
437
438 -- See Note [Analysing top-level-binds]
439 callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])
440 callArityTopLvl exported _ []
441 = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])
442 , [] )
443 callArityTopLvl exported int1 (b:bs)
444 = (ae2, b':bs')
445 where
446 int2 = bindersOf b
447 exported' = filter isExportedId int2 ++ exported
448 int' = int1 `addInterestingBinds` b
449 (ae1, bs') = callArityTopLvl exported' int' bs
450 (ae2, b') = callArityBind (boringBinds b) ae1 int1 b
451
452
453 callArityRHS :: CoreExpr -> CoreExpr
454 callArityRHS = snd . callArityAnal 0 emptyVarSet
455
456 -- The main analysis function. See Note [Analysis type signature]
457 callArityAnal ::
458 Arity -> -- The arity this expression is called with
459 VarSet -> -- The set of interesting variables
460 CoreExpr -> -- The expression to analyse
461 (CallArityRes, CoreExpr)
462 -- How this expression uses its interesting variables
463 -- and the expression with IdInfo updated
464
465 -- The trivial base cases
466 callArityAnal _ _ e@(Lit _)
467 = (emptyArityRes, e)
468 callArityAnal _ _ e@(Type _)
469 = (emptyArityRes, e)
470 callArityAnal _ _ e@(Coercion _)
471 = (emptyArityRes, e)
472 -- The transparent cases
473 callArityAnal arity int (Tick t e)
474 = second (Tick t) $ callArityAnal arity int e
475 callArityAnal arity int (Cast e co)
476 = second (\e -> Cast e co) $ callArityAnal arity int e
477
478 -- The interesting case: Variables, Lambdas, Lets, Applications, Cases
479 callArityAnal arity int e@(Var v)
480 | v `elemVarSet` int
481 = (unitArityRes v arity, e)
482 | otherwise
483 = (emptyArityRes, e)
484
485 -- Non-value lambdas are ignored
486 callArityAnal arity int (Lam v e) | not (isId v)
487 = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e
488
489 -- We have a lambda that may be called multiple times, so its free variables
490 -- can all be co-called.
491 callArityAnal 0 int (Lam v e)
492 = (ae', Lam v e')
493 where
494 (ae, e') = callArityAnal 0 (int `delVarSet` v) e
495 ae' = calledMultipleTimes ae
496 -- We have a lambda that we are calling. decrease arity.
497 callArityAnal arity int (Lam v e)
498 = (ae, Lam v e')
499 where
500 (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e
501
502 -- Application. Increase arity for the called expression, nothing to know about
503 -- the second
504 callArityAnal arity int (App e (Type t))
505 = second (\e -> App e (Type t)) $ callArityAnal arity int e
506 callArityAnal arity int (App e1 e2)
507 = (final_ae, App e1' e2')
508 where
509 (ae1, e1') = callArityAnal (arity + 1) int e1
510 (ae2, e2') = callArityAnal 0 int e2
511 -- If the argument is trivial (e.g. a variable), then it will _not_ be
512 -- let-bound in the Core to STG transformation (CorePrep actually),
513 -- so no sharing will happen here, and we have to assume many calls.
514 ae2' | exprIsTrivial e2 = calledMultipleTimes ae2
515 | otherwise = ae2
516 final_ae = ae1 `both` ae2'
517
518 -- Case expression.
519 callArityAnal arity int (Case scrut bndr ty alts)
520 = -- pprTrace "callArityAnal:Case"
521 -- (vcat [ppr scrut, ppr final_ae])
522 (final_ae, Case scrut' bndr ty alts')
523 where
524 (alt_aes, alts') = unzip $ map go alts
525 go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e
526 in (ae, (dc, bndrs, e'))
527 alt_ae = lubRess alt_aes
528 (scrut_ae, scrut') = callArityAnal 0 int scrut
529 final_ae = scrut_ae `both` alt_ae
530
531 -- For lets, use callArityBind
532 callArityAnal arity int (Let bind e)
533 = -- pprTrace "callArityAnal:Let"
534 -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])
535 (final_ae, Let bind' e')
536 where
537 int_body = int `addInterestingBinds` bind
538 (ae_body, e') = callArityAnal arity int_body e
539 (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind
540
541 -- Which bindings should we look at?
542 -- See Note [Which variables are interesting]
543 isInteresting :: Var -> Bool
544 isInteresting v = not $ null (typeArity (idType v))
545
546 interestingBinds :: CoreBind -> [Var]
547 interestingBinds = filter isInteresting . bindersOf
548
549 boringBinds :: CoreBind -> VarSet
550 boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf
551
552 addInterestingBinds :: VarSet -> CoreBind -> VarSet
553 addInterestingBinds int bind
554 = int `delVarSetList` bindersOf bind -- Possible shadowing
555 `extendVarSetList` interestingBinds bind
556
557 -- Used for both local and top-level binds
558 -- Second argument is the demand from the body
559 callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
560 -- Non-recursive let
561 callArityBind boring_vars ae_body int (NonRec v rhs)
562 | otherwise
563 = -- pprTrace "callArityBind:NonRec"
564 -- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
565 (final_ae, NonRec v' rhs')
566 where
567 is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]
568 -- If v is boring, we will not find it in ae_body, but always assume (0, False)
569 boring = v `elemVarSet` boring_vars
570
571 (arity, called_once)
572 | boring = (0, False) -- See Note [Taking boring variables into account]
573 | otherwise = lookupCallArityRes ae_body v
574 safe_arity | called_once = arity
575 | is_thunk = 0 -- A thunk! Do not eta-expand
576 | otherwise = arity
577
578 -- See Note [Trimming arity]
579 trimmed_arity = trimArity v safe_arity
580
581 (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs
582
583
584 ae_rhs'| called_once = ae_rhs
585 | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
586 | otherwise = calledMultipleTimes ae_rhs
587
588 called_by_v = domRes ae_rhs'
589 called_with_v
590 | boring = domRes ae_body
591 | otherwise = calledWith ae_body v `delUnVarSet` v
592 final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body
593
594 v' = v `setIdCallArity` trimmed_arity
595
596
597 -- Recursive let. See Note [Recursion and fixpointing]
598 callArityBind boring_vars ae_body int b@(Rec binds)
599 = -- (if length binds > 300 then
600 -- pprTrace "callArityBind:Rec"
601 -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $
602 (final_ae, Rec binds')
603 where
604 -- See Note [Taking boring variables into account]
605 any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]
606
607 int_body = int `addInterestingBinds` b
608 (ae_rhs, binds') = fix initial_binds
609 final_ae = bindersOf b `resDelList` ae_rhs
610
611 initial_binds = [(i,Nothing,e) | (i,e) <- binds]
612
613 fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])
614 fix ann_binds
615 | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $
616 any_change
617 = fix ann_binds'
618 | otherwise
619 = (ae, map (\(i, _, e) -> (i, e)) ann_binds')
620 where
621 aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]
622 ae = callArityRecEnv any_boring aes_old ae_body
623
624 rerun (i, mbLastRun, rhs)
625 | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)
626 -- No call to this yet, so do nothing
627 = (False, (i, Nothing, rhs))
628
629 | Just (old_called_once, old_arity, _) <- mbLastRun
630 , called_once == old_called_once
631 , new_arity == old_arity
632 -- No change, no need to re-analyze
633 = (False, (i, mbLastRun, rhs))
634
635 | otherwise
636 -- We previously analyzed this with a different arity (or not at all)
637 = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]
638
639 safe_arity | is_thunk = 0 -- See Note [Thunks in recursive groups]
640 | otherwise = new_arity
641
642 -- See Note [Trimming arity]
643 trimmed_arity = trimArity i safe_arity
644
645 (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs
646
647 ae_rhs' | called_once = ae_rhs
648 | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
649 | otherwise = calledMultipleTimes ae_rhs
650
651 i' = i `setIdCallArity` trimmed_arity
652
653 in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs'))
654 where
655 -- See Note [Taking boring variables into account]
656 (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False)
657 | otherwise = lookupCallArityRes ae i
658
659 (changes, ann_binds') = unzip $ map rerun ann_binds
660 any_change = or changes
661
662 -- Combining the results from body and rhs, (mutually) recursive case
663 -- See Note [Analysis II: The Co-Called analysis]
664 callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes
665 callArityRecEnv any_boring ae_rhss ae_body
666 = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $
667 ae_new
668 where
669 vars = map fst ae_rhss
670
671 ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body
672
673 cross_calls
674 -- See Note [Taking boring variables into account]
675 | any_boring = completeGraph (domRes ae_combined)
676 -- Also, calculating cross_calls is expensive. Simply be conservative
677 -- if the mutually recursive group becomes too large.
678 | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined)
679 | otherwise = unionUnVarGraphs $ map cross_call ae_rhss
680 cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v
681 where
682 is_thunk = idCallArity v == 0
683 -- What rhs are relevant as happening before (or after) calling v?
684 -- If v is a thunk, everything from all the _other_ variables
685 -- If v is not a thunk, everything can happen.
686 ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body
687 | otherwise = ae_combined
688 -- What do we want to know from these?
689 -- Which calls can happen next to any recursive call.
690 called_with_v
691 = unionUnVarSets $ map (calledWith ae_before_v) vars
692 called_by_v = domRes ae_rhs
693
694 ae_new = first (cross_calls `unionUnVarGraph`) ae_combined
695
696 -- See Note [Trimming arity]
697 trimArity :: Id -> Arity -> Arity
698 trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]
699 where
700 max_arity_by_type = length (typeArity (idType v))
701 max_arity_by_strsig
702 | isBotRes result_info = length demands
703 | otherwise = a
704
705 (demands, result_info) = splitStrictSig (idStrictness v)
706
707 ---------------------------------------
708 -- Functions related to CallArityRes --
709 ---------------------------------------
710
711 -- Result type for the two analyses.
712 -- See Note [Analysis I: The arity analysis]
713 -- and Note [Analysis II: The Co-Called analysis]
714 type CallArityRes = (UnVarGraph, VarEnv Arity)
715
716 emptyArityRes :: CallArityRes
717 emptyArityRes = (emptyUnVarGraph, emptyVarEnv)
718
719 unitArityRes :: Var -> Arity -> CallArityRes
720 unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)
721
722 resDelList :: [Var] -> CallArityRes -> CallArityRes
723 resDelList vs ae = foldr resDel ae vs
724
725 resDel :: Var -> CallArityRes -> CallArityRes
726 resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)
727
728 domRes :: CallArityRes -> UnVarSet
729 domRes (_, ae) = varEnvDom ae
730
731 -- In the result, find out the minimum arity and whether the variable is called
732 -- at most once.
733 lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)
734 lookupCallArityRes (g, ae) v
735 = case lookupVarEnv ae v of
736 Just a -> (a, not (v `elemUnVarSet` (neighbors g v)))
737 Nothing -> (0, False)
738
739 calledWith :: CallArityRes -> Var -> UnVarSet
740 calledWith (g, _) v = neighbors g v
741
742 addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
743 addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)
744
745 -- Replaces the co-call graph by a complete graph (i.e. no information)
746 calledMultipleTimes :: CallArityRes -> CallArityRes
747 calledMultipleTimes res = first (const (completeGraph (domRes res))) res
748
749 -- Used for application and cases
750 both :: CallArityRes -> CallArityRes -> CallArityRes
751 both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2
752
753 -- Used when combining results from alternative cases; take the minimum
754 lubRes :: CallArityRes -> CallArityRes -> CallArityRes
755 lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)
756
757 lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
758 lubArityEnv = plusVarEnv_C min
759
760 lubRess :: [CallArityRes] -> CallArityRes
761 lubRess = foldl lubRes emptyArityRes