[commit: ghc] wip/better-ho-cardinality: Return exprArity, not manifestArity (753b254)

[git at git.haskell.org]

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

On branch  : wip/better-ho-cardinality
Link       : http://ghc.haskell.org/trac/ghc/changeset/753b25499fa0060ff403c3bb592b343ff98abe81/ghc

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

commit 753b25499fa0060ff403c3bb592b343ff98abe81
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Dec 11 18:20:21 2013 +0000

    Return exprArity, not manifestArity
    
    This patch was authored by SPJ, and extracted from "Improve the handling
    of used-once stuff" by Joachim.


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

753b25499fa0060ff403c3bb592b343ff98abe81
 compiler/simplCore/SimplUtils.lhs |   19 ++++++++++++++++---
 1 file changed, 16 insertions(+), 3 deletions(-)

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 6c7dcc2..36f292d 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -1195,8 +1195,11 @@ tryEtaExpandRhs env bndr rhs
   = do { dflags <- getDynFlags
        ; (new_arity, new_rhs) <- try_expand dflags
 
-       ; WARN( new_arity < old_arity || new_arity < _dmd_arity,
-               (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_arity
+       ; WARN( new_arity < old_arity,
+               (ptext (sLit "Arity decrease:") <+> (ppr bndr
+                <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )
+         WARN( new_arity < _dmd_arity,
+               (ptext (sLit "Arity less than dmd sig arity:") <+> (ppr bndr
                 <+> ppr new_arity <+> ppr _dmd_arity) $$ ppr new_rhs) )
                         -- Note [Arity decrease]
          return (new_arity, new_rhs) }
@@ -1211,13 +1214,23 @@ tryEtaExpandRhs env bndr rhs
       = do { tick (EtaExpansion bndr)
            ; return (new_arity, etaExpand new_arity rhs) }
       | otherwise
-      = return (manifest_arity, rhs)
+      = return (exprArity rhs, rhs)   -- See Note [Return exprArity, not manifestArity]
 
     manifest_arity = manifestArity rhs
     old_arity  = idArity bndr
     _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr
 \end{code}
 
+Note [Return exprArity, not manifestArity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f = \xy. blah
+  g = f 2
+The f will get arity 2, and we want g to get arity 1, even though
+exprEtaExpandArity (and hence findArity) may not eta-expand it.
+Hence tryEtaExpand should return (exprArity (f 2)), not its
+manifest arity (which is zero).
+
 Note [Eta-expanding at let bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We now eta expand at let-bindings, which is where the payoff comes.