summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDai <daig@users.noreply.github.com>2022-10-14 13:07:43 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-10-19 10:45:45 -0400
commit5b3a992f5d166007c3c5a22f120ed08e0a27f01a (patch)
tree4da760b794be76a6298acefa62e3be4c61b3794e
parent99dc3e3d76daab80a5c5209a3e0c44c9e4664e06 (diff)
downloadhaskell-5b3a992f5d166007c3c5a22f120ed08e0a27f01a.tar.gz
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
-rw-r--r--compiler/GHC/Cmm/Utils.hs3
-rw-r--r--compiler/GHC/Stg/Unarise.hs2
-rw-r--r--compiler/GHC/Types/Literal.hs3
-rw-r--r--compiler/GHC/Types/RepType.hs6
-rw-r--r--testsuite/tests/unboxedsums/T22187.hs6
-rw-r--r--testsuite/tests/unboxedsums/T22187_run.hs50
-rw-r--r--testsuite/tests/unboxedsums/T22187_run.stdout4
-rw-r--r--testsuite/tests/unboxedsums/all.T3
8 files changed, 73 insertions, 4 deletions
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index 3671366d07..7524ba7c5e 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -113,7 +113,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
@@ -123,6 +123,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 440b184d44..8dfdeb607c 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -694,6 +694,8 @@ 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 vec_rep)
+ where vec_rep = primRepToRuntimeRep (VecRep n e)
--------------------------------------------------------------------------------
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index 199d744034..9997859afc 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/compiler/GHC/Types/Literal.hs
@@ -67,6 +67,7 @@ module GHC.Types.Literal
import GHC.Prelude
import GHC.Builtin.Types.Prim
+import GHC.Core.TyCo.Rep ( RuntimeRepType )
import GHC.Core.Type
import GHC.Utils.Outputable
import GHC.Data.FastString
@@ -131,7 +132,7 @@ data Literal
-- that can be represented as a Literal. Create
-- with 'nullAddrLit'
- | LitRubbish Type -- ^ A nonsense value of the given
+ | LitRubbish RuntimeRepType -- ^ A nonsense value of the given
-- representation. See Note [Rubbish literals].
--
-- The Type argument, rr, is of kind RuntimeRep.
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index 993694e1c3..30eb12c7a7 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -286,7 +286,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
@@ -301,6 +301,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
@@ -326,7 +327,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
@@ -335,6 +336,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)
--
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..38a30f5e5a
--- /dev/null
+++ b/testsuite/tests/unboxedsums/T22187_run.hs
@@ -0,0 +1,50 @@
+{-# language MagicHash, UnboxedTuples, UnboxedSums #-}
+
+module Main ( main ) where
+
+import GHC.Exts
+import GHC.Int
+import GHC.Word
+import GHC.Float
+
+foo :: (# Int64X2# | Bool | DoubleX2# #)
+ -> (# Integer | (# FloatX4#, Int64#, Int64# #) | 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#, Int64#, Int64# #) | 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# ( intToInt64# 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 ba25543d54..2fb0b9ad60 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -35,3 +35,6 @@ test('T20858b', [extra_files(['T20858.hs'])
,extra_hc_opts("-fprint-explicit-runtime-reps -fprint-explicit-kinds")]
, ghci_script, ['T20858b.script'])
test('T20859', normal, compile, [''])
+
+test('T22187',[only_ways(llvm_ways), expect_broken(22296)],compile,[''])
+test('T22187_run',[only_ways(llvm_ways), expect_broken(22296)],compile_and_run,[''])