[Git][ghc/ghc][master] 4 commits: Add VecSlot for unboxed sums of SIMD vectors

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Wed Oct 19 14:46:09 UTC 2022



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
5b3a992f by Dai at 2022-10-19T10:45:45-04:00
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

- - - - -
6d7d9181 by sheaf at 2022-10-19T10:45:45-04:00
Remove SIMD conversions

This patch makes it so that packing/unpacking SIMD
vectors always uses the right sized types, e.g.
unpacking a Word16X4# will give a tuple of Word16#s.

As a result, we can get rid of the conversion instructions
that were previously required.

Fixes #22296

- - - - -
3be48877 by sheaf at 2022-10-19T10:45:45-04:00
Cmm Lint: relax SIMD register assignment check

As noted in #22297, SIMD vector registers can be used
to store different kinds of values, e.g. xmm1 can be used
both to store integer and floating point values.
The Cmm type system doesn't properly account for this, so
we weaken the Cmm register assignment lint check to only
compare widths when comparing a vector type with its
allocated vector register.

- - - - -
f7b7a312 by sheaf at 2022-10-19T10:45:45-04:00
Disable some SIMD tests on non-X86 architectures

- - - - -


15 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Cmm/Lint.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Utils.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Types/Literal.hs
- compiler/GHC/Types/RepType.hs
- + testsuite/tests/codeGen/should_run/T22296.hs
- + testsuite/tests/codeGen/should_run/T22296.stdout
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/unboxedsums/T22187.hs
- + testsuite/tests/unboxedsums/T22187_run.hs
- + testsuite/tests/unboxedsums/T22187_run.stdout
- testsuite/tests/unboxedsums/all.T


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3832,9 +3832,9 @@ section "SIMD Vectors"
   [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \
   ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \
   ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \
-  ,<Word8,Word#,16>,<Word16,Word#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \
-  ,<Word8,Word#,32>,<Word16,Word#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \
-  ,<Word8,Word#,64>,<Word16,Word#,32>,<Word32,Word32#,16>,<Word64,Word64#,8> \
+  ,<Word8,Word8#,16>,<Word16,Word16#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \
+  ,<Word8,Word8#,32>,<Word16,Word16#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \
+  ,<Word8,Word8#,64>,<Word16,Word16#,32>,<Word32,Word32#,16>,<Word64,Word64#,8> \
   ,<Float,Float#,4>,<Double,Double#,2> \
   ,<Float,Float#,8>,<Double,Double#,4> \
   ,<Float,Float#,16>,<Double,Double#,8>]
@@ -3856,9 +3856,9 @@ section "SIMD Vectors"
   [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \
   ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \
   ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \
-  ,<Word8,Word#,16>,<Word16,Word#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \
-  ,<Word8,Word#,32>,<Word16,Word#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \
-  ,<Word8,Word#,64>,<Word16,Word#,32>,<Word32,Word32#,16>,<Word64,Word64#,8>]
+  ,<Word8,Word8#,16>,<Word16,Word16#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \
+  ,<Word8,Word8#,32>,<Word16,Word16#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \
+  ,<Word8,Word8#,64>,<Word16,Word16#,32>,<Word32,Word32#,16>,<Word64,Word64#,8>]
 
 primtype VECTOR
    with llvm_only = True


=====================================
compiler/GHC/Cmm/Lint.hs
=====================================
@@ -174,9 +174,21 @@ lintCmmMiddle node = case node of
             platform <- getPlatform
             erep <- lintCmmExpr expr
             let reg_ty = cmmRegType platform reg
-            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
-                then return ()
-                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
+            unless (compat_regs erep reg_ty) $
+              cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
+    where
+      compat_regs :: CmmType -> CmmType -> Bool
+      compat_regs ty1 ty2
+        -- As noted in #22297, SIMD vector registers can be used for
+        -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats,
+        -- or 4 Int32s, or 2 Word64s, ...
+        -- To allow this, we relax the check: we only ensure that the widths
+        -- match, until we can find a more robust solution.
+        | isVecType ty1
+        , isVecType ty2
+        = typeWidth ty1 == typeWidth ty2
+        | otherwise
+        = cmmEqType_ignoring_ptrhood ty1 ty2
 
   CmmStore l r _alignment -> do
             _ <- lintCmmExpr l


=====================================
compiler/GHC/Cmm/MachOp.hs
=====================================
@@ -514,8 +514,11 @@ machOpArgReps platform op =
     MO_FS_Conv from _   -> [from]
     MO_FF_Conv from _   -> [from]
 
-    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform]
-    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth platform]
+    MO_V_Insert   l r   -> [typeWidth (vec l (cmmBits r)),r, W32]
+    MO_V_Extract  l r   -> [typeWidth (vec l (cmmBits r)), W32]
+    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,W32]
+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),W32]
+      -- SIMD vector indices are always 32 bit
 
     MO_V_Add _ r        -> [r,r]
     MO_V_Sub _ r        -> [r,r]
@@ -528,9 +531,6 @@ machOpArgReps platform op =
     MO_VU_Quot _ r      -> [r,r]
     MO_VU_Rem  _ r      -> [r,r]
 
-    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform]
-    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth platform]
-
     MO_VF_Add  _ r      -> [r,r]
     MO_VF_Sub  _ r      -> [r,r]
     MO_VF_Mul  _ r      -> [r,r]


=====================================
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


=====================================
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)
 
 --------------------------------------------------------------------------------
 


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -853,7 +853,7 @@ emitPrimOp cfg primop =
 -- SIMD primops
   (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do
     checkVecCompatibility cfg vcat n w
-    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res
+    doVecPackOp ty zeros (replicate n e) res
    where
     zeros :: CmmExpr
     zeros = CmmLit $ CmmVec (replicate n zero)
@@ -871,7 +871,7 @@ emitPrimOp cfg primop =
     checkVecCompatibility cfg vcat n w
     when (es `lengthIsNot` n) $
         panic "emitPrimOp: VecPackOp has wrong number of arguments"
-    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res
+    doVecPackOp ty zeros es res
    where
     zeros :: CmmExpr
     zeros = CmmLit $ CmmVec (replicate n zero)
@@ -889,14 +889,14 @@ emitPrimOp cfg primop =
     checkVecCompatibility cfg vcat n w
     when (res `lengthIsNot` n) $
         panic "emitPrimOp: VecUnpackOp has wrong number of results"
-    doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res
+    doVecUnpackOp ty arg res
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
 
   (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do
     checkVecCompatibility cfg vcat n w
-    doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res
+    doVecInsertOp ty v e i res
    where
     ty :: CmmType
     ty = vecVmmType vcat n w
@@ -2215,31 +2215,6 @@ vecCmmCat IntVec   = cmmBits
 vecCmmCat WordVec  = cmmBits
 vecCmmCat FloatVec = cmmFloat
 
-vecElemInjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp
-vecElemInjectCast _        FloatVec _   =  Nothing
-vecElemInjectCast platform   IntVec   W8  =  Just (mo_WordTo8  platform)
-vecElemInjectCast platform   IntVec   W16 =  Just (mo_WordTo16 platform)
-vecElemInjectCast platform   IntVec   W32 =  Just (mo_WordTo32 platform)
-vecElemInjectCast _        IntVec   W64 =  Nothing
-vecElemInjectCast platform   WordVec  W8  =  Just (mo_WordTo8  platform)
-vecElemInjectCast platform   WordVec  W16 =  Just (mo_WordTo16 platform)
-vecElemInjectCast platform   WordVec  W32 =  Just (mo_WordTo32 platform)
-vecElemInjectCast _        WordVec  W64 =  Nothing
-vecElemInjectCast _        _        _   =  Nothing
-
-vecElemProjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp
-vecElemProjectCast _        FloatVec _   =  Nothing
-vecElemProjectCast platform   IntVec   W8  =  Just (mo_s_8ToWord  platform)
-vecElemProjectCast platform   IntVec   W16 =  Just (mo_s_16ToWord platform)
-vecElemProjectCast platform   IntVec   W32 =  Just (mo_s_32ToWord platform)
-vecElemProjectCast _        IntVec   W64 =  Nothing
-vecElemProjectCast platform   WordVec  W8  =  Just (mo_u_8ToWord  platform)
-vecElemProjectCast platform   WordVec  W16 =  Just (mo_u_16ToWord platform)
-vecElemProjectCast platform   WordVec  W32 =  Just (mo_u_32ToWord platform)
-vecElemProjectCast _        WordVec  W64 =  Nothing
-vecElemProjectCast _        _        _   =  Nothing
-
-
 -- Note [SIMD Design for the future]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- Check to make sure that we can generate code for the specified vector type
@@ -2302,13 +2277,12 @@ checkVecCompatibility cfg vcat l w =
 ------------------------------------------------------------------------------
 -- Helpers for translating vector packing and unpacking.
 
-doVecPackOp :: Maybe MachOp  -- Cast from element to vector component
-            -> CmmType       -- Type of vector
+doVecPackOp :: CmmType       -- Type of vector
             -> CmmExpr       -- Initial vector
             -> [CmmExpr]     -- Elements
             -> CmmFormal     -- Destination for result
             -> FCode ()
-doVecPackOp maybe_pre_write_cast ty z es res = do
+doVecPackOp ty z es res = do
     dst <- newTemp ty
     emitAssign (CmmLocal dst) z
     vecPack dst es 0
@@ -2321,31 +2295,25 @@ doVecPackOp maybe_pre_write_cast ty z es res = do
         dst <- newTemp ty
         if isFloatType (vecElemType ty)
           then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)
-                                                    [CmmReg (CmmLocal src), cast e, iLit])
+                                                    [CmmReg (CmmLocal src), e, iLit])
           else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)
-                                                    [CmmReg (CmmLocal src), cast e, iLit])
+                                                    [CmmReg (CmmLocal src), e, iLit])
         vecPack dst es (i + 1)
       where
         -- vector indices are always 32-bits
         iLit = CmmLit (CmmInt (toInteger i) W32)
 
-    cast :: CmmExpr -> CmmExpr
-    cast val = case maybe_pre_write_cast of
-                 Nothing   -> val
-                 Just cast -> CmmMachOp cast [val]
-
     len :: Length
     len = vecLength ty
 
     wid :: Width
     wid = typeWidth (vecElemType ty)
 
-doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result
-              -> CmmType       -- Type of vector
+doVecUnpackOp :: CmmType       -- Type of vector
               -> CmmExpr       -- Vector
               -> [CmmFormal]   -- Element results
               -> FCode ()
-doVecUnpackOp maybe_post_read_cast ty e res =
+doVecUnpackOp ty e res =
     vecUnpack res 0
   where
     vecUnpack :: [CmmFormal] -> Int -> FCode ()
@@ -2354,46 +2322,36 @@ doVecUnpackOp maybe_post_read_cast ty e res =
 
     vecUnpack (r : rs) i = do
         if isFloatType (vecElemType ty)
-          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)
-                                             [e, iLit]))
-          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)
-                                             [e, iLit]))
+          then emitAssign (CmmLocal r) (CmmMachOp (MO_VF_Extract len wid)
+                                             [e, iLit])
+          else emitAssign (CmmLocal r) (CmmMachOp (MO_V_Extract len wid)
+                                             [e, iLit])
         vecUnpack rs (i + 1)
       where
         -- vector indices are always 32-bits
         iLit = CmmLit (CmmInt (toInteger i) W32)
 
-    cast :: CmmExpr -> CmmExpr
-    cast val = case maybe_post_read_cast of
-                 Nothing   -> val
-                 Just cast -> CmmMachOp cast [val]
-
     len :: Length
     len = vecLength ty
 
     wid :: Width
     wid = typeWidth (vecElemType ty)
 
-doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component
-              -> CmmType       -- Vector type
+doVecInsertOp :: CmmType       -- Vector type
               -> CmmExpr       -- Source vector
               -> CmmExpr       -- Element
               -> CmmExpr       -- Index at which to insert element
               -> CmmFormal     -- Destination for result
               -> FCode ()
-doVecInsertOp maybe_pre_write_cast ty src e idx res = do
+doVecInsertOp ty src e idx res = do
     platform <- getPlatform
     -- vector indices are always 32-bits
     let idx' :: CmmExpr
         idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]
     if isFloatType (vecElemType ty)
-      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])
-      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])
+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, e, idx'])
+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, e, idx'])
   where
-    cast :: CmmExpr -> CmmExpr
-    cast val = case maybe_pre_write_cast of
-                 Nothing   -> val
-                 Just cast -> CmmMachOp cast [val]
 
     len :: Length
     len = vecLength ty


=====================================
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.


=====================================
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)
 --


=====================================
testsuite/tests/codeGen/should_run/T22296.hs
=====================================
@@ -0,0 +1,41 @@
+{-# language MagicHash, UnboxedTuples, UnboxedSums #-}
+
+module Main ( main ) where
+
+import GHC.Exts
+import GHC.Int
+import GHC.Word
+
+foo :: Word16X8# -> Integer
+foo w16x8 =
+  case unpackWord16X8# w16x8 of
+    (# w1, w2, w3, w4, w5, w6, w7, w8 #) ->
+      let
+        s = sum $ map fromIntegral
+             [ W16# w1, W16# w2, W16# w3, W16# w4
+             , W16# w5, W16# w6, W16# w7, W16# w8 ]
+      in s
+
+bar :: Int32X4# -> Integer
+bar i32x4 =
+  case unpackInt32X4# i32x4 of
+    (# i1, i2, i3, i4 #) ->
+      let
+        s = sum $ map fromIntegral
+             [ I32# i1, I32# i2, I32# i3, I32# i4 ]
+      in s
+
+baz :: FloatX4# -> Float
+baz fx4 =
+  case unpackFloatX4# fx4 of
+    (# f1, f2, f3, f4 #) ->
+      let
+        s = sum
+             [ F# f1, F# f2, F# f3, F# f4 ]
+      in s
+
+main :: IO ()
+main = do
+  print ( foo ( broadcastWord16X8# ( wordToWord16# 1## ) ) )
+  print ( bar ( broadcastInt32X4#  ( intToInt32# 1# ) ) )
+  print ( baz ( broadcastFloatX4#  ( 1.0# ) ) )


=====================================
testsuite/tests/codeGen/should_run/T22296.stdout
=====================================
@@ -0,0 +1,3 @@
+8
+4
+4.0


=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -218,3 +218,5 @@ test('T21141', normal, compile_and_run, [''])
 test('T21186', normal, compile_and_run, [''])
 test('T20640a', normal, compile_and_run, [''])
 test('T20640b', normal, compile_and_run, [''])
+test('T22296',[only_ways(llvm_ways)
+              ,unless(arch('x86_64'), skip)],compile_and_run,[''])


=====================================
testsuite/tests/unboxedsums/T22187.hs
=====================================
@@ -0,0 +1,6 @@
+{-# language MagicHash,UnboxedSums #-}
+module T22187 where
+import GHC.Exts
+
+foo :: (# Int64X2# | () #) -> ()
+foo _ = ()


=====================================
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 #) )


=====================================
testsuite/tests/unboxedsums/T22187_run.stdout
=====================================
@@ -0,0 +1,4 @@
+(# 2 | | #)
+(# | | 'F' #)
+(# 0 | | #)
+(# | (# (# 128.0, -45.0, -2.5e-3, -45.0 #), 4503599627370496, -5764607523034235 #) | #)


=====================================
testsuite/tests/unboxedsums/all.T
=====================================
@@ -35,3 +35,8 @@ 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)],compile,[''])
+test('T22187_run',[only_ways(llvm_ways)
+                  ,unless(arch('x86_64'), skip)],compile_and_run,[''])
+



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/99dc3e3d76daab80a5c5209a3e0c44c9e4664e06...f7b7a3122185222d5059e37315991afcf319e43c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/99dc3e3d76daab80a5c5209a3e0c44c9e4664e06...f7b7a3122185222d5059e37315991afcf319e43c
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221019/08c3d9c5/attachment-0001.html>


More information about the ghc-commits mailing list