[commit: ghc] wip/T7994-calledArity: Consider less lets as interesting (0a551b0)

[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/0a551b05bdc1be7224ee18202c83980405fc9232/ghc

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

commit 0a551b05bdc1be7224ee18202c83980405fc9232
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jan 28 23:26:39 2014 +0000

    Consider less lets as interesting
    
    if there is no eta-expansion possible, do not consider that. This is a
    win because uninteresting lets can cause the code to choose the wrong
    side in a case/app. But it could also be a loss if the interesting call
    path passes through a fully expanded function. We'll see.


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

0a551b05bdc1be7224ee18202c83980405fc9232
 compiler/coreSyn/CoreArity.lhs |   18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 4903bf8..6ffce8e 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -1129,6 +1129,15 @@ callArityAnal arity int (Lam v e)
   where
     (ae, e') = callArityAnal (arity - 1) int e
 
+-- Boring non-recursive let, i.e. no eta expansion possible. do not be smart about this
+callArityAnal arity int (Let (NonRec v rhs) e)
+    | exprArity rhs >= length (typeArity (idType v))
+    = (ae_final, Let (NonRec v rhs') e')
+  where
+    (ae_rhs, rhs') = callArityAnal 0 int rhs
+    (ae_body, e')  = callArityAnal arity int e
+    ae_final = forgetTailCalls ae_rhs `lubEnv` ae_body
+
 -- Non-recursive let. Find out how the body calls the rhs, analise that,
 -- and combine the results, convervatively using both
 callArityAnal arity int (Let (NonRec v rhs) e)
@@ -1158,6 +1167,15 @@ callArityAnal arity int (Let (NonRec v rhs) e)
     ae_body' = ae_body `delVarEnv` v
     rhs_arity = lookupWithDefaultVarEnv ae_body Nothing v
 
+-- Boring recursive let, i.e. no eta expansion possible. do not be smart about this
+callArityAnal arity int (Let (Rec [(v,rhs)]) e)
+    | exprArity rhs >= length (typeArity (idType v))
+    = (ae_final, Let (Rec [(v,rhs')]) e')
+  where
+    (ae_rhs, rhs') = callArityAnal 0 int rhs
+    (ae_body, e')  = callArityAnal arity int e
+    ae_final = forgetTailCalls ae_rhs `lubEnv` ae_body
+
 -- Recursive let. Again, find out how the body calls the rhs, analise that,
 -- but then check if it is compatible with how rhs calls itself. If not,
 -- retry with lower arity.