[commit: ghc] ghc-7.10: Trim Call Arity (011f691)

[git at git.haskell.org]

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

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/011f691333aff2833acc900ee3911885e488cf1b/ghc

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

commit 011f691333aff2833acc900ee3911885e488cf1b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sat Mar 21 15:58:38 2015 +0100

    Trim Call Arity
    
    to not accidentially invalidate a strictness signature with a Diverges
    result info. This seems to fix #10176.
    
    (cherry picked from commit b4efac59ef5aac74d382d1fd57652982edddbe75)


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

011f691333aff2833acc900ee3911885e488cf1b
 compiler/simplCore/CallArity.hs                | 51 +++++++++++++++++++++++---
 testsuite/tests/simplCore/should_compile/all.T |  2 +-
 2 files changed, 47 insertions(+), 6 deletions(-)

diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index 5ee5fe2..2f4f107 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -18,6 +18,7 @@ import CoreArity ( typeArity )
 import CoreUtils ( exprIsHNF )
 --import Outputable
 import UnVarGraph
+import Demand
 
 import Control.Arrow ( first, second )
 
@@ -360,6 +361,28 @@ to them. The plan is as follows: Treat the top-level binds as nested lets around
 a body representing “all external calls”, which returns a pessimistic
 CallArityRes (the co-call graph is the complete graph, all arityies 0).
 
+Note [Trimming arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the Call Arity papers, we are working on an untyped lambda calculus with no
+other id annotations, where eta-expansion is always possible. But this is not
+the case for Core!
+ 1. We need to ensure the invariant
+      callArity e <= typeArity (exprType e)
+    for the same reasons that exprArity needs this invariant (see Note
+    [exprArity invariant] in CoreArity).
+
+    If we are not doing that, a too-high arity annotation will be stored with
+    the id, confusing the simplifier later on.
+
+ 2. Eta-expanding a right hand side might invalidate existing annotations. In
+    particular, if an id has a strictness annotation of <...><...>b, then
+    passing one argument to it will definitely bottom out, so the simplifier
+    will throw away additional parameters. This conflicts with Call Arity! So
+    we ensure that we never eta-expand such a value beyond the number of
+    arguments mentioned in the strictness signature.
+    See #10176 for a real-world-example.
+
 -}
 
 -- Main entry point
@@ -508,15 +531,19 @@ callArityBind ae_body int (NonRec v rhs)
     safe_arity | called_once = arity
                | is_thunk    = 0      -- A thunk! Do not eta-expand
                | otherwise   = arity
-    (ae_rhs, rhs') = callArityAnal safe_arity int rhs
+
+    -- See Note [Trimming arity]
+    trimmed_arity = trimArity v safe_arity
+
+    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs
+
 
     ae_rhs'| called_once     = ae_rhs
            | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
            | otherwise       = calledMultipleTimes ae_rhs
 
     final_ae = callArityNonRecEnv v ae_rhs' ae_body
-    v' = v `setIdCallArity` safe_arity
-
+    v' = v `setIdCallArity` trimmed_arity
 
 
 -- Recursive let. See Note [Recursion and fixpointing]
@@ -560,19 +587,33 @@ callArityBind ae_body int b@(Rec binds)
                   safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]
                              | otherwise   = new_arity
 
-                  (ae_rhs, rhs') = callArityAnal safe_arity int_body rhs
+                  -- See Note [Trimming arity]
+                  trimmed_arity = trimArity i safe_arity
+
+                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs
 
                   ae_rhs' | called_once     = ae_rhs
                           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
                           | otherwise       = calledMultipleTimes ae_rhs
 
-              in (True, (i `setIdCallArity` safe_arity, Just (called_once, new_arity, ae_rhs'), rhs'))
+              in (True, (i `setIdCallArity` trimmed_arity, Just (called_once, new_arity, ae_rhs'), rhs'))
           where
             (new_arity, called_once)  = lookupCallArityRes ae i
 
         (changes, ann_binds') = unzip $ map rerun ann_binds
         any_change = or changes
 
+-- See Note [Trimming arity]
+trimArity :: Id -> Arity -> Arity
+trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]
+  where
+    max_arity_by_type = length (typeArity (idType v))
+    max_arity_by_strsig
+        | isBotRes result_info = length demands
+        | otherwise = a
+
+    (demands, result_info) = splitStrictSig (idStrictness v)
+
 -- Combining the results from body and rhs, non-recursive case
 -- See Note [Analysis II: The Co-Called analysis]
 callArityNonRecEnv :: Var -> CallArityRes -> CallArityRes -> CallArityRes
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 998894a..32aa8ea 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -209,4 +209,4 @@ test('T6056', only_ways(['optasm']), multimod_compile, ['T6056', '-v0 -ddump-rul
 test('T9400', only_ways(['optasm']), compile, ['-O0 -ddump-simpl -dsuppress-uniques'])
 test('T9583', only_ways(['optasm']), compile, [''])
 test('T9565', only_ways(['optasm']), compile, [''])
-test('T10176', [only_ways(['optasm']), expect_broken(10176)], compile, [''])
+test('T10176', only_ways(['optasm']), compile, [''])