Add VecSlot for unboxed sums of SIMD vectors

This patch adds the missing `VecRep` case to `primRepSlot` function and
all the necessary machinery to carry this new `VecSlot` through code
generation. This allows programs involving unboxed sums of SIMD vectors
to be written and compiled.

Fixes #22187

(cherry picked from commit 5b3a992f5d166007c3c5a22f120ed08e0a27f01a)

7 files changed, 70 insertions, 3 deletions

diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index 9e9566b334..e2957ec704 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -115,7 +115,7 @@ primRepCmmType platform = \case
    AddrRep          -> bWord platform
    FloatRep         -> f32
    DoubleRep        -> f64
-   (VecRep len rep) -> vec len (primElemRepCmmType rep)
+   VecRep len rep   -> vec len (primElemRepCmmType rep)
 
 slotCmmType :: Platform -> SlotTy -> CmmType
 slotCmmType platform = \case
@@ -125,6 +125,7 @@ slotCmmType platform = \case
    Word64Slot      -> b64
    FloatSlot       -> f32
    DoubleSlot      -> f64
+   VecSlot l e     -> vec l (primElemRepCmmType e)
 
 primElemRepCmmType :: PrimElemRep -> CmmType
 primElemRepCmmType Int8ElemRep   = b8
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index 872ce1a2af..f82a0d5468 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -658,6 +658,7 @@ ubxSumRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0)
 ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0)
 ubxSumRubbishArg FloatSlot  = StgLitArg (LitFloat 0)
 ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
+ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish [VecRep n e])
 
 --------------------------------------------------------------------------------
 
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index 30d97ae724..d259ef92f7 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -235,7 +235,7 @@ layoutUbxSum sum_slots0 arg_slots0 =
 --
 -- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit
 -- values, so that we can pack things more tightly.
-data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
+data SlotTy = PtrLiftedSlot | PtrUnliftedSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot | VecSlot Int PrimElemRep
   deriving (Eq, Ord)
     -- Constructor order is important! If slot A could fit into slot B
     -- then slot A must occur first.  E.g.  FloatSlot before DoubleSlot
@@ -250,6 +250,7 @@ instance Outputable SlotTy where
   ppr WordSlot        = text "WordSlot"
   ppr DoubleSlot      = text "DoubleSlot"
   ppr FloatSlot       = text "FloatSlot"
+  ppr (VecSlot n e)   = text "VecSlot" <+> ppr n <+> ppr e
 
 typeSlotTy :: UnaryType -> Maybe SlotTy
 typeSlotTy ty
@@ -275,7 +276,7 @@ primRepSlot Word64Rep   = Word64Slot
 primRepSlot AddrRep     = WordSlot
 primRepSlot FloatRep    = FloatSlot
 primRepSlot DoubleRep   = DoubleSlot
-primRepSlot VecRep{}    = pprPanic "primRepSlot" (text "No slot for VecRep")
+primRepSlot (VecRep n e) = VecSlot n e
 
 slotPrimRep :: SlotTy -> PrimRep
 slotPrimRep PtrLiftedSlot   = LiftedRep
@@ -284,6 +285,7 @@ slotPrimRep Word64Slot      = Word64Rep
 slotPrimRep WordSlot        = WordRep
 slotPrimRep DoubleSlot      = DoubleRep
 slotPrimRep FloatSlot       = FloatRep
+slotPrimRep (VecSlot n e)   = VecRep n e
 
 -- | Returns the bigger type if one fits into the other. (commutative)
 fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy
diff --git a/testsuite/tests/unboxedsums/T22187.hs b/testsuite/tests/unboxedsums/T22187.hs
new file mode 100644
index 0000000000..89ccfc2a6c
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T22187.hs
@@ -0,0 +1,6 @@
+{-# language MagicHash,UnboxedSums #-}
+module T22187 where
+import GHC.Exts
+
+foo :: (# Int64X2# | () #) -> ()
+foo _ = ()
diff --git a/testsuite/tests/unboxedsums/T22187_run.hs b/testsuite/tests/unboxedsums/T22187_run.hs
new file mode 100644
index 0000000000..b107b97dfb
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T22187_run.hs
@@ -0,0 +1,51 @@
+{-# language MagicHash, UnboxedTuples, UnboxedSums #-}
+
+module Main ( main ) where
+
+import GHC.Exts
+import GHC.Int
+import GHC.Word
+import GHC.Float
+import GHC.Prim
+
+foo :: (# Int64X2# | Bool | DoubleX2# #)
+    -> (# Integer | (# FloatX4#, Int#, Int# #) | Char #)
+foo (# i64x2 | | #) =
+  case unpackInt64X2# i64x2 of
+    (# i1, i2 #) ->
+      let
+        s = sum $ map fromIntegral
+             [ I64# i1, I64# i2 ]
+      in (# s | | #)
+
+foo (# | b | #) = if b then (# 0 | | #) else (# | | 'F' #)
+foo (# | | dx2 #) =
+  case unpackDoubleX2# dx2 of
+    (# d1, d2 #) ->
+      let (# m1, e1 #) = decodeDouble_Int64# d1
+          (# m2, e2 #) = decodeDouble_Int64# d2
+          v = packFloatX4#
+                (# double2Float# d1
+                ,  int2Float#    e1
+                ,  double2Float# d2
+                ,  int2Float#    e1 #)
+      in (# | (# v, m1, m2 #) | #)
+
+show_it :: (# Integer | (# FloatX4#, Int#, Int# #) | Char #) -> String
+show_it (# i | | #) = "(# " ++ show i ++ " | | #)"
+show_it (# | (# fx4, m1, m2 #) | #) = "(# | (# " ++ showFloatX4 fx4 ++ ", " ++ show (I64# m1) ++ ", " ++ show (I64# m2) ++ " #) | #)"
+show_it (# | | c #) = "(# | | " ++ show c ++ " #)"
+
+showFloatX4 :: FloatX4# -> String
+showFloatX4 fx4 = case unpackFloatX4# fx4 of
+  (# f1, f2, f3, f4 #) ->
+    "(# " ++ show (F# f1) ++ ", " ++ show (F# f2) ++ ", "
+          ++ show (F# f3) ++ ", " ++ show (F# f4) ++ " #)"
+
+main :: IO ()
+main = do
+  putStrLn $ show_it ( foo (# broadcastInt64X2# 1# | | #) )
+  putStrLn $ show_it ( foo (# | False | #) )
+  putStrLn $ show_it ( foo (# | True | #) )
+  let dx2 = packDoubleX2# (# 128.0##, -0.0025## #)
+  putStrLn $ show_it ( foo (# | | dx2 #) )
diff --git a/testsuite/tests/unboxedsums/T22187_run.stdout b/testsuite/tests/unboxedsums/T22187_run.stdout
new file mode 100644
index 0000000000..e48a94c190
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T22187_run.stdout
@@ -0,0 +1,4 @@
+(# 2 | | #)
+(# | | 'F' #)
+(# 0 | | #)
+(# | (# (# 128.0, -45.0, -2.5e-3, -45.0 #), 4503599627370496, -5764607523034235 #) | #)
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index c3cf9f1559..b86e65a4b0 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -27,3 +27,5 @@ test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script'])
 test('UbxSumLevPoly', normal, compile, ['-Wno-overlapping-patterns'])
 test('T14051', normal, multi_compile, ['T14051.hs', [('T14051a.hs', '')], '-O2 -v0'])
 test('T19645', normal, compile_and_run, [''])
+test('T22187',[only_ways(llvm_ways), expect_broken(22296)],compile,[''])
+test('T22187_run',[only_ways(llvm_ways), expect_broken(22296)],compile_and_run,[''])