[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: NCG: Fix 64bit int comparisons on 32bit x86
Marge Bot
gitlab at gitlab.haskell.org
Thu Nov 5 00:20:28 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job 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)
- - - - -
cefa2d98 by Viktor Dukhovni at 2020-11-04T19:20:14-05:00
Naming, value types and tests for Addr# atomics
The atomic Exchange and CAS operations on integral types are updated to
take and return more natural `Word#` rather than `Int#` values. These
are bit-block not arithmetic operations, and the sign bit plays no
special role.
Standardises the names to `atomic<OpType><ValType>Addr#`, where `OpType` is one
of `Cas` or `Exchange` and `ValType` is presently either `Word` or `Addr`.
Eventually, variants for `Word32` and `Word64` can and should be added,
once #11953 and related issues (e.g. #13825) are resolved.
Adds tests for `Addr#` CAS that mirror existing tests for
`MutableByteArray#`.
- - - - -
99413bee by Ryan Scott at 2020-11-04T19:20:14-05:00
Add a regression test for #18920
Commit f594a68a5500696d94ae36425bbf4d4073aca3b2
(`Use level numbers for generalisation`) ended up fixing #18920. Let's add a
regression test to ensure that it stays fixed.
Fixes #18920.
- - - - -
23 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Cond.hs
- compiler/GHC/StgToCmm/Prim.hs
- libraries/base/GHC/Event/Internal.hs
- libraries/ghc-prim/changelog.md
- 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
- testsuite/tests/codeGen/should_compile/cg011.hs
- testsuite/tests/codeGen/should_run/cas_int.hs
- testsuite/tests/codeGen/should_run/cgrun080.hs
- testsuite/tests/concurrent/should_run/AtomicPrimops.hs
- testsuite/tests/concurrent/should_run/AtomicPrimops.stdout
- + testsuite/tests/typecheck/should_compile/T18920.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2079,39 +2079,47 @@ primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp
with has_side_effects = True
can_fail = True
-primop InterlockedExchange_Addr "atomicExchangeAddr#" GenPrimOp
+primop InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp
Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
{The atomic exchange operation. Atomically exchanges the value at the first address
with the Addr# given as second argument. Implies a read barrier.}
with has_side_effects = True
+ can_fail = True
-primop InterlockedExchange_Int "atomicExchangeInt#" GenPrimOp
- Addr# -> Int# -> State# s -> (# State# s, Int# #)
+primop InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp
+ Addr# -> Word# -> State# s -> (# State# s, Word# #)
{The atomic exchange operation. Atomically exchanges the value at the address
with the given value. Returns the old value. Implies a read barrier.}
with has_side_effects = True
+ can_fail = True
-primop AtomicCompareExchange_Int "atomicCasInt#" GenPrimOp
- Addr# -> Int# -> Int# -> State# s -> (# State# s, Int# #)
+primop CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp
+ Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
{ Compare and swap on a word-sized memory location.
- Use as atomicCasInt# location expected desired
+ Use as: \s -> atomicCasAddrAddr# location expected desired s
- This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).
+ This version always returns the old value read. This follows the normal
+ protocol for CAS operations (and matches the underlying instruction on
+ most architectures).
Implies a full memory barrier.}
with has_side_effects = True
+ can_fail = True
-primop AtomicCompareExchange_Addr "atomicCasAddr#" GenPrimOp
- Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
- { Compare and swap on a word-sized memory location.
+primop CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp
+ Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)
+ { Compare and swap on a word-sized and aligned memory location.
- Use as atomicCasAddr# location expected desired
+ Use as: \s -> atomicCasWordAddr# location expected desired s
- This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).
+ This version always returns the old value read. This follows the normal
+ protocol for CAS operations (and matches the underlying instruction on
+ most architectures).
Implies a full memory barrier.}
with has_side_effects = True
+ can_fail = True
------------------------------------------------------------------------
section "Mutable variables"
=====================================
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/StgToCmm/Prim.hs
=====================================
@@ -848,11 +848,11 @@ emitPrimOp dflags primop = case primop of
-- Atomic operations
InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
- InterlockedExchange_Int -> \[src, value] -> opIntoRegs $ \[res] ->
+ InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
- AtomicCompareExchange_Int -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
+ CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
- AtomicCompareExchange_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
+ CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
-- SIMD primops
=====================================
libraries/base/GHC/Event/Internal.hs
=====================================
@@ -109,5 +109,5 @@ throwErrnoIfMinus1NoRetry loc f = do
exchangePtr :: Ptr (Ptr a) -> Ptr a -> IO (Ptr a)
exchangePtr (Ptr dst) (Ptr val) =
IO $ \s ->
- case (atomicExchangeAddr# dst val s) of
+ case (atomicExchangeAddrAddr# dst val s) of
(# s2, old_val #) -> (# s2, Ptr old_val #)
=====================================
libraries/ghc-prim/changelog.md
=====================================
@@ -1,6 +1,6 @@
## 0.7.0 (edit as necessary)
-- Shipped with GHC 8.12.1
+- Shipped with GHC 9.0.1
- Add known-key `cstringLength#` to `GHC.CString`. This is just the
C function `strlen`, but a built-in rewrite rule allows GHC to
@@ -21,8 +21,13 @@
- Add primops for atomic exchange:
- atomicExchangeAddr# :: Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
- atomicExchangeInt# :: Addr# -> Int# -> State# s -> (# State# s, Int# #)
+ atomicExchangeAddrAddr# :: Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
+ atomicExchangeWordAddr# :: Addr# -> Word# -> State# s -> (# State# s, Word# #)
+
+- Add primops for atomic compare and swap at a given Addr#:
+
+ atomicCasAddrAddr# :: Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
+ atomicCasWordAddr# :: Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)
- Add an explicit fixity for `(~)` and `(~~)`:
=====================================
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, [''])
=====================================
testsuite/tests/codeGen/should_compile/cg011.hs
=====================================
@@ -4,8 +4,8 @@
module M where
-import GHC.Exts (atomicExchangeInt#, Int#, Addr#, State# )
+import GHC.Exts (atomicExchangeWordAddr#, Word#, Addr#, State# )
-swap :: Addr# -> Int# -> State# s -> (# #)
-swap ptr val s = case (atomicExchangeInt# ptr val s) of
+swap :: Addr# -> Word# -> State# s -> (# #)
+swap ptr val s = case (atomicExchangeWordAddr# ptr val s) of
(# s2, old_val #) -> (# #)
=====================================
testsuite/tests/codeGen/should_run/cas_int.hs
=====================================
@@ -26,16 +26,16 @@ import GHC.Ptr
#include "MachDeps.h"
main = do
- alloca $ \(ptr_p :: Ptr (Ptr Int)) -> do
- alloca $ \(ptr_i :: Ptr Int) -> do
- alloca $ \(ptr_j :: Ptr Int) -> do
- poke ptr_i (1 :: Int)
- poke ptr_j (2 :: Int)
+ alloca $ \(ptr_p :: Ptr (Ptr Word)) -> do
+ alloca $ \(ptr_i :: Ptr Word) -> do
+ alloca $ \(ptr_j :: Ptr Word) -> do
+ poke ptr_i (1 :: Word)
+ poke ptr_j (2 :: Word)
--expected to swap
- res_i <- cas ptr_i 1 3 :: IO Int
+ res_i <- cas ptr_i 1 3 :: IO Word
-- expected to fail
- res_j <- cas ptr_j 1 4 :: IO Int
+ res_j <- cas ptr_j 1 4 :: IO Word
putStrLn "Returned results:"
--(1,2)
@@ -48,7 +48,7 @@ main = do
--(3,2)
print (i,j)
-cas :: Ptr Int -> Int -> Int -> IO Int
-cas (Ptr ptr) (I# expected) (I# desired)= do
- IO $ \s -> case (atomicCasInt# ptr expected desired s) of
- (# s2, old_val #) -> (# s2, I# old_val #)
+cas :: Ptr Word -> Word -> Word -> IO Word
+cas (Ptr ptr) (W# expected) (W# desired)= do
+ IO $ \s -> case (atomicCasWordAddr# ptr expected desired s) of
+ (# s2, old_val #) -> (# s2, W# old_val #)
=====================================
testsuite/tests/codeGen/should_run/cgrun080.hs
=====================================
@@ -25,8 +25,8 @@ import GHC.Types
main = do
alloca $ \ptr_i -> do
- poke ptr_i (1 :: Int)
- w1 <- newEmptyMVar :: IO (MVar Int)
+ poke ptr_i (1 :: Word)
+ w1 <- newEmptyMVar :: IO (MVar Word)
forkIO $ do
v <- swapN 50000 2 ptr_i
putMVar w1 v
@@ -37,15 +37,14 @@ main = do
-- Should be [1,2,3]
print $ sort [v0,v1,v2]
-swapN :: Int -> Int -> Ptr Int -> IO Int
+swapN :: Word -> Word -> Ptr Word -> IO Word
swapN 0 val ptr = return val
swapN n val ptr = do
val' <- swap ptr val
swapN (n-1) val' ptr
-swap :: Ptr Int -> Int -> IO Int
-swap (Ptr ptr) (I# val) = do
- IO $ \s -> case (atomicExchangeInt# ptr val s) of
- (# s2, old_val #) -> (# s2, I# old_val #)
-
+swap :: Ptr Word -> Word -> IO Word
+swap (Ptr ptr) (W# val) = do
+ IO $ \s -> case (atomicExchangeWordAddr# ptr val s) of
+ (# s2, old_val #) -> (# s2, W# old_val #)
=====================================
testsuite/tests/concurrent/should_run/AtomicPrimops.hs
=====================================
@@ -6,6 +6,8 @@ module Main ( main ) where
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (when)
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
import Foreign.Storable
import GHC.Exts
import GHC.IO
@@ -22,6 +24,7 @@ main = do
fetchOrTest
fetchXorTest
casTest
+ casTestAddr
readWriteTest
-- | Test fetchAddIntArray# by having two threads concurrenctly
@@ -54,12 +57,14 @@ fetchXorTest = do
work mba 0 val = return ()
work mba n val = fetchXorIntArray mba 0 val >> work mba (n-1) val
- -- Initial value is a large prime and the two patterns are 1010...
- -- and 0101...
+ -- The two patterns are 1010... and 0101... The second pattern is larger
+ -- than maxBound, avoid warnings by initialising as a Word.
(n0, t1pat, t2pat)
| sizeOf (undefined :: Int) == 8 =
- (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999)
- | otherwise = (0x0000ffff, 0x55555555, 0x99999999)
+ ( 0x00000000ffffffff, 0x5555555555555555
+ , fromIntegral (0x9999999999999999 :: Word))
+ | otherwise = ( 0x0000ffff, 0x55555555
+ , fromIntegral (0x99999999 :: Word))
expected
| sizeOf (undefined :: Int) == 8 = 4294967295
| otherwise = 65535
@@ -90,13 +95,15 @@ fetchOpTest op expected name = do
-- | Initial value and operation arguments for race test.
--
--- Initial value is a large prime and the two patterns are 1010...
--- and 0101...
+-- The two patterns are 1010... and 0101... The second pattern is larger than
+-- maxBound, avoid warnings by initialising as a Word.
n0, t1pat, t2pat :: Int
(n0, t1pat, t2pat)
| sizeOf (undefined :: Int) == 8 =
- (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999)
- | otherwise = (0x0000ffff, 0x55555555, 0x99999999)
+ ( 0x00000000ffffffff, 0x5555555555555555
+ , fromIntegral (0x9999999999999999 :: Word))
+ | otherwise = ( 0x0000ffff, 0x55555555
+ , fromIntegral (0x99999999 :: Word))
fetchAndTest :: IO ()
fetchAndTest = fetchOpTest fetchAndIntArray expected "fetchAndTest"
@@ -120,8 +127,10 @@ fetchNandTest = do
fetchOrTest :: IO ()
fetchOrTest = fetchOpTest fetchOrIntArray expected "fetchOrTest"
where expected
- | sizeOf (undefined :: Int) == 8 = 15987178197787607039
- | otherwise = 3722313727
+ | sizeOf (undefined :: Int) == 8
+ = fromIntegral (15987178197787607039 :: Word)
+ | otherwise
+ = fromIntegral (3722313727 :: Word)
-- | Test casIntArray# by using it to emulate fetchAddIntArray# and
-- then having two threads concurrenctly increment a counter,
@@ -131,7 +140,7 @@ casTest = do
tot <- race 0
(\ mba -> work mba iters 1)
(\ mba -> work mba iters 2)
- assertEq 3000000 tot "casTest"
+ assertEq (3 * iters) tot "casTest"
where
work :: MByteArray -> Int -> Int -> IO ()
work mba 0 val = return ()
@@ -179,6 +188,45 @@ race n0 thread1 thread2 = do
mapM_ takeMVar [done1, done2]
readIntArray mba 0
+-- | Test atomicCasWordAddr# by having two threads concurrenctly increment a
+-- counter, checking the sum at the end.
+casTestAddr :: IO ()
+casTestAddr = do
+ tot <- raceAddr 0
+ (\ addr -> work addr (fromIntegral iters) 1)
+ (\ addr -> work addr (fromIntegral iters) 2)
+ assertEq (3 * fromIntegral iters) tot "casTestAddr"
+ where
+ work :: Ptr Word -> Word -> Word -> IO ()
+ work ptr 0 val = return ()
+ work ptr n val = add ptr val >> work ptr (n-1) val
+
+ -- Fetch-and-add implemented using CAS.
+ add :: Ptr Word -> Word -> IO ()
+ add ptr n = peek ptr >>= go
+ where
+ go old = do
+ old' <- atomicCasWordPtr ptr old (old + n)
+ when (old /= old') $ go old'
+
+ -- | Create two threads that mutate the byte array passed to them
+ -- concurrently. The array is one word large.
+ raceAddr :: Word -- ^ Initial value of array element
+ -> (Ptr Word -> IO ()) -- ^ Thread 1 action
+ -> (Ptr Word -> IO ()) -- ^ Thread 2 action
+ -> IO Word -- ^ Final value of array element
+ raceAddr n0 thread1 thread2 = do
+ done1 <- newEmptyMVar
+ done2 <- newEmptyMVar
+ ptr <- asWordPtr <$> callocBytes (sizeOf (undefined :: Word))
+ forkIO $ thread1 ptr >> putMVar done1 ()
+ forkIO $ thread2 ptr >> putMVar done2 ()
+ mapM_ takeMVar [done1, done2]
+ peek ptr
+ where
+ asWordPtr :: Ptr a -> Ptr Word
+ asWordPtr = castPtr
+
------------------------------------------------------------------------
-- Test helper
@@ -254,3 +302,13 @@ casIntArray :: MByteArray -> Int -> Int -> Int -> IO Int
casIntArray (MBA mba#) (I# ix#) (I# old#) (I# new#) = IO $ \ s# ->
case casIntArray# mba# ix# old# new# s# of
(# s2#, old2# #) -> (# s2#, I# old2# #)
+
+------------------------------------------------------------------------
+-- Wrappers around Addr#
+
+-- Should this be added to Foreign.Storable? Similar to poke, but does the
+-- update atomically.
+atomicCasWordPtr :: Ptr Word -> Word -> Word -> IO Word
+atomicCasWordPtr (Ptr addr#) (W# old#) (W# new#) = IO $ \ s# ->
+ case atomicCasWordAddr# addr# old# new# s# of
+ (# s2#, old2# #) -> (# s2#, W# old2# #)
=====================================
testsuite/tests/concurrent/should_run/AtomicPrimops.stdout
=====================================
@@ -4,4 +4,5 @@ fetchNandTest: OK
fetchOrTest: OK
fetchXorTest: OK
casTest: OK
+casTestAddr: OK
readWriteTest: OK
=====================================
testsuite/tests/typecheck/should_compile/T18920.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs #-}
+module T18920 where
+
+import Data.Kind
+
+class Monad solver => Solver solver where
+ type Constraint solver :: Type
+ type Label solver :: Type
+
+class Queue q
+
+data Tree s a where
+ NewVar :: Term s t => (t -> Tree s a) -> Tree s a
+
+class Solver solver => Term solver term
+
+class Transformer t where
+ type EvalState t :: Type
+ type TreeState t :: Type
+ type ForSolver t :: (Type -> Type)
+ type ForResult t :: Type
+ nextT :: SearchSig (ForSolver t) q t (ForResult t)
+ returnT :: ContinueSig solver q t (ForResult t)
+
+type ContinueSig solver q t a =
+ ( Solver solver, Queue q, Transformer t )
+ => Int -> q -> t -> EvalState t
+ -> solver (Int, [a])
+
+type SearchSig solver q t a =
+ (Solver solver, Queue q, Transformer t )
+ => Int -> Tree solver a -> q -> t -> EvalState t -> TreeState t
+ -> solver (Int,[a])
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -725,6 +725,7 @@ test('T18470', normal, compile, [''])
test('T18323', normal, compile, [''])
test('T18585', normal, compile, [''])
test('T18831', normal, compile, [''])
+test('T18920', normal, compile, [''])
test('T15942', normal, compile, [''])
test('ClassDefaultInHsBoot', [extra_files(['ClassDefaultInHsBootA1.hs','ClassDefaultInHsBootA2.hs','ClassDefaultInHsBootA2.hs-boot','ClassDefaultInHsBootA3.hs'])], multimod_compile, ['ClassDefaultInHsBoot', '-v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f782f586c353afe0999dbc189af5213ec3bf8817...99413bee163030a93ab4b8be75cb44b17a1f7d7a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f782f586c353afe0999dbc189af5213ec3bf8817...99413bee163030a93ab4b8be75cb44b17a1f7d7a
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/d2c7e474/attachment-0001.html>
More information about the ghc-commits
mailing list