From 0696fc6d4de28cb589f6c751b8491911a5baf774 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Fri, 26 Jun 2015 11:40:01 +0100
Subject: Improve CPR behavior for strict constructors

When working on Trac #10482 I noticed that we could give constructor
arguments the CPR property if they are use strictly.

This is documented carefully in
    Note [CPR in a product case alternative]
and also
    Note [Initial CPR for strict binders]

There are a bunch of intersting examples in
    Note [CPR examples]
which I have added to the test suite as T10482a.

I also added a test for #10482 itself.
---
 testsuite/tests/stranal/T10482a.hs                 | 61 +++++++++++++++++++++
 testsuite/tests/stranal/should_compile/Makefile    | 12 +++++
 testsuite/tests/stranal/should_compile/T10482.hs   | 14 +++++
 .../tests/stranal/should_compile/T10482.stdout     |  1 +
 testsuite/tests/stranal/should_compile/T10482a.hs  | 63 ++++++++++++++++++++++
 .../tests/stranal/should_compile/T10482a.stdout    |  4 ++
 testsuite/tests/stranal/should_compile/all.T       |  6 +++
 7 files changed, 161 insertions(+)
 create mode 100644 testsuite/tests/stranal/T10482a.hs
 create mode 100644 testsuite/tests/stranal/should_compile/T10482.hs
 create mode 100644 testsuite/tests/stranal/should_compile/T10482.stdout
 create mode 100644 testsuite/tests/stranal/should_compile/T10482a.hs
 create mode 100644 testsuite/tests/stranal/should_compile/T10482a.stdout

(limited to 'testsuite')

diff --git a/testsuite/tests/stranal/T10482a.hs b/testsuite/tests/stranal/T10482a.hs
new file mode 100644
index 0000000000..3547ebd35e
--- /dev/null
+++ b/testsuite/tests/stranal/T10482a.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-}
+                -- Makes f2 a bit more challenging
+
+module Foo where
+
+
+h :: Int -> Int -> Bool
+h 0 y = y>0
+h n y = h (n-1) y
+
+-- The main point: all of these functions can have the CPR property
+
+------- f1 -----------
+-- x is used strictly by h, so it'll be available
+-- unboxed before it is returned in the True branch
+
+f1 :: Int -> Int
+f1 x = case h x x of
+        True  -> x
+        False -> f1 (x-1)
+
+
+------- f2 -----------
+-- x is a strict field of MkT2, so we'll pass it unboxed
+-- to $wf2, so it's available unboxed.  This depends on
+-- the case expression analysing (a subcomponent of) one
+-- of the original arguments to the function, so it's
+-- a bit more delicate.
+
+data T2 = MkT2 !Int Int
+
+f2 :: T2 -> Int
+f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
+              | y>1       = 1
+              | otherwise = x
+
+
+------- f3 -----------
+-- h is strict in x, so x will be unboxed before it
+-- is rerturned in the otherwise case.
+
+data T3 = MkT3 Int Int
+
+f1 :: T3 -> Int
+f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
+              | otherwise = x
+
+
+------- f4 -----------
+-- Just like f2, but MkT4 can't unbox its strict
+-- argument automatically, as f2 can
+
+data family Foo a
+newtype instance Foo Int = Foo Int
+
+data T4 a = MkT4 !(Foo a) Int
+
+f4 :: T4 Int -> Int
+f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
+                      | otherwise = v
diff --git a/testsuite/tests/stranal/should_compile/Makefile b/testsuite/tests/stranal/should_compile/Makefile
index 9101fbd40a..32cc92490a 100644
--- a/testsuite/tests/stranal/should_compile/Makefile
+++ b/testsuite/tests/stranal/should_compile/Makefile
@@ -1,3 +1,15 @@
 TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
+
+# T10482
+#   The intent here is to check that $wfoo has type
+#         $wfoo :: Int# -> Int# -> Int
+#   with two unboxed args.  See Trac #10482 for background
+T10482:
+	$(RM) -f T10482.o T10482.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl T10482.hs | grep 'T10482.*wfoo.*Int'
+
+T10482a:
+	$(RM) -f T10482a.o T10482a.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl T10482a.hs | grep 'wf.*Int'
diff --git a/testsuite/tests/stranal/should_compile/T10482.hs b/testsuite/tests/stranal/should_compile/T10482.hs
new file mode 100644
index 0000000000..ef7c29c4be
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T10482.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+module T10482 where
+
+data family Foo a
+data instance Foo (a, b) = FooPair !(Foo a) !(Foo b)
+newtype instance Foo Int = Foo Int
+
+foo :: Foo ((Int, Int), Int) -> Int -> Int
+foo !f k =
+  if k == 0 then 0
+  else if even k then foo f (k-1)
+  else case f of
+    FooPair (FooPair (Foo n) _) _ -> n
diff --git a/testsuite/tests/stranal/should_compile/T10482.stdout b/testsuite/tests/stranal/should_compile/T10482.stdout
new file mode 100644
index 0000000000..010cb4c60e
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T10482.stdout
@@ -0,0 +1 @@
+T10482.$wfoo [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
diff --git a/testsuite/tests/stranal/should_compile/T10482a.hs b/testsuite/tests/stranal/should_compile/T10482a.hs
new file mode 100644
index 0000000000..e633ebe6b7
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T10482a.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-}
+                -- Makes f2 a bit more challenging
+
+-- Tests inspired by Note [CPR examples] in DmdAnal, and Trac #10482
+
+module Foo where
+
+
+h :: Int -> Int -> Bool
+h 0 y = y>0
+h n y = h (n-1) y
+
+-- The main point: all of these functions can have the CPR property
+
+------- f1 -----------
+-- x is used strictly by h, so it'll be available
+-- unboxed before it is returned in the True branch
+
+f1 :: Int -> Int
+f1 x = case h x x of
+        True  -> x
+        False -> f1 (x-1)
+
+
+------- f2 -----------
+-- x is a strict field of MkT2, so we'll pass it unboxed
+-- to $wf2, so it's available unboxed.  This depends on
+-- the case expression analysing (a subcomponent of) one
+-- of the original arguments to the function, so it's
+-- a bit more delicate.
+
+data T2 = MkT2 !Int Int
+
+f2 :: T2 -> Int
+f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
+              | y>1       = 1
+              | otherwise = x
+
+
+------- f3 -----------
+-- h is strict in x, so x will be unboxed before it
+-- is rerturned in the otherwise case.
+
+data T3 = MkT3 Int Int
+
+f3 :: T3 -> Int
+f3 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
+              | otherwise = x
+
+
+------- f4 -----------
+-- Just like f2, but MkT4 can't unbox its strict
+-- argument automatically, as f2 can
+
+data family Foo a
+newtype instance Foo Int = Foo Int
+
+data T4 a = MkT4 !(Foo a) Int
+
+f4 :: T4 Int -> Int
+f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
+                      | otherwise = v
diff --git a/testsuite/tests/stranal/should_compile/T10482a.stdout b/testsuite/tests/stranal/should_compile/T10482a.stdout
new file mode 100644
index 0000000000..bb19e36946
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T10482a.stdout
@@ -0,0 +1,4 @@
+Foo.$wf2 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
+Foo.$wf1 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int#
+Foo.$wf3 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
+Foo.$wf4 [InlPrag=[0], Occ=LoopBreaker] :: Int# -> Int# -> Int#
diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T
index 62a430625c..54b77365a6 100644
--- a/testsuite/tests/stranal/should_compile/all.T
+++ b/testsuite/tests/stranal/should_compile/all.T
@@ -20,6 +20,12 @@ test('T8467', normal, compile, [''])
 test('T8037', normal, compile, [''])
 test('T8743', [ extra_clean(['T8743.o-boot', 'T8743a.hi', 'T8743a.o', 'T8743.hi-boot']) ], multimod_compile, ['T8743', '-v0'])
 
+# test('T10482', normal, compile, [''])
+
+test('T10482',  only_ways(['normal']), run_command, ['$MAKE -s --no-print-directory T10482'])
+test('T10482a', only_ways(['normal']), run_command, ['$MAKE -s --no-print-directory T10482a'])
+
 test('T9208', when(compiler_debugged(), expect_broken(9208)), compile, [''])
 # T9208 fails (and should do so) if you have assertion checking on in the compiler
 # Hence the above expect_broken.  See comments in the Trac ticket
+
-- 
cgit v1.2.1