Marge Bot pushed to branch master 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
    ... ... @@ -661,6 +661,15 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
    661 661 
     -- sub-word-size value always contains the zero-extended form of that value
    662 662 
     -- in between operations.
    663 663 
     --
    664 
    +-- IMPORTANT: this invariant only holds within a single expression tree as
    665 
    +-- generated by the NCG (via truncateReg after each sub-word operation). It
    666 
    +-- does NOT hold at function entry points or across basic block boundaries,
    667 
    +-- because the GHC calling convention does not guarantee that callers
    668 
    +-- zero-extend sub-word arguments. Therefore, any operation that is sensitive
    669 
    +-- to the upper bits of its input (e.g. unsigned right shift, unsigned
    670 
    +-- division) must explicitly zero- or sign-extend its operands rather than
    671 
    +-- assuming they are already extended.
    672 
    +--
    664 673 
     -- For instance, consider the program,
    665 674 
     --
    666 675 
     --    test(bits64 buffer)
    ... ... @@ -679,7 +688,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
    679 688 
     -- Next we compute `c`: The `%not` requires no extension of its operands, but
    680 689 
     -- we must still truncate the result back down to 8-bits. Finally the `%shrl`
    681 690 
     -- requires no extension and no truncate since we can assume that
    682 
    --- `c` is zero-extended.
    691 
    +-- `c` is zero-extended (it was produced by a truncateReg in the same block).
    683 692 
     --
    684 693 
     -- TODO:
    685 694 
     --   Don't use Width in Operands
    ... ... @@ -1084,17 +1093,30 @@ getRegister' config plat expr
    1084 1093 
         CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do
    1085 1094 
           (reg_x, _format_x, code_x) <- getSomeReg x
    1086 1095 
           (reg_y, _format_y, code_y) <- getSomeReg y
    1087 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    1088 
    -                                                                        (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL`
    1089 
    -                                                                        (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    1096 
    +      tmp_x <- getNewRegNat (intFormat w)
    1097 
    +      tmp_y <- getNewRegNat (intFormat w)
    1098 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w tmp_x) (OpReg w reg_x)) `snocOL`
    1099 
    +                                                                        (UXTB (OpReg w tmp_y) (OpReg w reg_y)) `snocOL`
    1100 
    +                                                                        (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y)))
    1090 1101 
         CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do
    1091 1102 
           (reg_x, _format_x, code_x) <- getSomeReg x
    1092 1103 
           (reg_y, _format_y, code_y) <- getSomeReg y
    1093 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    1094 
    -                                                                        (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL`
    1095 
    -                                                                        (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    1104 
    +      tmp_x <- getNewRegNat (intFormat w)
    1105 
    +      tmp_y <- getNewRegNat (intFormat w)
    1106 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w tmp_x) (OpReg w reg_x)) `snocOL`
    1107 
    +                                                                        (UXTH (OpReg w tmp_y) (OpReg w reg_y)) `snocOL`
    1108 
    +                                                                        (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y)))
    1096 1109
    1097 1110 
         -- 2. Shifts. x << n, x >> n.
    1111 
    +    -- Sub-word left shifts by a constant: use UBFM (UBFIZ alias) to shift
    1112 
    +    -- and mask in a single instruction.  See Note [Signed arithmetic on AArch64].
    1113 
    +    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do
    1114 
    +      (reg_x, _format_x, code_x) <- getSomeReg x
    1115 
    +      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)))))
    1116 
    +    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
    1117 
    +      (reg_x, _format_x, code_x) <- getSomeReg x
    1118 
    +      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)))))
    1119 
    +
    1098 1120 
         CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))]
    1099 1121 
           | w == W32 || w == W64
    1100 1122 
           , 0 <= n, n < fromIntegral (widthInBits w) -> do
    ... ... @@ -1108,8 +1130,11 @@ getRegister' config plat expr
    1108 1130 
         CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do
    1109 1131 
           (reg_x, _format_x, code_x) <- getSomeReg x
    1110 1132 
           (reg_y, _format_y, code_y) <- getSomeReg y
    1111 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    1112 
    -                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`
    1133 
    +      -- Use a temporary register to avoid sign-extending reg_x in-place,
    1134 
    +      -- as other operations may use reg_x.
    1135 
    +      tmp <- getNewRegNat (intFormat w)
    1136 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w tmp) (OpReg w reg_x)) `snocOL`
    1137 
    +                                                                         (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL`
    1113 1138 
                                                                              (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
    1114 1139
    1115 1140 
         CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
    ... ... @@ -1119,8 +1144,11 @@ getRegister' config plat expr
    1119 1144 
         CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do
    1120 1145 
           (reg_x, _format_x, code_x) <- getSomeReg x
    1121 1146 
           (reg_y, _format_y, code_y) <- getSomeReg y
    1122 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    1123 
    -                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`
    1147 
    +      -- Use a temporary register to avoid sign-extending reg_x in-place,
    1148 
    +      -- as other operations may use reg_x.
    1149 
    +      tmp <- getNewRegNat (intFormat w)
    1150 
    +      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w tmp) (OpReg w reg_x)) `snocOL`
    1151 
    +                                                                         (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL`
    1124 1152 
                                                                              (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]
    1125 1153
    1126 1154 
         CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]
    ... ... @@ -1135,8 +1163,8 @@ getRegister' config plat expr
    1135 1163 
         CmmMachOp (MO_U_Shr w) [x, y] | w == W8 -> do
    1136 1164 
           (reg_x, _format_x, code_x) <- getSomeReg x
    1137 1165 
           (reg_y, _format_y, code_y) <- getSomeReg y
    1138 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`
    1139 
    -                                                                        (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    1166 
    +      tmp <- getNewRegNat (intFormat w)
    1167 
    +      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)))
    1140 1168
    1141 1169 
         CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
    1142 1170 
           (reg_x, _format_x, code_x) <- getSomeReg x
    ... ... @@ -1144,8 +1172,8 @@ getRegister' config plat expr
    1144 1172 
         CmmMachOp (MO_U_Shr w) [x, y] | w == W16 -> do
    1145 1173 
           (reg_x, _format_x, code_x) <- getSomeReg x
    1146 1174 
           (reg_y, _format_y, code_y) <- getSomeReg y
    1147 
    -      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x))
    1148 
    -                                                                `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
    1175 
    +      tmp <- getNewRegNat (intFormat w)
    1176 
    +      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)))
    1149 1177
    1150 1178 
         CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))]
    1151 1179 
           | 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
    ... ... @@ -23,3 +23,11 @@ test('avx512-int64-minmax', [unless(arch('x86_64'), skip),
    23 23 
                                  when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512vl'])
    24 24 
     test('avx512-word64-minmax', [unless(arch('x86_64'), skip),
    25 25 
                                   when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512vl'])
    26 
    +is_aarch64_codegen = [
    27 
    +    unless(arch('aarch64'), skip),
    28 
    +    when(unregisterised(), skip),
    29 
    +]
    30 
    +
    31 
    +# AArch64-specific tests
    32 
    +test('aarch64-ushr-subword', is_aarch64_codegen, compile_grep_asm, ['hs', True, '-O'])
    33 
    +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
    ... ... @@ -279,3 +279,6 @@ test('T27072d', [req_c, only_ways(['dyn']), when(not opsys('darwin'), skip),
    279 279 
     # Skipped on Darwin (Apple linker doesn't support --wrap).
    280 280 
     test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)],
    281 281 
          compile_and_run, ['T27072w_c.c -no-hs-main -optl-Wl,--wrap=hs_spt_remove'])
    282 
    +# AArch64-specific runtime tests
    283 
    +test('aarch64-ushr-subword-run', [unless(arch('aarch64'), skip)], compile_and_run, ['-O'])
    284 
    +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