Implement unboxed sum primitive type

Summary:
This patch implements primitive unboxed sum types, as described in
https://ghc.haskell.org/trac/ghc/wiki/UnpackedSumTypes.

Main changes are:

- Add new syntax for unboxed sums types, terms and patterns. Hidden
  behind `-XUnboxedSums`.

- Add unlifted unboxed sum type constructors and data constructors,
  extend type and pattern checkers and desugarer.

- Add new RuntimeRep for unboxed sums.

- Extend unarise pass to translate unboxed sums to unboxed tuples right
  before code generation.

- Add `StgRubbishArg` to `StgArg`, and a new type `CmmArg` for better
  code generation when sum values are involved.

- Add user manual section for unboxed sums.

Some other changes:

- Generalize `UbxTupleRep` to `MultiRep` and `UbxTupAlt` to
  `MultiValAlt` to be able to use those with both sums and tuples.

- Don't use `tyConPrimRep` in `isVoidTy`: `tyConPrimRep` is really
  wrong, given an `Any` `TyCon`, there's no way to tell what its kind
  is, but `kindPrimRep` and in turn `tyConPrimRep` returns `PtrRep`.

- Fix some bugs on the way: #12375.

Not included in this patch:

- Update Haddock for new the new unboxed sum syntax.

- `TemplateHaskell` support is left as future work.

For reviewers:

- Front-end code is mostly trivial and adapted from unboxed tuple code
  for type checking, pattern checking, renaming, desugaring etc.

- Main translation routines are in `RepType` and `UnariseStg`.
  Documentation in `UnariseStg` should be enough for understanding
  what's going on.

Credits:

- Johan Tibell wrote the initial front-end and interface file
  extensions.

- Simon Peyton Jones reviewed this patch many times, wrote some code,
  and helped with debugging.

Reviewers: bgamari, alanz, goldfire, RyanGlScott, simonpj, austin,
           simonmar, hvr, erikd

Reviewed By: simonpj

Subscribers: Iceland_jack, ggreif, ezyang, RyanGlScott, goldfire,
             thomie, mpickering

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

42 files changed, 561 insertions, 1 deletions

diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 7bdbaefd00..45e257e4ec 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -39,7 +39,8 @@ expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
                              "AlternativeLayoutRuleTransitional",
-                             "TypeFamilyDependencies"]
+                             "TypeFamilyDependencies",
+                             "UnboxedSums"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/unboxedsums/Makefile b/testsuite/tests/unboxedsums/Makefile
new file mode 100644
index 0000000000..ff17bccc51
--- /dev/null
+++ b/testsuite/tests/unboxedsums/Makefile
@@ -0,0 +1,10 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: sum_api_annots
+sum_api_annots:
+	number=1 ; while [[ $$number -le 11 ]] ; do \
+	  $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" unboxedsums$$number.hs ; \
+		((number = number + 1)) ; \
+	done
diff --git a/testsuite/tests/unboxedsums/T12375.hs b/testsuite/tests/unboxedsums/T12375.hs
new file mode 100644
index 0000000000..62b6094e64
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T12375.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+type Null = (# #)
+
+{-# NOINLINE showNull #-}
+showNull :: Null -> String
+showNull (# #) = "(# #)"
+
+{-# NOINLINE showNullPair #-}
+showNullPair :: (# Null, Null #) -> String
+showNullPair (# n1, n2 #) = "(# " ++ showNull n1 ++ ", " ++ showNull n2 ++ " #)"
+
+main :: IO ()
+main = do
+    putStrLn (showNullPair (# (# #), (# #) #))
diff --git a/testsuite/tests/unboxedsums/T12375.stdout b/testsuite/tests/unboxedsums/T12375.stdout
new file mode 100644
index 0000000000..7cfa66fe07
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T12375.stdout
@@ -0,0 +1 @@
+(# (# #), (# #) #)
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
new file mode 100644
index 0000000000..274045f393
--- /dev/null
+++ b/testsuite/tests/unboxedsums/all.T
@@ -0,0 +1,25 @@
+test('unarise',       omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums1',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums2',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums3',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums4',  omit_ways(['ghci']), compile_fail, [''])
+test('unboxedsums5',  omit_ways(['ghci']), compile, [''])
+test('unboxedsums6',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums7',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums8',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums9',  omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums10', omit_ways(['ghci']), compile_and_run, [''])
+test('unboxedsums11', omit_ways(['ghci']), compile_and_run, [''])
+
+test('ffi1', normal, compile_fail, [''])
+test('thunk', only_ways(['normal']), compile_and_run, [''])
+test('T12375', only_ways(['normal']), compile_and_run, [''])
+test('empty_sum', only_ways(['normal']), compile_and_run, [''])
+test('sum_rr', normal, compile_fail, [''])
+
+# 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) ])],
+#      run_command,
+#      ['$MAKE -s --no-print-directory sum_api_annots'])
diff --git a/testsuite/tests/unboxedsums/empty_sum.hs b/testsuite/tests/unboxedsums/empty_sum.hs
new file mode 100644
index 0000000000..7abbfd87a9
--- /dev/null
+++ b/testsuite/tests/unboxedsums/empty_sum.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE UnboxedTuples, UnboxedSums, MagicHash #-}
+
+module Main where
+
+type Null = (# #)
+
+{-# NOINLINE showNull #-}
+showNull :: Null -> String
+showNull (# #) = "(# #)"
+
+{-# NOINLINE showNullAlt #-}
+showNullAlt :: (# Null | Null #) -> String
+showNullAlt (# n1 | #) = "(# " ++ showNull n1 ++ " | #)"
+showNullAlt (# | n2 #) = "(# | " ++ showNull n2 ++ " #)"
+
+main :: IO ()
+main = do
+    putStrLn (showNull (# #))
+    putStrLn (showNullAlt (# (# #) | #))
+    putStrLn (showNullAlt (# | (# #) #))
diff --git a/testsuite/tests/unboxedsums/empty_sum.stdout b/testsuite/tests/unboxedsums/empty_sum.stdout
new file mode 100644
index 0000000000..7d3a7bf569
--- /dev/null
+++ b/testsuite/tests/unboxedsums/empty_sum.stdout
@@ -0,0 +1,3 @@
+(# #)
+(# (# #) | #)
+(# | (# #) #)
diff --git a/testsuite/tests/unboxedsums/ffi1.hs b/testsuite/tests/unboxedsums/ffi1.hs
new file mode 100644
index 0000000000..e6128e4ff1
--- /dev/null
+++ b/testsuite/tests/unboxedsums/ffi1.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Lib where
+
+import GHC.Prim
+
+-- Can't unboxed tuples and sums to FFI, we should fail appropriately.
+
+foreign import ccall "f1" f1 :: (# Int | Int #) -> IO Int
+foreign import ccall "f2" f2 :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int
+foreign import ccall "f3" f3 :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int
diff --git a/testsuite/tests/unboxedsums/ffi1.stderr b/testsuite/tests/unboxedsums/ffi1.stderr
new file mode 100644
index 0000000000..3a97270d0d
--- /dev/null
+++ b/testsuite/tests/unboxedsums/ffi1.stderr
@@ -0,0 +1,23 @@
+
+ffi1.hs:9:1: error:
+    • Unacceptable argument type in foreign declaration:
+        ‘(# Int | Int #)’ cannot be marshalled in a foreign call
+    • When checking declaration:
+        foreign import ccall safe "static f1" f1
+          :: (# Int | Int #) -> IO Int
+
+ffi1.hs:10:1: error:
+    • Unacceptable argument type in foreign declaration:
+        ‘(# (# Int, Int #) |
+            (# Float#, Float# #) #)’ cannot be marshalled in a foreign call
+    • When checking declaration:
+        foreign import ccall safe "static f2" f2
+          :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int
+
+ffi1.hs:11:1: error:
+    • Unacceptable argument type in foreign declaration:
+        ‘(# (# #) | Void# |
+            (# Int# | String #) #)’ cannot be marshalled in a foreign call
+    • When checking declaration:
+        foreign import ccall safe "static f3" f3
+          :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int
diff --git a/testsuite/tests/unboxedsums/module/Lib.hs b/testsuite/tests/unboxedsums/module/Lib.hs
new file mode 100644
index 0000000000..569da49b7f
--- /dev/null
+++ b/testsuite/tests/unboxedsums/module/Lib.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Lib (flip, getInt) where
+
+import GHC.Exts
+import Prelude (Int)
+
+{-# NOINLINE flip #-}
+flip :: (# Int | Int# #) -> (# Int# | Int #)
+flip (# i | #) = (# | i #)
+flip (# | i #) = (# i | #)
+
+{-# NOINLINE getInt #-}
+getInt :: (# Int# | Int #) -> Int
+getInt (# i | #) = I# i
+getInt (# | i #) = i
diff --git a/testsuite/tests/unboxedsums/module/Main.hs b/testsuite/tests/unboxedsums/module/Main.hs
new file mode 100644
index 0000000000..6940dee8b1
--- /dev/null
+++ b/testsuite/tests/unboxedsums/module/Main.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE UnboxedSums #-}
+
+module Main where
+
+import Lib
+
+import Prelude (print, IO)
+
+main :: IO ()
+main = do
+    print (getInt (flip (# 123 | #)))
diff --git a/testsuite/tests/unboxedsums/module/Makefile b/testsuite/tests/unboxedsums/module/Makefile
new file mode 100644
index 0000000000..2c955459c3
--- /dev/null
+++ b/testsuite/tests/unboxedsums/module/Makefile
@@ -0,0 +1,16 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+	rm -f *.o
+	rm -f *.hi
+	rm -f Main
+
+main:
+	rm -f *.o
+	rm -f *.hi
+	rm -f Main
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c Lib.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) Main.hs
+	./Main
diff --git a/testsuite/tests/unboxedsums/module/all.T b/testsuite/tests/unboxedsums/module/all.T
new file mode 100644
index 0000000000..fe76aac11d
--- /dev/null
+++ b/testsuite/tests/unboxedsums/module/all.T
@@ -0,0 +1,4 @@
+test('sum_mod',
+     [normalise_slashes, clean_cmd('$MAKE -s clean'), extra_files(['Lib.hs', 'Main.hs'])],
+     run_command,
+     ['$MAKE -s main --no-print-director'])
diff --git a/testsuite/tests/unboxedsums/module/sum_mod.stdout b/testsuite/tests/unboxedsums/module/sum_mod.stdout
new file mode 100644
index 0000000000..615266b7f6
--- /dev/null
+++ b/testsuite/tests/unboxedsums/module/sum_mod.stdout
@@ -0,0 +1,3 @@
+[2 of 2] Compiling Main             ( Main.hs, Main.o )
+Linking Main ...
+123
diff --git a/testsuite/tests/unboxedsums/sum_rr.hs b/testsuite/tests/unboxedsums/sum_rr.hs
new file mode 100644
index 0000000000..287edcf452
--- /dev/null
+++ b/testsuite/tests/unboxedsums/sum_rr.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE DataKinds, KindSignatures #-}
+
+module Example where
+
+import Data.Typeable
+import GHC.Exts
+
+data Wat (a :: TYPE 'UnboxedSumRep) = Wat a
diff --git a/testsuite/tests/unboxedsums/sum_rr.stderr b/testsuite/tests/unboxedsums/sum_rr.stderr
new file mode 100644
index 0000000000..2ac9b7452f
--- /dev/null
+++ b/testsuite/tests/unboxedsums/sum_rr.stderr
@@ -0,0 +1,7 @@
+
+sum_rr.hs:8:39: error:
+    • The type ‘a’ is not an unboxed sum,
+      and yet its kind suggests that it has the representation
+      of an unboxed sum. This is not allowed.
+    • In the definition of data constructor ‘Wat’
+      In the data type declaration for ‘Wat’
diff --git a/testsuite/tests/unboxedsums/thunk.hs b/testsuite/tests/unboxedsums/thunk.hs
new file mode 100644
index 0000000000..53e941d174
--- /dev/null
+++ b/testsuite/tests/unboxedsums/thunk.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+{-# NOINLINE f #-}
+f :: (# #) -> [Int]
+f (# #) = [ 1 .. ]
+
+main :: IO ()
+main = print (sum (take 10 (f (# #))))
diff --git a/testsuite/tests/unboxedsums/thunk.stdout b/testsuite/tests/unboxedsums/thunk.stdout
new file mode 100644
index 0000000000..c3f407c095
--- /dev/null
+++ b/testsuite/tests/unboxedsums/thunk.stdout
@@ -0,0 +1 @@
+55
diff --git a/testsuite/tests/unboxedsums/unarise.hs b/testsuite/tests/unboxedsums/unarise.hs
new file mode 100644
index 0000000000..9cdabc4021
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unarise.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+{-# NOINLINE f1 #-}
+f1 :: (# #) -> (# #) -> String
+f1 (# #) (# #) = "o"
+
+{-# NOINLINE f2 #-}
+f2 :: (# (# #), (# #) #) -> String
+f2 (# (# #), (# #) #) = "k"
+
+main :: IO ()
+main = do
+    let t = (# (# #), (# #) #)
+    case t of
+      (# t1, t2 #) -> putStrLn (f1 t1 t2 ++ f2 t)
diff --git a/testsuite/tests/unboxedsums/unarise.stdout b/testsuite/tests/unboxedsums/unarise.stdout
new file mode 100644
index 0000000000..9766475a41
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unarise.stdout
@@ -0,0 +1 @@
+ok
diff --git a/testsuite/tests/unboxedsums/unboxedsums1.hs b/testsuite/tests/unboxedsums/unboxedsums1.hs
new file mode 100644
index 0000000000..42a04ae94e
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums1.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+import System.Mem (performMajorGC)
+
+type Either1 a b = (# a | b #)
+
+showEither1 :: (Show a, Show b) => Either1 a b -> String
+showEither1 (# left | #)  = "Left " ++ show left
+showEither1 (# | right #) = "Right " ++ show right
+
+showEither2 :: (# Int# | Float# #) -> String
+showEither2 (# i | #) = "Left " ++ show (I# i)
+showEither2 (# | f #) = "Right " ++ show (F# f)
+
+showEither3 :: Show a => (# a | Int# #) -> String
+showEither3 (# a | #) = "Left " ++ show a
+showEither3 (# | i #) = "Right " ++ show (I# i)
+
+type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #)
+
+showEither4 :: T -> String
+showEither4 (# i | | | | | | #) = "Alt0: " ++ show i
+showEither4 (# | b | | | | | #) = "Alt1: " ++ show b
+showEither4 (# | | s | | | | #) = "Alt2: " ++ show s
+showEither4 (# | | | c | | | #) = "Alt3: " ++ show c
+showEither4 (# | | | | e | | #) = "Alt4: " ++ show e
+showEither4 (# | | | | | i | #) = "Alt5: " ++ show (I# i)
+showEither4 (# | | | | | | f #) = "Alt6: " ++ show (F# f)
+
+main :: IO ()
+main = do
+    putStrLn (showEither1 e1_1)
+    putStrLn (showEither1 e1_2)
+    putStrLn (showEither2 e2_1)
+    putStrLn (showEither2 e2_2)
+    putStrLn (showEither3 e3_1)
+    putStrLn (showEither3 e3_2)
+
+    putStrLn (showEither4 e4_1)
+    putStrLn (showEither4 e4_2)
+    putStrLn (showEither4 e4_3)
+    putStrLn (showEither4 e4_4)
+    putStrLn (showEither4 e4_5)
+    putStrLn (showEither4 e4_6)
+    putStrLn (showEither4 e4_7)
+
+    -- make sure we don't put pointers to non-pointer slots
+    performMajorGC
+
+    -- make sure pointers in unboxed sums are really roots
+    putStrLn (showEither1 e1_1)
+  where
+    -- boxed types only
+    e1_1, e1_2 :: Either1 String Int
+    e1_1 = (# "error" | #)
+    e1_2 = (# | 10 #)
+
+    -- prim types only
+    e2_1, e2_2 :: (# Int# | Float# #)
+    e2_1 = (# 10# | #)
+    e2_2 = (# | 1.2# #)
+
+    -- a mix of prim and boxed types
+    e3_1, e3_2 :: (# String | Int# #)
+    e3_1 = (# "OK" | #)
+    e3_2 = (# | 123# #)
+
+    -- big arity
+    e4_1, e4_2, e4_3, e4_4, e4_5, e4_6, e4_7 :: T
+    e4_1 = (# 10 | | | | | | #)
+    e4_2 = (# | False | | | | | #)
+    e4_3 = (# | | "ok" | | | | #)
+    e4_4 = (# | | | 'a' | | | #)
+    e4_5 = (# | | | | Right True | | #)
+    e4_6 = (# | | | | | 123# | #)
+    e4_7 = (# | | | | | | 54.3# #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums1.stdout b/testsuite/tests/unboxedsums/unboxedsums1.stdout
new file mode 100644
index 0000000000..3dba0a0685
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums1.stdout
@@ -0,0 +1,14 @@
+Left "error"
+Right 10
+Left 10
+Right 1.2
+Left "OK"
+Right 123
+Alt0: 10
+Alt1: False
+Alt2: "ok"
+Alt3: 'a'
+Alt4: Right True
+Alt5: 123
+Alt6: 54.3
+Left "error"
diff --git a/testsuite/tests/unboxedsums/unboxedsums10.hs b/testsuite/tests/unboxedsums/unboxedsums10.hs
new file mode 100644
index 0000000000..00f5e548fa
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums10.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Main where
+
+type Ty = (# (Int -> Int) | (Int -> Int) #)
+
+{-# NOINLINE apply #-}
+apply :: Ty -> Int
+apply (# f | #) = f 0
+apply (# | f #) = f 1
+
+main :: IO ()
+main = do
+  print (apply (# (\x -> x * 2) | #))
+  print (apply (# | (\x -> x * 3) #))
diff --git a/testsuite/tests/unboxedsums/unboxedsums10.stdout b/testsuite/tests/unboxedsums/unboxedsums10.stdout
new file mode 100644
index 0000000000..12decc137a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums10.stdout
@@ -0,0 +1,2 @@
+0
+3
diff --git a/testsuite/tests/unboxedsums/unboxedsums11.hs b/testsuite/tests/unboxedsums/unboxedsums11.hs
new file mode 100644
index 0000000000..2cac84767e
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums11.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE UnboxedSums, MagicHash #-}
+
+module Main where
+
+type Ty = (# () | () #)
+
+{-# NOINLINE showTy #-}
+showTy :: Ty -> String
+showTy (# _ | #)  = "(# _ | #)"
+showTy (# | () #) = "(# | () #)"
+
+main :: IO ()
+main = do
+  print (showTy (# undefined | #))
+  print (showTy (# | () #))
diff --git a/testsuite/tests/unboxedsums/unboxedsums11.stdout b/testsuite/tests/unboxedsums/unboxedsums11.stdout
new file mode 100644
index 0000000000..b32d36a531
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums11.stdout
@@ -0,0 +1,2 @@
+"(# _ | #)"
+"(# | () #)"
diff --git a/testsuite/tests/unboxedsums/unboxedsums2.hs b/testsuite/tests/unboxedsums/unboxedsums2.hs
new file mode 100644
index 0000000000..115415f7c6
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums2.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE UnboxedSums, MagicHash, BangPatterns #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+-- Code generator used to fail with illegal instruction errors when Float# is
+-- involved.
+
+toInt :: (# Int# | Float# #) -> Int#
+toInt (# i | #) = i
+toInt (# | f #) = let !(I# i) = ceiling (F# f) in i
+
+toFloat :: (# Int# | Float# #) -> Float#
+toFloat (# i | #) = let !(F# f) = fromIntegral (I# i) in f
+toFloat (# | f #) = f
+
+data D = D { f1 :: (# Int# | Float# #) }
+
+instance Show D where
+  show (D (# i | #)) = "D " ++ show (I# i)
+  show (D (# | f #)) = "D " ++ show (F# f)
+
+main :: IO ()
+main = do
+    !(F# f) <- readLn
+    print (I# (toInt (# | f #)))
+
+    !(I# i) <- readLn
+    print (F# (toFloat (# i | #)))
+
+    print (D (# | f #))
+    print (D (# i | #))
diff --git a/testsuite/tests/unboxedsums/unboxedsums2.stdin b/testsuite/tests/unboxedsums/unboxedsums2.stdin
new file mode 100644
index 0000000000..82ef7c5f14
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums2.stdin
@@ -0,0 +1,2 @@
+20.123
+10
diff --git a/testsuite/tests/unboxedsums/unboxedsums2.stdout b/testsuite/tests/unboxedsums/unboxedsums2.stdout
new file mode 100644
index 0000000000..5d7d3ffb7f
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums2.stdout
@@ -0,0 +1,4 @@
+21
+10.0
+D 20.123
+D 10
diff --git a/testsuite/tests/unboxedsums/unboxedsums3.hs b/testsuite/tests/unboxedsums/unboxedsums3.hs
new file mode 100644
index 0000000000..add8aa73df
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums3.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE UnboxedSums, MagicHash, BangPatterns, UnboxedTuples #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+import Data.Void (Void)
+import System.Mem (performMajorGC)
+
+showAlt0 :: (# Void# | (# #) | () #) -> String
+showAlt0 (# | (# #) | #) = "(# | (# #) | #)"
+showAlt0 (# | | () #) = "(# | | () #)"
+
+showAlt1 :: (# Void | Float# #) -> String
+showAlt1 (# _ | #) = "(# Void | #)"
+showAlt1 (# | f #) = "(# | " ++ show (F# f) ++ "# #)"
+
+data D = D { f1 :: (# Void# | (# #) | () #)
+           , f2 :: (# Void | Float# #)
+           }
+
+showD :: D -> String
+showD (D f1 f2) = showAlt0 f1 ++ "\n" ++ showAlt1 f2
+
+main :: IO ()
+main = do
+    putStrLn (showAlt0 (# | (# #) | #))
+    putStrLn (showAlt0 (# | | () #))
+    putStrLn (showAlt1 (# undefined | #))
+    putStrLn (showAlt1 (# | 8.1# #))
+    putStrLn (showD (D (# | (# #) | #) (# | 1.2# #)))
+    performMajorGC
diff --git a/testsuite/tests/unboxedsums/unboxedsums3.stdout b/testsuite/tests/unboxedsums/unboxedsums3.stdout
new file mode 100644
index 0000000000..b37cc04c30
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums3.stdout
@@ -0,0 +1,6 @@
+(# | (# #) | #)
+(# | | () #)
+(# Void | #)
+(# | 8.1# #)
+(# | (# #) | #)
+(# | 1.2# #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums4.hs b/testsuite/tests/unboxedsums/unboxedsums4.hs
new file mode 100644
index 0000000000..3257a7043e
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums4.hs
@@ -0,0 +1,3 @@
+module Lib where
+
+sum = (10 |)
diff --git a/testsuite/tests/unboxedsums/unboxedsums4.stderr b/testsuite/tests/unboxedsums/unboxedsums4.stderr
new file mode 100644
index 0000000000..2cd4be6c9a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums4.stderr
@@ -0,0 +1,2 @@
+
+unboxedsums4.hs:3:7: error: Boxed sums not supported: ( 10 | )
diff --git a/testsuite/tests/unboxedsums/unboxedsums5.hs b/testsuite/tests/unboxedsums/unboxedsums5.hs
new file mode 100644
index 0000000000..0bb8c67c7e
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums5.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE UnboxedSums #-}
+
+module Lib where
+
+-- No spaces needed in the type syntax
+type T = (#Int|Bool|String#)
+
+-- Term syntax needs spaces, otherwise we parser bars as sections
+-- for ||, ||| etc.
+--
+-- t1 :: T
+-- t1 = (# 10 | | #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums6.hs b/testsuite/tests/unboxedsums/unboxedsums6.hs
new file mode 100644
index 0000000000..767366d4d5
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums6.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE UnboxedSums, MagicHash, UnboxedTuples #-}
+
+-- Nesting sums and tuples is OK
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+import System.Mem (performMajorGC)
+
+type S_T_T a b c d = (# (# a , b #) | (# c , d #) #)
+type S_S_S a b c d = (# (# a | b #) | (# c | d #) #)
+
+show_stt :: (Show a, Show b, Show c, Show d) => S_T_T a b c d -> String
+show_stt (# (# a, b #) | #) = show a ++ show b
+show_stt (# | (# c, d #) #) = show c ++ show d
+
+show_sss :: (Show a, Show b, Show c, Show d) => S_S_S a b c d -> String
+show_sss (# (# a | #) | #) = show a
+show_sss (# (# | b #) | #) = show b
+show_sss (# | (# c | #) #) = show c
+show_sss (# | (# | d #) #) = show d
+
+main :: IO ()
+main = do
+    putStrLn (show_stt stt)
+    putStrLn (show_sss sss)
+    performMajorGC
+  where
+    stt :: S_T_T Int Bool Float String
+    stt = (# (# 123, True #) | #)
+
+    sss :: S_S_S Int Bool Float String
+    sss = (# | (# 1.2 | #) #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums6.stdout b/testsuite/tests/unboxedsums/unboxedsums6.stdout
new file mode 100644
index 0000000000..f2448cc95f
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums6.stdout
@@ -0,0 +1,2 @@
+123True
+1.2
diff --git a/testsuite/tests/unboxedsums/unboxedsums7.hs b/testsuite/tests/unboxedsums/unboxedsums7.hs
new file mode 100644
index 0000000000..d64dabb13a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums7.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+type Either1 a b c = (# a | (# b, c #) #)
+
+-- The bug disappears when this is inlined
+{-# NOINLINE showEither1 #-}
+
+showEither1 :: Either1 String Int Bool -> String
+showEither1 (# left | #) = "Left " ++ show left
+showEither1 (# | (# right1, right2 #) #) = "Right " ++ show right1 ++ " " ++ show right2
+
+main :: IO ()
+main = do
+    -- This line used to print "Right -4611686018427359531 False"
+    putStrLn (showEither1 e1_2)
+  where
+    -- boxed types only
+    e1_2 :: Either1 String Int Bool
+    e1_2 = (# | (# 10, True #) #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums7.stdout b/testsuite/tests/unboxedsums/unboxedsums7.stdout
new file mode 100644
index 0000000000..7c5942246e
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums7.stdout
@@ -0,0 +1 @@
+Right 10 True
diff --git a/testsuite/tests/unboxedsums/unboxedsums8.hs b/testsuite/tests/unboxedsums/unboxedsums8.hs
new file mode 100644
index 0000000000..07ef122b69
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums8.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Main where
+
+import GHC.Prim
+import GHC.Types
+
+type Sum1 = (# (# Int#, Int #) | (# Int#, Int# #) | (# Int, Int# #) #)
+
+{-# NOINLINE showSum1 #-}
+showSum1 :: Sum1 -> String
+showSum1 (# p1 | | #) = showP1 p1
+showSum1 (# | p2 | #) = showP2 p2
+showSum1 (# | | p3 #) = showP3 p3
+
+{-# NOINLINE showP1 #-}
+showP1 :: (# Int#, Int #) -> String
+showP1 (# i1, i2 #) = show (I# i1) ++ show i2
+
+{-# NOINLINE showP2 #-}
+showP2 :: (# Int#, Int# #) -> String
+showP2 (# i1, i2 #) = show (I# i1) ++ show (I# i2)
+
+{-# NOINLINE showP3 #-}
+showP3 :: (# Int, Int# #) -> String
+showP3 (# i1, i2 #) = show i1 ++ show (I# i2)
+
+main :: IO ()
+main = do
+    putStrLn (showSum1 s1)
+    putStrLn (showSum1 s2)
+    putStrLn (showSum1 s3)
+  where
+    s1, s2, s3 :: Sum1
+    s1 = (# (# 123#, 456 #) | | #)
+    s2 = (# | (# 876#, 543# #) | #)
+    s3 = (# | | (# 123, 456# #) #)
diff --git a/testsuite/tests/unboxedsums/unboxedsums8.stdout b/testsuite/tests/unboxedsums/unboxedsums8.stdout
new file mode 100644
index 0000000000..35242be50a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums8.stdout
@@ -0,0 +1,3 @@
+123456
+876543
+123456
diff --git a/testsuite/tests/unboxedsums/unboxedsums9.hs b/testsuite/tests/unboxedsums/unboxedsums9.hs
new file mode 100644
index 0000000000..79927fc58b
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums9.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-}
+
+module Main where
+
+type UbxBool = (# (# #) | (# #) #)
+
+{-# NOINLINE packBool #-}
+packBool :: UbxBool -> Bool
+packBool (# _ | #) = True
+packBool (# | _ #) = False
+
+{-# NOINLINE unpackBool #-}
+unpackBool :: Bool -> UbxBool
+unpackBool True  = (# (# #) | #)
+unpackBool False = (# | (# #) #)
+
+{-# NOINLINE showUbxBool #-}
+showUbxBool :: UbxBool -> String
+showUbxBool b = show (packBool b)
+
+main :: IO ()
+main = do
+  putStrLn (showUbxBool (unpackBool True))
+  putStrLn (showUbxBool (unpackBool False))
+  putStrLn (show (packBool (# (# #) | #)))
+  putStrLn (show (packBool (# | (# #) #)))
diff --git a/testsuite/tests/unboxedsums/unboxedsums9.stdout b/testsuite/tests/unboxedsums/unboxedsums9.stdout
new file mode 100644
index 0000000000..7474532fd2
--- /dev/null
+++ b/testsuite/tests/unboxedsums/unboxedsums9.stdout
@@ -0,0 +1,4 @@
+True
+False
+True
+False