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.

4 files changed, 25 insertions, 1 deletions

diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index bd7b5c33bf..f240be4cd7 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -596,7 +596,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 530e4e58f2..e36fb00f0f 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -65,3 +65,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, [''])