[commit: ghc] wip/T7994-calledArity: Do not be too strict about things being tail-calls (6f18b41)

[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/6f18b415a21b0e63513f1742331b47bfde006de1/ghc

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

commit 6f18b415a21b0e63513f1742331b47bfde006de1
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jan 28 14:27:30 2014 +0000

    Do not be too strict about things being tail-calls
    
    It is ok to take the information from the scrunitee of a case, as long
    as then, any information from the body is Nothing’ified.


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

6f18b415a21b0e63513f1742331b47bfde006de1
 compiler/coreSyn/CoreArity.lhs |   14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 287087b..0088dab 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -42,7 +42,7 @@ import FastString
 import Pair
 import Util     ( debugIsOn )
 import Control.Arrow ( second )
-import Data.Maybe ( fromMaybe )
+import Data.Maybe ( fromMaybe, isJust )
 \end{code}
 
 %************************************************************************
@@ -1205,7 +1205,11 @@ callArityAnal arity int (App e1 e2)
     (ae2, e2') = callArityAnal 0           int e2
     final_ae = ae1 `lubEnv` forgetTailCalls ae2
 
--- Case expression. Not much happening here.
+-- 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
 callArityAnal arity int (Case scrut bndr ty alts)
     = -- pprTrace "callArityAnal:Case"
       --          (vcat [ppr scrut, ppr final_ae])
@@ -1215,7 +1219,8 @@ callArityAnal arity int (Case scrut bndr ty alts)
     go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e
                         in  (ae, (dc, bndrs, e'))
     (ae, scrut') = callArityAnal 0 int scrut
-    final_ae = foldl lubEnv (forgetTailCalls ae) aes
+    final_ae | anyTailCalls ae = foldl lubEnv ae $ map forgetTailCalls aes
+             | otherwise       = foldl lubEnv (forgetTailCalls ae) aes
 
 callArityFix :: Arity -> VarSet -> Id -> CoreExpr -> (CallArityEnv, Maybe Arity, CoreExpr)
 callArityFix arity int v e
@@ -1235,6 +1240,9 @@ callArityFix arity int v e
     new_arity = lookupWithDefaultVarEnv ae Nothing v
 
 
+anyTailCalls :: VarEnv (Maybe Arity) -> Bool
+anyTailCalls = foldVarEnv ((||) . isJust) False
+
 forgetTailCalls :: VarEnv (Maybe Arity) -> VarEnv (Maybe Arity)
 forgetTailCalls = mapVarEnv (const Nothing)