Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
    ... ... @@ -662,7 +662,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
    662 662 
     -- in between operations.
    663 663 
     --
    664 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
    665 
    +-- generated by the NCG (via truncateRegInplace after each sub-word operation). It
    666 666 
     -- does NOT hold at function entry points or across basic block boundaries,
    667 667 
     -- because the GHC calling convention does not guarantee that callers
    668 668 
     -- zero-extend sub-word arguments. Therefore, any operation that is sensitive
    ... ... @@ -688,7 +688,7 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
    688 688 
     -- Next we compute `c`: The `%not` requires no extension of its operands, but
    689 689 
     -- we must still truncate the result back down to 8-bits. Finally the `%shrl`
    690 690 
     -- requires no extension and no truncate since we can assume that
    691 
    --- `c` is zero-extended (it was produced by a truncateReg in the same block).
    691 
    +-- `c` is zero-extended (it was produced by a truncateRegInplace in the same block).
    692 692 
     --
    693 693 
     -- TODO:
    694 694 
     --   Don't use Width in Operands
    ... ... @@ -931,7 +931,7 @@ getRegister' config plat expr
    931 931 
                 let w' = opRegWidth w
    932 932 
                  in code `snocOL`
    933 933 
                     MVN (OpReg w' dst) (OpReg w' reg) `appOL`
    934 
    -                truncateReg w' w dst -- See Note [Signed arithmetic on AArch64]
    934 
    +                truncateRegInplace w' w dst -- See Note [Signed arithmetic on AArch64]
    935 935
    936 936 
             MO_S_Neg w -> negate code w reg
    937 937 
             MO_F_Neg w -> return $ Any fmt (\dst -> code `snocOL` NEG fmt (OpReg w dst) (OpReg w reg))
    ... ... @@ -1064,7 +1064,7 @@ getRegister' config plat expr
    1064 1064 
                     code `appOL`
    1065 1065 
                     code_sx `snocOL`
    1066 1066 
                     NEG fmt (OpReg w' dst) (OpReg w' reg') `appOL`
    1067 
    -                truncateReg w' w dst
    1067 
    +                truncateRegInplace w' w dst
    1068 1068
    1069 1069 
             ss_conv from to reg code =
    1070 1070 
                 let w' = opRegWidth (max from to)
    ... ... @@ -1073,7 +1073,7 @@ getRegister' config plat expr
    1073 1073 
                     SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`
    1074 1074 
                     -- At this point an 8- or 16-bit value would be sign-extended
    1075 1075 
                     -- to 32-bits. Truncate back down the final width.
    1076 
    -                truncateReg w' to dst
    1076 
    +                truncateRegInplace w' to dst
    1077 1077
    1078 1078 
         -- Dyadic machops:
    1079 1079 
         --
    ... ... @@ -1220,7 +1220,7 @@ getRegister' config plat expr
    1220 1220 
                     code_y `appOL`
    1221 1221 
                     op (OpReg w dst) (OpReg w reg_x) op_y)
    1222 1222
    1223 
    -          -- A (potentially signed) integer operation.
    1223 
    +          -- A (potentially signed) integer operation that can have immediate arguments.
    1224 1224 
               -- In the case of 8- and 16-bit signed arithmetic we must first
    1225 1225 
               -- sign-extend both arguments to 32-bits.
    1226 1226 
               -- See Note [Signed arithmetic on AArch64].
    ... ... @@ -1230,6 +1230,7 @@ getRegister' config plat expr
    1230 1230 
                   -- compute x<m> <- x
    1231 1231 
                   -- compute x<o> <- y
    1232 1232 
                   -- <OP> x<n>, x<m>, x<o>
    1233 
    +              let w' = opRegWidth w
    1233 1234 
                   (reg_x, format_x, code_x) <- getSomeReg x
    1234 1235 
                   (op_y, format_y, code_y) <- case y of
    1235 1236 
                     CmmLit (CmmInt n w)
    ... ... @@ -1241,12 +1242,11 @@ getRegister' config plat expr
    1241 1242 
                   massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"
    1242 1243 
                   -- This is the width of the registers on which the operation
    1243 1244 
                   -- should be performed.
    1244 
    -              let w' = opRegWidth w
    1245 1245 
                   return $ Any (intFormat w) $ \dst ->
    1246 1246 
                       code_x `appOL`
    1247 1247 
                       code_y `appOL`
    1248 1248 
                       op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL`
    1249 
    -                  truncateReg w' w dst -- truncate back to the operand's original width
    1249 
    +                  truncateRegInplace w' w dst -- truncate back to the operand's original width
    1250 1250
    1251 1251 
               -- A (potentially signed) integer operation.
    1252 1252 
               -- In the case of 8- and 16-bit signed arithmetic we must first
    ... ... @@ -1263,7 +1263,8 @@ getRegister' config plat expr
    1263 1263 
                   -- should be performed.
    1264 1264 
                   let w' = opRegWidth w
    1265 1265 
                       signExt r
    1266 
    -                    | not is_signed  = return (r, nilOL)
    1266 
    +                    -- See Note [Signed arithmetic on AArch64] and #27430
    1267 
    +                    | not is_signed  = truncateReg w w' r
    1267 1268 
                         | otherwise      = signExtendReg w w' r
    1268 1269 
                   (reg_x_sx, code_x_sx) <- signExt reg_x
    1269 1270 
                   (reg_y_sx, code_y_sx) <- signExt reg_y
    ... ... @@ -1274,7 +1275,7 @@ getRegister' config plat expr
    1274 1275 
                       code_x_sx `appOL`
    1275 1276 
                       code_y_sx `appOL`
    1276 1277 
                       op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL`
    1277 
    -                  truncateReg w' w dst -- truncate back to the operand's original width
    1278 
    +                  truncateRegInplace w' w dst -- truncate back to the operand's original width
    1278 1279
    1279 1280 
               floatOp w op = do
    1280 1281 
                 (reg_fx, format_x, code_fx) <- getFloatReg x
    ... ... @@ -1904,10 +1905,28 @@ signExtendReg w w' r =
    1904 1905 
             r' <- getNewRegNat (intFormat w')
    1905 1906 
             return (r', unitOL $ instr (OpReg w' r') (OpReg w r))
    1906 1907
    1907 
    --- | Instructions to truncate the value in the given register from width @w@
    1908 
    +-- | Instructions to truncate (zero extend) the value in the given register from width @w@
    1909 
    +-- down to width @w'@ into a new register. Or return the original register if it's a noop.
    1910 
    +truncateReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
    1911 
    +truncateReg w w' r = do
    1912 
    +    case w' of
    1913 
    +      W64 -> noop
    1914 
    +      W32
    1915 
    +        | w' == W32 -> noop
    1916 
    +        | otherwise -> trunc MOV
    1917 
    +      W16           -> trunc UXTH
    1918 
    +      W8            -> trunc UXTB
    1919 
    +      _             -> panic "intOp"
    1920 
    +  where
    1921 
    +    noop = return (r, nilOL)
    1922 
    +    trunc instr = do
    1923 
    +        r' <- getNewRegNat (intFormat w')
    1924 
    +        return (r', unitOL $ instr (OpReg w' r') (OpReg w r))
    1925 
    +
    1926 
    +-- | Instructions to truncate (zero extend) the value in the given register from width @w@
    1908 1927 
     -- down to width @w'@.
    1909 
    -truncateReg :: Width -> Width -> Reg -> OrdList Instr
    1910 
    -truncateReg w w' r =
    1928 
    +truncateRegInplace :: Width -> Width -> Reg -> OrdList Instr
    1929 
    +truncateRegInplace w w' r =
    1911 1930 
         case w of
    1912 1931 
           W64 -> nilOL
    1913 1932 
           W32
    ... ... @@ -2352,7 +2371,7 @@ genCCall target dest_regs arg_regs = do
    2352 2371 
                       -- product, and hi gets the overflow (sign extension bits).
    2353 2372 
                       SMULL (OpReg w' lo) (OpReg W32 reg_a) (OpReg W32 reg_b) `snocOL`
    2354 2373 
                       ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL`
    2355 
    -                  truncateReg w' w lo `snocOL`
    2374 
    +                  truncateRegInplace w' w lo `snocOL`
    2356 2375 
                       -- CMN (compare negative) tests hi + lo' == 0, i.e. hi == -lo'.
    2357 2376 
                       -- lo' = LSR(lo, w-1) gives 1 if lo is negative, 0 if positive.
    2358 2377 
                       -- No overflow iff hi is the sign extension of lo:
    ... ... @@ -2362,7 +2381,7 @@ genCCall target dest_regs arg_regs = do
    2362 2381 
                       -- NE to set nd = 1 when overflow occurred.
    2363 2382 
                       CMN   (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL`
    2364 2383 
                       CSET  (OpReg w' nd) NE `appOL`
    2365 
    -                  truncateReg w' w hi
    2384 
    +                  truncateRegInplace w' w hi
    2366 2385 
               -- Can't handle > 64 bit operands
    2367 2386 
               | otherwise -> unsupported (MO_S_Mul2 w)
    2368 2387 
         PrimTarget (MO_U_Mul2  w)
    ... ... @@ -2412,7 +2431,7 @@ genCCall target dest_regs arg_regs = do
    2412 2431 
                           (OpImm (ImmInt $ widthInBits w)) -- lsb
    2413 2432 
                           (OpImm (ImmInt $ widthInBits w)) -- width to extract
    2414 2433 
                           `appOL`
    2415 
    -                  truncateReg W64 w lo
    2434 
    +                  truncateRegInplace W64 w lo
    2416 2435 
                       )
    2417 2436 
               | otherwise -> unsupported (MO_U_Mul2  w)
    2418 2437 
         PrimTarget (MO_Clz  w)
    ... ... @@ -2916,7 +2935,14 @@ genCCall target dest_regs arg_regs = do
    2916 2935 
               r_dst = getRegisterReg platform (CmmLocal dst)
    2917 2936 
           if isFloatFormat format || isVecFormat format
    2918 2937 
             then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))
    2919 
    -        else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg))
    2938 
    +        else do
    2939 
    +          -- See [Signed arithmetic on AArch64]
    2940 
    +          -- Strictly speaking we don't have to here but err on the side of caution.
    2941 
    +          let !mov_instr = case w of
    2942 
    +                W8  -> UXTB
    2943 
    +                W16 -> UXTH
    2944 
    +                _   -> MOV
    2945 
    +          readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` mov_instr (OpReg w r_dst) (OpReg w gpReg))
    2920 2946
    2921 2947 
         unaryFloatOp w op arg_reg dest_reg = do
    2922 2948 
           platform <- getPlatform

  • testsuite/tests/codeGen/should_run/T27430.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +{-# OPTIONS_GHC -dno-typeable-binds -ddump-to-file -dsuppress-ticks -dsuppress-timestamps -ddump-stg-from-core -ddump-stg-final -ddump-cmm -ddump-cmm-raw -ddump-asm #-}
    3 
    +
    4 
    +import GHC.Exts
    5 
    +import Data.Bits
    6 
    +import GHC.Word
    7 
    +
    8 
    +foreign import ccall unsafe "u64_to_u8" u64_to_u8 :: Word64 -> Word8
    9 
    +foreign import ccall unsafe "u64_to_u16" u64_to_u16 :: Word64 -> Word16
    10 
    +foreign import ccall unsafe "u64_to_u32" u64_to_u32 :: Word64 -> Word32
    11 
    +
    12 
    +x :: Word64
    13 
    +x = 5
    14 
    +
    15 
    +-- Those should give just x when truncated.
    16 
    +y8,y16,y32 :: Word64
    17 
    +y8 = setBit x 8
    18 
    +y16 = setBit x 16
    19 
    +y32 = setBit x 32
    20 
    +
    21 
    +eq8 :: Word8 -> Word8 -> Int
    22 
    +eq8 (W8# a) (W8# b) = I# (eqWord8# a b)
    23 
    +
    24 
    +eq16 :: Word16 -> Word16 -> Int
    25 
    +eq16 (W16# a) (W16# b) = I# (eqWord16# a b)
    26 
    +
    27 
    +eq32 :: Word32 -> Word32 -> Int
    28 
    +eq32 (W32# a) (W32# b) = I# (eqWord32# a b)
    29 
    +
    30 
    +{-# NOINLINE outline_eq8 #-}
    31 
    +outline_eq8 = eq8
    32 
    +{-# NOINLINE outline_eq16 #-}
    33 
    +outline_eq16 = eq16
    34 
    +{-# NOINLINE outline_eq32 #-}
    35 
    +outline_eq32 = eq32
    36 
    +
    37 
    +main :: IO ()
    38 
    +main = do
    39 
    +  print (eq8 (u64_to_u8 x) (u64_to_u8 y8))
    40 
    +  print (eq16 (u64_to_u16 x) (u64_to_u16 y16))
    41 
    +  print (eq32 (u64_to_u32 x) (u64_to_u32 y32))
    42 
    +
    43 
    +  print (outline_eq8 (u64_to_u8 x) (u64_to_u8 y8))
    44 
    +  print (outline_eq16 (u64_to_u16 x) (u64_to_u16 y16))
    45 
    +  print (outline_eq32 (u64_to_u32 x) (u64_to_u32 y32))

  • testsuite/tests/codeGen/should_run/T27430.stdout
    1 
    +1
    2 
    +1
    3 
    +1
    4 
    +1
    5 
    +1
    6 
    +1

  • testsuite/tests/codeGen/should_run/T27430_c.c
    1 
    +#include <stdint.h>
    2 
    +
    3 
    +uint8_t u64_to_u8(uint64_t v) { return (uint8_t)v; }
    4 
    +uint8_t u64_to_u16(uint64_t v) { return (uint16_t)v; }
    5 
    +uint8_t u64_to_u32(uint64_t v) { return (uint32_t)v; }

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -295,3 +295,5 @@ test('aarch64-sxtw-run',
    295 295 
            when(unregisterised(), skip)],
    296 296 
          multi_compile_and_run,
    297 297 
          ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O'])
    298 
    +
    299 
    +test('T27430', [req_c], compile_and_run, ['T27430_c.c'])

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