[commit: ghc] wip/T11731: Used-once variables are not trivial (7ac5610)

[git at git.haskell.org]

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

On branch  : wip/T11731
Link       : http://ghc.haskell.org/trac/ghc/changeset/7ac5610606e8f338cd2eb92eb5d711e054d9d55a/ghc

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

commit 7ac5610606e8f338cd2eb92eb5d711e054d9d55a
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Mar 30 12:55:10 2016 +0200

    Used-once variables are not trivial
    
    The specification for exprIsTrivial demands that we are unconditionally
    happy to duplicate the expression. This is not true for variables where
    we would like to exploit (or already have exploited) that they are used
    at most once. In order to preserve this property, they must not be
    duplicated nilly-willy. This fixes #11731 and comes with a test case.


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

7ac5610606e8f338cd2eb92eb5d711e054d9d55a
 compiler/coreSyn/CoreUtils.hs                      | 12 +++++++-
 testsuite/.gitignore                               |  1 +
 testsuite/tests/simplCore/should_run/T11731.hs     | 36 ++++++++++++++++++++++
 testsuite/tests/simplCore/should_run/T11731.stderr |  1 +
 testsuite/tests/simplCore/should_run/all.T         |  1 +
 5 files changed, 50 insertions(+), 1 deletion(-)

diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 1d9b83b..d02b934 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -62,6 +62,7 @@ import DataCon
 import PrimOp
 import Id
 import IdInfo
+import Demand ( isUsedOnce )
 import Type
 import Coercion
 import TyCon
@@ -755,6 +756,13 @@ Note [exprIsTrivial]
 
 Note [Variables are trivial]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Variables are usually trivial.
+
+Except if 'isUsedOnce (idDemandInfo v) == True':
+In this case we have previously determined that a variable is used at most
+once, and we likely rely on this information, e.g. during code generation. In
+this case, we are not unconditionally happy to duplicate, so we don’t.  See #11731.
+
 There used to be a gruesome test for (hasNoBinding v) in the
 Var case:
         exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
@@ -793,7 +801,9 @@ it off at source.
 -}
 
 exprIsTrivial :: CoreExpr -> Bool
-exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
+exprIsTrivial (Var v) -- See Note [Variables are trivial]
+  | isUsedOnce (idDemandInfo v) = False
+  | otherwise                  = True
 exprIsTrivial (Type _)         = True
 exprIsTrivial (Coercion _)     = True
 exprIsTrivial (Lit lit)        = litIsTrivial lit
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 8926e4e..b578602 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1474,6 +1474,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
 /tests/simplCore/should_run/T5997
 /tests/simplCore/should_run/T7101
 /tests/simplCore/should_run/T7924
+/tests/simplCore/should_run/T11731
 /tests/simplCore/should_run/T9128
 /tests/simplCore/should_run/T9390
 /tests/simplCore/should_run/runST
diff --git a/testsuite/tests/simplCore/should_run/T11731.hs b/testsuite/tests/simplCore/should_run/T11731.hs
new file mode 100644
index 0000000..e148507
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T11731.hs
@@ -0,0 +1,36 @@
+module Main (main ) where
+
+import Debug.Trace
+
+foo :: (a,b) -> a
+foo (x,y) = x
+{-# NOINLINE foo #-}
+
+wwMe :: Int -> (Int,Int) -> (Int, Int)
+wwMe 0 p =
+    let a = fst p
+        b = snd p
+        -- This ensure sharing of b, as seen by the demand analyzer
+
+    in foo p `seq`
+       -- This ensures that wwMe is strict in the tuple, but that the tuple
+       -- is preserved.
+       (b + a, a + b)
+
+wwMe n p = wwMe (n-1) (0,0)
+    -- ^ Make it recursive, so that it is attractive to worker-wrapper
+
+go :: Int -> IO ()
+go seed = do
+    let shareMeThunk = trace "Evaluated (should only happen once)" (seed + 1)
+        {-# NOINLINE shareMeThunk #-}
+        -- ^ This is the thunk that is wrongly evaluated twice.
+
+    let (x,y) = wwMe 0 (seed,shareMeThunk)
+
+    (x + y) `seq` return ()
+    -- ^ Use both components
+{-# NOINLINE go #-}
+
+main :: IO ()
+main = go 42
diff --git a/testsuite/tests/simplCore/should_run/T11731.stderr b/testsuite/tests/simplCore/should_run/T11731.stderr
new file mode 100644
index 0000000..8d1fc60
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T11731.stderr
@@ -0,0 +1 @@
+Evaluated (should only happen once)
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 9c15b0f..7fd1812 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -71,3 +71,4 @@ test('T9128', normal, compile_and_run, [''])
 test('T9390', normal, compile_and_run, [''])
 test('T10830', extra_run_opts('+RTS -K100k -RTS'), compile_and_run, [''])
 test('T11172', normal, compile_and_run, [''])
+test('T11731', normal, compile_and_run, ['-fspec-constr'])