Major Call Arity rework

This patch improves the call arity analysis in various ways.

Most importantly, it enriches the analysis result information so that
when looking at a call, we do not have to make a random choice about
what side we want to take the information from. Instead we can combine
the results in a way that does not lose valuable information.

To do so, besides the incoming arities, we store remember "what can be
called with what", i.e. an undirected graph between the (interesting)
free variables of an expression. Of course it makes combining the
results a bit more tricky (especially mutual recursion), but still
doable.

The actually implemation of the graph structure is abstractly put away
in a module of its own (UnVarGraph.hs)

The implementation is geared towards efficiently representing the graphs
that we need (which can contain large complete and large complete
bipartite graphs, which would be huge in other representations). If
someone feels like designing data structures: There is surely some
speed-up to be obtained by improving that data structure.

Additionally, the analysis now takes into account that if a RHS stays a
thunk, then its calls happen only once, even if the variables the RHS is
bound to is evaluated multiple times, or is part of a recursive group.

2 files changed, 55 insertions, 6 deletions

diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs
index ddfc8586c9..8a142d54c7 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 eebeaf8d2d..d5d7d91f77 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