[commit: ghc] wip/T7994-calledArity: Call Arity refactoring: fakeBoringCalls (af7428e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T7994-calledArity
Link       : http://ghc.haskell.org/trac/ghc/changeset/af7428e8bfe056cccb5035c21a91c6117a908c1a/ghc

>---------------------------------------------------------------

commit af7428e8bfe056cccb5035c21a91c6117a908c1a
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Feb 18 19:02:24 2014 +0000

    Call Arity refactoring: fakeBoringCalls


>---------------------------------------------------------------

af7428e8bfe056cccb5035c21a91c6117a908c1a
 compiler/simplCore/CallArity.hs |   17 ++++++-----------
 1 file changed, 6 insertions(+), 11 deletions(-)

diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index 7f62070..f3fedb5 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -396,21 +396,16 @@ interestingBinds bind =
   where
     go (v,e) = exprArity e < length (typeArity (idType v))
 
-boringBinds :: CoreBind -> [Var]
-boringBinds 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))
-
 addInterestingBinds :: VarSet -> CoreBind -> VarSet
 addInterestingBinds int bind
     = int `delVarSetList`    bindersOf bind -- Possible shadowing
           `extendVarSetList` interestingBinds bind
 
-addBoringCalls :: CallArityEnv -> CoreBind -> CallArityEnv
-addBoringCalls ae bind
-    = ae `lubEnv` (mkVarEnv $ zip (boringBinds bind) (repeat topCallCount))
+-- 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
@@ -433,7 +428,7 @@ callArityBind ae_body int b@(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 `addBoringCalls` b
+    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