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

Commits:

14 changed files:

Changes:

  • changelog.d/T26978
    1 
    +section: compiler
    2 
    +issues: #26978
    3 
    +mrs: !15619
    4 
    +synopsis:
    5 
    +  AArch64 code generation: use ``SXTH`` instead of ``SXTW`` for ``W32`` sign extension
    6 
    +description:
    7 
    +  Fix the AArch64 code generator incorrectly using using ``SXTH``
    8 
    +  (sign-extend halfword, 16-bit) for ``W32``-to-``W64`` sign extension, and
    9 
    +  always use the source width for the source operand in sign extension
    10 
    +  instructions.
    11 
    +
    12 
    +  Also ensures that sub-W64 code generation for ``MO_S_Mul2`` uses ``W32``
    13 
    +  registers as mandated by the ARM specification.
    14 
    +

  • changelog.d/T27047
    1 
    +section: compiler
    2 
    +issues: #27047
    3 
    +mrs: !15619
    4 
    +synopsis:
    5 
    +  Fix incorrect overflow bit for ``MUL2`` on AArch64 for sub-``W64`` operands.
    6 
    +description:
    7 
    +  This fixes the computation of the overflow bit for ``MO_S_Mul2`` on
    8 
    +  sub-``W64`` operands; the old condition was exactly inverted.
    9 
    +

  • compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
    ... ... @@ -1894,15 +1894,15 @@ signExtendReg w w' r =
    1894 1894 
           W64 -> noop
    1895 1895 
           W32
    1896 1896 
             | w' == W32 -> noop
    1897 
    -        | otherwise -> extend SXTH
    1897 
    +        | otherwise -> extend SXTW
    1898 1898 
           W16           -> extend SXTH
    1899 1899 
           W8            -> extend SXTB
    1900 1900 
           _             -> panic "intOp"
    1901 1901 
       where
    1902 1902 
         noop = return (r, nilOL)
    1903 1903 
         extend instr = do
    1904 
    -        r' <- getNewRegNat II64
    1905 
    -        return (r', unitOL $ instr (OpReg w' r') (OpReg w' r))
    1904 
    +        r' <- getNewRegNat (intFormat w')
    1905 
    +        return (r', unitOL $ instr (OpReg w' r') (OpReg w r))
    1906 1906
    1907 1907 
     -- | Instructions to truncate the value in the given register from width @w@
    1908 1908 
     -- down to width @w'@.
    ... ... @@ -2333,41 +2333,35 @@ genCCall target dest_regs arg_regs = do
    2333 2333 
                   let lo = getRegisterReg platform (CmmLocal dst_lo)
    2334 2334 
                       hi = getRegisterReg platform (CmmLocal dst_hi)
    2335 2335 
                       nd = getRegisterReg platform (CmmLocal dst_needed)
    2336 
    -                  -- Do everything in a full 64 bit registers
    2337 2336 
                       w' = platformWordWidth platform
    2338 2337
    2339 
    -              (reg_a, code_a') <- signExtendReg w w' reg_a'
    2340 
    -              (reg_b, code_b') <- signExtendReg w w' reg_b'
    2338 
    +              -- Sign-extend inputs to W32 for SMULL (Xd = Wn * Wm).
    2339 
    +              -- signExtendReg always allocates a fresh temp for w < W32,
    2340 
    +              -- and is a noop for W32 (safe: SMULL reads both sources
    2341 
    +              -- atomically before writing the destination).
    2342 
    +              (reg_a, code_a') <- signExtendReg w W32 reg_a'
    2343 
    +              (reg_b, code_b') <- signExtendReg w W32 reg_b'
    2341 2344
    2342 2345 
                   return $
    2343 2346 
                       code_a  `appOL`
    2344 2347 
                       code_b  `appOL`
    2345 2348 
                       code_a' `appOL`
    2346 2349 
                       code_b' `snocOL`
    2347 
    -                  -- the low 2w' of lo contains the full multiplication;
    2348 
    -                  -- eg: int8 * int8 -> int16 result
    2349 
    -                  -- so lo is in the last w of the register, and hi is in the second w.
    2350 
    -                  SMULL (OpReg w' lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL`
    2351 
    -                  -- Make sure we hold onto the sign bits for dst_needed
    2352 
    -                  ASR (OpReg w' hi) (OpReg w' lo)    (OpImm (ImmInt $ widthInBits w)) `appOL`
    2353 
    -                  -- lo can now be truncated so we can get at it's top bit easily.
    2350 
    +                  -- SMULL Xd, Wn, Wm: multiply two W32 values producing a
    2351 
    +                  -- 64-bit result. The low w bits of lo contain the truncated
    2352 
    +                  -- product, and hi gets the overflow (sign extension bits).
    2353 
    +                  SMULL (OpReg w' lo) (OpReg W32 reg_a) (OpReg W32 reg_b) `snocOL`
    2354 
    +                  ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL`
    2354 2355 
                       truncateReg w' w lo `snocOL`
    2355 
    -                  -- Note the use of CMN (compare negative), not CMP: we want to
    2356 
    -                  -- test if the top half is negative one and the top
    2357 
    -                  -- bit of the bottom half is positive one. eg:
    2358 
    -                  -- hi = 0b1111_1111  (actually 64 bits)
    2359 
    -                  -- lo = 0b1010_1111  (-81, so the result didn't need the top half)
    2360 
    -                  -- lo' = ASR(lo,7)   (second reg of SMN)
    2361 
    -                  --     = 0b0000_0001 (theeshift gives us 1 for negative,
    2362 
    -                  --                    and 0 for positive)
    2363 
    -                  -- hi == -lo'?
    2364 
    -                  -- 0b1111_1111 == 0b1111_1111 (yes, top half is just overflow)
    2365 
    -                  -- Another way to think of this is if hi + lo' == 0, which is what
    2366 
    -                  -- CMN really is under the hood.
    2356 
    +                  -- CMN (compare negative) tests hi + lo' == 0, i.e. hi == -lo'.
    2357 
    +                  -- lo' = LSR(lo, w-1) gives 1 if lo is negative, 0 if positive.
    2358 
    +                  -- No overflow iff hi is the sign extension of lo:
    2359 
    +                  --   lo positive (bit w-1 = 0) => lo' = 0, need hi == 0
    2360 
    +                  --   lo negative (bit w-1 = 1) => lo' = 1, need hi == -1
    2361 
    +                  -- CMN sets Z when hi + lo' == 0 (no overflow), so we use
    2362 
    +                  -- NE to set nd = 1 when overflow occurred.
    2367 2363 
                       CMN   (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL`
    2368 
    -                  -- Set dst_needed to 1 if hi and lo' were (negatively) equal
    2369 
    -                  CSET  (OpReg w' nd) EQ `appOL`
    2370 
    -                  -- Finally truncate hi to drop any extraneous sign bits.
    2364 
    +                  CSET  (OpReg w' nd) NE `appOL`
    2371 2365 
                       truncateReg w' w hi
    2372 2366 
               -- Can't handle > 64 bit operands
    2373 2367 
               | otherwise -> unsupported (MO_S_Mul2 w)

  • compiler/GHC/CmmToAsm/AArch64/Instr.hs
    ... ... @@ -105,6 +105,7 @@ regUsageOfInstr platform instr = case instr of
    105 105 
       SXTB dst src             -> usage (regOp src, regOp dst)
    106 106 
       UXTB dst src             -> usage (regOp src, regOp dst)
    107 107 
       SXTH dst src             -> usage (regOp src, regOp dst)
    108 
    +  SXTW dst src             -> usage (regOp src, regOp dst)
    108 109 
       UXTH dst src             -> usage (regOp src, regOp dst)
    109 110 
       CLZ  dst src             -> usage (regOp src, regOp dst)
    110 111 
       RBIT dst src             -> usage (regOp src, regOp dst)
    ... ... @@ -296,6 +297,7 @@ patchRegsOfInstr instr env = case instr of
    296 297 
         SXTB o1 o2       -> SXTB (patchOp o1) (patchOp o2)
    297 298 
         UXTB o1 o2       -> UXTB (patchOp o1) (patchOp o2)
    298 299 
         SXTH o1 o2       -> SXTH (patchOp o1) (patchOp o2)
    300 
    +    SXTW o1 o2       -> SXTW (patchOp o1) (patchOp o2)
    299 301 
         UXTH o1 o2       -> UXTH (patchOp o1) (patchOp o2)
    300 302 
         CLZ o1 o2        -> CLZ  (patchOp o1) (patchOp o2)
    301 303 
         RBIT o1 o2       -> RBIT (patchOp o1) (patchOp o2)
    ... ... @@ -699,8 +701,7 @@ data Instr
    699 701 
         | UXTB Operand Operand
    700 702 
         | SXTH Operand Operand
    701 703 
         | UXTH Operand Operand
    702 
    -    -- | SXTW Operand Operand
    703 
    -    -- | SXTX Operand Operand
    704 
    +    | SXTW Operand Operand
    704 705 
         | PUSH_STACK_FRAME
    705 706 
         | POP_STACK_FRAME
    706 707 
         -- 1. Arithmetic Instructions ----------------------------------------------
    ... ... @@ -857,6 +858,7 @@ instrCon i =
    857 858 
           SXTB{} -> "SXTB"
    858 859 
           UXTB{} -> "UXTB"
    859 860 
           SXTH{} -> "SXTH"
    861 
    +      SXTW{} -> "SXTW"
    860 862 
           UXTH{} -> "UXTH"
    861 863 
           PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"
    862 864 
           POP_STACK_FRAME{} -> "POP_STACK_FRAME"

  • compiler/GHC/CmmToAsm/AArch64/Ppr.hs
    ... ... @@ -516,6 +516,7 @@ pprInstr platform instr = case instr of
    516 516 
       SXTB o1 o2       -> op2 (text "\tsxtb") o1 o2
    517 517 
       UXTB o1 o2       -> op2 (text "\tuxtb") o1 o2
    518 518 
       SXTH o1 o2       -> op2 (text "\tsxth") o1 o2
    519 
    +  SXTW o1 o2       -> op2 (text "\tsxtw") o1 o2
    519 520 
       UXTH o1 o2       -> op2 (text "\tuxth") o1 o2
    520 521
    521 522 
       -- 3. Logical and Move Instructions ------------------------------------------

  • testsuite/tests/codeGen/should_gen_asm/aarch64-sxth-mul2.asm
    1 
    +sxth

  • testsuite/tests/codeGen/should_gen_asm/aarch64-sxth-mul2.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +// Exercises MO_S_Mul2 W16: signExtendReg W16 W32 must emit SXTH to
    4 
    +// sign-extend the 16-bit inputs to 32-bit before SMULL.
    5 
    +testMul2W16 (W_ buffer) {
    6 
    +    I16 a, b, needed, hi, lo;
    7 
    +    a = I16[buffer];
    8 
    +    b = I16[buffer + 2];
    9 
    +    (needed, hi, lo) = prim %mul2_16(a, b);
    10 
    +    I16[buffer + 4] = lo;
    11 
    +    return();
    12 
    +}

  • testsuite/tests/codeGen/should_gen_asm/aarch64-sxtw.asm
    1 
    +smull

  • testsuite/tests/codeGen/should_gen_asm/aarch64-sxtw.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +// Exercises MO_S_Mul2 W32, which uses SMULL (Xd = Wn * Wm).
    4 
    +// After the fix, signExtendReg W32 W32 is a noop (no SXTW needed),
    5 
    +// but the SMULL instruction itself must still appear.
    6 
    +testMul2W32 (W_ buffer) {
    7 
    +    I32 a, b, needed, hi, lo;
    8 
    +    a = I32[buffer];
    9 
    +    b = I32[buffer + 4];
    10 
    +    (needed, hi, lo) = prim %mul2_32(a, b);
    11 
    +    I32[buffer + 8] = lo;
    12 
    +    return();
    13 
    +}

  • testsuite/tests/codeGen/should_gen_asm/all.T
    ... ... @@ -31,3 +31,5 @@ is_aarch64_codegen = [
    31 31 
     # AArch64-specific tests
    32 32 
     test('aarch64-ushr-subword', is_aarch64_codegen, compile_grep_asm, ['hs', True, '-O'])
    33 33 
     test('aarch64-shl-subword', is_aarch64_codegen, compile_grep_asm, ['hs', True, '-O'])
    34 
    +test('aarch64-sxtw', is_aarch64_codegen, compile_grep_asm, ['cmm', True, ''])
    35 
    +test('aarch64-sxth-mul2', is_aarch64_codegen, compile_grep_asm, ['cmm', True, ''])

  • testsuite/tests/codeGen/should_run/aarch64-sxtw-cmm.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +// MO_S_Mul2 W32: signExtendReg W32 W32 is a noop (inputs already W32).
    4 
    +// Tests the SMULL path with values whose bit 15 != bit 31 (the old SXTH
    5 
    +// bug would corrupt these).
    6 
    +runMul2W32zh (W_ x) {
    7 
    +    I32 a, b, needed, hi, lo;
    8 
    +    a = %lobits32(x);
    9 
    +    b = 2::I32;
    10 
    +    (needed, hi, lo) = prim %mul2_32(a, b);
    11 
    +    return(TO_W_(lo));
    12 
    +}
    13 
    +
    14 
    +// MO_S_Mul2 W16: signExtendReg W16 W32 emits SXTH before SMULL.
    15 
    +runMul2W16zh (W_ x) {
    16 
    +    I16 a, b, needed, hi, lo;
    17 
    +    a = %lobits16(x);
    18 
    +    b = 2::I16;
    19 
    +    (needed, hi, lo) = prim %mul2_16(a, b);
    20 
    +    return(TO_W_(lo));
    21 
    +}
    22 
    +
    23 
    +// MO_S_Mul2 W8: signExtendReg W8 W32 emits SXTB before SMULL.
    24 
    +runMul2W8zh (W_ x) {
    25 
    +    I8 a, b, needed, hi, lo;
    26 
    +    a = %lobits8(x);
    27 
    +    b = 2::I8;
    28 
    +    (needed, hi, lo) = prim %mul2_8(a, b);
    29 
    +    return(TO_W_(lo));
    30 
    +}
    31 
    +
    32 
    +// MO_S_Mul2 W16 returning (needed, hi, lo) as a packed triple.
    33 
    +// Tests the CSET NE overflow detection: needed=1 when overflow occurs.
    34 
    +// Returns (needed << 32) | (lo & 0xFFFF) so the Haskell side can inspect both.
    35 
    +runMul2W16Overflowzh (W_ x, W_ y) {
    36 
    +    I16 a, b, needed, hi, lo;
    37 
    +    a = %lobits16(x);
    38 
    +    b = %lobits16(y);
    39 
    +    (needed, hi, lo) = prim %mul2_16(a, b);
    40 
    +    return(TO_W_(needed) * 0x100000000 + (TO_W_(lo) `and` 0xFFFF));
    41 
    +}

  • testsuite/tests/codeGen/should_run/aarch64-sxtw-run.hs
    1 
    +{-# LANGUAGE ForeignFunctionInterface #-}
    2 
    +{-# LANGUAGE GHCForeignImportPrim #-}
    3 
    +{-# LANGUAGE MagicHash #-}
    4 
    +{-# LANGUAGE UnliftedFFITypes #-}
    5 
    +module Main where
    6 
    +
    7 
    +import GHC.Exts
    8 
    +import Data.Bits (shiftR, (.&.))
    9 
    +
    10 
    +foreign import prim "runMul2W32zh" runMul2W32# :: Word# -> Word#
    11 
    +foreign import prim "runMul2W16zh" runMul2W16# :: Word# -> Word#
    12 
    +foreign import prim "runMul2W8zh"  runMul2W8#  :: Word# -> Word#
    13 
    +foreign import prim "runMul2W16Overflowzh"
    14 
    +    runMul2W16Overflow# :: Word# -> Word# -> Word#
    15 
    +
    16 
    +mul2W32 :: Word -> Word
    17 
    +mul2W32 (W# x) = W# (runMul2W32# x)
    18 
    +
    19 
    +mul2W16 :: Word -> Word
    20 
    +mul2W16 (W# x) = W# (runMul2W16# x)
    21 
    +
    22 
    +mul2W8 :: Word -> Word
    23 
    +mul2W8 (W# x) = W# (runMul2W8# x)
    24 
    +
    25 
    +mul2W16Overflow :: Word -> Word -> (Word, Word)
    26 
    +mul2W16Overflow (W# x) (W# y) =
    27 
    +    let r = W# (runMul2W16Overflow# x y)
    28 
    +        needed = r `shiftR` 32
    29 
    +        lo = r .&. 0xFFFF
    30 
    +    in (needed, lo)
    31 
    +
    32 
    +main :: IO ()
    33 
    +main = do
    34 
    +    -- W32: 50000 has bit 15 set, bit 31 clear. The old SXTH bug would
    35 
    +    -- sign-extend from bit 15, corrupting the value before SMULL.
    36 
    +    putStrLn $ "W32 50000*2 = " ++ show (mul2W32 50000)
    37 
    +    putStrLn $ "W32 1*2 = " ++ show (mul2W32 1)
    38 
    +    putStrLn $ "W32 70000*2 = " ++ show (mul2W32 70000)
    39 
    +
    40 
    +    -- W16: exercises signExtendReg W16 W32 (SXTH before SMULL).
    41 
    +    putStrLn $ "W16 200*2 = " ++ show (mul2W16 200)
    42 
    +    putStrLn $ "W16 100*2 = " ++ show (mul2W16 100)
    43 
    +
    44 
    +    -- W8: exercises signExtendReg W8 W32 (SXTB before SMULL).
    45 
    +    putStrLn $ "W8 50*2 = " ++ show (mul2W8 50)
    46 
    +    putStrLn $ "W8 3*2 = " ++ show (mul2W8 3)
    47 
    +
    48 
    +    -- Overflow detection (CSET NE fix):
    49 
    +    -- 200 * 200 = 40000, overflows I16 [-32768, 32767]. needed=1.
    50 
    +    let (n1, lo1) = mul2W16Overflow 200 200
    51 
    +    putStrLn $ "W16 200*200: needed=" ++ show n1 ++ " lo=" ++ show lo1
    52 
    +    -- 100 * 2 = 200, fits in I16. needed=0.
    53 
    +    let (n2, lo2) = mul2W16Overflow 100 2
    54 
    +    putStrLn $ "W16 100*2: needed=" ++ show n2 ++ " lo=" ++ show lo2
    55 
    +    -- 181 * 181 = 32761, just under 32767. needed=0.
    56 
    +    let (n3, lo3) = mul2W16Overflow 181 181
    57 
    +    putStrLn $ "W16 181*181: needed=" ++ show n3 ++ " lo=" ++ show lo3
    58 
    +    -- 182 * 182 = 33124, just over 32767. needed=1.
    59 
    +    let (n4, lo4) = mul2W16Overflow 182 182
    60 
    +    putStrLn $ "W16 182*182: needed=" ++ show n4 ++ " lo=" ++ show lo4

  • testsuite/tests/codeGen/should_run/aarch64-sxtw-run.stdout
    1 
    +W32 50000*2 = 100000
    2 
    +W32 1*2 = 2
    3 
    +W32 70000*2 = 140000
    4 
    +W16 200*2 = 400
    5 
    +W16 100*2 = 200
    6 
    +W8 50*2 = 100
    7 
    +W8 3*2 = 6
    8 
    +W16 200*200: needed=1 lo=40000
    9 
    +W16 100*2: needed=0 lo=200
    10 
    +W16 181*181: needed=0 lo=32761
    11 
    +W16 182*182: needed=1 lo=33124

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -289,3 +289,9 @@ test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)],
    289 289 
     # AArch64-specific runtime tests
    290 290 
     test('aarch64-ushr-subword-run', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])
    291 291 
     test('aarch64-subword-ops', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])
    292 
    +test('aarch64-sxtw-run',
    293 
    +     [ extra_files(['aarch64-sxtw-cmm.cmm']),
    294 
    +       unless(arch('aarch64'), skip),
    295 
    +       when(unregisterised(), skip)],
    296 
    +     multi_compile_and_run,
    297 
    +     ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help