Add GHC.Prim.oneShot

to allow the programer to explictitly set the oneShot flag. This helps
with #7994 and will be used in left folds. Also see
https://ghc.haskell.org/trac/ghc/wiki/OneShot

This commit touches libraries/base/GHC/Event/Manager.hs (which used to
have a local definition of the name oneShot) to avoid a shadowing error.

Differential Revision: https://phabricator.haskell.org/D392

6 files changed, 77 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/prog003/Makefile b/testsuite/tests/simplCore/prog003/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/simplCore/prog003/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/simplCore/prog003/OneShot1.hs b/testsuite/tests/simplCore/prog003/OneShot1.hs
new file mode 100644
index 0000000000..3f6589acd1
--- /dev/null
+++ b/testsuite/tests/simplCore/prog003/OneShot1.hs
@@ -0,0 +1,21 @@
+module OneShot1 where
+
+import GHC.Base
+
+-- This oneShot is a lie, and together with unsafePerformIO (in the form of
+-- trace) in OneShot2, we can observe the difference.
+
+-- Two modules to ensure that oneShot annotations surive interface files, both
+-- in explicits unfoldings (foo) and in unannotated functions (baz)
+
+foo :: Int -> Int -> Int
+foo y = oneShot (\x -> x+y)
+{-# INLINE foo #-}
+
+bar :: Int -> Int -> Int
+bar y = (\x -> y+x)
+{-# INLINE bar #-}
+
+baz :: Int -> Int -> Int
+baz y = oneShot (\x -> x+y)
+
diff --git a/testsuite/tests/simplCore/prog003/OneShot2.hs b/testsuite/tests/simplCore/prog003/OneShot2.hs
new file mode 100644
index 0000000000..9d2052a1d4
--- /dev/null
+++ b/testsuite/tests/simplCore/prog003/OneShot2.hs
@@ -0,0 +1,24 @@
+import OneShot1
+import System.Environment
+import Debug.Trace
+
+p n = trace "p evaluated" (n > 0)
+{-# NOINLINE p #-}
+
+summap :: (Int -> Int) -> (Int -> Int)
+summap f n = sum $ map f [1..10]
+{-# NOINLINE summap #-}
+
+foo' n = if p n then foo n else foo (n+1)
+{-# NOINLINE foo' #-}
+
+bar' n = if p n then bar n else bar (n+1)
+{-# NOINLINE bar' #-}
+
+baz' n = if p n then baz n else baz (n+1)
+{-# NOINLINE baz' #-}
+
+main = do
+  n <- length `fmap` getArgs
+  print $ summap (foo' n) n + summap (bar' n) n + summap (baz' n) n
+
diff --git a/testsuite/tests/simplCore/prog003/simplCore.oneShot.stderr b/testsuite/tests/simplCore/prog003/simplCore.oneShot.stderr
new file mode 100644
index 0000000000..b288d52e93
--- /dev/null
+++ b/testsuite/tests/simplCore/prog003/simplCore.oneShot.stderr
@@ -0,0 +1,21 @@
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
+p evaluated
diff --git a/testsuite/tests/simplCore/prog003/simplCore.oneShot.stdout b/testsuite/tests/simplCore/prog003/simplCore.oneShot.stdout
new file mode 100644
index 0000000000..6bb2f98fb0
--- /dev/null
+++ b/testsuite/tests/simplCore/prog003/simplCore.oneShot.stdout
@@ -0,0 +1 @@
+195
diff --git a/testsuite/tests/simplCore/prog003/test.T b/testsuite/tests/simplCore/prog003/test.T
new file mode 100644
index 0000000000..387bd20508
--- /dev/null
+++ b/testsuite/tests/simplCore/prog003/test.T
@@ -0,0 +1,7 @@
+test('simplCore.oneShot',
+     [ only_ways(['optasm']),
+       extra_clean(['OneShot1.hi', 'OneShot1.o',
+                    'OneShot2.hi', 'OneShot2.o']),
+     ],
+     multimod_compile_and_run,
+     ['OneShot2', '-v0'])