[commit: ghc] ghc-7.8: Fix a serious, but rare, strictness analyser bug (Trac #9128) (020350b)

[git at git.haskell.org]

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

On branch  : ghc-7.8
Link       : http://ghc.haskell.org/trac/ghc/changeset/020350be1da87eacf23e804d2290137bdfec89db/ghc

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

commit 020350be1da87eacf23e804d2290137bdfec89db
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Jun 11 19:53:06 2014 +0100

    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)


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

020350be1da87eacf23e804d2290137bdfec89db
 compiler/stranal/DmdAnal.lhs                                 | 11 ++++++++++-
 testsuite/tests/simplCore/should_run/T9128.hs                | 12 ++++++++++++
 .../cgrun033.stdout => simplCore/should_run/T9128.stdout}    |  0
 testsuite/tests/simplCore/should_run/all.T                   |  2 ++
 4 files changed, 24 insertions(+), 1 deletion(-)

diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 1d27a53..31996cb 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 0000000..73aa39b
--- /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/codeGen/should_run/cgrun033.stdout b/testsuite/tests/simplCore/should_run/T9128.stdout
similarity index 100%
copy from testsuite/tests/codeGen/should_run/cgrun033.stdout
copy to testsuite/tests/simplCore/should_run/T9128.stdout
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 430d61f..ed7de1c 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, [''])