diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-06-11 19:53:06 +0100 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2014-06-23 02:38:22 -0500 |
| commit | 020350be1da87eacf23e804d2290137bdfec89db (patch) | |
| tree | ed2b786bd1e59a4019df752a7038cc6897b97052 | |
| parent | f98d2c279e5757d3156427c834281d2ce2ab92db (diff) | |
| download | haskell-020350be1da87eacf23e804d2290137bdfec89db.tar.gz | |
Fix a serious, but rare, strictness analyser bug (Trac #9128)
In a special case for trivial RHSs (see DmdAnal.unpackTrivial),
I'd forgotten to include a demand for the RHS itself.
See Note [Remember to demand the function itself].
Thanks to David Terei for guiding me to the bug,
at PLDI in Edinburgh.
(cherry picked from commit 7d9feb264a4fc3c15d1e5f88f2e7a04202ed9743)
| -rw-r--r-- | compiler/stranal/DmdAnal.lhs | 11 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/T9128.hs | 12 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/T9128.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/all.T | 2 |
4 files changed, 25 insertions, 1 deletions
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 1d27a53e34..31996cb99a 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -597,7 +597,16 @@ dmdAnalRhs :: TopLevelFlag dmdAnalRhs top_lvl rec_flag env id rhs | Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides] , let fn_str = getStrictness env fn - = (fn_str, emptyDmdEnv, set_idStrictness env id fn_str, rhs) + fn_fv | isLocalId fn = unitVarEnv fn topDmd + | otherwise = emptyDmdEnv + -- Note [Remember to demand the function itself] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- fn_fv: don't forget to produce a demand for fn itself + -- Lacking this caused Trac #9128 + -- The demand is very conservative (topDmd), but that doesn't + -- matter; trivial bindings are usually inlined, so it only + -- kicks in for top-level bindings and NOINLINE bindings + = (fn_str, fn_fv, set_idStrictness env id fn_str, rhs) | otherwise = (sig_ty, lazy_fv, id', mkLams bndrs' body') diff --git a/testsuite/tests/simplCore/should_run/T9128.hs b/testsuite/tests/simplCore/should_run/T9128.hs new file mode 100644 index 0000000000..73aa39b31b --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T9128.hs @@ -0,0 +1,12 @@ +module Main where + +newtype T a = MkT a + +-- Trac #9128: we treated x as absent!!!! + +f x = let {-# NOINLINE h #-} + h = case x of MkT g -> g + in + h (h (h (h (h (h True))))) + +main = print (f (MkT id)) diff --git a/testsuite/tests/simplCore/should_run/T9128.stdout b/testsuite/tests/simplCore/should_run/T9128.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T9128.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 430d61f1c5..ed7de1c461 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -63,3 +63,5 @@ test('T7924', exit_code(1), compile_and_run, ['']) # Run this test *without* optimisation too test('T457', [ only_ways(['normal','optasm']), exit_code(1) ], compile_and_run, ['']) + +test('T9128', normal, compile_and_run, ['']) |