From 011f691333aff2833acc900ee3911885e488cf1b Mon Sep 17 00:00:00 2001 From: Joachim Breitner <mail@joachim-breitner.de> Date: Sat, 21 Mar 2015 15:58:38 +0100 Subject: [PATCH] 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) --- compiler/simplCore/CallArity.hs | 51 +++++++++++++++++-- .../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 5ee5fe296ade..2f4f107a80b2 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 998894abbfd7..32aa8ea8bd86 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, ['']) -- GitLab