diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 2356df8c8eab2dea3383231080f47515af654daa..bf62ac399618a373bca69c9da0409d83fa4d5ccc 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -165,6 +165,7 @@ Library
Var
VarEnv
VarSet
+ UnVarGraph
BlockId
CLabel
Cmm
diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index f3fedb56089aeb3b052638ef65be82cd1ab61c60..6334d8d245eeee053aa33eae743e8bfcc1ce0b5c 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -14,9 +14,10 @@ import DynFlags ( DynFlags )
import BasicTypes
import CoreSyn
import Id
-import CoreArity ( exprArity, typeArity )
+import CoreArity ( typeArity )
import CoreUtils ( exprIsHNF )
-import Outputable
+--import Outputable
+import UnVarGraph
import Control.Arrow ( first, second )
@@ -58,55 +59,142 @@ The specification of the `calledArity` field is:
No work will be lost if you eta-expand me to the arity in `calledArity`.
-The specification of the analysis
----------------------------------
-
-The analysis only does a conservative approximation, there are plenty of
-situations where eta-expansion would be ok, but we do not catch it. We are
-content if all the code that foldl-via-foldr generates is being optimized
-sufficiently.
-
-The work-hourse of the analysis is the function `callArityAnal`, with the
-following type:
-
- data Count = Many | OnceAndOnly
- type CallCount = (Count, Arity)
- type CallArityEnv = VarEnv (CallCount, Arity)
- callArityAnal ::
- Arity -> -- The arity this expression is called with
- VarSet -> -- The set of interesting variables
- CoreExpr -> -- The expression to analyse
- (CallArityEnv, CoreExpr)
-
-and the following specification:
-
- (callArityEnv, expr') = callArityEnv arity interestingIds expr
-
- <=>
-
- Assume the expression `expr` is being passed `arity` arguments. Then it calls
- the functions mentioned in `interestingIds` according to `callArityEnv`:
- * The domain of `callArityEnv` is a subset of `interestingIds`.
- * Any variable from interestingIds that is not mentioned in the `callArityEnv`
- is absent, i.e. not called at all.
- * Of all the variables that are mapped to OnceAndOnly by the `callArityEnv`,
- at most one is being called, at most once, with at least that many
- arguments.
- * Variables mapped to Many are called an unknown number of times, but if they
- are called, then with at least that many arguments.
- Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.
-
-The (pointwise) domain is a product domain:
-
- Many 0
- | × |
- OneAndOnly 1
- |
- ...
-
-The at-most-once is important for various reasons:
-
- 1. Consider:
+What we want to know for a variable
+-----------------------------------
+
+For every let-bound variable we'd like to know:
+ 1. A lower bound on the arity of all calls to the variable, and
+ 2. whether the variable is being called at most once or possible multiple
+ times.
+
+It is always ok to lower the arity, or pretend that there are multiple calls.
+In particular, "Minimum arity 0 and possible called multiple times" is always
+correct.
+
+
+What we want to know from an expression
+---------------------------------------
+
+In order to obtain that information for variables, we analyize expression and
+obtain bits of information:
+
+ I. The arity analysis:
+ For every variable, whether it is absent, or called,
+ and if called, which what arity.
+
+ II. The Co-Called analysis:
+ For every two variables, whether there is a possibility that both are being
+ called.
+ We obtain as a special case: For every variables, whether there is a
+ possibility that it is being called twice.
+
+For efficiency reasons, we gather this information only for a set of
+*interesting variables*, to avoid spending time on, e.g., variables from pattern matches.
+
+The two analysis are not completely independent, as a higher arity can improve
+the information about what variables are being called once or multiple times.
+
+Note [Analysis I: The arity analyis]
+------------------------------------
+
+The arity analysis is quite straight forward: The information about an
+expression is an
+ VarEnv Arity
+where absent variables are bound to Nothing and otherwise to a lower bound to
+their arity.
+
+When we analyize an expression, we analyize it with a given context arity.
+Lambdas decrease and applications increase the incoming arity. Analysizing a
+variable will put that arity in the environment. In lets or cases all the
+results from the various subexpressions are lubed, which takes the point-wise
+minimum (considering Nothing an infinity).
+
+
+Note [Analysis II: The Co-Called analysis]
+------------------------------------------
+
+The second part is more sophisticated. For reasons explained below, it is not
+sufficient to simply know how often an expression evalutes a variable. Instead
+we need to know which variables are possibly called together.
+
+The data structure here is an undirected graph of variables, which is provided
+by the abstract
+ UnVarGraph
+
+It is safe to return a larger graph, i.e. one with more edges. The worst case
+(i.e. the least useful and always correct result) is the complete graph on all
+free variables, which means that anything can be called together with anything
+(including itself).
+
+Notation for the following:
+C(e) is the co-called result for e.
+Gâ‚∪Gâ‚‚ is the union of two graphs
+fv is the set of free variables (conveniently the domain of the arity analysis result)
+Sâ‚×Sâ‚‚ is the complete bipartite graph { {a,b} | a ∈ Sâ‚, b ∈ Sâ‚‚ }
+S² is the complete graph on the set of variables S, S² = S×S
+C'(e) is a variant for bound expression:
+ If e is called at most once, or it is and stays a thunk (after the analysis),
+ it is simply C(e). Otherwise, the expression can be called multiple times
+ and we return (fv e)²
+
+The interesting cases of the analysis:
+ * Var v:
+ No other variables are being called.
+ Return {} (the empty graph)
+ * Lambda v e, under arity 0:
+ This means that e can be evaluated many times and we cannot get
+ any useful co-call information.
+ Return (fv e)²
+ * Case alternatives altâ‚,altâ‚‚,...:
+ Only one can be execuded, so
+ Return (alt₠∪ alt₂ ∪...)
+ * App eâ‚ eâ‚‚ (and analogously Case scrut alts):
+ We get the results from both sides. Additionally, anything called by eâ‚ can
+ possibly called with anything from eâ‚‚.
+ Return: C(eâ‚) ∪ C(eâ‚‚) ∪ (fv eâ‚) × (fv eâ‚‚)
+ * Let v = rhs in body:
+ In addition to the results from the subexpressions, add all co-calls from
+ everything that the body calls together with v to everthing that is called
+ by v.
+ Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}
+ * Letrec vâ‚ = rhsâ‚ ... vâ‚™ = rhsâ‚™ in body
+ Tricky.
+ We assume that it is really mutually recursive, i.e. that every variable
+ calls one of the others, and that this is strongly connected (otherwise we
+ return an over-approximation, so that's ok), see note [Recursion and fixpointing].
+
+ Let V = {vâ‚,...vâ‚™}.
+ Assume that the vs have been analysed with an incoming demand and
+ cardinality consistent with the final result (this is the fixed-pointing).
+ Again we can use the results from all subexpressions.
+ In addition, for every variable váµ¢, we need to find out what it is called
+ with (calls this set Sáµ¢). There are two cases:
+ * If váµ¢ is a function, we need to go through all right-hand-sides and bodies,
+ and collect every variable that is called together with any variable from V:
+ Sáµ¢ = {v' | j ∈ {1,...,n}, {v',vâ±¼} ∈ C'(rhsâ‚) ∪ ... ∪ C'(rhsâ‚™) ∪ C(body) }
+ * If váµ¢ is a thunk, then its rhs is evaluated only once, so we need to
+ exclude it from this set:
+ Sáµ¢ = {v' | j ∈ {1,...,n}, j≠i, {v',vâ±¼} ∈ C'(rhsâ‚) ∪ ... ∪ C'(rhsâ‚™) ∪ C(body) }
+ Finally, combine all this:
+ Return: C(body) ∪
+ C'(rhsâ‚) ∪ ... ∪ C'(rhsâ‚™) ∪
+ (fv rhsâ‚) × Sâ‚) ∪ ... ∪ (fv rhsâ‚™) × Sâ‚™)
+
+Using the result: Eta-Expansion
+-------------------------------
+
+We use the result of these two analyses to decide whether we can eta-expand the
+rhs of a let-bound variable.
+
+If the variable is already a function (exprIsHNF), and all calls to the
+variables have a higher arity than the current manifest arity (i.e. the number
+of lambdas), expand.
+
+If the variable is a thunk we must be careful: Eta-Expansion will prevent
+sharing of work, so this is only safe if there is at most one call to the
+function. Therefore, we check whether {v,v} ∈ G.
+
+ Example:
let n = case .. of .. -- A thunk!
in n 0 + n 1
@@ -121,24 +209,12 @@ The at-most-once is important for various reasons:
once in the body of the outer let. So we need to know, for each variable
individually, that it is going to be called at most once.
- 2. We need to know it for non-thunks as well, because they might call a thunk:
-
- let n = case .. of ..
- f x = n (x+1)
- in f 1 + f 2
-
- vs.
-
- let n = case .. of ..
- f x = n (x+1)
- in case .. of T -> f 0
- F -> f 1
- Here, the body of f calls n exactly once, but f itself is being called
- multiple times, so eta-expansion is not allowed.
+Why the co-call graph?
+----------------------
- 3. We need to know that at most one of the interesting functions is being
- called, because of recursion. Consider:
+Why is it not sufficient to simply remember which variables are called once and
+which are called multiple times? It would be in the previous example, but consider
let n = case .. of ..
in case .. of
@@ -148,7 +224,7 @@ The at-most-once is important for various reasons:
in go 1
False -> n
- vs.
+vs.
let n = case .. of ..
in case .. of
@@ -158,131 +234,117 @@ The at-most-once is important for various reasons:
in go 1
False -> n
- In both cases, the body and the rhs of the inner let call n at most once.
- But only in the second case that holds for the whole expression! The
- crucial difference is that in the first case, the rhs of `go` can call
- *both* `go` and `n`, and hence can call `n` multiple times as it recurses,
- while in the second case it calls `go` or `n`, but not both.
+In both cases, the body and the rhs of the inner let call n at most once.
+But only in the second case that holds for the whole expression! The
+crucial difference is that in the first case, the rhs of `go` can call
+*both* `go` and `n`, and hence can call `n` multiple times as it recurses,
+while in the second case find out that `go` and `n` are not called together.
-Note [Which variables are interesting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Unfortunately, the set of interesting variables is not irrelevant for the
-precision of the analysis. Consider this example (and ignore the pointlessnes
-of `d` recursing into itself):
+Why co-call information for functions?
+--------------------------------------
- let n = ... :: Int
- in let d = let d = case ... of
- False -> d
- True -> id
- in \z -> d (x + z)
- in d 0
+Although for eta-expansion we need the information only for thunks, we still
+need to know whether functions are being called once or multiple times, and
+together with what other functions.
-Of course, `d` should be interesting. If we consider `n` as interesting as
-well, then the body of the second let will return
- { go |-> (Many, 1) , n |-> (OnceAndOnly, 0) }
-or
- { go |-> (OnceAndOnly, 1), n |-> (Many, 0)}.
-Only the latter is useful, but it is hard to decide that locally.
-(Returning OnceAndOnly for both would be wrong, as both are being called.)
+ Example:
-So the heuristics is:
+ let n = case .. of ..
+ f x = n (x+1)
+ in f 1 + f 2
- Variables are interesting if their RHS has a lower exprArity than
- typeArity.
+ vs.
-(which is precisely the those variables where this analysis can actually cause
-some eta-expansion.)
+ let n = case .. of ..
+ f x = n (x+1)
+ in case .. of T -> f 0
+ F -> f 1
-But this is not uniformly a win. Consider:
+ Here, the body of f calls n exactly once, but f itself is being called
+ multiple times, so eta-expansion is not allowed.
- let go = \x -> let d = case ... of
- False -> go (x+1)
- True -> id
- n x = d (x+1)
- in \z -> n (x + z)
- in go n 0
-Now `n` is not going to be considered interesting (its type is `Int -> Int`).
-But this will prevent us from detecting how often the body of the let calls
-`d`, and we will not find out anything.
+Note [Analysis type signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The work-hourse of the analysis is the function `callArityAnal`, with the
+following type:
+
+ type CallArityRes = (UnVarGraph, VarEnv Arity)
+ callArityAnal ::
+ Arity -> -- The arity this expression is called with
+ VarSet -> -- The set of interesting variables
+ CoreExpr -> -- The expression to analyse
+ (CallArityRes, CoreExpr)
+
+and the following specification:
+
+ ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr
-It might be possible to be smarter here; this needs find-tuning as we find more
-examples.
+ <=>
+ Assume the expression `expr` is being passed `arity` arguments. Then it holds that
+ * The domain of `callArityEnv` is a subset of `interestingIds`.
+ * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`
+ is absent, i.e. not called at all.
+ * Every call from `expr` to a variable bound to n in `callArityEnv` has at
+ least n value arguments.
+ * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,
+ then in no execution of `expr` both are being called.
+ Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.
+
+
+Note [Which variables are interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The analysis would quickly become prohibitive expensive if we would analyse all
+variables; for most variables we simply do not care about how often they are
+called, i.e. variables bound in a pattern match. So interesting are variables that are
+ * top-level or let bound
+ * and possibly functions (typeArity > 0)
Note [Recursion and fixpointing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a recursive let, we begin by analysing the body, using the same incoming
-arity as for the whole expression.
- * We use the arity from the body on the variable as the incoming demand on the
- rhs. Then we check if the rhs calls itself with the same arity.
- - If so, we are done.
- - If not, we re-analise the rhs with the reduced arity. We do that until
- we are down to the exprArity, which then is certainly correct.
- * If the rhs calls itself many times, we must (conservatively) pass the result
- through forgetOnceCalls.
- * Similarly, if the body calls the variable many times, we must pass the
- result of the fixpointing through forgetOnceCalls.
- * Then we can `lubEnv` the results from the body and the rhs: If all mentioned
- calls are OnceAndOnly calls, then the body calls *either* the rhs *or* one
- of the other mentioned variables. Similarly, the rhs calls *either* itself
- again *or* one of the other mentioned variables. This precision is required!
- If the recursive function is called by the body, or the rhs, tagged with Many
- then we can also just `lubEnv`, because the result will no longer contain
- any OnceAndOnly values.
-
-Note [Case and App: Which side to take?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Combining the case branches is easy, just `lubEnv` them – at most one branch is
-taken.
-
-But how to combine that with the information coming from the scrunitee? Very
-similarly, how to combine the information from the callee and argument of an
-`App`?
-
-It would not be correct to just `lubEnv` then: `f n` obviously calls *both* `f`
-and `n`. We need to forget about the cardinality of calls from one side using
-`forgetOnceCalls`. But which one?
-
-Both are correct, and sometimes one and sometimes the other is more precise
-(also see example in [Which variables are interesting]).
-
-So currently, we first check the scrunitee (resp. the callee) if the returned
-value has any usesful information, and if so, we use that; otherwise we use the
-information from the alternatives (resp. the argument).
-
-It might be smarter to look for “more important†variables first, i.e. the
-innermost recursive variable.
+For a mutually recursive let, we begin by
+ 1. analysing the body, using the same incoming arity as for the whole expression.
+ 2. Then we iterate, memoizing for each of the bound variables the last
+ analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.
+ 3. We combine the analysis result from the body and the memoized results for
+ the arguments (if already present).
+ 4. For each variable, we find out the incoming arity and whether it is called
+ once, based on the the current analysis result. If this differs from the
+ memoized results, we re-analyse the rhs and update the memoized table.
+ 5. If nothing had to be reanalized, we are done.
+ Otherwise, repeat from step 3.
Note [Analysing top-level binds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can eta-expand top-level-binds if they are not exported, as we see all calls
to them. The plan is as follows: Treat the top-level binds as nested lets around
-a body representing “all external callsâ€, which returns a CallArityEnv that calls
-every exported function with the top of the lattice.
-
-This means that the incoming arity on all top-level binds will have a Many
-attached, and we will never eta-expand CAFs. Which is good.
+a body representing “all external callsâ€, which returns a pessimistic
+CallArityRes (the co-call graph is the complete graph, all arityies 0).
-}
+-- Main entry point
+
callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram
callArityAnalProgram _dflags binds = binds'
where
(_, binds') = callArityTopLvl [] emptyVarSet binds
-- See Note [Analysing top-level-binds]
-callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityEnv, [CoreBind])
+callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])
callArityTopLvl exported _ []
- = (mkVarEnv $ zip exported (repeat topCallCount), [])
+ = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])
+ , [] )
callArityTopLvl exported int1 (b:bs)
= (ae2, b':bs')
where
- int2 = interestingBinds b
+ int2 = bindersOf b
exported' = filter isExportedId int2 ++ exported
int' = int1 `addInterestingBinds` b
(ae1, bs') = callArityTopLvl exported' int' bs
@@ -292,30 +354,22 @@ callArityTopLvl exported int1 (b:bs)
callArityRHS :: CoreExpr -> CoreExpr
callArityRHS = snd . callArityAnal 0 emptyVarSet
-
-data Count = Many | OnceAndOnly deriving (Eq, Ord)
-type CallCount = (Count, Arity)
-
-topCallCount :: CallCount
-topCallCount = (Many, 0)
-
-type CallArityEnv = VarEnv CallCount
-
+-- The main analysis function. See Note [Analysis type signature]
callArityAnal ::
Arity -> -- The arity this expression is called with
VarSet -> -- The set of interesting variables
CoreExpr -> -- The expression to analyse
- (CallArityEnv, CoreExpr)
+ (CallArityRes, CoreExpr)
-- How this expression uses its interesting variables
-- and the expression with IdInfo updated
-- The trivial base cases
callArityAnal _ _ e@(Lit _)
- = (emptyVarEnv, e)
+ = (emptyArityRes, e)
callArityAnal _ _ e@(Type _)
- = (emptyVarEnv, e)
+ = (emptyArityRes, e)
callArityAnal _ _ e@(Coercion _)
- = (emptyVarEnv, e)
+ = (emptyArityRes, e)
-- The transparent cases
callArityAnal arity int (Tick t e)
= second (Tick t) $ callArityAnal arity int e
@@ -325,38 +379,27 @@ callArityAnal arity int (Cast e co)
-- The interesting case: Variables, Lambdas, Lets, Applications, Cases
callArityAnal arity int e@(Var v)
| v `elemVarSet` int
- = (unitVarEnv v (OnceAndOnly, arity), e)
+ = (unitArityRes v arity, e)
| otherwise
- = (emptyVarEnv, e)
+ = (emptyArityRes, e)
-- Non-value lambdas are ignored
callArityAnal arity int (Lam v e) | not (isId v)
= second (Lam v) $ callArityAnal arity (int `delVarSet` v) e
--- We have a lambda that we are not sure to call. Tail calls therein
--- are no longer OneAndOnly calls
+-- We have a lambda that may be called multiple times, so its free variables
+-- can all be co-called.
callArityAnal 0 int (Lam v e)
= (ae', Lam v e')
where
(ae, e') = callArityAnal 0 (int `delVarSet` v) e
- ae' = forgetOnceCalls ae
+ ae' = calledMultipleTimes ae
-- We have a lambda that we are calling. decrease arity.
callArityAnal arity int (Lam v e)
= (ae, Lam v e')
where
(ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e
--- For lets, use callArityBind
-callArityAnal arity int (Let bind e)
- = -- pprTrace "callArityAnal:Let"
- -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])
- (final_ae, Let bind' e')
- where
- int_body = int `addInterestingBinds` bind
- (ae_body, e') = callArityAnal arity int_body e
- (final_ae, bind') = callArityBind ae_body int bind
-
-
-- Application. Increase arity for the called expresion, nothing to know about
-- the second
callArityAnal arity int (App e (Type t))
@@ -367,13 +410,9 @@ callArityAnal arity int (App e1 e2)
(ae1, e1') = callArityAnal (arity + 1) int e1
(ae2, e2') = callArityAnal 0 int e2
-- See Note [Case and App: Which side to take?]
- final_ae = ae1 `useBetterOf` ae2
+ final_ae = ae1 `both` ae2
--- Case expression. Here we decide whether
--- we want to look at calls from the scrunitee or the alternatives;
--- one of them we set to Nothing.
--- Naive idea: If there are interesting calls in the scrunitee,
--- zap the alternatives
+-- Case expression.
callArityAnal arity int (Case scrut bndr ty alts)
= -- pprTrace "callArityAnal:Case"
-- (vcat [ppr scrut, ppr final_ae])
@@ -382,147 +421,201 @@ callArityAnal arity int (Case scrut bndr ty alts)
(alt_aes, alts') = unzip $ map go alts
go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e
in (ae, (dc, bndrs, e'))
- alt_ae = foldl lubEnv emptyVarEnv alt_aes
+ alt_ae = lubRess alt_aes
(scrut_ae, scrut') = callArityAnal 0 int scrut
-- See Note [Case and App: Which side to take?]
- final_ae = scrut_ae `useBetterOf` alt_ae
+ final_ae = scrut_ae `both` alt_ae
+
+-- For lets, use callArityBind
+callArityAnal arity int (Let bind e)
+ = -- pprTrace "callArityAnal:Let"
+ -- (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])
+ (final_ae, Let bind' e')
+ where
+ int_body = int `addInterestingBinds` bind
+ (ae_body, e') = callArityAnal arity int_body e
+ (final_ae, bind') = callArityBind ae_body int bind
+
+-- This is a variant of callArityAnal that is additionally told whether
+-- the expression is called once or multiple times, and treats thunks appropriately.
+-- It also returns the actual arity that can be used for this expression.
+callArityBound :: Bool -> Arity -> VarSet -> CoreExpr -> (CallArityRes, Arity, CoreExpr)
+callArityBound called_once arity int e
+ = -- pprTrace "callArityBound" (vcat [ppr (called_once, arity), ppr is_thunk, ppr safe_arity]) $
+ (final_ae, safe_arity, e')
+ where
+ is_thunk = not (exprIsHNF e)
+
+ safe_arity | called_once = arity
+ | is_thunk = 0 -- A thunk! Do not eta-expand
+ | otherwise = arity
+
+ (ae, e') = callArityAnal safe_arity int e
+
+ final_ae | called_once = ae
+ | safe_arity == 0 = ae -- If it is not a function, its body is evaluated only once
+ | otherwise = calledMultipleTimes ae
+
-- Which bindings should we look at?
-- See Note [Which variables are interesting]
interestingBinds :: CoreBind -> [Var]
-interestingBinds bind =
- map fst $ filter go $ case bind of (NonRec v e) -> [(v,e)]
- (Rec ves) -> ves
- where
- go (v,e) = exprArity e < length (typeArity (idType v))
+interestingBinds = filter go . bindersOf
+ where go v = 0 < length (typeArity (idType v))
addInterestingBinds :: VarSet -> CoreBind -> VarSet
addInterestingBinds int bind
= int `delVarSetList` bindersOf bind -- Possible shadowing
`extendVarSetList` interestingBinds bind
--- This function pretens a (Many 0) call for every variable bound in the binder
--- that is not interesting, as calls to these are not reported by the analysis.
-fakeBoringCalls :: VarSet -> CoreBind -> CallArityEnv
-fakeBoringCalls int bind
- = mkVarEnv [ (v, topCallCount) | v <- bindersOf bind, not (v `elemVarSet` int) ]
-
-- Used for both local and top-level binds
-- First argument is the demand from the body
-callArityBind :: CallArityEnv -> VarSet -> CoreBind -> (CallArityEnv, CoreBind)
-
+callArityBind :: CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
-- Non-recursive let
callArityBind ae_body int (NonRec v rhs)
+ | otherwise
= -- pprTrace "callArityBind:NonRec"
-- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
(final_ae, NonRec v' rhs')
where
- callcount = lookupWithDefaultVarEnv ae_body topCallCount v
- (ae_rhs, safe_arity, rhs') = callArityBound callcount int rhs
- final_ae = ae_rhs `lubEnv` (ae_body `delVarEnv` v)
+ (arity, called_once) = lookupCallArityRes ae_body v
+ (ae_rhs, safe_arity, rhs') = callArityBound called_once arity int rhs
+ final_ae = callArityNonRecEnv v ae_rhs ae_body
v' = v `setIdCallArity` safe_arity
-- Recursive let. See Note [Recursion and fixpointing]
callArityBind ae_body int b@(Rec binds)
- = (final_ae, Rec binds')
+ = -- pprTrace "callArityBind:Rec"
+ -- (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) $
+ (final_ae, Rec binds')
where
int_body = int `addInterestingBinds` b
- -- We are ignoring calls to boring binds, so we need to pretend them here!
- ae_body' = ae_body `lubEnv` (fakeBoringCalls int_body b)
- (ae_rhs, binds') = callArityFix ae_body' int_body [(i,Nothing,e) | (i,e) <- binds]
- final_ae = ae_rhs `delVarEnvList` interestingBinds b
-
--- Here we do the fix-pointing for possibly mutually recursive values. The
--- idea is that we start with the calls coming from the body, and analyize
--- every called value with that arity, adding lub these calls into the
--- environment. We also remember for each variable the CallCount we analised it
--- with. Then we check for every variable if in the new envrionment, it is
--- called with a different (i.e. lower) arity. If so, we reanalize that, and
--- lub the result back into the environment. If we had a change for any of the
--- variables, we repeat this step, otherwise we are done.
-callArityFix ::
- CallArityEnv -> VarSet ->
- [(Id, Maybe CallCount, CoreExpr)] ->
- (CallArityEnv, [(Id, CoreExpr)])
-callArityFix ae int ann_binds
- | any_change
- = callArityFix ae' int ann_binds'
- | otherwise
- = (ae', map (\(i, a, e) -> (i `setArity` a, e)) ann_binds')
- where
- (changes, ae's, ann_binds') = unzip3 $ map rerun ann_binds
- any_change = or changes
- ae' = foldl lubEnv ae ae's
+ (ae_rhs, binds') = fix initial_binds
+ final_ae = bindersOf b `resDelList` ae_rhs
- rerun (i, mbArity, rhs)
-
- | mb_new_arity == mbArity
- -- No change. No need to re-analize, and no need to change the arity
- -- environment
- = (False, emptyVarEnv, (i,mbArity, rhs))
-
- | Just new_arity <- mb_new_arity
- -- We previously analized this with a different arity (or not at all)
- = let (ae_rhs, safe_arity, rhs') = callArityBound new_arity int rhs
- in (True, ae_rhs, (i `setIdCallArity` safe_arity, mb_new_arity, rhs'))
+ initial_binds = [(i,Nothing,e) | (i,e) <- binds]
+ fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])
+ fix ann_binds
+ | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $
+ any_change
+ = fix ann_binds'
| otherwise
- -- No call to this yet, so do nothing
- = (False, emptyVarEnv, (i, mbArity, rhs))
+ = (ae, map (\(i, _, e) -> (i, e)) ann_binds')
where
- mb_new_arity = lookupVarEnv ae i
-
- setArity i Nothing = i -- Completely absent value
- setArity i (Just (_, a)) = i `setIdCallArity` a
-
-
--- This is a variant of callArityAnal that takes a CallCount (i.e. an arity with a
--- cardinality) and adjust the resulting environment accordingly. It is to be used
--- on bound expressions that can possibly be shared.
--- It also returns the safe arity used: For a thunk that is called multiple
--- times, this will be 0!
-callArityBound :: CallCount -> VarSet -> CoreExpr -> (CallArityEnv, Arity, CoreExpr)
-callArityBound (count, arity) int e = (final_ae, safe_arity, e')
- where
- is_thunk = not (exprIsHNF e)
-
- safe_arity | OnceAndOnly <- count = arity
- | is_thunk = 0 -- A thunk! Do not eta-expand
- | otherwise = arity
-
- (ae, e') = callArityAnal safe_arity int e
-
- final_ae | OnceAndOnly <- count = ae
- | otherwise = forgetOnceCalls ae
-
-
-anyGoodCalls :: CallArityEnv -> Bool
-anyGoodCalls = foldVarEnv ((||) . isOnceCall) False
-
-isOnceCall :: CallCount -> Bool
-isOnceCall (OnceAndOnly, _) = True
-isOnceCall (Many, _) = False
-
-forgetOnceCalls :: CallArityEnv -> CallArityEnv
-forgetOnceCalls = mapVarEnv (first (const Many))
-
--- See Note [Case and App: Which side to take?]
-useBetterOf :: CallArityEnv -> CallArityEnv -> CallArityEnv
-useBetterOf ae1 ae2 | anyGoodCalls ae1 = ae1 `lubEnv` forgetOnceCalls ae2
-useBetterOf ae1 ae2 | otherwise = forgetOnceCalls ae1 `lubEnv` ae2
+ aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]
+ ae = callArityRecEnv aes_old ae_body
+
+ rerun (i, mbLastRun, rhs)
+ | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)
+ -- No call to this yet, so do nothing
+ = (False, (i, Nothing, rhs))
+
+ | Just (old_called_once, old_arity, _) <- mbLastRun
+ , called_once == old_called_once
+ , new_arity == old_arity
+ -- No change, no need to re-analize
+ = (False, (i, mbLastRun, rhs))
+
+ | otherwise
+ -- We previously analized this with a different arity (or not at all)
+ = let (ae_rhs, safe_arity, rhs') = callArityBound called_once new_arity int_body rhs
+ in (True, (i `setIdCallArity` safe_arity, Just (called_once, new_arity, ae_rhs), rhs'))
+ where
+ (new_arity, called_once) = lookupCallArityRes ae i
+
+ (changes, ann_binds') = unzip $ map rerun ann_binds
+ any_change = or changes
+
+-- Combining the results from body and rhs, non-recursive case
+-- See Note [Analysis II: The Co-Called analysis]
+callArityNonRecEnv :: Var -> CallArityRes -> CallArityRes -> CallArityRes
+callArityNonRecEnv v ae_rhs ae_body
+ = addCrossCoCalls called_by_v called_with_v $ ae_rhs `lubRes` resDel v ae_body
+ where
+ called_by_v = domRes ae_rhs
+ called_with_v = calledWith ae_body v `delUnVarSet` v
+
+-- Combining the results from body and rhs, (mutually) recursive case
+-- See Note [Analysis II: The Co-Called analysis]
+callArityRecEnv :: [(Var, CallArityRes)] -> CallArityRes -> CallArityRes
+callArityRecEnv ae_rhss ae_body
+ = -- pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new])
+ ae_new
+ where
+ vars = map fst ae_rhss
-lubCallCount :: CallCount -> CallCount -> CallCount
-lubCallCount (count1, arity1) (count2, arity2)
- = (count1 `lubCount` count2, arity1 `min` arity2)
+ ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body
-lubCount :: Count -> Count -> Count
-lubCount OnceAndOnly OnceAndOnly = OnceAndOnly
-lubCount _ _ = Many
+ cross_calls = unionUnVarGraphs $ map cross_call ae_rhss
+ cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v
+ where
+ is_thunk = idCallArity v == 0
+ -- What rhs are relevant as happening before (or after) calling v?
+ -- If v is a thunk, everything from all the _other_ variables
+ -- If v is not a thunk, everything can happen.
+ ae_before_v | is_thunk = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body
+ | otherwise = ae_combined
+ -- What do we want to know from these?
+ -- Which calls can happen next to any recursive call.
+ called_with_v
+ = unionUnVarSets $ map (calledWith ae_before_v) vars
+ called_by_v = domRes ae_rhs
+
+ ae_new = first (cross_calls `unionUnVarGraph`) ae_combined
+
+---------------------------------------
+-- Functions related to CallArityRes --
+---------------------------------------
+
+-- Result type for the two analyses.
+-- See Note [Analysis I: The arity analyis]
+-- and Note [Analysis II: The Co-Called analysis]
+type CallArityRes = (UnVarGraph, VarEnv Arity)
+
+emptyArityRes :: CallArityRes
+emptyArityRes = (emptyUnVarGraph, emptyVarEnv)
+
+unitArityRes :: Var -> Arity -> CallArityRes
+unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)
+
+resDelList :: [Var] -> CallArityRes -> CallArityRes
+resDelList vs ae = foldr resDel ae vs
+
+resDel :: Var -> CallArityRes -> CallArityRes
+resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)
+
+domRes :: CallArityRes -> UnVarSet
+domRes (_, ae) = varEnvDom ae
+
+-- In the result, find out the minimum arity and whether the variable is called
+-- at most once.
+lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)
+lookupCallArityRes (g, ae) v
+ = case lookupVarEnv ae v of
+ Just a -> (a, not (v `elemUnVarSet` (neighbors g v)))
+ Nothing -> (0, False)
+
+calledWith :: CallArityRes -> Var -> UnVarSet
+calledWith (g, _) v = neighbors g v
+
+addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
+addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)
+
+-- Replaces the co-call graph by a complete graph (i.e. no information)
+calledMultipleTimes :: CallArityRes -> CallArityRes
+calledMultipleTimes res = first (const (completeGraph (domRes res))) res
+
+-- Used for application and cases
+both :: CallArityRes -> CallArityRes -> CallArityRes
+both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2
-- Used when combining results from alternative cases; take the minimum
-lubEnv :: CallArityEnv -> CallArityEnv -> CallArityEnv
-lubEnv = plusVarEnv_C lubCallCount
+lubRes :: CallArityRes -> CallArityRes -> CallArityRes
+lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)
+
+lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
+lubArityEnv = plusVarEnv_C min
-instance Outputable Count where
- ppr Many = text "Many"
- ppr OnceAndOnly = text "OnceAndOnly"
+lubRess :: [CallArityRes] -> CallArityRes
+lubRess = foldl lubRes emptyArityRes
diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs
new file mode 100644
index 0000000000000000000000000000000000000000..228f3b5220bbdad235e83f8b4d6d52b844052205
--- /dev/null
+++ b/compiler/utils/UnVarGraph.hs
@@ -0,0 +1,136 @@
+{-
+
+Copyright (c) 2014 Joachim Breitner
+
+A data structure for undirected graphs of variables
+(or in plain terms: Sets of unordered pairs of numbers)
+
+
+This is very specifically tailored for the use in CallArity. In particular it
+stores the graph as a union of complete and complete bipartite graph, which
+would be very expensive to store as sets of edges or as adjanceny lists.
+
+It does not normalize the graphs. This means that g `unionUnVarGraph` g is
+equal to g, but twice as expensive and large.
+
+-}
+module UnVarGraph
+ ( UnVarSet
+ , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
+ , delUnVarSet
+ , elemUnVarSet, isEmptyUnVarSet
+ , UnVarGraph
+ , emptyUnVarGraph
+ , unionUnVarGraph, unionUnVarGraphs
+ , completeGraph, completeBipartiteGraph
+ , neighbors
+ , delNode
+ ) where
+
+import Id
+import VarEnv
+import UniqFM
+import Outputable
+import Data.List
+import Bag
+import Unique
+
+import qualified Data.IntSet as S
+
+-- We need a type for sets of variables (UnVarSet).
+-- We do not use VarSet, because for that we need to have the actual variable
+-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
+-- Therefore, use a IntSet directly (which is likely also a bit more efficient).
+
+-- Set of uniques, i.e. for adjancet nodes
+newtype UnVarSet = UnVarSet (S.IntSet)
+ deriving Eq
+
+k :: Var -> Int
+k v = getKey (getUnique v)
+
+emptyUnVarSet :: UnVarSet
+emptyUnVarSet = UnVarSet S.empty
+
+elemUnVarSet :: Var -> UnVarSet -> Bool
+elemUnVarSet v (UnVarSet s) = k v `S.member` s
+
+
+isEmptyUnVarSet :: UnVarSet -> Bool
+isEmptyUnVarSet (UnVarSet s) = S.null s
+
+delUnVarSet :: UnVarSet -> Var -> UnVarSet
+delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
+
+mkUnVarSet :: [Var] -> UnVarSet
+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
+
+varEnvDom :: VarEnv a -> UnVarSet
+varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
+
+unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
+unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
+
+unionUnVarSets :: [UnVarSet] -> UnVarSet
+unionUnVarSets = foldr unionUnVarSet emptyUnVarSet
+
+instance Outputable UnVarSet where
+ ppr (UnVarSet s) = braces $
+ hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
+
+
+-- The graph type. A list of complete bipartite graphs
+data Gen = CBPG UnVarSet UnVarSet -- complete bipartite
+ | CG UnVarSet -- complete
+newtype UnVarGraph = UnVarGraph (Bag Gen)
+
+emptyUnVarGraph :: UnVarGraph
+emptyUnVarGraph = UnVarGraph emptyBag
+
+unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
+{-
+Premature optimisation, it seems.
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+ | s1 == s3 && s2 == s4
+ = pprTrace "unionUnVarGraph fired" empty $
+ completeGraph (s1 `unionUnVarSet` s2)
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+ | s2 == s3 && s1 == s4
+ = pprTrace "unionUnVarGraph fired2" empty $
+ completeGraph (s1 `unionUnVarSet` s2)
+-}
+unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)
+ = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $
+ UnVarGraph (g1 `unionBags` g2)
+
+unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
+
+-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
+completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2
+
+completeGraph :: UnVarSet -> UnVarGraph
+completeGraph s = prune $ UnVarGraph $ unitBag $ CG s
+
+neighbors :: UnVarGraph -> Var -> UnVarSet
+neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g
+ where go (CG s) = (if v `elemUnVarSet` s then [s] else [])
+ go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++
+ (if v `elemUnVarSet` s2 then [s1] else [])
+
+delNode :: UnVarGraph -> Var -> UnVarGraph
+delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g
+ where go (CG s) = CG (s `delUnVarSet` v)
+ go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)
+
+prune :: UnVarGraph -> UnVarGraph
+prune (UnVarGraph g) = UnVarGraph $ filterBag go g
+ where go (CG s) = not (isEmptyUnVarSet s)
+ go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)
+
+instance Outputable Gen where
+ ppr (CG s) = ppr s <> char '²'
+ ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2
+instance Outputable UnVarGraph where
+ ppr (UnVarGraph g) = ppr g
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 52cd3dd7915ed72c9c066e64d3ca3668b995679d..a13a17c412f14e0c5a9b7b28b30c664950bb8749 100644
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -58,6 +58,7 @@ module UniqFM (
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM, keysUFM, splitUFM,
+ ufmToSet_Directly,
ufmToList,
joinUFM
) where
@@ -69,6 +70,7 @@ import Compiler.Hoopl hiding (Unique)
import Data.Function (on)
import qualified Data.IntMap as M
+import qualified Data.IntSet as S
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
import Data.Typeable
@@ -180,6 +182,7 @@ lookupWithDefaultUFM_Directly
:: UniqFM elt -> elt -> Unique -> elt
keysUFM :: UniqFM elt -> [Unique] -- Get the keys
eltsUFM :: UniqFM elt -> [elt]
+ufmToSet_Directly :: UniqFM elt -> S.IntSet
ufmToList :: UniqFM elt -> [(Unique, elt)]
\end{code}
@@ -293,6 +296,7 @@ lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
keysUFM (UFM m) = map getUnique $ M.keys m
eltsUFM (UFM m) = M.elems m
+ufmToSet_Directly (UFM m) = M.keysSet m
ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
-- Hoopl
diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs
index ddfc8586c9c31a2d56e14b5b2afd2a12b2fa8fa7..8a142d54c730614f9141cd6f517188b1318ddd4a 100644
--- a/testsuite/tests/callarity/unittest/CallArity1.hs
+++ b/testsuite/tests/callarity/unittest/CallArity1.hs
@@ -57,11 +57,12 @@ exprs =
mkLams [z] $ Var d `mkVarApps` [x] )$
Var go2 `mkApps` [mkLit 1] ) $
go `mkLApps` [0, 0]
- , ("d0",) $
+ , ("d0 (go 2 would be bad)",) $
mkRFun go [x]
(mkLet d (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)
- ) $ mkLams [z] $ Var f `mkApps` [ Var d `mkVarApps` [x], Var d `mkVarApps` [x] ]) $
+ ) $
+ mkLams [z] $ Var f `mkApps` [ Var d `mkVarApps` [x], Var d `mkVarApps` [x] ]) $
go `mkLApps` [0, 0]
, ("go2 (in case crut)",) $
mkRFun go [x]
@@ -90,7 +91,11 @@ exprs =
(mkLams [y] $ Var y)
) $ mkLams [z] $ Var d `mkVarApps` [x]) $
Var f `mkApps` [Var z, go `mkLApps` [0, 0]]
- , ("two recursions (both arity 1 would be good!)",) $
+ , ("two calls, one from let and from body (d 1 would be bad)",) $
+ mkLet d (mkACase (mkLams [y] $ mkLit 0) (mkLams [y] $ mkLit 0)) $
+ mkFun go [x,y] (mkVarApps (Var d) [x]) $
+ mkApps (Var d) [mkLApps go [1,2]]
+ , ("two recursions",) $
mkRLet n (mkACase (mkLams [y] $ mkLit 0) (Var n)) $
mkRLet d (mkACase (mkLams [y] $ mkLit 0) (Var d)) $
Var n `mkApps` [d `mkLApps` [0]]
@@ -135,6 +140,29 @@ exprs =
Let (Rec [ (go, mkLams [x, y] (Var d `mkApps` [go2 `mkLApps` [1,2]]))
, (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
Var d `mkApps` [go2 `mkLApps` [0,1]]
+ , ("a thunk (non-function-type), called twice, still calls once",) $
+ mkLet d (f `mkLApps` [0]) $
+ mkLet x (d `mkLApps` [1]) $
+ Var f `mkVarApps` [x, x]
+ , ("a thunk (function type), called multiple times, still calls once",) $
+ mkLet d (f `mkLApps` [0]) $
+ mkLet n (Var f `mkApps` [d `mkLApps` [1]]) $
+ mkLams [x] $ Var n `mkVarApps` [x]
+ , ("a thunk (non-function-type), in mutual recursion, still calls once (d 1 would be good)",) $
+ mkLet d (f `mkLApps` [0]) $
+ Let (Rec [ (x, Var d `mkApps` [go `mkLApps` [1,2]])
+ , (go, mkLams [x] $ mkACase (mkLams [z] $ Var x) (Var go `mkVarApps` [x]) ) ]) $
+ Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
+ , ("a thunk (function type), in mutual recursion, still calls once (d 1 would be good)",) $
+ mkLet d (f `mkLApps` [0]) $
+ Let (Rec [ (n, Var go `mkApps` [d `mkLApps` [1]])
+ , (go, mkLams [x] $ mkACase (Var n) (Var go `mkApps` [Var n `mkVarApps` [x]]) ) ]) $
+ Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
+ , ("a thunk (function type), in mutual recursion, still calls once, d part of mutual recursion (d 1 would be good)",) $
+ Let (Rec [ (d, Var f `mkApps` [n `mkLApps` [1]])
+ , (n, Var go `mkApps` [d `mkLApps` [1]])
+ , (go, mkLams [x] $ mkACase (Var n) (Var go `mkApps` [Var n `mkVarApps` [x]]) ) ]) $
+ Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
]
main = do
diff --git a/testsuite/tests/callarity/unittest/CallArity1.stderr b/testsuite/tests/callarity/unittest/CallArity1.stderr
index eebeaf8d2da87675ec59f78cc885961476c5d8d5..d5d7d91f77f0d1e2a6aa83223ba380a83ff5cb60 100644
--- a/testsuite/tests/callarity/unittest/CallArity1.stderr
+++ b/testsuite/tests/callarity/unittest/CallArity1.stderr
@@ -6,7 +6,7 @@ nested_go2:
go2 2
d 1
n 1
-d0:
+d0 (go 2 would be bad):
go 1
d 0
go2 (in case crut):
@@ -23,8 +23,11 @@ go2 (using surrounding boring let):
go 2
d 1
z 0
-two recursions (both arity 1 would be good!):
+two calls, one from let and from body (d 1 would be bad):
+ go 2
d 0
+two recursions:
+ d 1
n 1
two recursions (semantically like the previous case):
d 1
@@ -54,6 +57,24 @@ mutual recursion (functions), but no thunks:
go 2
go2 2
mutual recursion (functions), one boring (d 1 would be bad):
- go 0
+ go 2
go2 2
d 0
+a thunk (non-function-type), called twice, still calls once:
+ x 0
+ d 1
+a thunk (function type), called multiple times, still calls once:
+ d 1
+ n 0
+a thunk (non-function-type), in mutual recursion, still calls once (d 1 would be good):
+ go 2
+ x 0
+ d 1
+a thunk (function type), in mutual recursion, still calls once (d 1 would be good):
+ go 1
+ d 1
+ n 0
+a thunk (function type), in mutual recursion, still calls once, d part of mutual recursion (d 1 would be good):
+ go 1
+ d 1
+ n 0
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index f8ab5cf26538f016149aa2e360ff0b90a0481658..fc0abc9131d81b29cc60b93e62e25203da3cd4d6 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -392,10 +392,11 @@ test('T6048',
[(wordsize(32), 48887164, 10),
# prev: 38000000 (x86/Linux)
# 2012-10-08: 48887164 (x86/Linux)
- (wordsize(64), 95960720, 10)])
+ (wordsize(64), 110646312, 10)])
# 18/09/2012 97247032 amd64/Linux
# 16/01/2014 108578664 amd64/Linux (unknown, likely foldl-via-foldr)
# 18/01/2014 95960720 amd64/Linux Call Arity improvements
# 28/02/2014 105556793 amd64/Linux (unknown, tweak in base/4d9e7c9e3 resulted in change)
+ # 05/03/2014 110646312 amd64/Linux Call Arity became more elaborate
],
compile,[''])