Trim Call Arity

to not accidentially invalidate a strictness signature with a Diverges
result info. This seems to fix #10176.

Differential Revision: https://phabricator.haskell.org/D747

1 files changed, 46 insertions, 5 deletions

diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index 36a8b961a9..4a0b8ee376 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
@@ -506,15 +529,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]
@@ -558,19 +585,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