diff options
author | Dai <daig@users.noreply.github.com> | 2022-10-14 13:07:43 +0200 |
---|---|---|
committer | Matthew Pickering <matthewtpickering@gmail.com> | 2022-12-13 09:30:47 +0000 |
commit | 7a40261fd963c2b8895afd34bf6a7969d5e474cf (patch) | |
tree | decf56cbfa09083071bd5d410416baaafd77350b | |
parent | 3e64864250e5322b7b9d50731d93671069911dda (diff) | |
download | haskell-7a40261fd963c2b8895afd34bf6a7969d5e474cf.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
(cherry picked from commit 5b3a992f5d166007c3c5a22f120ed08e0a27f01a)
-rw-r--r-- | compiler/GHC/Cmm/Utils.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Stg/Unarise.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Types/Literal.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Types/RepType.hs | 8 | ||||
-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, 76 insertions, 7 deletions
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index 2060be5bda..21de329ffd 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 84f508bd9b..c39791e7ce 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -391,7 +391,6 @@ import GHC.Utils.Monad (mapAccumLM) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Stg.Utils import GHC.Core.Type @@ -401,6 +400,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique import GHC.Utils.Misc import GHC.Types.Var.Env +import GHC.Types.RepType import Data.Bifunctor (second) import Data.Maybe (mapMaybe) @@ -848,7 +848,7 @@ castArgRename ops in_arg rhs = -- Construct a case binder used when casting sums, of a given type and unique. mkCastVar :: Unique -> Type -> Id -mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty +mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq Many ty mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_ty in_rhs = @@ -952,6 +952,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 5b14ecc78d..31519f7044 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 8b39fc468b..94ff7c1d38 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -13,7 +13,7 @@ module GHC.Types.RepType -- * Type representation for the code generator typePrimRep, typePrimRep1, runtimeRepPrimRep, typePrimRepArgs, - PrimRep(..), primRepToType, + PrimRep(..), primRepToType, primRepToRuntimeRep, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, tyConPrimRep, tyConPrimRep1, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, @@ -288,7 +288,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 @@ -303,6 +303,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 @@ -328,7 +329,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 @@ -337,6 +338,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 2c28e160e9..6e77687ce4 100644 --- a/testsuite/tests/unboxedsums/all.T +++ b/testsuite/tests/unboxedsums/all.T @@ -45,3 +45,6 @@ test('ManyUbxSums', ['ManyUbxSums', [('ManyUbxSums_Addr.hs','')] , '-v0 -dstg-lint -dcmm-lint']) + +test('T22187',[only_ways(llvm_ways), expect_broken(22296)],compile,['']) +test('T22187_run',[only_ways(llvm_ways), expect_broken(22296)],compile_and_run,['']) |