[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: x86 NCG: fix regUsageOfInstr for VMOVU & friends
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Nov 21 12:47:36 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
1fc02399 by sheaf at 2024-11-20T18:11:03-05:00
x86 NCG: fix regUsageOfInstr for VMOVU & friends
This commit fixes the implementation of 'regUsageOfInstr' for vector
operations that take an 'Operand' as the destination, by ensuring that
when the destination is an address then the address should be *READ*,
and not *WRITTEN*.
Getting this wrong is a disaster, as it means the register allocator
has incorrect information, which can lead to it discard stores to
registers, segfaults ensuing.
Fixes #25486
- - - - -
9c7c03c8 by Brandon Chinn at 2024-11-21T07:47:21-05:00
Fix CRLF in multiline strings (#25375)
- - - - -
5cffc92d by Matthew Pickering at 2024-11-21T07:47:22-05:00
driver: Always link against "base" package when one shot linking
The default value for base-unit-id is stored in the settings file.
At install time, this can be set by using the BASE_UNIT_ID environment
variable.
At runtime, the value can be set by `-base-unit-id` flag.
For whether all this is a good idea, see #25382
Fixes #25382
- - - - -
24 changed files:
- .gitattributes
- compiler/GHC/CmmToAsm/Format.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Parser/String.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Settings/IO.hs
- compiler/GHC/Unit/State.hs
- distrib/configure.ac.in
- docs/users_guide/exts/multiline_strings.rst
- docs/users_guide/packages.rst
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/src/Rules/Generate.hs
- testsuite/tests/driver/Makefile
- + testsuite/tests/driver/T25382.hs
- testsuite/tests/driver/all.T
- + testsuite/tests/parser/should_run/T25375.hs
- + testsuite/tests/parser/should_run/T25375.stdout
- testsuite/tests/parser/should_run/all.T
- + testsuite/tests/simd/should_run/T25486.hs
- + testsuite/tests/simd/should_run/T25486.stdout
- testsuite/tests/simd/should_run/all.T
Changes:
=====================================
.gitattributes
=====================================
@@ -2,3 +2,4 @@
# don't convert anything on checkout
* text=auto eol=lf
mk/win32-tarballs.md5sum text=auto eol=LF
+testsuite/tests/parser/should_run/T25375.hs text=auto eol=crlf
=====================================
compiler/GHC/CmmToAsm/Format.hs
=====================================
@@ -273,6 +273,9 @@ instance Show RegWithFormat where
instance Uniquable RegWithFormat where
getUnique = getUnique . regWithFormat_reg
+instance Outputable VirtualRegWithFormat where
+ ppr (VirtualRegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt
+
instance Outputable RegWithFormat where
ppr (RegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt
=====================================
compiler/GHC/CmmToAsm/X86/Instr.hs
=====================================
@@ -373,8 +373,9 @@ regUsageOfInstr platform instr
| otherwise
-> usageRW fmt src dst
MOVD fmt src dst ->
- -- NB: MOVD/MOVQ always zero any remaining upper part of destination
- mkRU (use_R fmt src []) (use_R (movdOutFormat fmt) dst [])
+ -- NB: MOVD and MOVQ always zero any remaining upper part of destination,
+ -- so the destination is "written" not "modified".
+ usageRW' fmt (movdOutFormat fmt) src dst
CMOV _ fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
MOVZxL fmt src dst -> usageRW fmt src dst
MOVSxL fmt src dst -> usageRW fmt src dst
@@ -475,7 +476,7 @@ regUsageOfInstr platform instr
-- vector instructions
VBROADCAST fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]
- VEXTRACT fmt _off src dst -> mkRU [mk fmt src] (use_R fmt dst [])
+ VEXTRACT fmt _off src dst -> usageRW fmt (OpReg src) dst
INSERTPS fmt (ImmInt off) src dst
-> mkRU ((use_R fmt src []) ++ [mk fmt dst | not doesNotReadDst]) [mk fmt dst]
where
@@ -488,12 +489,12 @@ regUsageOfInstr platform instr
INSERTPS fmt _off src dst
-> mkRU ((use_R fmt src []) ++ [mk fmt dst]) [mk fmt dst]
- VMOVU fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- MOVU fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- MOVL fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- MOVH fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- MOVDQU fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- VMOVDQU fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
+ VMOVU fmt src dst -> usageRW fmt src dst
+ MOVU fmt src dst -> usageRW fmt src dst
+ MOVL fmt src dst -> usageRM fmt src dst
+ MOVH fmt src dst -> usageRM fmt src dst
+ MOVDQU fmt src dst -> usageRW fmt src dst
+ VMOVDQU fmt src dst -> usageRW fmt src dst
PXOR fmt (OpReg src) dst
| src == dst
@@ -531,11 +532,12 @@ regUsageOfInstr platform instr
-> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
MINMAX _ _ fmt src dst
- -> mkRU (use_R fmt src $ use_R fmt dst []) (use_R fmt dst [])
+ -> usageRM fmt src dst
VMINMAX _ _ fmt src1 src2 dst
-> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]
_other -> panic "regUsage: unrecognised instr"
where
+
-- # Definitions
--
-- Written: If the operand is a register, it's written. If it's an
@@ -551,6 +553,11 @@ regUsageOfInstr platform instr
usageRW fmt op (OpAddr ea) = mkRUR (use_R fmt op $! use_EA ea [])
usageRW _ _ _ = panic "X86.RegInfo.usageRW: no match"
+ usageRW' :: HasDebugCallStack => Format -> Format -> Operand -> Operand -> RegUsage
+ usageRW' fmt1 fmt2 op (OpReg reg) = mkRU (use_R fmt1 op []) [mk fmt2 reg]
+ usageRW' fmt1 _ op (OpAddr ea) = mkRUR (use_R fmt1 op $! use_EA ea [])
+ usageRW' _ _ _ _ = panic "X86.RegInfo.usageRW: no match"
+
-- 2 operand form; first operand Read; second Modified
usageRM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage
usageRM fmt op (OpReg reg) = mkRU (use_R fmt op [mk fmt reg]) [mk fmt reg]
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -62,6 +62,10 @@ module GHC.Driver.DynFlags (
versionedAppDir, versionedFilePath,
extraGccViaCFlags, globalPackageDatabasePath,
+ --
+ baseUnitId,
+
+
-- * Include specifications
IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,
addImplicitQuoteInclude,
@@ -165,6 +169,8 @@ data DynFlags = DynFlags {
-- formerly Settings
ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion,
fileSettings :: {-# UNPACK #-} !FileSettings,
+ unitSettings :: {-# UNPACK #-} !UnitSettings,
+
targetPlatform :: Platform, -- Filled in by SysTools
toolSettings :: {-# UNPACK #-} !ToolSettings,
platformMisc :: {-# UNPACK #-} !PlatformMisc,
@@ -634,6 +640,7 @@ defaultDynFlags mySettings =
splitInfo = Nothing,
ghcNameVersion = sGhcNameVersion mySettings,
+ unitSettings = sUnitSettings mySettings,
fileSettings = sFileSettings mySettings,
toolSettings = sToolSettings mySettings,
targetPlatform = sTargetPlatform mySettings,
@@ -1484,6 +1491,11 @@ versionedAppDir appname platform = do
versionedFilePath :: ArchOS -> FilePath
versionedFilePath platform = uniqueSubdir platform
+-- | Access the unit-id of the version of `base` which we will automatically link
+-- against.
+baseUnitId :: DynFlags -> UnitId
+baseUnitId dflags = unitSettings_baseUnitId (unitSettings dflags)
+
-- SDoc
-------------------------------------------
-- | Initialize the pretty-printing options
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -80,6 +80,9 @@ module GHC.Driver.Session (
safeDirectImpsReq, safeImplicitImpsReq,
unsafeFlags, unsafeFlagsForInfer,
+ -- ** base
+ baseUnitId,
+
-- ** System tool settings and locations
Settings(..),
sProgramName,
@@ -390,6 +393,7 @@ settings :: DynFlags -> Settings
settings dflags = Settings
{ sGhcNameVersion = ghcNameVersion dflags
, sFileSettings = fileSettings dflags
+ , sUnitSettings = unitSettings dflags
, sTargetPlatform = targetPlatform dflags
, sToolSettings = toolSettings dflags
, sPlatformMisc = platformMisc dflags
@@ -488,6 +492,10 @@ opt_las dflags = toolSettings_opt_las $ toolSettings dflags
opt_i :: DynFlags -> [String]
opt_i dflags= toolSettings_opt_i $ toolSettings dflags
+
+setBaseUnitId :: String -> DynP ()
+setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) }
+
-----------------------------------------------------------------------------
{-
@@ -2053,6 +2061,7 @@ package_flags_deps = [
(NoArg (setGeneralFlag Opt_DistrustAllPackages))
, make_ord_flag defFlag "trust" (HasArg trustPackage)
, make_ord_flag defFlag "distrust" (HasArg distrustPackage)
+ , make_ord_flag defFlag "base-unit-id" (HasArg setBaseUnitId)
]
where
setPackageEnv env = upd $ \s -> s { packageEnv = Just env }
=====================================
compiler/GHC/Parser/String.hs
=====================================
@@ -261,6 +261,7 @@ lexMultilineString = lexStringWith processChars processChars
processChars :: HasChar c => [c] -> Either (c, LexErr) [c]
processChars =
collapseGaps -- Step 1
+ >>> normalizeEOL
>>> expandLeadingTabs -- Step 3
>>> rmCommonWhitespacePrefix -- Step 4
>>> collapseOnlyWsLines -- Step 5
@@ -268,6 +269,19 @@ lexMultilineString = lexStringWith processChars processChars
>>> rmLastNewline -- Step 7b
>>> resolveEscapes -- Step 8
+ -- Normalize line endings to LF. The spec dictates that lines should be
+ -- split on newline characters and rejoined with ``\n``. But because we
+ -- aren't actually splitting/rejoining, we'll manually normalize here
+ normalizeEOL :: HasChar c => [c] -> [c]
+ normalizeEOL =
+ let go = \case
+ Char '\r' : c@(Char '\n') : cs -> c : go cs
+ c@(Char '\r') : cs -> setChar '\n' c : go cs
+ c@(Char '\f') : cs -> setChar '\n' c : go cs
+ c : cs -> c : go cs
+ [] -> []
+ in go
+
-- expands all tabs, since the lexer will verify that tabs can only appear
-- as leading indentation
expandLeadingTabs :: HasChar c => [c] -> [c]
=====================================
compiler/GHC/Settings.hs
=====================================
@@ -5,6 +5,7 @@ module GHC.Settings
( Settings (..)
, ToolSettings (..)
, FileSettings (..)
+ , UnitSettings(..)
, GhcNameVersion (..)
, Platform (..)
, PlatformMisc (..)
@@ -73,6 +74,7 @@ import GHC.Prelude
import GHC.Utils.CliOption
import GHC.Utils.Fingerprint
import GHC.Platform
+import GHC.Unit.Types
data Settings = Settings
{ sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion
@@ -80,12 +82,15 @@ data Settings = Settings
, sTargetPlatform :: Platform -- Filled in by SysTools
, sToolSettings :: {-# UNPACK #-} !ToolSettings
, sPlatformMisc :: {-# UNPACK #-} !PlatformMisc
+ , sUnitSettings :: !UnitSettings
-- You shouldn't need to look things up in rawSettings directly.
-- They should have their own fields instead.
, sRawSettings :: [(String, String)]
}
+data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId }
+
-- | Settings for other executables GHC calls.
--
-- Probably should further split down by phase, or split between
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Utils.Panic
import GHC.ResponseFile
import GHC.Settings
import GHC.SysTools.BaseDir
+import GHC.Unit.Types
import Data.Char
import Control.Monad.Trans.Except
@@ -174,6 +175,8 @@ initSettings top_dir = do
ghcWithInterpreter <- getBooleanSetting "Use interpreter"
useLibFFI <- getBooleanSetting "Use LibFFI"
+ baseUnitId <- getSetting "base unit-id"
+
return $ Settings
{ sGhcNameVersion = GhcNameVersion
{ ghcNameVersion_programName = "ghc"
@@ -188,6 +191,11 @@ initSettings top_dir = do
, fileSettings_globalPackageDatabase = globalpkgdb_path
}
+ , sUnitSettings = UnitSettings
+ {
+ unitSettings_baseUnitId = stringToUnitId baseUnitId
+ }
+
, sToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind
, toolSettings_ldSupportsFilelist = ldSupportsFilelist
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -364,9 +364,13 @@ initUnitConfig dflags cached_dbs home_units =
autoLink
| not (gopt Opt_AutoLinkPackages dflags) = []
- -- By default we add ghc-internal & rts to the preload units (when they are
+ -- By default we add base, ghc-internal and rts to the preload units (when they are
-- found in the unit database) except when we are building them
- | otherwise = filter (hu_id /=) [ghcInternalUnitId, rtsUnitId]
+ --
+ -- Since "base" is not wired in, then the unit-id is discovered
+ -- from the settings file by default, but can be overriden by power-users
+ -- by specifying `-base-unit-id` flag.
+ | otherwise = filter (hu_id /=) [baseUnitId dflags, ghcInternalUnitId, rtsUnitId]
-- if the home unit is indefinite, it means we are type-checking it only
-- (not producing any code). Hence we can use virtual units instantiated
=====================================
distrib/configure.ac.in
=====================================
@@ -366,6 +366,17 @@ if test "x$UseLibdw" = "xYES" ; then
fi
AC_SUBST(UseLibdw)
+dnl What is the version of the base library which we are going to use?
+dnl The user can use BASE_UNIT_ID at install time to point the compiler to
+dnl link against a different base package by default.
+dnl If the package is unavailable it will simply not be linked against.
+BaseUnitId=@BaseUnitId@
+if test -n "$BASE_UNIT_ID"; then
+ BaseUnitId="$BASE_UNIT_ID"
+fi
+
+AC_SUBST(BaseUnitId)
+
FP_SETTINGS
# We get caught by
=====================================
docs/users_guide/exts/multiline_strings.rst
=====================================
@@ -14,7 +14,9 @@ With this extension, GHC now recognizes multiline string literals with ``"""`` d
Normal string literals are lexed, then string gaps are collapsed, then escape characters are resolved. Multiline string literals add the following post-processing steps between collapsing string gaps and resolving escape characters:
-#. Split the string by newlines
+#. Split the string by newline characters
+
+ * Includes ``\r\n``, ``\r``, ``\n``, ``\f``
#. Replace leading tabs with spaces up to the next tab stop
@@ -24,7 +26,9 @@ Normal string literals are lexed, then string gaps are collapsed, then escape ch
#. Join the string back with ``\n`` delimiters
-#. If the first character of the string is a newline, remove it
+#. If the first character of the string is ``\n``, remove it
+
+#. If the last character of the string is ``\n``, remove it
Examples
~~~~~~~~
=====================================
docs/users_guide/packages.rst
=====================================
@@ -239,9 +239,27 @@ The GHC command line options that control packages are:
:type: dynamic
:category:
- By default, GHC will automatically link in the ``base`` and ``rts``
+ By default, GHC will automatically link in the ``base``, ``ghc-internal`` and ``rts``
packages. This flag disables that behaviour.
+ The unit-id of the ``base`` package which is automatically linked can be set using
+ the :ghc-flag:`-base-unit-id ⟨unit-id⟩` flag.
+
+.. ghc-flag:: -base-unit-id ⟨unit-id⟩
+ :shortdesc: The unit-id of the "base" package, which will be automatically linked.
+ :type: dynamic
+ :category:
+
+ By default the compiler will link against the ``base``, ``ghc-internal``,
+ and ``rts`` package, this flag controls what the ``base`` package linked
+ against is.
+
+ You should only need to pass this flag if you really know what you are doing.
+ Distributors can set a default unit-id for base at install time by specifying
+ the ``BASE_UNIT_ID`` environment variable.
+
+
+
.. ghc-flag:: -this-unit-id ⟨unit-id⟩
:shortdesc: Compile to be part of unit (i.e. package)
⟨unit-id⟩
=====================================
hadrian/bindist/Makefile
=====================================
@@ -142,6 +142,7 @@ lib/settings : config.mk
@echo ',("Use LibFFI", "$(UseLibffiForAdjustors)")' >> $@
@echo ',("RTS expects libdw", "$(GhcRtsWithLibdw)")' >> $@
@echo ',("Relative Global Package DB", "package.conf.d")' >> $@
+ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@
@echo "]" >> $@
# We need to install binaries relative to libraries.
=====================================
hadrian/bindist/config.mk.in
=====================================
@@ -134,6 +134,7 @@ CrossCompiling = @CrossCompiling@
CrossCompilePrefix = @CrossCompilePrefix@
GhcUnregisterised = @Unregisterised@
EnableDistroToolchain = @SettingsUseDistroMINGW@
+BaseUnitId = @BaseUnitId@
# The THREADED_RTS requires `BaseReg` to be in a register and the
# `GhcUnregisterised` mode doesn't allow that.
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -435,6 +435,7 @@ bindistRules = do
, interpolateVar "UseLibdw" $ fmap yesNo $ interp $ getFlag UseLibdw
, interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
, interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
+ , interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base
]
where
interp = interpretInContext (semiEmptyTarget Stage2)
@@ -471,6 +472,14 @@ generateSettings settingsFile = do
Stage2 -> get_pkg_db Stage1
Stage3 -> get_pkg_db Stage2
+ -- The unit-id of the base package which is always linked against (#25382)
+ base_unit_id <- expr $ do
+ case stage of
+ Stage0 {} -> error "Unable to generate settings for stage0"
+ Stage1 -> pkgUnitId Stage1 base
+ Stage2 -> pkgUnitId Stage1 base
+ Stage3 -> pkgUnitId Stage2 base
+
let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path
settings <- traverse sequence $
@@ -531,6 +540,7 @@ generateSettings settingsFile = do
, ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
, ("RTS expects libdw", yesNo <$> getFlag UseLibdw)
, ("Relative Global Package DB", pure rel_pkg_db)
+ , ("base unit-id", pure base_unit_id)
]
let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
pure $ case settings of
=====================================
testsuite/tests/driver/Makefile
=====================================
@@ -808,3 +808,8 @@ T23339B:
"$(TEST_HC)" -tmpdir "$(PWD)/tmp" $(TEST_HC_OPTS) -v0 T23339B.hs -finfo-table-map
# Check that the file is kept and is the right one
find . -name "*.c" -exec cat {} \; | grep "init__ip_init"
+
+# Test that base is linked against implicitly
+T25382:
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c T25382.hs
+ "$(TEST_HC)" $(TEST_HC_OPTS) T25382.o -o main
=====================================
testsuite/tests/driver/T25382.hs
=====================================
@@ -0,0 +1,7 @@
+module Main where
+
+import Data.Complex
+
+main = do
+ x <- readLn :: IO (Complex Int)
+ print $ realPart x
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -330,3 +330,4 @@ test('T23944', [unless(have_dynamic(), skip), extra_files(['T23944A.hs'])], mult
test('T24286', [cxx_src, unless(have_profiling(), skip), extra_files(['T24286.cpp'])], compile, ['-prof -no-hs-main'])
test('T24839', [unless(arch('x86_64') or arch('aarch64'), skip), extra_files(["t24839_sub.S"])], compile_and_run, ['t24839_sub.S'])
test('t25150', [extra_files(["t25150"])], multimod_compile, ['Main.hs', '-v0 -working-dir t25150/dir a.c'])
+test('T25382', normal, makefile_test, [])
=====================================
testsuite/tests/parser/should_run/T25375.hs
=====================================
@@ -0,0 +1,38 @@
+{-# LANGUAGE MultilineStrings #-}
+
+str1 = unlines
+ [ "aaa"
+ , "bbb"
+ , "ccc"
+ ]
+
+str2 = "aaa\n\
+ \bbb\n\
+ \ccc\n"
+
+str3 = """
+ aaa
+ bbb
+ ccc
+ """
+
+str4 = """
+
+ aaa
+ bbb
+ ccc
+
+ """
+
+str5 = """
+ aaa
+ bbb
+ ccc\n
+ """
+
+main = do
+ print str1
+ print str2
+ print str3
+ print str4
+ print str5
=====================================
testsuite/tests/parser/should_run/T25375.stdout
=====================================
@@ -0,0 +1,5 @@
+"aaa\nbbb\nccc\n"
+"aaa\nbbb\nccc\n"
+"aaa\nbbb\nccc"
+"\naaa\nbbb\nccc\n"
+"aaa\nbbb\nccc\n"
=====================================
testsuite/tests/parser/should_run/all.T
=====================================
@@ -23,3 +23,4 @@ test('RecordDotSyntax5', normal, compile_and_run, [''])
test('ListTuplePunsConstraints', extra_files(['ListTuplePunsConstraints.hs']), ghci_script, ['ListTuplePunsConstraints.script'])
test('MultilineStrings', normal, compile_and_run, [''])
test('MultilineStringsOverloaded', normal, compile_and_run, [''])
+test('T25375', normal, compile_and_run, [''])
=====================================
testsuite/tests/simd/should_run/T25486.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+import Data.Array.Base
+import Data.Array.IO.Internals
+import Control.Monad
+import Foreign.Marshal.Array
+
+writeFloatX4OffAddr :: Ptr Float -> Int -> FloatX4# -> IO ()
+writeFloatX4OffAddr (Ptr addr) (I# i) v =
+ IO $ \s -> (# writeFloatX4OffAddr# addr i v s, () #)
+
+writeAsFloatX4OffAddr :: Ptr Float -> Int -> FloatX4# -> IO ()
+writeAsFloatX4OffAddr (Ptr addr) (I# i) v =
+ IO $ \s -> (# writeFloatOffAddrAsFloatX4# addr i v s, () #)
+
+writeFloatX4 :: IOUArray Int Float -> Int -> FloatX4# -> IO ()
+writeFloatX4 (IOUArray (STUArray l _ _ mba)) i v = case i - l of
+ I# i# -> IO $ \s -> (# writeFloatX4Array# mba i# v s, () #)
+
+writeAsFloatX4 :: IOUArray Int Float -> Int -> FloatX4# -> IO ()
+writeAsFloatX4 (IOUArray (STUArray l _ _ mba)) i v = case i - l of
+ I# i# -> IO $ \s -> (# writeFloatArrayAsFloatX4# mba i# v s, () #)
+
+main :: IO ()
+main = do
+ let v = packFloatX4# (# 0.1#, 1.1#, 2.2#, 3.3# #)
+
+ xs <- withArray ([0..15] :: [Float]) $ \ptr -> do
+ writeFloatX4OffAddr ptr 2 v
+ peekArray 16 ptr
+ print xs
+
+ ys <- withArray ([0..15] :: [Float]) $ \ptr -> do
+ writeAsFloatX4OffAddr ptr 2 v
+ peekArray 16 ptr
+ print ys
+
+ ma <- newListArray (0, 9) ([0..9] :: [Float])
+ writeFloatX4 ma 1 v
+ print =<< getElems ma
+
+ ma <- newListArray (0, 9) ([0..9] :: [Float])
+ writeAsFloatX4 ma 1 v
+ print =<< getElems ma
=====================================
testsuite/tests/simd/should_run/T25486.stdout
=====================================
@@ -0,0 +1,4 @@
+[0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,0.1,1.1,2.2,3.3,12.0,13.0,14.0,15.0]
+[0.0,1.0,0.1,1.1,2.2,3.3,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0]
+[0.0,1.0,2.0,3.0,0.1,1.1,2.2,3.3,8.0,9.0]
+[0.0,0.1,1.1,2.2,3.3,5.0,6.0,7.0,8.0,9.0]
=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -90,3 +90,4 @@ test('T25062_V64'
test('T25169', [], compile_and_run, [''])
test('T25455', [], compile_and_run, [''])
+test('T25486', [], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46c53f87d75130ce4a87d54029ec264bba378ac5...5cffc92d345cab38274c7a6a45baa72eab62bd94
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46c53f87d75130ce4a87d54029ec264bba378ac5...5cffc92d345cab38274c7a6a45baa72eab62bd94
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/20241121/4dfa838c/attachment-0001.html>
More information about the ghc-commits
mailing list