Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC

Commits:

12 changed files:

Changes:

  • changelog.d/T26979
    1 
    +section: compiler
    2 
    +issues: #26979
    3 
    +mrs: !15620
    4 
    +synopsis:
    5 
    +  On AArch64, use an arithmetic instead of a logical right shift when
    6 
    +  sign extending at 8/16 bit word size.
    7 
    +description:
    8 
    +  The unsigned right shift ``MO_U_Shr`` for sub-word widths (``W8``, ``W16``)
    9 
    +  with a variable shift amount now correctly emits ``LSR`` instead of ``ASR``.
    10 
    +  ``ASR`` was semantically wrong, and would break if the zero-extension were
    11 
    +  ever optimized away.

  • compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
    ... ... @@ -525,6 +525,15 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
    525 525 
     -- sub-word-size value always contains the zero-extended form of that value
    526 526 
     -- in between operations.
    527 527 
     --
    528 
    +-- IMPORTANT: this invariant only holds within a single expression tree as
    529 
    +-- generated by the NCG (via truncateReg after each sub-word operation). It
    530 
    +-- does NOT hold at function entry points or across basic block boundaries,
    531 
    +-- because the GHC calling convention does not guarantee that callers
    532 
    +-- zero-extend sub-word arguments. Therefore, any operation that is sensitive
    533 
    +-- to the upper bits of its input (e.g. unsigned right shift, unsigned
    534 
    +-- division) must explicitly zero- or sign-extend its operands rather than
    535 
    +-- assuming they are already extended.
    536 
    +--
    528 537 
     -- For instance, consider the program,
    529 538 
     --
    530 539 
     --    test(bits64 buffer)
    ... ... @@ -543,7 +552,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
    543 552 
     -- Next we compute `c`: The `%not` requires no extension of its operands, but
    544 553 
     -- we must still truncate the result back down to 8-bits. Finally the `%shrl`
    545 554 
     -- requires no extension and no truncate since we can assume that
    546 
    --- `c` is zero-extended.
    555 
    +-- `c` is zero-extended (it was produced by a truncateReg in the same block).
    547 556 
     --
    548 557 
     -- TODO:
    549 558 
     --   Don't use Width in Operands
    ... ... @@ -877,17 +886,30 @@ getRegister' config plat expr
    877 886 
         CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do
    878 887 
           (reg_x, _format_x, code_x) <- getSomeReg x
    879 888 
           (reg_y, _format_y, code_y) <- getSomeReg y
    880 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    881 
    -                                                                        (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL`
    882 
    -                                                                        (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    889 
    +      tmp_x <- getNewRegNat (intFormat w)
    890 
    +      tmp_y <- getNewRegNat (intFormat w)
    891 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w tmp_x) (OpReg w reg_x)) `snocOL`
    892 
    +                                                                        (UXTB (OpReg w tmp_y) (OpReg w reg_y)) `snocOL`
    893 
    +                                                                        (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y)))
    883 894 
         CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do
    884 895 
           (reg_x, _format_x, code_x) <- getSomeReg x
    885 896 
           (reg_y, _format_y, code_y) <- getSomeReg y
    886 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    887 
    -                                                                        (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL`
    888 
    -                                                                        (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    897 
    +      tmp_x <- getNewRegNat (intFormat w)
    898 
    +      tmp_y <- getNewRegNat (intFormat w)
    899 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w tmp_x) (OpReg w reg_x)) `snocOL`
    900 
    +                                                                        (UXTH (OpReg w tmp_y) (OpReg w reg_y)) `snocOL`
    901 
    +                                                                        (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y)))
    889 902
    890 903 
         -- 2. Shifts. x << n, x >> n.
    904 
    +    -- Sub-word left shifts by a constant: use UBFM (UBFIZ alias) to shift
    905 
    +    -- and mask in a single instruction.  See Note [Signed arithmetic on AArch64].
    906 
    +    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do
    907 
    +      (reg_x, _format_x, code_x) <- getSomeReg x
    908 
    +      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFM (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger ((32 - n) `mod` 32))) (OpImm (ImmInteger (7 - n)))))
    909 
    +    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
    910 
    +      (reg_x, _format_x, code_x) <- getSomeReg x
    911 
    +      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFM (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger ((32 - n) `mod` 32))) (OpImm (ImmInteger (15 - n)))))
    912 
    +
    891 913 
         CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))]
    892 914 
           | w == W32 || w == W64
    893 915 
           , 0 <= n, n < fromIntegral (widthInBits w) -> do
    ... ... @@ -901,8 +923,11 @@ getRegister' config plat expr
    901 923 
         CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do
    902 924 
           (reg_x, _format_x, code_x) <- getSomeReg x
    903 925 
           (reg_y, _format_y, code_y) <- getSomeReg y
    904 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    905 
    -                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`
    926 
    +      -- Use a temporary register to avoid sign-extending reg_x in-place,
    927 
    +      -- as other operations may use reg_x.
    928 
    +      tmp <- getNewRegNat (intFormat w)
    929 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w tmp) (OpReg w reg_x)) `snocOL`
    930 
    +                                                                         (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL`
    906 931 
                                                                              (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
    907 932
    908 933 
         CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
    ... ... @@ -912,8 +937,11 @@ getRegister' config plat expr
    912 937 
         CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do
    913 938 
           (reg_x, _format_x, code_x) <- getSomeReg x
    914 939 
           (reg_y, _format_y, code_y) <- getSomeReg y
    915 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    916 
    -                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`
    940 
    +      -- Use a temporary register to avoid sign-extending reg_x in-place,
    941 
    +      -- as other operations may use reg_x.
    942 
    +      tmp <- getNewRegNat (intFormat w)
    943 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w tmp) (OpReg w reg_x)) `snocOL`
    944 
    +                                                                         (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL`
    917 945 
                                                                              (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
    918 946
    919 947 
         CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]
    ... ... @@ -928,8 +956,8 @@ getRegister' config plat expr
    928 956 
         CmmMachOp (MO_U_Shr w) [x, y] | w == W8 -> do
    929 957 
           (reg_x, _format_x, code_x) <- getSomeReg x
    930 958 
           (reg_y, _format_y, code_y) <- getSomeReg y
    931 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    932 
    -                                                                        (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    959 
    +      tmp <- getNewRegNat (intFormat w)
    960 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` UXTB (OpReg w tmp) (OpReg w reg_x) `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)))
    933 961
    934 962 
         CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
    935 963 
           (reg_x, _format_x, code_x) <- getSomeReg x
    ... ... @@ -937,8 +965,8 @@ getRegister' config plat expr
    937 965 
         CmmMachOp (MO_U_Shr w) [x, y] | w == W16 -> do
    938 966 
           (reg_x, _format_x, code_x) <- getSomeReg x
    939 967 
           (reg_y, _format_y, code_y) <- getSomeReg y
    940 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x))
    941 
    -                                                                `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    968 
    +      tmp <- getNewRegNat (intFormat w)
    969 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` UXTH (OpReg w tmp) (OpReg w reg_x) `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)))
    942 970
    943 971 
         CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))]
    944 972 
           | w == W32 || w == W64

  • testsuite/tests/codeGen/should_gen_asm/aarch64-shl-subword.asm
    1 
    +ubfm

  • testsuite/tests/codeGen/should_gen_asm/aarch64-shl-subword.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +module ShlSubWord (shlW8) where
    3 
    +
    4 
    +import GHC.Exts
    5 
    +import GHC.Word
    6 
    +
    7 
    +shlW8 :: Word8 -> Word8
    8 
    +shlW8 (W8# w) = W8# (uncheckedShiftLWord8# w 4#)

  • testsuite/tests/codeGen/should_gen_asm/aarch64-ushr-subword.asm
    1 
    +lsr

  • testsuite/tests/codeGen/should_gen_asm/aarch64-ushr-subword.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +module UShrSubWord (ushrW8) where
    3 
    +
    4 
    +import GHC.Exts
    5 
    +import GHC.Word
    6 
    +
    7 
    +ushrW8 :: Word8 -> Int -> Word8
    8 
    +ushrW8 x n = x `shiftR` n
    9 
    +  where shiftR (W8# w) (I# i) = W8# (wordToWord8# (word8ToWord# w `uncheckedShiftRL#` i))

  • testsuite/tests/codeGen/should_gen_asm/all.T
    ... ... @@ -12,3 +12,11 @@ test('bytearray-memcpy-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True,
    12 12 
     test('T18137', [when(opsys('darwin'), skip), only_ways(llvm_ways)], compile_grep_asm, ['hs', False, '-fllvm -split-sections'])
    13 13
    14 14 
     test('T24941', [only_ways(['optasm'])], compile, ['-fregs-graph'])
    15 
    +is_aarch64_codegen = [
    16 
    +    unless(arch('aarch64'), skip),
    17 
    +    when(unregisterised(), skip),
    18 
    +]
    19 
    +
    20 
    +# AArch64-specific tests
    21 
    +test('aarch64-ushr-subword', is_aarch64_codegen, compile_grep_asm, ['hs', True, '-O'])
    22 
    +test('aarch64-shl-subword', is_aarch64_codegen, compile_grep_asm, ['hs', True, '-O'])

  • testsuite/tests/codeGen/should_run/aarch64-subword-ops.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +module Main where
    3 
    +
    4 
    +import GHC.Exts
    5 
    +import GHC.Word
    6 
    +import GHC.Int
    7 
    +
    8 
    +-- Uses sub-word primops directly so that the NCG sees MO_Shl W8,
    9 
    +-- MO_U_Shr W8, MO_S_Shr W8 etc. (the Bits class widens to Word#/Int#).
    10 
    +
    11 
    +-- NOINLINE to prevent constant folding.
    12 
    +
    13 
    +-- MO_U_Shr W8/W16 variable shift
    14 
    +{-# NOINLINE ushrW8 #-}
    15 
    +ushrW8 :: Word8 -> Int -> Word8
    16 
    +ushrW8 (W8# w) (I# i) = W8# (uncheckedShiftRLWord8# w i)
    17 
    +
    18 
    +{-# NOINLINE ushrW16 #-}
    19 
    +ushrW16 :: Word16 -> Int -> Word16
    20 
    +ushrW16 (W16# w) (I# i) = W16# (uncheckedShiftRLWord16# w i)
    21 
    +
    22 
    +-- MO_S_Shr W8/W16 variable shift
    23 
    +{-# NOINLINE sshrI8 #-}
    24 
    +sshrI8 :: Int8 -> Int -> Int8
    25 
    +sshrI8 (I8# x) (I# i) = I8# (uncheckedShiftRAInt8# x i)
    26 
    +
    27 
    +{-# NOINLINE sshrI16 #-}
    28 
    +sshrI16 :: Int16 -> Int -> Int16
    29 
    +sshrI16 (I16# x) (I# i) = I16# (uncheckedShiftRAInt16# x i)
    30 
    +
    31 
    +-- MO_Shl W8/W16 variable shift
    32 
    +{-# NOINLINE shlW8 #-}
    33 
    +shlW8 :: Word8 -> Int -> Word8
    34 
    +shlW8 (W8# w) (I# i) = W8# (uncheckedShiftLWord8# w i)
    35 
    +
    36 
    +{-# NOINLINE shlW16 #-}
    37 
    +shlW16 :: Word16 -> Int -> Word16
    38 
    +shlW16 (W16# w) (I# i) = W16# (uncheckedShiftLWord16# w i)
    39 
    +
    40 
    +-- quot exercising MO_U_Quot W8/W16
    41 
    +{-# NOINLINE quotW8 #-}
    42 
    +quotW8 :: Word8 -> Word8 -> Word8
    43 
    +quotW8 (W8# x) (W8# y) = W8# (quotWord8# x y)
    44 
    +
    45 
    +{-# NOINLINE quotW16 #-}
    46 
    +quotW16 :: Word16 -> Word16 -> Word16
    47 
    +quotW16 (W16# x) (W16# y) = W16# (quotWord16# x y)
    48 
    +
    49 
    +-- Register clobbering: use a value both in a shift/quot and afterward.
    50 
    +-- If the sign/zero extension clobbers the source register, the second
    51 
    +-- use sees the wrong value.
    52 
    +
    53 
    +{-# NOINLINE sshrAndAdd8 #-}
    54 
    +sshrAndAdd8 :: Int8 -> Int -> Int8
    55 
    +sshrAndAdd8 a n = sshrI8 a n + a
    56 
    +
    57 
    +{-# NOINLINE sshrAndAdd16 #-}
    58 
    +sshrAndAdd16 :: Int16 -> Int -> Int16
    59 
    +sshrAndAdd16 a n = sshrI16 a n + a
    60 
    +
    61 
    +{-# NOINLINE quotAndAdd8 #-}
    62 
    +quotAndAdd8 :: Word8 -> Word8 -> Word8
    63 
    +quotAndAdd8 a b = quotW8 a b + a + b
    64 
    +
    65 
    +{-# NOINLINE quotAndAdd16 #-}
    66 
    +quotAndAdd16 :: Word16 -> Word16 -> Word16
    67 
    +quotAndAdd16 a b = quotW16 a b + a + b
    68 
    +
    69 
    +main :: IO ()
    70 
    +main = do
    71 
    +    putStrLn "-- MO_U_Shr variable shift"
    72 
    +    print (ushrW8 0x80 1)     -- 64
    73 
    +    print (ushrW8 0xFF 4)     -- 15
    74 
    +    print (ushrW8 0x42 0)     -- 66
    75 
    +    print (ushrW16 0x8000 1)  -- 16384
    76 
    +    print (ushrW16 0xFFFF 8)  -- 255
    77 
    +    print (ushrW16 0x1234 0)  -- 4660
    78 
    +
    79 
    +    putStrLn "-- MO_S_Shr variable shift"
    80 
    +    print (sshrI8 (-1) 1)      -- -1
    81 
    +    print (sshrI8 (-128) 1)    -- -64
    82 
    +    print (sshrI8 127 1)       -- 63
    83 
    +    print (sshrI8 0x42 3)      -- 8
    84 
    +    print (sshrI16 (-1) 1)     -- -1
    85 
    +    print (sshrI16 (-32768) 1) -- -16384
    86 
    +    print (sshrI16 32767 8)    -- 127
    87 
    +
    88 
    +    putStrLn "-- MO_Shl variable shift"
    89 
    +    print (shlW8 0x01 0)    -- 1
    90 
    +    print (shlW8 0x01 4)    -- 16
    91 
    +    print (shlW8 0xFF 1)    -- 254
    92 
    +    print (shlW8 0x42 3)    -- 16
    93 
    +    print (shlW16 0x0001 0) -- 1
    94 
    +    print (shlW16 0x0001 8) -- 256
    95 
    +    print (shlW16 0xFFFF 1) -- 65534
    96 
    +    print (shlW16 0x1234 4) -- 9024
    97 
    +
    98 
    +    putStrLn "-- MO_U_Quot"
    99 
    +    print (quotW8 255 10)      -- 25
    100 
    +    print (quotW8 200 7)       -- 28
    101 
    +    print (quotW8 1 1)         -- 1
    102 
    +    print (quotW16 65535 256)  -- 255
    103 
    +    print (quotW16 1000 3)     -- 333
    104 
    +
    105 
    +    putStrLn "-- register clobbering: shift + reuse"
    106 
    +    print (sshrAndAdd8 (-128) 1)    -- 64  (wraps: -64 + -128 = -192 = 64 as Int8)
    107 
    +    print (sshrAndAdd8 0x42 1)      -- 99
    108 
    +    print (sshrAndAdd16 (-32768) 1) -- 16384  (wraps)
    109 
    +    print (sshrAndAdd16 0x1234 4)   -- 4951
    110 
    +
    111 
    +    putStrLn "-- register clobbering: quot + reuse"
    112 
    +    print (quotAndAdd8 200 7)      -- 235
    113 
    +    print (quotAndAdd8 255 10)     -- 34  (wraps: 290 mod 256)
    114 
    +    print (quotAndAdd16 1000 3)    -- 1336
    115 
    +    print (quotAndAdd16 65535 256) -- 510  (wraps: 66046 mod 65536)

  • testsuite/tests/codeGen/should_run/aarch64-subword-ops.stdout
    1 
    +-- MO_U_Shr variable shift
    2 
    +64
    3 
    +15
    4 
    +66
    5 
    +16384
    6 
    +255
    7 
    +4660
    8 
    +-- MO_S_Shr variable shift
    9 
    +-1
    10 
    +-64
    11 
    +63
    12 
    +8
    13 
    +-1
    14 
    +-16384
    15 
    +127
    16 
    +-- MO_Shl variable shift
    17 
    +1
    18 
    +16
    19 
    +254
    20 
    +16
    21 
    +1
    22 
    +256
    23 
    +65534
    24 
    +9024
    25 
    +-- MO_U_Quot
    26 
    +25
    27 
    +28
    28 
    +1
    29 
    +255
    30 
    +333
    31 
    +-- register clobbering: shift + reuse
    32 
    +64
    33 
    +99
    34 
    +16384
    35 
    +4951
    36 
    +-- register clobbering: quot + reuse
    37 
    +235
    38 
    +34
    39 
    +1336
    40 
    +510

  • testsuite/tests/codeGen/should_run/aarch64-ushr-subword-run.hs
    1 
    +import Data.Bits (shiftR)
    2 
    +import Data.Word (Word8, Word16)
    3 
    +
    4 
    +main :: IO ()
    5 
    +main = do
    6 
    +    print (shiftR (0x80 :: Word8) 1)
    7 
    +    print (shiftR (0xFF :: Word8) 4)
    8 
    +    print (shiftR (0x8000 :: Word16) 1)
    9 
    +    print (shiftR (0xFFFF :: Word16) 8)

  • testsuite/tests/codeGen/should_run/aarch64-ushr-subword-run.stdout
    1 
    +64
    2 
    +15
    3 
    +16384
    4 
    +255

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -275,3 +275,6 @@ test('T27072d', [req_c, only_ways(['dyn']), when(not opsys('darwin'), skip),
    275 275 
     # Skipped on Darwin (Apple linker doesn't support --wrap).
    276 276 
     test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)],
    277 277 
          compile_and_run, ['T27072w_c.c -no-hs-main -optl-Wl,--wrap=hs_spt_remove'])
    278 
    +# AArch64-specific runtime tests
    279 
    +test('aarch64-ushr-subword-run', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])
    280 
    +test('aarch64-subword-ops', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])

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