Implement UNPACK support for sum types.

This is based on osa's unpack_sums PR from ages past.

The meat of the patch is implemented in dataConArgUnpackSum
and described in Note [UNPACK for sum types].

17 files changed, 242 insertions, 0 deletions

diff --git a/testsuite/tests/unboxedsums/Makefile b/testsuite/tests/unboxedsums/Makefile
new file mode 100644
index 0000000000..23548ec58c
--- /dev/null
+++ b/testsuite/tests/unboxedsums/Makefile
@@ -0,0 +1,11 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: unpack_sums_7
+
+unpack_sums_7:
+	$(RM) -f unpack_sums_7.o unpack_sums_7.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c unpack_sums_7.hs  -O -dsuppress-all -ddump-simpl | grep -q '\(# |_ #\)'
+	# This is a test to check for the presence of an unboxed sum in the core for a program using UNPACK
+	# on a sum type which is evidence that the field has been correctly unpacked.
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index d1278a4eb2..0d887c60ed 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -40,3 +40,18 @@ test('T22187',[only_ways(llvm_ways)],compile,[''])
 test('T22187_run',[only_ways(llvm_ways)
                   ,unless(arch('x86_64'), skip)],compile_and_run,[''])
 
+test('unpack_sums_1', normal, compile_and_run, ['-O'])
+test('unpack_sums_2', normal, compile, ['-O'])
+test('unpack_sums_3', normal, compile_and_run, ['-O'])
+test('unpack_sums_4', normal, compile_and_run, ['-O'])
+test('unpack_sums_5', normal, compile, ['-O'])
+test('unpack_sums_6', normal, compile_and_run, ['-O'])
+test('unpack_sums_7', [], makefile_test, [])
+test('unpack_sums_8', normal, compile_and_run, [""])
+test('unpack_sums_9', normal, compile, [""])
+
+# TODO: Need to run this in --slow mode only
+# test('sum_api_annots',
+#      [only_ways(['normal']),
+#       extra_files([ "unboxedsums" + str(i) + ".hs" for i in range(1, 12) ])],
+#      makefile_test, [])
diff --git a/testsuite/tests/unboxedsums/unpack_sums_1.hs b/testsuite/tests/unboxedsums/unpack_sums_1.hs
new file mode 100644
index 0000000000..91f286a9de
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_1.hs
@@ -0,0 +1,22 @@
+module Main where
+
+data T = T1 Int | T2 String
+  deriving (Show, Eq, Ord, Read)
+
+data T' = T' {-# UNPACK #-} !T
+  deriving (Show, Eq, Ord, Read)
+
+t1, t2 :: T
+t1 = T1 123
+t2 = T2 "OK"
+{-# NOINLINE t1 #-}
+{-# NOINLINE t2 #-}
+
+t'1, t'2 :: T'
+t'1 = T' t1
+t'2 = T' t2
+
+main :: IO ()
+main = do
+  print t'1
+  print t'2
diff --git a/testsuite/tests/unboxedsums/unpack_sums_1.stdout b/testsuite/tests/unboxedsums/unpack_sums_1.stdout
new file mode 100644
index 0000000000..0990251757
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_1.stdout
@@ -0,0 +1,2 @@
+T' (T1 123)
+T' (T2 "OK")
diff --git a/testsuite/tests/unboxedsums/unpack_sums_2.hs b/testsuite/tests/unboxedsums/unpack_sums_2.hs
new file mode 100644
index 0000000000..ff530974e2
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_2.hs
@@ -0,0 +1,9 @@
+module Lib where
+
+data Number = F {-# UNPACK #-} !Float | I {-# UNPACK #-} !Int
+
+-- This UNPACK was causing a panic:
+--   ghc-stage1: panic! (the 'impossible' happened)
+--     (GHC version 8.1.20160722 for x86_64-unknown-linux):
+--           LocalReg's live-in to graph crG {_grh::F32, _gri::I64}
+data T = T {-# UNPACK #-} !Number
diff --git a/testsuite/tests/unboxedsums/unpack_sums_3.hs b/testsuite/tests/unboxedsums/unpack_sums_3.hs
new file mode 100644
index 0000000000..01860f2d12
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_3.hs
@@ -0,0 +1,14 @@
+-- Check that we can unpack a strict Maybe Int field.
+import System.Exit
+
+data T = MkT {-# UNPACK #-} !(Maybe Int)
+
+xs = Nothing : [Just n | n <- [1..10]]
+
+ts = map MkT xs
+
+main = if xs == map (\(MkT m) -> m) ts
+  then return ()
+  else do
+    putStrLn "Error in packing and unpacking!"
+    exitFailure
diff --git a/testsuite/tests/unboxedsums/unpack_sums_4.hs b/testsuite/tests/unboxedsums/unpack_sums_4.hs
new file mode 100644
index 0000000000..0d28398cca
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_4.hs
@@ -0,0 +1,8 @@
+-- Check that nothing goes wrong with UNPACK in recursive case.
+data T = MkT {-# UNPACK #-} !(Maybe T)
+  deriving Show
+
+t :: T
+t = MkT (Just t)
+
+main = print $ take 100 (show t)
diff --git a/testsuite/tests/unboxedsums/unpack_sums_4.stdout b/testsuite/tests/unboxedsums/unpack_sums_4.stdout
new file mode 100644
index 0000000000..be36978242
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_4.stdout
@@ -0,0 +1 @@
+"MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (MkT (Just (M"
diff --git a/testsuite/tests/unboxedsums/unpack_sums_5.hs b/testsuite/tests/unboxedsums/unpack_sums_5.hs
new file mode 100644
index 0000000000..87514f63cb
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_5.hs
@@ -0,0 +1,11 @@
+module UnpackSumsFive where
+-- Check that failure to unpack is warned about.
+
+data SMaybeT = NoT | JustT {-# UNPACK #-} !T
+  deriving Show
+
+data T = MkT {-# UNPACK #-} !SMaybeT
+  deriving Show
+
+t :: T
+t = MkT (JustT (MkT (JustT (MkT NoT))))
diff --git a/testsuite/tests/unboxedsums/unpack_sums_5.stderr b/testsuite/tests/unboxedsums/unpack_sums_5.stderr
new file mode 100644
index 0000000000..96e786895a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_5.stderr
@@ -0,0 +1,10 @@
+
+unpack_sums_5.hs:4:22: warning:
+    • Ignoring unusable UNPACK pragma on the first argument of ‘JustT’
+    • In the definition of data constructor ‘JustT’
+      In the data type declaration for ‘SMaybeT’
+
+unpack_sums_5.hs:7:10: warning:
+    • Ignoring unusable UNPACK pragma on the first argument of ‘MkT’
+    • In the definition of data constructor ‘MkT’
+      In the data type declaration for ‘T’
diff --git a/testsuite/tests/unboxedsums/unpack_sums_6.hs b/testsuite/tests/unboxedsums/unpack_sums_6.hs
new file mode 100644
index 0000000000..ec60966282
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_6.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE BangPatterns #-}
+-- This perhaps overly simple test check if code involving
+-- unbacked sums is faster than non-unpacked ones which at
+-- least in this case we expect to be the case.
+-- However this test isn't quite robust, should it fail in
+-- the future we might want to redo it or mark it fragile.
+import Data.Time.Clock
+
+import Data.Int
+import System.Exit
+
+data A = ANothing | AJust {-# UNPACK #-} !Int64
+data B = BNothing | BJust {-# UNPACK #-} !A
+data C = CNothing | CJust {-# UNPACK #-} !B
+data D = DNothing | DJust {-# UNPACK #-} !C
+
+data Unlayered = Unlayered {-# UNPACK #-} !D
+
+data Layered = Layered !(Maybe (Maybe (Maybe (Maybe Int64))))
+
+makeUnlayered :: Int64 -> [Unlayered]
+makeUnlayered n = Unlayered . DJust . CJust . BJust . AJust <$> [1..n]
+
+makeLayered :: Int64 -> [Layered]
+makeLayered n = Layered . Just . Just . Just . Just <$> [1..n]
+
+sumUnlayered :: [Unlayered] -> Int64
+sumUnlayered = go 0
+ where
+  go !n [] = n
+  go !n (w:ws) = case w of
+    Unlayered (DJust (CJust (BJust (AJust i)))) -> go (n+i) ws
+    Unlayered _ -> go n ws
+
+sumLayered :: [Layered] -> Int64
+sumLayered = go 0
+ where
+  go !n [] = n
+  go !n (w:ws) = case w of
+    Layered (Just (Just (Just (Just i)))) -> go (n+i) ws
+    Layered _ -> go n ws
+
+main :: IO ()
+main = do
+  let magnitude = 10000000
+      unlayeredInts = makeUnlayered magnitude
+      layeredInts = makeLayered magnitude
+  now <- getCurrentTime
+  print $ sumUnlayered unlayeredInts
+  unlayeredTime <- getCurrentTime
+  print $ sumLayered layeredInts
+  layeredTime <- getCurrentTime
+  case (unlayeredTime `diffUTCTime` now) < (layeredTime `diffUTCTime` unlayeredTime) of
+    True -> exitSuccess
+    False -> exitFailure
diff --git a/testsuite/tests/unboxedsums/unpack_sums_6.stdout b/testsuite/tests/unboxedsums/unpack_sums_6.stdout
new file mode 100644
index 0000000000..90a8e417bd
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_6.stdout
@@ -0,0 +1,2 @@
+50000005000000
+50000005000000
diff --git a/testsuite/tests/unboxedsums/unpack_sums_7.hs b/testsuite/tests/unboxedsums/unpack_sums_7.hs
new file mode 100644
index 0000000000..cefa317a01
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_7.hs
@@ -0,0 +1,10 @@
+-- NB: Compiling this module throws an exception involving Weak# at the end of compilation.
+-- This is unrelated to unpacked sums but we need to include the error in the expected output for the test to pass.
+
+module UnpackedSums7 where
+
+data T = MkT {-# UNPACK #-} !MI
+
+data MI = NoI | JI Int
+
+t = MkT (JI 5)
diff --git a/testsuite/tests/unboxedsums/unpack_sums_7.stderr b/testsuite/tests/unboxedsums/unpack_sums_7.stderr
new file mode 100644
index 0000000000..d37b1c154a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_7.stderr
@@ -0,0 +1,2 @@
+Exception during Weak# finalization (ignored): <stdout>: hFlush: resource vanished (Broken pipe)
+Exception during Weak# finalization (ignored): <stdout>: hFlush: resource vanished (Broken pipe)
diff --git a/testsuite/tests/unboxedsums/unpack_sums_8.hs b/testsuite/tests/unboxedsums/unpack_sums_8.hs
new file mode 100644
index 0000000000..9946cc4ada
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_8.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
+
+module Main where
+
+data Void
+data WithVoid = LV Void | RV
+data EnumT = L | R
+    deriving Show
+
+data BoxEnum = BoxEnum {-# UNPACK #-} !EnumT
+    deriving Show
+
+l = BoxEnum L
+r = BoxEnum R
+
+main = do
+    print l
+    print r
+
+
+data BoxWithVoid = BoxWithVoid {-# UNPACK #-} !WithVoid
+wv = BoxWithVoid (LV undefined)
+
+data BoxVoid = BoxVoid {-# UNPACK #-} Void
+bv = BoxVoid undefined
+
+data BoxSum = BoxS {-# UNPACK #-} !(# Int | Char #)
+bs = BoxS (# 1 | #)
diff --git a/testsuite/tests/unboxedsums/unpack_sums_8.stdout b/testsuite/tests/unboxedsums/unpack_sums_8.stdout
new file mode 100644
index 0000000000..eb719d1446
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_8.stdout
@@ -0,0 +1,2 @@
+BoxEnum L
+BoxEnum R
diff --git a/testsuite/tests/unboxedsums/unpack_sums_9.hs b/testsuite/tests/unboxedsums/unpack_sums_9.hs
new file mode 100644
index 0000000000..af12debb25
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unpack_sums_9.hs
@@ -0,0 +1,39 @@
+
+module UnpackedSums8 where
+
+-- Unpack a sum of 100 ints in each constructor
+data Unpackee
+   = U !Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+
+    | O Word Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+        Int Int Int Int Int Int Int Int Int Int
+
+data Box = Box {-# UNPACK #-} !Unpackee
+
+b = Box $ U 0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0
+            0 0 0 0 0 0 0 0 0 0