Call Arity: Resurrect fakeBoringCalls

(Otherwise the analysis was wrong, as covered by the new test case.)

compiler/simplCore/CallArity.hs

@@ -348,7 +348,8 @@ callArityTopLvl exported int1 (b:bs)
     exported' = filter isExportedId int2 ++ exported
     int' = int1 `addInterestingBinds` b
     (ae1, bs') = callArityTopLvl exported' int' bs
-    (ae2, b')  = callArityBind ae1 int1 b
+    ae1' = fakeBoringCalls int' b ae1
+    (ae2, b')  = callArityBind ae1' int1 b
 
 
 callArityRHS :: CoreExpr -> CoreExpr
@@ -434,7 +435,8 @@ callArityAnal arity int (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
+    ae_body' = fakeBoringCalls int_body bind ae_body
+    (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.
@@ -468,6 +470,16 @@ addInterestingBinds int bind
     = int `delVarSetList`    bindersOf bind -- Possible shadowing
           `extendVarSetList` interestingBinds bind
 
+-- For every boring variable in the binder, this amends the CallArityRes to
+-- report safe information about them (co-called with everything else, arity 0).
+fakeBoringCalls :: VarSet -> CoreBind -> CallArityRes -> CallArityRes
+fakeBoringCalls int bind res
+    = addCrossCoCalls (domRes boring) (domRes res) $ (boring `lubRes` res)
+  where
+    boring = ( emptyUnVarGraph
+             ,  mkVarEnv [ (v, 0) | v <- bindersOf bind, not (v `elemVarSet` int)])
+
+
 -- Used for both local and top-level binds
 -- First argument is the demand from the body
 callArityBind :: CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)

testsuite/tests/callarity/unittest/CallArity1.hs

@@ -163,6 +163,10 @@ exprs =
              , (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 (non-function-type) co-calls with the body (d 1 would be bad)",) $
+    mkLet d (f `mkLApps` [0]) $
+        mkLet x (d `mkLApps` [1]) $
+            Var d `mkVarApps` [x]
   ]
 
 main = do

testsuite/tests/callarity/unittest/CallArity1.stderr

@@ -78,3 +78,6 @@ a thunk (function type), in mutual recursion, still calls once, d part of mutual
     go 1
     d 1
     n 0
+a thunk (non-function-type) co-calls with the body (d 1 would be bad):
+    x 0
+    d 0

testsuite/tests/perf/compiler/all.T

@@ -133,7 +133,7 @@ test('T3294',
            # 2012-10-08:  1373514844 (x86/Linux)
            # 2013-11-13: 1478325844  (x86/Windows, 64bit machine)
            # 2014-01-12: 1565185140  (x86/Linux)
-           (wordsize(64), 2897630040, 5)]),
+           (wordsize(64), 2705289664, 5)]),
             # old:        1357587088 (amd64/Linux)
             # 29/08/2012: 2961778696 (amd64/Linux)
             # (^ increase due to new codegen, see #7198)
@@ -141,6 +141,7 @@ test('T3294',
             # 08/06/2013: 2901451552 (amd64/Linux) (reason unknown)
             # 12/12/2013: 3083825616 (amd64/Linux) (reason unknown)
             # 18/02/2014: 2897630040 (amd64/Linux) (call arity improvements)
+            # 12/03/2014: 2705289664 (amd64/Linux) (more call arity improvements)
       conf_3294
       ],
      compile,