diff options
author | Dai <daig@users.noreply.github.com> | 2022-10-14 13:07:43 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-10-19 10:45:45 -0400 |
commit | 5b3a992f5d166007c3c5a22f120ed08e0a27f01a (patch) | |
tree | 4da760b794be76a6298acefa62e3be4c61b3794e | |
parent | 99dc3e3d76daab80a5c5209a3e0c44c9e4664e06 (diff) | |
download | haskell-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.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Stg/Unarise.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Types/Literal.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Types/RepType.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/unboxedsums/T22187.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/unboxedsums/T22187_run.hs | 50 | ||||
-rw-r--r-- | testsuite/tests/unboxedsums/T22187_run.stdout | 4 | ||||
-rw-r--r-- | testsuite/tests/unboxedsums/all.T | 3 |
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,['']) |