5 files changed, 186 insertions, 0 deletions
diff --git a/testsuite/tests/unboxedsums/GenManyUbxSums.hs b/testsuite/tests/unboxedsums/GenManyUbxSums.hs
new file mode 100755
index 0000000000..5d38f10b5b
--- /dev/null
+++ b/testsuite/tests/unboxedsums/GenManyUbxSums.hs
@@ -0,0 +1,109 @@
+#!/usr/bin/env runghc
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
+
+-- This little piece of code constructs a large set of functions
+-- constructing and deconstructing unboxed tuples of various types.
+module Main where
+
+import GHC.Exts
+import System.IO
+import Data.List (intersperse)
+inputs = ["Int", "Word"]
+sizes = ["","8","16","32","64"]
+
+-- ["Addr#","Int#","Int8#","Int16#","Int32#","Int64#","Word#","Word8#","Word16#","Word32#","Word64#"]
+types = "Addr#" : do
+    r <- inputs
+    s <- sizes
+    return $ r++s++"#"
+
+-- We eventually build two sums, one of type (# t1 | t2 #) and one of (# t1 | t3).
+-- So we build all possible combinations of three types here.
+combos = do
+    t1 <- types
+    t2 <- types
+    t3 <- types
+    return (t1,t2,t3)
+
+mkCon ty = case ty of
+    "Addr#" -> "Addr"
+    "Int#" -> "I#"
+    "Int8#" -> "I8#"
+    "Int16#" -> "I16#"
+    "Int32#" -> "I32#"
+    "Int64#" -> "I64#"
+    "Word#" -> "W#"
+    "Word8#" -> "W8#"
+    "Word16#" -> "W16#"
+    "Word32#" -> "W32#"
+    "Word64#" -> "W64#"
+
+-- Construct a function like the one below, varying the types in the sums based on the
+-- given type tuples.
+-- We need to NOINLINE or the function will be constant folded away.
+-- {-# NOINLINE fun0 #-}
+-- fun0 :: (# Addr# | I16# #) -> (# Addr# | I# #)
+-- fun0 x = case x of
+--   (# x1 | #) -> (# x1 | #) :: (# Addr# | I# #)
+mkFun n (t1,t2,t3) =
+    "{-# NOINLINE fun" ++ show n ++ " #-}\n" ++
+    "fun" ++ show n ++ " :: (# " ++ t1 ++" | " ++ t2 ++ " #) -> (# " ++ t1 ++" | " ++ t3 ++ " #)\n" ++
+    "fun" ++ show n ++ " x = case x of\n" ++
+    "  (# x1 | #) -> (# x1 | #) :: (# " ++ t1 ++ " | " ++ t3 ++ " #)"
+
+-- Generate functions for all the tuple combinations.
+mkFuns _ [] = ""
+mkFuns n (combo:combos) =
+    mkFun n combo ++ "\n" ++ mkFuns (n+1) combos
+
+-- generate a test that will put a value into a unboxed sum and then retrieve it later on.
+-- It generates code like the one below:
+-- test0 =
+--     let in_val = maxBound
+--         out_val = case in_val of I# x -> case fun0 (# x | #) of (# y | #) -> I# y
+--     in in_val == out_val
+mkTest n (t1,_,_)=
+    let test_name = "test" ++ show n
+        test_code = test_name ++ " =\n" ++
+                    "  let in_val = (maxBound)\n" ++
+                    "      out_val = case in_val of " ++ mkCon t1 ++ " x -> case fun" ++ show n ++ " (# x | #) of (# y | #) -> " ++ mkCon t1 ++ " y\n" ++
+                    "  in in_val == out_val"
+    in (test_code,test_name)
+
+-- Test all the tuples
+mkTests n combos =
+    let (defs, names) = unzip $ zipWith mkTest [0..] combos
+        assert_results = "\nassert_results = and [" ++ (concat $ intersperse "," names) ++ "]\n" :: String
+    in unlines defs ++ assert_results
+
+header =
+    "{-# LANGUAGE MagicHash #-}\n\
+    \{-# LANGUAGE UnboxedTuples #-}\n\
+    \{-# LANGUAGE UnboxedSums #-}\n\
+    \module Main where\n\
+    \import GHC.Exts\n\
+    \import GHC.Word\n\
+    \import GHC.Int\n\
+    \import ManyUbxSums_Addr\n"
+main = do
+    out <- openFile "ManyUbxSums.hs" WriteMode
+    hPutStrLn out header
+
+    let combo:_ = combos
+    -- putStrLn $ mkFun 1 combo
+    hPutStrLn out $ mkFuns 0 combos
+
+    hPutStrLn out $ mkTests 0 combos
+    hPutStrLn out "main = do"
+
+    hPutStrLn out $ "  putStrLn . show $ assert_results"
+
+    -- The snippet below would print all individual test results.
+    -- But for CI really just check if all results match the input
+    -- let runTest n =
+    --         hPutStrLn out $ "  putStrLn $ \"test" ++ show n ++ " \" ++ (show test" ++ show n ++ ")"
+    --         mapM runTest [0 .. length combos - 1]
+
+    hClose out
diff --git a/testsuite/tests/unboxedsums/ManyUbxSums.stdout b/testsuite/tests/unboxedsums/ManyUbxSums.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/unboxedsums/ManyUbxSums.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/unboxedsums/ManyUbxSums_Addr.hs b/testsuite/tests/unboxedsums/ManyUbxSums_Addr.hs
new file mode 100644
index 0000000000..6e718168e8
--- /dev/null
+++ b/testsuite/tests/unboxedsums/ManyUbxSums_Addr.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
+
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+
+module ManyUbxSums_Addr where
+
+import GHC.Exts
+-- import GHC.Word
+-- import GHC.Int
+--import GHC.Utils.Misc
+
+data Addr = Addr Addr#
+
+instance Eq Addr where
+    (Addr x) == (Addr y) = case (eqAddr# x y) of
+      1# -> True
+      0# -> False
+
+instance Num Addr where
+  fromInteger x = case fromIntegral x of I# x1 -> Addr (int2Addr# x1)
+
+instance Bounded Addr where
+  maxBound = fromIntegral (maxBound :: Word)
+  minBound = 0
+\ No newline at end of file
diff --git a/testsuite/tests/unboxedsums/T22208.hs b/testsuite/tests/unboxedsums/T22208.hs
new file mode 100644
index 0000000000..cc85eafcef
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T22208.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE MagicHash                 #-}
+{-# LANGUAGE UnboxedSums               #-}
+{-# LANGUAGE UnboxedTuples             #-}
+module M where
+
+import GHC.Base
+
+-- Reproducer from #22208
+foo :: (# Float# | Double# #) -> (# Float# | Float #)
+foo (# x | #) = (# x | #)
+bar :: (# Word# | Int64# #) -> (# Double# | Word# #)
+bar (# y | #) = let x = y in (# | x #)
+baz :: (# Word# | Word64# #) -> (# Word# | (##) #)
+baz (# x | #) = (# x | #)
+
+foo1 :: (# Float# | Double# #) -> (# Float# | Float #)
+foo1 (# x | #) = (# x | #)
+bar1 :: (# Word# | Int64# #) -> (# Double# | Word# #)
+bar1 (# y | #) = let x = y in (# | x #)
+baz1 :: (# Word# | Word64# #) -> (# Word# | (##) #)
+baz1 (# x | #) = (# x | #)
+
+-- i8 value from w64 slot
+baz2 :: (# Int8# | Word64# #) -> (# Int8# | (##) #)
+baz2 (# x | #) = (# x | #)
+
+-- w8 value from w64 slot
+baz3 :: (# Word8# | Word64# #) -> (# Word8# | (##) #)
+baz3 (# x | #) = (# x | #)
+
+-- w8 from w slot
+baz4 :: (# Word8# | Word# #) -> (# Word8# | (##) #)
+baz4 (# x | #) = (# x | #)
+
+-- w from w slot
+baz5 :: (# Word8# | Word# #) -> (# Word# | (##) #)
+baz5 (# | x #) = (# x | #)
+
+-- addr from w slot
+baz6 :: (# Addr# | Word# #) -> (# Addr# | (##) #)
+baz6 (# x | #) = (# x | #)
+\ No newline at end of file
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index 0d887c60ed..dc078fc8e6 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -55,3 +55,12 @@ test('unpack_sums_9', normal, compile, [""])
 #      [only_ways(['normal']),
 #       extra_files([ "unboxedsums" + str(i) + ".hs" for i in range(1, 12) ])],
 #      makefile_test, [])
+test('T22208', normal, compile, ['-dstg-lint -dcmm-lint'])
+test('ManyUbxSums',
+     [ pre_cmd('{compiler} --run ./GenManyUbxSums.hs'),
+       extra_files(['GenManyUbxSums.hs', 'ManyUbxSums_Addr.hs']),
+     ],
+     multi_compile_and_run,
+     ['ManyUbxSums',
+        [('ManyUbxSums_Addr.hs','')]
+        , '-v0 -dstg-lint -dcmm-lint'])