[Git][ghc/ghc][wip/angerman/aarch64-always-pic] 4 commits: NCG: Fix 64bit int comparisons on 32bit x86
Moritz Angermann
gitlab at gitlab.haskell.org
Thu Nov 5 04:41:42 UTC 2020
Moritz Angermann pushed to branch wip/angerman/aarch64-always-pic at Glasgow Haskell Compiler / GHC
Commits:
bb100805 by Andreas Klebinger at 2020-11-04T16:47:24-05:00
NCG: Fix 64bit int comparisons on 32bit x86
We no compare these by doing 64bit subtraction and
checking the resulting flags.
We used to do this differently but the old approach was
broken when the high bits compared equal and the comparison
was one of >= or <=.
The new approach should be both correct and faster.
- - - - -
b790b7f9 by Andreas Klebinger at 2020-11-04T16:47:59-05:00
Testsuite: Support for user supplied package dbs
We can now supply additional package dbs to the testsuite.
For make the package db can be supplied by
passing PACKAGE_DB=/path/to/db.
In the testsuite driver it's passed via the --test-package-db
argument.
- - - - -
81560981 by Sylvain Henry at 2020-11-04T16:48:42-05:00
Don't use LEA with 8-bit registers (#18614)
- - - - -
842e3f38 by Moritz Angermann at 2020-11-04T23:41:37-05:00
[AArch64] Aarch64 Always PIC
- - - - -
18 changed files:
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Cond.hs
- compiler/GHC/Driver/Session.hs
- docs/users_guide/runtime_control.rst
- includes/rts/Flags.h
- rts/Libdw.c
- rts/Linker.c
- rts/LinkerInternals.h
- testsuite/driver/runtests.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/mk/test.mk
- testsuite/tests/cmm/should_run/all.T
- + testsuite/tests/cmm/should_run/cmp64.hs
- + testsuite/tests/cmm/should_run/cmp64.stdout
- + testsuite/tests/cmm/should_run/cmp64_cmm.cmm
- + testsuite/tests/codeGen/should_compile/T18614.hs
- testsuite/tests/codeGen/should_compile/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -1052,7 +1052,9 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
--------------------
add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
add_code rep x (CmmLit (CmmInt y _))
- | is32BitInteger y = add_int rep x y
+ | is32BitInteger y
+ , rep /= W8 -- LEA doesn't support byte size (#18614)
+ = add_int rep x y
add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y
where format = intFormat rep
-- TODO: There are other interesting patterns we want to replace
@@ -1061,7 +1063,9 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
--------------------
sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
sub_code rep x (CmmLit (CmmInt y _))
- | is32BitInteger (-y) = add_int rep x (-y)
+ | is32BitInteger (-y)
+ , rep /= W8 -- LEA doesn't support byte size (#18614)
+ = add_int rep x (-y)
sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y
-- our three-operand add instruction:
@@ -1824,6 +1828,35 @@ I386: First, we have to ensure that the condition
codes are set according to the supplied comparison operation.
-}
+{- Note [64-bit integer comparisons on 32-bit]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ When doing these comparisons there are 2 kinds of
+ comparisons.
+
+ * Comparison for equality (or lack thereof)
+
+ We use xor to check if high/low bits are
+ equal. Then combine the results using or and
+ perform a single conditional jump based on the
+ result.
+
+ * Other comparisons:
+
+ We map all other comparisons to the >= operation.
+ Why? Because it's easy to encode it with a single
+ conditional jump.
+
+ We do this by first computing [r1_lo - r2_lo]
+ and use the carry flag to compute
+ [r1_high - r2_high - CF].
+
+ At which point if r1 >= r2 then the result will be
+ positive. Otherwise negative so we can branch on this
+ condition.
+
+-}
+
genCondBranch
:: BlockId -- the source of the jump
@@ -1841,22 +1874,63 @@ genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
-> NatM InstrBlock
-- 64-bit integer comparisons on 32-bit
+-- See Note [64-bit integer comparisons on 32-bit]
genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])
| is32Bit, Just W64 <- maybeIntComparison mop = do
- ChildCode64 code1 r1_lo <- iselExpr64 e1
- ChildCode64 code2 r2_lo <- iselExpr64 e2
- let r1_hi = getHiVRegFromLo r1_lo
- r2_hi = getHiVRegFromLo r2_lo
- cond = machOpToCond mop
- Just cond' = maybeFlipCond cond
- --TODO: Update CFG for x86
- let code = code1 `appOL` code2 `appOL` toOL [
- CMP II32 (OpReg r2_hi) (OpReg r1_hi),
- JXX cond true,
- JXX cond' false,
- CMP II32 (OpReg r2_lo) (OpReg r1_lo),
- JXX cond true] `appOL` genBranch false
- return code
+
+ -- The resulting registers here are both the lower part of
+ -- the register as well as a way to get at the higher part.
+ ChildCode64 code1 r1 <- iselExpr64 e1
+ ChildCode64 code2 r2 <- iselExpr64 e2
+ let cond = machOpToCond mop :: Cond
+
+ let cmpCode = intComparison cond true false r1 r2
+ return $ code1 `appOL` code2 `appOL` cmpCode
+
+ where
+ intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock
+ intComparison cond true false r1_lo r2_lo =
+ case cond of
+ -- Impossible results of machOpToCond
+ ALWAYS -> panic "impossible"
+ NEG -> panic "impossible"
+ POS -> panic "impossible"
+ CARRY -> panic "impossible"
+ OFLO -> panic "impossible"
+ PARITY -> panic "impossible"
+ NOTPARITY -> panic "impossible"
+ -- Special case #1 x == y and x != y
+ EQQ -> cmpExact
+ NE -> cmpExact
+ -- [x >= y]
+ GE -> cmpGE
+ GEU -> cmpGE
+ -- [x > y] <==> ![y >= x]
+ GTT -> intComparison GE false true r2_lo r1_lo
+ GU -> intComparison GEU false true r2_lo r1_lo
+ -- [x <= y] <==> [y >= x]
+ LE -> intComparison GE true false r2_lo r1_lo
+ LEU -> intComparison GEU true false r2_lo r1_lo
+ -- [x < y] <==> ![x >= x]
+ LTT -> intComparison GE false true r1_lo r2_lo
+ LU -> intComparison GEU false true r1_lo r2_lo
+ where
+ r1_hi = getHiVRegFromLo r1_lo
+ r2_hi = getHiVRegFromLo r2_lo
+ cmpExact :: OrdList Instr
+ cmpExact =
+ toOL
+ [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)
+ , XOR II32 (OpReg r2_lo) (OpReg r1_lo)
+ , OR II32 (OpReg r1_hi) (OpReg r1_lo)
+ , JXX cond true
+ , JXX ALWAYS false
+ ]
+ cmpGE = toOL
+ [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)
+ , SBB II32 (OpReg r2_hi) (OpReg r1_hi)
+ , JXX cond true
+ , JXX ALWAYS false ]
genCondBranch' _ bid id false bool = do
CondCode is_float cond cond_code <- getCondCode bool
=====================================
compiler/GHC/CmmToAsm/X86/Cond.hs
=====================================
@@ -11,22 +11,22 @@ import GHC.Prelude
data Cond
= ALWAYS -- What's really used? ToDo
- | EQQ
- | GE
- | GEU
- | GTT
- | GU
- | LE
- | LEU
- | LTT
- | LU
- | NE
- | NEG
- | POS
- | CARRY
- | OFLO
- | PARITY
- | NOTPARITY
+ | EQQ -- je/jz -> zf = 1
+ | GE -- jge
+ | GEU -- ae
+ | GTT -- jg
+ | GU -- ja
+ | LE -- jle
+ | LEU -- jbe
+ | LTT -- jl
+ | LU -- jb
+ | NE -- jne
+ | NEG -- js
+ | POS -- jns
+ | CARRY -- jc
+ | OFLO -- jo
+ | PARITY -- jp
+ | NOTPARITY -- jnp
deriving Eq
condToUnsigned :: Cond -> Cond
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3796,8 +3796,21 @@ validHoleFitsImpliedGFlags
default_PIC :: Platform -> [GeneralFlag]
default_PIC platform =
case (platformOS platform, platformArch platform) of
- (OSDarwin, ArchX86_64) -> [Opt_PIC]
- (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in
+ -- Darwin always requires PIC. Especially on more recent macOS releases
+ -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses
+ -- while we could work around this on x86_64 (like WINE does), we won't be
+ -- able on aarch64, where this is enforced.
+ (OSDarwin, ArchX86_64) -> [Opt_PIC]
+ -- For AArch64, we need to always have PIC enabled. The relocation model
+ -- on AArch64 does not permit arbitrary relocations. Under ASLR, we can't
+ -- control much how far apart symbols are in memory for our in-memory static
+ -- linker; and thus need to ensure we get sufficiently capable relocations.
+ -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top
+ -- of that. Subsequently we expect all code on aarch64/linux (and macOS) to
+ -- be built with -fPIC.
+ (OSDarwin, ArchARM64) -> [Opt_PIC]
+ (OSLinux, ArchARM64) -> [Opt_PIC, Opt_ExternalDynamicRefs]
+ (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in
-- OpenBSD since 5.3 release
-- (1 May 2013) we need to
-- always generate PIC. See
=====================================
docs/users_guide/runtime_control.rst
=====================================
@@ -327,8 +327,10 @@ Miscellaneous RTS options
an object, the linker will probably fail with an error message when the
problem is detected.
- On some platforms where PIC is always the case, e.g. x86_64 MacOS X, this
- flag is enabled by default.
+ On some platforms where PIC is always the case, e.g. macOS and OpenBSD on
+ x86_64, and macOS and Linux on aarch64 this flag is enabled by default.
+ One repercussion of this is that referenced system libraries also need to be
+ compiled with ``-fPIC`` if we need to load them in the runtime linker.
.. rts-flag:: -xm ⟨address⟩
=====================================
includes/rts/Flags.h
=====================================
@@ -200,7 +200,7 @@ typedef struct _CONCURRENT_FLAGS {
* files were compiled with -fPIC -fexternal-dynamic-refs and load them
* anywhere in the address space.
*/
-#if defined(x86_64_HOST_ARCH) && defined(darwin_HOST_OS)
+#if defined(darwin_HOST_OS) || defined(aarch64_HOST_ARCH)
#define DEFAULT_LINKER_ALWAYS_PIC true
#else
#define DEFAULT_LINKER_ALWAYS_PIC false
=====================================
rts/Libdw.c
=====================================
@@ -133,8 +133,9 @@ int libdwLookupLocation(LibdwSession *session, Location *frame,
Dwfl_Module *mod = dwfl_addrmodule(session->dwfl, addr);
if (mod == NULL)
return 1;
+ void *object_file = &frame->object_file;
dwfl_module_info(mod, NULL, NULL, NULL, NULL, NULL,
- &frame->object_file, NULL);
+ object_file, NULL);
// Find function name
frame->function = dwfl_module_addrname(mod, addr);
=====================================
rts/Linker.c
=====================================
@@ -1022,42 +1022,6 @@ resolveSymbolAddr (pathchar* buffer, int size,
}
#if RTS_LINKER_USE_MMAP
-
-/* -----------------------------------------------------------------------------
- Occationally we depend on mmap'd region being close to already mmap'd regions.
-
- Our static in-memory linker may be restricted by the architectures relocation
- range. E.g. aarch64 has a +-4GB range for PIC code, thus we'd preferrably
- get memory for the linker close to existing mappings. mmap on it's own is
- free to return any memory location, independent of what the preferred
- location argument indicates.
-
- For example mmap (via qemu) might give you addresses all over the available
- memory range if the requested location is already occupied.
-
- mmap_next will do a linear search from the start page upwards to find a
- suitable location that is as close as possible to the locations (proivded
- via the first argument).
- -------------------------------------------------------------------------- */
-
-void*
-mmap_next(void *addr, size_t length, int prot, int flags, int fd, off_t offset) {
- if(addr == NULL) return mmap(addr, length, prot, flags, fd, offset);
- // we are going to look for up to pageSize * 1024 * 1024 (4GB) from the
- // address.
- size_t pageSize = getPageSize();
- for(int i = (uintptr_t)addr & (pageSize-1) ? 1 : 0; i < 1024*1024; i++) {
- void *target = (void*)(((uintptr_t)addr & ~(pageSize-1))+(i*pageSize));
- void *mem = mmap(target, length, prot, flags, fd, offset);
- if(mem == NULL) return mem;
- if(mem == target) return mem;
- munmap(mem, length);
- IF_DEBUG(linker && (i % 1024 == 0),
- debugBelch("mmap_next failed to find suitable space in %p - %p\n", addr, target));
- }
- return NULL;
-}
-
//
// Returns NULL on failure.
//
@@ -1089,8 +1053,8 @@ mmap_again:
debugBelch("mmapForLinker: \tflags %#0x\n",
MAP_PRIVATE | tryMap32Bit | fixed | flags));
- result = mmap_next(map_addr, size, prot,
- MAP_PRIVATE|tryMap32Bit|fixed|flags, fd, offset);
+ result = mmap(map_addr, size, prot,
+ MAP_PRIVATE|tryMap32Bit|fixed|flags, fd, offset);
if (result == MAP_FAILED) {
sysErrorBelch("mmap %" FMT_Word " bytes at %p",(W_)size,map_addr);
=====================================
rts/LinkerInternals.h
=====================================
@@ -14,7 +14,6 @@
#if RTS_LINKER_USE_MMAP
#include <sys/mman.h>
-void* mmap_next(void *addr, size_t length, int prot, int flags, int fd, off_t offset);
#endif
void printLoadedObjects(void);
=====================================
testsuite/driver/runtests.py
=====================================
@@ -73,6 +73,7 @@ parser.add_argument("--junit", type=argparse.FileType('wb'), help="output testsu
parser.add_argument("--broken-test", action="append", default=[], help="a test name to mark as broken for this run")
parser.add_argument("--test-env", default='local', help="Override default chosen test-env.")
parser.add_argument("--perf-baseline", type=GitRef, metavar='COMMIT', help="Baseline commit for performance comparsons.")
+parser.add_argument("--test-package-db", dest="test_package_db", action="append", help="Package db providing optional packages used by the testsuite.")
perf_group.add_argument("--skip-perf-tests", action="store_true", help="skip performance tests")
perf_group.add_argument("--only-perf-tests", action="store_true", help="Only do performance tests")
@@ -109,6 +110,9 @@ config.baseline_commit = args.perf_baseline
if args.top:
config.top = args.top
+if args.test_package_db:
+ config.test_package_db = args.test_package_db
+
if args.only:
config.only = args.only
config.run_only_some_tests = True
=====================================
testsuite/driver/testglobals.py
=====================================
@@ -169,6 +169,9 @@ class TestConfig:
# Baseline commit for performane metric comparisons.
self.baseline_commit = None # type: Optional[GitRef]
+ # Additional package dbs to inspect for test dependencies.
+ self.test_package_db = [] # type: [PathToPackageDb]
+
# Should we skip performance tests
self.skip_perf_tests = False
=====================================
testsuite/driver/testlib.py
=====================================
@@ -165,7 +165,16 @@ def have_library(lib: str) -> bool:
got_it = have_lib_cache[lib]
else:
cmd = strip_quotes(config.ghc_pkg)
- p = subprocess.Popen([cmd, '--no-user-package-db', 'describe', lib],
+ cmd_line = [cmd, '--no-user-package-db']
+
+ for db in config.test_package_db:
+ cmd_line.append("--package-db="+db)
+
+ cmd_line.extend(['describe', lib])
+
+ print(cmd_line)
+
+ p = subprocess.Popen(cmd_line,
stdout=subprocess.PIPE,
stderr=subprocess.PIPE,
env=ghc_env)
@@ -181,6 +190,10 @@ def have_library(lib: str) -> bool:
def _reqlib( name, opts, lib ):
if not have_library(lib):
opts.expect = 'missing-lib'
+ else:
+ opts.extra_hc_opts = opts.extra_hc_opts + ' -package ' + lib + ' '
+ for db in config.test_package_db:
+ opts.extra_hc_opts = opts.extra_hc_opts + ' -package-db=' + db + ' '
def req_haddock( name, opts ):
if not config.haddock:
=====================================
testsuite/mk/test.mk
=====================================
@@ -216,6 +216,10 @@ ifneq "$(THREADS)" ""
RUNTEST_OPTS += --threads=$(THREADS)
endif
+ifneq "$(PACKAGE_DB)" ""
+RUNTEST_OPTS += --test-package-db=$(PACKAGE_DB)
+endif
+
ifneq "$(VERBOSE)" ""
RUNTEST_OPTS += --verbose=$(VERBOSE)
endif
=====================================
testsuite/tests/cmm/should_run/all.T
=====================================
@@ -2,3 +2,19 @@ test('HooplPostorder',
extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
+
+test('cmp64',
+ [ extra_run_opts('"' + config.libdir + '"')
+ , omit_ways(['ghci'])
+ , extra_clean('cmp64_cmm.o')
+ ],
+ multi_compile_and_run,
+ ['cmp64', [('cmp64_cmm.cmm', '')], '-O'])
+
+
+# test('T17516',
+# [ collect_compiler_stats('bytes allocated', 5),
+# extra_clean(['T17516A.hi', 'T17516A.o'])
+# ],
+# multimod_compile,
+# ['T17516', '-O -v0'])
\ No newline at end of file
=====================================
testsuite/tests/cmm/should_run/cmp64.hs
=====================================
@@ -0,0 +1,156 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE CPP #-}
+
+{- Test 64bit comparisons.
+ We simply compare a number of values in different ways
+ and print the results. 32bit and 64bit platforms use
+ different code paths so if either one breaks this test
+ should catch it.
+
+-}
+
+module Main where
+
+#if defined(__GLASGOW_HASKELL__)
+#include "MachDeps.h"
+#endif
+
+import GHC.Types
+import GHC.Exts
+import GHC.Word
+import GHC.Int
+import Data.Bits
+import Control.Monad
+import Unsafe.Coerce
+
+#if WORD_SIZE_IN_BITS < 64
+#define INT64 Int64#
+#define WORD64 Word64#
+#define I64CON I64#
+#else
+#define INT64 Int#
+#define WORD64 Word#
+#define I64CON I#
+#endif
+
+
+data I64 = I64 INT64
+data W64 = W64 WORD64
+
+foreign import prim "test_lt" lt_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_gt" gt_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_le" le_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_ge" ge_s :: INT64 -> INT64 -> Int#
+
+foreign import prim "test_eq" eq_s :: INT64 -> INT64 -> Int#
+foreign import prim "test_ne" ne_s :: INT64 -> INT64 -> Int#
+
+foreign import prim "test_ltu" lt_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_gtu" gt_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_leu" le_u :: WORD64 -> WORD64 -> Int#
+foreign import prim "test_geu" ge_u :: WORD64 -> WORD64 -> Int#
+
+wordValues :: [Word64]
+wordValues = do
+ lowerBits <- interestingValues
+ higherBits <- interestingValues
+ return $ (fromIntegral higherBits `shiftL` 32) .|. fromIntegral lowerBits
+
+interestingValues :: [Word32]
+interestingValues =
+ [ 0x00000000
+ , 0x00000001
+ , 0x00000002
+
+ , 0x7FFFFFFD
+ , 0x7FFFFFFE
+ , 0x7FFFFFFF
+
+ , 0xFFFFFFFE
+ , 0xFFFFFFFD
+ , 0xFFFFFFFF
+
+ , 0x80000000
+ , 0x80000001
+ , 0x80000002
+ ]
+
+intValues :: [Int64]
+intValues = map fromIntegral wordValues
+
+intOps :: [(INT64 -> INT64 -> Int#, String)]
+intOps = [(lt_s, "lt_s")
+ ,(gt_s, "gt_s")
+ ,(le_s, "le_s")
+ ,(ge_s, "ge_s")
+
+ ,(eq_s, "eq_s")
+ ,(ne_s, "ne_s")]
+
+testInt :: Int64 -> Int64 -> (INT64 -> INT64 -> Int#) -> String -> IO ()
+testInt x y op op_name = do
+ (I64 w1,I64 w2) <- getInts x y
+ let !res = I# (op w1 w2)
+ putStrLn $ "(" ++ (show x) ++ " `" ++ op_name ++ "` " ++ show y ++ ") = " ++ show res
+ return ()
+
+testInts = do
+ let tests = do
+ (op,op_desc) <- intOps
+ x <- intValues
+ y <- intValues
+ return $ testInt x y op op_desc
+ sequence tests
+
+wordOps :: [(WORD64 -> WORD64 -> Int#, String)]
+wordOps = [(lt_u, "lt_u")
+ ,(gt_u, "gt_u")
+ ,(le_u, "le_u")
+ ,(ge_u, "ge_u")]
+
+testWord x y op op_name = do
+ (W64 w1,W64 w2) <- getWords x y
+ let !res = I# (op w1 w2)
+ putStrLn $ "(" ++ (show x) ++ " `" ++ op_name ++ "` " ++ show y ++ ") = " ++ show res
+
+testWords = do
+ let tests = do
+ (op,op_desc) <- wordOps
+ x <- wordValues
+ y <- wordValues
+ return $ testWord x y op op_desc
+ sequence tests
+
+main = do
+ testInts
+ testWords
+
+ print "done"
+ print wordValues
+ print intValues
+ return ()
+
+
+-- We want to get a I64#/W64# both and 64 and 32bit platforms.
+-- We unsafeCoerce on 64bit, on 32bit the unboxed argument already
+-- has the right type.
+
+getInts :: Int64 -> Int64 -> IO ( I64, I64 )
+#if WORD_SIZE_IN_BITS < 64
+getInts (I64# a1) (I64# a2) = return (I64 a1, I64 a2)
+#else
+getInts (I64# a1) (I64# a2) = return $ unsafeCoerce# (I64 a1, I64 a2)
+#endif
+
+
+getWords :: Word64 -> Word64 -> IO ( W64, W64 )
+#if WORD_SIZE_IN_BITS < 64
+getWords (W64# a1) (W64# a2) = return (W64 a1, W64 a2)
+#else
+getWords (W64# a1) (W64# a2) = return $ unsafeCoerce# (W64 a1, W64 a2)
+#endif
=====================================
testsuite/tests/cmm/should_run/cmp64.stdout
=====================================
The diff for this file was not included because it is too large.
=====================================
testsuite/tests/cmm/should_run/cmp64_cmm.cmm
=====================================
@@ -0,0 +1,31 @@
+#include "Cmm.h"
+
+#define TEST(name, op) \
+ name (bits64 x, bits64 y) { \
+ if(x `op` y) { \
+ return (1); \
+ } else { \
+ return (0); \
+ } \
+ }
+
+cmm_func_test(bits64 foo, bits64 bar) {
+ return (1);
+}
+
+TEST(test_lt, lt)
+TEST(test_gt, gt)
+
+TEST(test_ne, ne)
+TEST(test_eq, eq)
+
+TEST(test_ge, ge)
+TEST(test_le, le)
+
+TEST(test_geu, geu)
+TEST(test_leu, leu)
+
+TEST(test_ltu, ltu)
+TEST(test_gtu, gtu)
+
+
=====================================
testsuite/tests/codeGen/should_compile/T18614.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+{-# OPTIONS_GHC -O #-}
+
+module Main where
+
+import GHC.Exts
+
+main = pure ()
+
+test :: Word8# -> Word8#
+test x = x `plusWord8#` narrowWord8# 1##
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -101,3 +101,5 @@ test('T15570',
compile, ['-Wno-overflowed-literals'])
# skipped with CmmToC because it generates a warning:
# warning: integer constant is so large that it is unsigned
+
+test('T18614', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6cc2b8646579e296f49f1029d660c38bb44d979a...842e3f3888f73567d4f20e7e213c6ad28cfa0eb2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6cc2b8646579e296f49f1029d660c38bb44d979a...842e3f3888f73567d4f20e7e213c6ad28cfa0eb2
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/20201104/02792d71/attachment-0001.html>
More information about the ghc-commits
mailing list