Fix a serious, but rare, strictness analyser bug (Trac #9128)
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 11 Jun 2014 18:53:06 +0000 (19:53 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 11 Jun 2014 19:56:38 +0000 (20:56 +0100)
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.

compiler/stranal/DmdAnal.lhs
testsuite/tests/simplCore/should_run/T9128.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_run/T9128.stdout [new file with mode: 0644]
testsuite/tests/simplCore/should_run/all.T

index bd7b5c3..f240be4 100644 (file)
@@ -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 (file)
index 0000000..73aa39b
--- /dev/null
@@ -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 (file)
index 0000000..0ca9514
--- /dev/null
@@ -0,0 +1 @@
+True
index 530e4e5..e36fb00 100644 (file)
@@ -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, [''])