[Git][ghc/ghc][wip/ghc-8.10-backports] 3 commits: testsuite: Add test for #18346
Ben Gamari
gitlab at gitlab.haskell.org
Sat Nov 14 11:47:38 UTC 2020
Ben Gamari pushed to branch wip/ghc-8.10-backports at Glasgow Haskell Compiler / GHC
Commits:
f96d6cd7 by Ben Gamari at 2020-11-14T06:47:14-05:00
testsuite: Add test for #18346
This was fixed by 4291bddaea3148908c55f235ee8978e1d9aa6f20.
(cherry picked from commit ee5dcdf95a7c408e9c339aacebf89a007a735f8f)
- - - - -
36c1027d by Ben Gamari at 2020-11-14T06:47:14-05:00
rts/linker: Fix relocation overflow in PE linker
Previously the overflow check for the IMAGE_REL_AMD64_ADDR32NB
relocation failed to account for the signed nature of the value.
Specifically, the overflow check was:
uint64_t v;
v = S + A;
if (v >> 32) { ... }
However, `v` ultimately needs to fit into 32-bits as a signed value.
Consequently, values `v > 2^31` in fact overflow yet this is not caught
by the existing overflow check.
Here we rewrite the overflow check to rather ensure that
`INT32_MIN <= v <= INT32_MAX`. There is now quite a bit of repetition
between the `IMAGE_REL_AMD64_REL32` and `IMAGE_REL_AMD64_ADDR32` cases
but I am leaving fixing this for future work.
This bug was first noticed by @awson.
Fixes #15808.
(cherry picked from commit 6d21ecee535782f01dba9947a49e282afee25724)
- - - - -
215f5c30 by Andreas Klebinger at 2020-11-14T06:47:22-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.
(cherry picked from commit bb100805337adc666867da300ee5b0b11c18fe00)
(cherry picked from commit fda3e50b559f6f25347f9ad7239e5003e27937b0)
- - - - -
12 changed files:
- compiler/nativeGen/X86/CodeGen.hs
- compiler/nativeGen/X86/Cond.hs
- rts/PrimOps.cmm
- rts/RtsMessages.c
- rts/linker/PEi386.c
- 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/simplCore/should_compile/T18346/MiniLens.hs
- + testsuite/tests/simplCore/should_compile/T18346/T18346.hs
- + testsuite/tests/simplCore/should_compile/T18346/all.T
Changes:
=====================================
compiler/nativeGen/X86/CodeGen.hs
=====================================
@@ -1804,6 +1804,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
@@ -1821,22 +1850,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/nativeGen/X86/Cond.hs
=====================================
@@ -13,22 +13,22 @@ import GhcPrelude
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
condUnsigned :: Cond -> Bool
=====================================
rts/PrimOps.cmm
=====================================
@@ -1821,7 +1821,9 @@ loop:
StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
}
- ASSERT(StgTSO_block_info(tso) == mvar);
+ if(StgTSO_block_info(tso) != mvar) {
+ ccall putMVarError(mvar "ptr", tso "ptr");
+ }
// save why_blocked here, because waking up the thread destroys
// this information
W_ why_blocked;
=====================================
rts/RtsMessages.c
=====================================
@@ -40,6 +40,16 @@ RtsMsgFunction *debugMsgFn = rtsDebugMsgFn;
RtsMsgFunction *errorMsgFn = rtsErrorMsgFn;
RtsMsgFunction *sysErrorMsgFn = rtsSysErrorMsgFn;
+void
+putMVarError(StgMVar *mvar, StgTSO *tso)
+{
+ errorBelch("putMVarzh: uh oh, blocked mismatch\n");
+ errorBelch(" tso->why_blocked=%d\n", tso->why_blocked);
+ errorBelch(" tso->block_info=%p\n", tso->block_info);
+ errorBelch(" mvar=%p\n", mvar);
+ barf("he's dead, jim.\n");
+}
+
void
barf(const char*s, ...)
{
=====================================
rts/linker/PEi386.c
=====================================
@@ -1952,13 +1952,15 @@ ocResolve_PEi386 ( ObjectCode* oc )
{
uint64_t v;
v = S + A;
- if (v >> 32) {
+ // N.B. in the case of the sign-extended relocations we must ensure that v
+ // fits in a signed 32-bit value. See #15808.
+ if (((int64_t) v > (int64_t) INT32_MAX) || ((int64_t) v < (int64_t) INT32_MIN)) {
copyName (getSymShortName (info, sym), oc,
symbol, sizeof(symbol)-1);
S = makeSymbolExtra_PEi386(oc, symIndex, S, (char *)symbol);
/* And retry */
v = S + A;
- if (v >> 32) {
+ if (((int64_t) v > (int64_t) INT32_MAX) || ((int64_t) v < (int64_t) INT32_MIN)) {
barf("IMAGE_REL_AMD64_ADDR32[NB]: High bits are set in %zx for %s",
v, (char *)symbol);
}
@@ -1970,14 +1972,14 @@ ocResolve_PEi386 ( ObjectCode* oc )
{
intptr_t v;
v = S + (int32_t)A - ((intptr_t)pP) - 4;
- if ((v > (intptr_t) INT32_MAX) || (v < (intptr_t) INT32_MIN)) {
+ if ((v > (int64_t) INT32_MAX) || (v < (int64_t) INT32_MIN)) {
/* Make the trampoline then */
copyName (getSymShortName (info, sym),
oc, symbol, sizeof(symbol)-1);
S = makeSymbolExtra_PEi386(oc, symIndex, S, (char *)symbol);
/* And retry */
v = S + (int32_t)A - ((intptr_t)pP) - 4;
- if ((v > (intptr_t) INT32_MAX) || (v < (intptr_t) INT32_MIN)) {
+ if ((v > (int64_t) INT32_MAX) || (v < (int64_t) INT32_MIN)) {
barf("IMAGE_REL_AMD64_REL32: High bits are set in %zx for %s",
v, (char *)symbol);
}
=====================================
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/simplCore/should_compile/T18346/MiniLens.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE RankNTypes #-}
+
+module MiniLens ((^.), Getting, Lens', lens, view) where
+
+import Data.Functor.Const (Const(..))
+
+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
+
+type Lens' s a = Lens s s a a
+
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+lens sa sbt afb s = sbt s <$> afb (sa s)
+{-# INLINE lens #-}
+
+type Getting r s a = (a -> Const r a) -> s -> Const r s
+
+view :: Getting a s a -> s -> a
+view l = getConst . l Const
+{-# INLINE view #-}
+
+(^.) :: s -> Getting a s a -> a
+s ^. l = getConst (l Const s)
+{-# INLINE (^.) #-}
=====================================
testsuite/tests/simplCore/should_compile/T18346/T18346.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE RankNTypes #-}
+
+module GHCBug (field) where
+
+import MiniLens ((^.), Getting, Lens', lens, view)
+
+t' :: Getting () () ()
+t' = lens id const
+{-# NOINLINE t' #-}
+
+mlift :: Functor f => Getting b a b -> Lens' (f a) (f b)
+mlift l = lens (fmap (^. l)) const
+{-# INLINE mlift #-}
+
+newtype Field = F (Maybe () -> Maybe ())
+
+field :: Field
+field = F (view (mlift t'))
=====================================
testsuite/tests/simplCore/should_compile/T18346/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T18346', [extra_files(['MiniLens.hs'])], multimod_compile, ['T18346.hs', '-v0'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9d871d567e8f63c63dcd4d65ae18fd42d5c5fdf...215f5c305f3ce53f385b4337dca19d562a034b90
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9d871d567e8f63c63dcd4d65ae18fd42d5c5fdf...215f5c305f3ce53f385b4337dca19d562a034b90
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/20201114/2196985a/attachment-0001.html>
More information about the ghc-commits
mailing list