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

Commits:

12 changed files:

Changes:

  • compiler/GHC/Cmm/Lint.hs
    ... ... @@ -88,8 +88,9 @@ lintCmmBlock labels block
    88 88 
     -- byte/word mismatches.
    89 89
    90 90 
     lintCmmExpr :: CmmExpr -> CmmLint CmmType
    91 
    -lintCmmExpr (CmmLoad expr rep _alignment) = do
    92 
    -  _ <- lintCmmExpr expr
    91 
    +lintCmmExpr e@(CmmLoad expr rep _alignment) = do
    92 
    +  ty <- lintCmmExpr expr
    93 
    +  lintAddrTy e ty
    93 94 
       -- Disabled, if we have the inlining phase before the lint phase,
    94 95 
       -- we can have funny offsets due to pointer tagging. -- EZY
    95 96 
       -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
    ... ... @@ -112,6 +113,15 @@ lintCmmExpr expr =
    112 113 
       do platform <- getPlatform
    113 114 
          return (cmmExprType platform expr)
    114 115
    116 
    +-- We require every address to refer to be word-width since we don't support 32
    117 
    +-- bit pointers on 64bit platforms.
    118 
    +lintAddrTy :: CmmExpr -> CmmType -> CmmLint ()
    119 
    +lintAddrTy e addr_ty = do
    120 
    +  p <- getPlatform
    121 
    +  -- We don't support any platforms where wordwidth /= ptrWidth currently.
    122 
    +  unless (addr_ty `cmmCompatType` bWord p) $ cmmLintErr (text "Non word-width address found in:" <+> pdoc p e)
    123 
    +
    124 
    +
    115 125 
     -- | Check for obviously out-of-bounds shift operations
    116 126 
     lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
    117 127 
     lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)]
    ... ... @@ -173,10 +183,10 @@ lintCmmMiddle node = case node of
    173 183 
                 unless (erep `cmmCompatType` reg_ty) $
    174 184 
                   cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
    175 185
    176 
    -  CmmStore l r _alignment -> do
    177 
    -            _ <- lintCmmExpr l
    178 
    -            _ <- lintCmmExpr r
    179 
    -            return ()
    186 
    +  CmmStore addr rhs _alignment -> do
    187 
    +            addr_ty <- lintCmmExpr addr
    188 
    +            _ <- lintCmmExpr rhs
    189 
    +            lintAddrTy addr addr_ty
    180 190
    181 191 
       CmmUnsafeForeignCall target _formals actuals -> do
    182 192 
                 let lintArg expr = do

  • compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
    ... ... @@ -376,8 +376,10 @@ getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _ty))
    376 376 
     -- -----------------------------------------------------------------------------
    377 377 
     -- General things for putting together code sequences
    378 378
    379 
    --- | The dual to getAnyReg: compute an expression into a register, but
    380 
    ---      we don't mind which one it is.
    379 
    +-- | Computes the register into some register, but we can't pick which one.
    380 
    +-- This means the register might be mapped to a global or local variable and
    381 
    +-- we can only mutate the result reg in place if we know the Cmm expression can't
    382 
    +-- refer to local or global variables.
    381 383 
     getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
    382 384 
     getSomeReg expr = do
    383 385 
       r <- getRegister expr
    ... ... @@ -955,7 +957,7 @@ getRegister' config plat expr
    955 957 
                   return $ Fixed (intFormat to) trunc_reg (code `appOL` code_trunc)
    956 958
    957 959 
             -- Vector
    958 
    -        MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg))
    960 
    +        MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpReg w reg))
    959 961 
               where fmt = VecFormat l (intScalarFormat w)
    960 962 
                     vw = formatToWidth fmt
    961 963 
             MO_VF_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg))
    ... ... @@ -1071,7 +1073,7 @@ getRegister' config plat expr
    1071 1073 
                 in return $ Any (intFormat to) $ \dst ->
    1072 1074 
                     code `snocOL`
    1073 1075 
                     SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`
    1074 
    -                -- At this point an 8- or 16-bit value would be sign-extended
    1076 
    +                -- At this point an 8- or 16-bit value is sign-extended
    1075 1077 
                     -- to 32-bits. Truncate back down the final width.
    1076 1078 
                     truncateSubwordRegInplace to dst
    1077 1079
    ... ... @@ -1760,7 +1762,7 @@ getRegister' config plat expr
    1760 1762 
               tmp <- getNewRegNat format
    1761 1763 
               return $ Any format $ \dst ->
    1762 1764 
                 code_x `appOL` code_y `appOL`
    1763 
    -            if dst == reg_y
    1765 
    +            if dst == reg_y --unlike MO_V_Insert here y/dst can overlap.
    1764 1766 
                 then toOL [ MOV (OpReg W128 tmp) (OpReg W128 reg_x)
    1765 1767 
                           , INS format (OpVecLane w tmp index) (OpScalarAsVec w reg_y)
    1766 1768 
                           , MOV (OpReg W128 dst) (OpReg W128 tmp)
    ... ... @@ -2062,23 +2064,33 @@ genCondJump bid expr = do
    2062 2064 
                     -- compute both sides.
    2063 2065 
                     (reg_x, _format_x, code_x) <- getSomeReg x
    2064 2066 
                     (reg_y, _format_y, code_y) <- getSomeReg y
    2065 
    -                let x' = OpReg w reg_x
    2066 
    -                    y' = OpReg w reg_y
    2067 
    -                return $ case w of
    2068 
    -                  W8  -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
    2069 
    -                  W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
    2070 
    -                  _   -> code_x `appOL` code_y `appOL` toOL [                         CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
    2067 
    +
    2068 
    +                -- If all computations reliably produce zero-extended subword results
    2069 
    +                -- this truncation is redundant. But for now better to be correct than
    2070 
    +                -- fast.
    2071 
    +                (reg_x', trunc_x) <- truncateSubwordReg w reg_x
    2072 
    +                -- TODO: Use CMP on OpRegExt rather than extending explicitly.
    2073 
    +                (reg_y', trunc_y) <- truncateSubwordReg w reg_y
    2074 
    +
    2075 
    +                let x' = OpReg w reg_x'
    2076 
    +                    y' = OpReg w reg_y'
    2077 
    +                return $ concatOL [code_x, trunc_x, code_y, trunc_y,
    2078 
    +                                   toOL [CMP x' y', (annExpr expr (BCOND cmp (TBlock bid)))]]
    2071 2079
    2072 2080 
                 sbcond w cmp = do
    2073 2081 
                     -- compute both sides.
    2074 2082 
                     (reg_x, _format_x, code_x) <- getSomeReg x
    2075 2083 
                     (reg_y, _format_y, code_y) <- getSomeReg y
    2076 
    -                let x' = OpReg w reg_x
    2077 
    -                    y' = OpReg w reg_y
    2078 
    -                return $ case w of
    2079 
    -                  W8  -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
    2080 
    -                  W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
    2081 
    -                  _   -> code_x `appOL` code_y `appOL` toOL [                         CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
    2084 
    +
    2085 
    +                -- W64 always works, even if we ultimately compare at W32.
    2086 
    +                (reg_x', ext_x) <- signExtendReg w W64 reg_x
    2087 
    +                -- TODO: Use CMP on OpRegExt rather than extending explicitly.
    2088 
    +                (reg_y', ext_y) <- signExtendReg w W64 reg_y
    2089 
    +
    2090 
    +                let x' = OpReg w reg_x'
    2091 
    +                    y' = OpReg w reg_y'
    2092 
    +                return $ concatOL [code_x, ext_x, code_y, ext_y,
    2093 
    +                                   toOL [CMP x' y', (annExpr expr (BCOND cmp (TBlock bid)))]]
    2082 2094
    2083 2095 
                 fbcond w cmp = do
    2084 2096 
                   -- ensure we get float regs
    ... ... @@ -2750,6 +2762,7 @@ genCCall target dest_regs arg_regs = do
    2750 2762 
               | [p_reg, val_reg] <- arg_regs -> do
    2751 2763 
                   (p, _fmt_p, code_p) <- getSomeReg p_reg
    2752 2764 
                   (val, fmt_val, code_val) <- getSomeReg val_reg
    2765 
    +              massert (fmt_val == intFormat w)
    2753 2766 
                   let instr = case ord of
    2754 2767 
                           MemOrderRelaxed -> STR
    2755 2768 
                           _               -> STLR

  • compiler/GHC/CmmToAsm/AArch64/Instr.hs
    ... ... @@ -771,7 +771,8 @@ data Instr
    771 771 
         | MOVZ Operand Operand
    772 772 
         | MVN Operand Operand -- rd = ~rn
    773 773 
         | ORR Format Operand Operand Operand -- rd = rn | op2
    774 
    -    -- Load and stores.
    774 
    +    -- Load and stores, we support subwords by picking the subword variant
    775 
    +    -- based on the format.
    775 776 
         -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register.
    776 777 
         | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr
    777 778 
         | STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr

  • compiler/GHC/CmmToAsm/AArch64/Ppr.hs
    ... ... @@ -569,12 +569,8 @@ pprInstr platform instr = case instr of
    569 569 
       -- NOTE: GHC may do whacky things where it only load the lower part of an
    570 570 
       --       address. Not observing the correct size when loading will lead
    571 571 
       --       inevitably to crashes.
    572 
    -  STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
    573 
    -    op2 (text "\tstrb") o1 o2
    574 
    -  STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
    575 
    -    op2 (text "\tstrh") o1 o2
    576 
    -  STR _f o1 o2 -> op2 (text "\tstr") o1 o2
    577 
    -  STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2
    572 
    +  STR f o1 o2 ->  op2 (subword_suffix f $ text "\tstr") o1 o2
    573 
    +  STLR f o1 o2 -> op2 (subword_suffix f $ text "\tstlr") o1 o2
    578 574
    579 575 
       LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
    580 576 
         let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in
    ... ... @@ -622,12 +618,8 @@ pprInstr platform instr = case instr of
    622 618 
         op_adrp o1 adrp' $$
    623 619 
         op_add o1 ldr'
    624 620
    625 
    -  LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
    626 
    -    op2 (text "\tldrb") o1 o2
    627 
    -  LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
    628 
    -    op2 (text "\tldrh") o1 o2
    629 
    -  LDR _f o1 o2 -> op2 (text "\tldr") o1 o2
    630 
    -  LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2
    621 
    +  LDR f o1 o2 -> op2 (subword_suffix f $ text "\tldr") o1 o2
    622 
    +  LDAR f o1 o2 -> op2 (subword_suffix f $ text "\tldar") o1 o2
    631 623
    632 624 
       -- 8. Synchronization Instructions -------------------------------------------
    633 625 
       DMBISH DmbLoadStore -> line $ text "\tdmb ish"
    ... ... @@ -698,6 +690,12 @@ pprInstr platform instr = case instr of
    698 690 
            check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else
    699 691 
              pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit"
    700 692
    693 
    +       -- Some instructions encode with via b/h suffix on the instruction.
    694 
    +       -- We handle this here relying on the format rather then the operands.
    695 
    +       subword_suffix II8  t = t <> char 'b'
    696 
    +       subword_suffix II16 t = t <> char 'h'
    697 
    +       subword_suffix _    t = t
    698 
    +
    701 699 
     pprBcond :: IsLine doc => Cond -> doc
    702 700 
     pprBcond c = text "b." <> pprCond c
    703 701

  • testsuite/tests/codeGen/should_run/T27533.hs
    1 
    +{-# LANGUAGE MagicHash, UnboxedTuples, GHCForeignImportPrim, UnliftedFFITypes #-}
    2 
    +
    3 
    +import GHC.Exts
    4 
    +import GHC.IO (IO(..))
    5 
    +import Foreign.Marshal.Alloc (allocaBytes)
    6 
    +import Foreign.Ptr (Ptr(..))
    7 
    +import Numeric (showHex)
    8 
    +import System.IO
    9 
    +
    10 
    +foreign import prim "store8" store8# :: Addr# -> Word#
    11 
    +foreign import prim "load8"  load8#  :: Addr# -> Word#
    12 
    +
    13 
    +main :: IO ()
    14 
    +main = do
    15 
    +  hSetBuffering stdout NoBuffering
    16 
    +  allocaBytes 8 $ \(Ptr a) -> do
    17 
    +    -- 1. Silent corruption: release-store of 1 byte into an all-ones word.
    18 
    +    IO (\s -> (# writeWordOffAddr# a 0# 0xFFFFFFFFFFFFFFFF## s, () #))
    19 
    +    case store8# a of _ -> return ()   -- case on unlifted Word# forces the call
    20 
    +    w <- IO (\s -> case readWordOffAddr# a 0# s of (# s', v #) -> (# s', W# v #))
    21 
    +    putStrLn ("after 1-byte release-store: 0x" ++ showHex w "")
    22 
    +    -- expected 0xffffffffffffff43; buggy NCG gives 0xffffffff00000043
    23 
    +
    24 
    +    -- 2. SIGBUS: acquire-load of 1 byte at an odd address (well-defined).
    25 
    +    r <- IO (\s -> (# s, W# (load8# (a `plusAddr#` 1#)) #))
    26 
    +    putStrLn ("acquire byte load at p+1:   0x" ++ showHex r "")
    27 
    +    -- expected 0xff; buggy NCG dies with SIGBUS before printing

  • testsuite/tests/codeGen/should_run/T27533.stdout
    1 
    +after 1-byte release-store: 0xffffffffffffff43
    2 
    +acquire byte load at p+1:   0xff

  • testsuite/tests/codeGen/should_run/T27533_cmm.cmm
    1 
    +#include "Cmm.h"
    2 
    +
    3 
    +// Release-store one byte at p. Must touch exactly 1 byte.
    4 
    +store8 (W_ p) {
    5 
    +    %release I8[p] = 67 :: I8;
    6 
    +    return (0);
    7 
    +}
    8 
    +
    9 
    +// Acquire-load one byte from p.
    10 
    +load8 (W_ p) {
    11 
    +    I8 v;
    12 
    +    v = %acquire I8[p];
    13 
    +    return (%zx64(v));
    14 
    +}

  • testsuite/tests/codeGen/should_run/T27538.hs
    ... ... @@ -14,6 +14,7 @@ f x = if isTrue# (x `ltInt8#` intToInt8# 0#)
    14 14
    15 15 
     main :: IO ()
    16 16 
     main = do
    17 
    +  -- Test for use of byte-width read.
    17 18 
       let !(I# i) = ix
    18 19 
           x = indexInt8OffAddr# "\x80"# i
    19 20 
       putStrLn ("f(0x80) = " ++ show (I# (f x)))

  • testsuite/tests/codeGen/should_run/all.T
    ... ... @@ -298,6 +298,10 @@ test('aarch64-sxtw-run',
    298 298
    299 299 
     test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c'])
    300 300
    301 
    +test('T27533', [req_cmm, extra_ways(['optasm'])], multi_compile_and_run,
    302 
    +               ['T27533', [('T27533_cmm.cmm', '')], '-O'])
    303 
    +
    301 304 
     test('T27537', normal, compile_and_run, ['-O'])
    302 305
    303 306 
     test('T27538', normal, compile_and_run, ['-O'])
    307 
    +

  • testsuite/tests/simd/should_run/T27565.hs
    1 
    +{-# LANGUAGE MagicHash, UnboxedTuples #-}
    2 
    +module Main (main) where
    3 
    +import GHC.Exts
    4 
    +import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..))
    5 
    +
    6 
    +{-# OPAQUE broadcast_i8 #-}
    7 
    +broadcast_i8 :: Int8# -> Int8X16#
    8 
    +broadcast_i8 x = broadcastInt8X16# x
    9 
    +
    10 
    +{-# OPAQUE broadcast_i16 #-}
    11 
    +broadcast_i16 :: Int16# -> Int16X8#
    12 
    +broadcast_i16 x = broadcastInt16X8# x
    13 
    +
    14 
    +{-# OPAQUE broadcast_i32 #-}
    15 
    +broadcast_i32 :: Int32# -> Int32X4#
    16 
    +broadcast_i32 x = broadcastInt32X4# x
    17 
    +
    18 
    +{-# OPAQUE broadcast_i64 #-}
    19 
    +broadcast_i64 :: Int64# -> Int64X2#
    20 
    +broadcast_i64 x = broadcastInt64X2# x
    21 
    +
    22 
    +main :: IO ()
    23 
    +main = do
    24 
    +  case unpackInt8X16# (broadcast_i8 (intToInt8# 32#)) of
    25 
    +    (# a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15 #) ->
    26 
    +      print [ I8# a0, I8# a1, I8# a2, I8# a3, I8# a4, I8# a5, I8# a6, I8# a7
    27 
    +            , I8# a8, I8# a9, I8# a10, I8# a11, I8# a12, I8# a13, I8# a14, I8# a15 ]
    28 
    +  case unpackInt16X8# (broadcast_i16 (intToInt16# 32#)) of
    29 
    +    (# b0,b1,b2,b3,b4,b5,b6,b7 #) ->
    30 
    +      print [ I16# b0, I16# b1, I16# b2, I16# b3, I16# b4, I16# b5, I16# b6, I16# b7 ]
    31 
    +  case unpackInt32X4# (broadcast_i32 (intToInt32# 32#)) of
    32 
    +    (# c0,c1,c2,c3 #) ->
    33 
    +      print [ I32# c0, I32# c1, I32# c2, I32# c3 ]
    34 
    +  case unpackInt64X2# (broadcast_i64 (intToInt64# 32#)) of
    35 
    +    (# d0,d1 #) ->
    36 
    +      print [ I64# d0, I64# d1 ]

  • testsuite/tests/simd/should_run/T27565.stdout
    1 
    +[32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32]
    2 
    +[32,32,32,32,32,32,32,32]
    3 
    +[32,32,32,32]
    4 
    +[32,32]

  • testsuite/tests/simd/should_run/all.T
    ... ... @@ -217,3 +217,5 @@ test('StackAlignment64'
    217 217 
         , compile_and_run if have_cpu_feature('avx512f') else compile
    218 218 
         , ['StackAlignment64_main.c']
    219 219 
         )
    220 
    +
    221 
    +test('T27565', [], compile_and_run, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/1523beef0d172548211894720063a32ffe8453bc...e5d9fac3d83f85330249c5786dabc02f9c08d798 at 1785251267