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

Commits:

3 changed files:

Changes:

  • testsuite/tests/codeGen/should_run/CCallConv.hs
    ... ... @@ -3,6 +3,7 @@
    3 3 
     {-# LANGUAGE MagicHash #-}
    4 4 
     {-# LANGUAGE UnboxedTuples #-}
    5 5 
     {-# LANGUAGE UnliftedFFITypes #-}
    6 
    +{-# LANGUAGE ExtendedLiterals #-}
    6 7
    7 8 
     -- | This test ensures that sub-word signed and unsigned parameters are correctly
    8 9 
     -- handed over to C functions. I.e. it asserts the calling-convention.
    ... ... @@ -16,6 +17,7 @@ import Data.Word
    16 17 
     import GHC.Exts
    17 18 
     import GHC.Int
    18 19 
     import System.IO
    20 
    +import GHC.Stack
    19 21
    20 22 
     foreign import ccall "fun8"
    21 23 
       fun8 ::
    ... ... @@ -59,6 +61,31 @@ foreign import ccall "fun32"
    59 61 
         Int32# -> -- s1
    60 62 
         Int64# -- result
    61 63
    64 
    +foreign import ccall "shrink32"
    65 
    +  shrink32 ::
    66 
    +    Int64# -> -- a0
    67 
    +    Int32# -- result
    68 
    +
    69 
    +foreign import ccall "shrink16"
    70 
    +  shrink16 ::
    71 
    +    Int64# -> -- a0
    72 
    +    Int16# -- result
    73 
    +
    74 
    +foreign import ccall "shrink8"
    75 
    +  shrink8 ::
    76 
    +    Int64# -> -- a0
    77 
    +    Int8# -- result
    78 
    +
    79 
    +foreign import ccall "shrink32_16"
    80 
    +  shrink32_16 ::
    81 
    +    Int32# -> -- a0
    82 
    +    Int16# -- result
    83 
    +
    84 
    +foreign import ccall "shrink32_8"
    85 
    +  shrink32_8 ::
    86 
    +    Int32# -> -- a0
    87 
    +    Int8# -- result
    88 
    +
    62 89 
     foreign import ccall "funFloat"
    63 90 
       funFloat ::
    64 91 
         Float# -> -- a0
    ... ... @@ -115,6 +142,16 @@ main = do
    115 142 
       hFlush stdout
    116 143 
       assertEqual expected_res32 (I64# res32)
    117 144
    145 
    +  -- Shrinking/zeroing of subword sizes
    146 
    +  do
    147 
    +    assertTrue# (shrink32 -1#Int64 `eq32` -1#Int32)
    148 
    +    assertTrue# (shrink16 -1#Int64 `eq16` -1#Int16)
    149 
    +    assertTrue# (shrink8 -1#Int64 `eq8` -1#Int8)
    150 
    +
    151 
    +    assertTrue# (shrink32_16 -1#Int32 `eq16` -1#Int16)
    152 
    +    assertTrue# (shrink32_8 -1#Int32 `eq8` -1#Int8)
    153 
    +
    154 
    +
    118 155 
       let resFloat :: Float = F# (funFloat 1.0# 1.1# 1.2# 1.3# 1.4# 1.5# 1.6# 1.7# 1.8# 1.9#)
    119 156 
       print $ "funFloat result:" ++ show resFloat
    120 157 
       hFlush stdout
    ... ... @@ -125,8 +162,26 @@ main = do
    125 162 
       hFlush stdout
    126 163 
       assertEqual (14.5 :: Double) resDouble
    127 164
    165 
    +-- We want to avoid constant folding, hence we hide the eqInt# primops
    166 
    +{-# NOINLINE eq8 #-}
    167 
    +{-# NOINLINE eq16 #-}
    168 
    +{-# NOINLINE eq32 #-}
    169 
    +eq8 :: Int8# -> Int8# -> Int#
    170 
    +eq16 :: Int16# -> Int16# -> Int#
    171 
    +eq32 :: Int32# -> Int32# -> Int#
    172 
    +eq8 = eqInt8#
    173 
    +eq16 = eqInt16#
    174 
    +eq32 = eqInt32#
    175 
    +
    128 176 
     assertEqual :: (Eq a, Show a) => a -> a -> IO ()
    129 177 
     assertEqual a b =
    130 178 
       if a == b
    131 179 
         then pure ()
    132 180 
         else error $ show a ++ " =/= " ++ show b
    181 
    +
    182 
    +assertTrue# :: HasCallStack => Int# -> IO ()
    183 
    +assertTrue# x =
    184 
    +  case (I# x) of
    185 
    +    1 -> pure ()
    186 
    +    0 -> error $ "assertTrue# failed"
    187 
    +

  • testsuite/tests/codeGen/should_run/CCallConv.stdout
    ... ... @@ -34,6 +34,16 @@ a7: 0xffffffff -1
    34 34 
     s0: 0xffffffff 4294967295
    35 35 
     s1: 0xffffffff -1
    36 36 
     "fun32 result:8589934582"
    37 
    +shrink32:
    38 
    +a0: 0xffffffffffffffff -1
    39 
    +shrink16:
    40 
    +a0: 0xffffffffffffffff -1
    41 
    +shrink8:
    42 
    +a0: 0xffffffffffffffff -1
    43 
    +shrink32_16:
    44 
    +a0: 0xffffffff -1
    45 
    +shrink32_8:
    46 
    +a0: 0xffffffff -1
    37 47 
     funFloat:
    38 48 
     a0: 1.000000
    39 49 
     a1: 1.100000

  • testsuite/tests/codeGen/should_run/CCallConv_c.c
    ... ... @@ -62,6 +62,51 @@ int64_t fun32(int32_t a0, uint32_t a1, int32_t a2, int32_t a3, int32_t a4,
    62 62 
              s1;
    63 63 
     }
    64 64
    65 
    +int32_t shrink32(int64_t a0) {
    66 
    +  printf("shrink32:\n");
    67 
    +  printf("a0: %#llx %lld\n", a0, a0);
    68 
    +
    69 
    +  fflush(stdout);
    70 
    +
    71 
    +  return a0;
    72 
    +}
    73 
    +
    74 
    +int16_t shrink16(int64_t a0) {
    75 
    +  printf("shrink16:\n");
    76 
    +  printf("a0: %#llx %lld\n", a0, a0);
    77 
    +
    78 
    +  fflush(stdout);
    79 
    +
    80 
    +  return a0;
    81 
    +}
    82 
    +
    83 
    +int8_t shrink8(int64_t a0) {
    84 
    +  printf("shrink8:\n");
    85 
    +  printf("a0: %#llx %lld\n", a0, a0);
    86 
    +
    87 
    +  fflush(stdout);
    88 
    +
    89 
    +  return a0;
    90 
    +}
    91 
    +
    92 
    +int16_t shrink32_16(int32_t a0) {
    93 
    +  printf("shrink32_16:\n");
    94 
    +  printf("a0: %#x %d\n", a0, a0);
    95 
    +
    96 
    +  fflush(stdout);
    97 
    +
    98 
    +  return a0;
    99 
    +}
    100 
    +
    101 
    +int8_t shrink32_8(int32_t a0) {
    102 
    +  printf("shrink32_8:\n");
    103 
    +  printf("a0: %#x %d\n", a0, a0);
    104 
    +
    105 
    +  fflush(stdout);
    106 
    +
    107 
    +  return a0;
    108 
    +}
    109 
    +
    65 110 
     float funFloat(float a0, float a1, float a2, float a3, float a4, float a5,
    66 111 
                  float a6, float a7, float s0, float s1) {
    67 112 
       printf("funFloat:\n");

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