[Git][ghc/ghc][wip/andreask/arm-ffi] Expand CCallConv test

29 Jun 2026


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


Commits:
98fa02eb by Andreas Klebinger at 2026-06-29T08:20:07+02:00
Expand CCallConv test

On some platforms (e.g. arm64) we have invariants about zeroing the high bits of
returned values we want to catch.

- - - - -


3 changed files:

- testsuite/tests/codeGen/should_run/CCallConv.hs
- testsuite/tests/codeGen/should_run/CCallConv.stdout
- testsuite/tests/codeGen/should_run/CCallConv_c.c


Changes:

=====================================
testsuite/tests/codeGen/should_run/CCallConv.hs
=====================================
@@ -3,6 +3,7 @@
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE ExtendedLiterals #-}
 
 -- | This test ensures that sub-word signed and unsigned parameters are correctly
 -- handed over to C functions. I.e. it asserts the calling-convention.
@@ -16,6 +17,7 @@ import Data.Word
 import GHC.Exts
 import GHC.Int
 import System.IO
+import GHC.Stack
 
 foreign import ccall "fun8"
   fun8 ::
@@ -59,6 +61,31 @@ foreign import ccall "fun32"
     Int32# -> -- s1
     Int64# -- result
 
+foreign import ccall "shrink32"
+  shrink32 ::
+    Int64# -> -- a0
+    Int32# -- result
+
+foreign import ccall "shrink16"
+  shrink16 ::
+    Int64# -> -- a0
+    Int16# -- result
+
+foreign import ccall "shrink8"
+  shrink8 ::
+    Int64# -> -- a0
+    Int8# -- result
+
+foreign import ccall "shrink32_16"
+  shrink32_16 ::
+    Int32# -> -- a0
+    Int16# -- result
+
+foreign import ccall "shrink32_8"
+  shrink32_8 ::
+    Int32# -> -- a0
+    Int8# -- result
+
 foreign import ccall "funFloat"
   funFloat ::
     Float# -> -- a0
@@ -115,6 +142,16 @@ main = do
   hFlush stdout
   assertEqual expected_res32 (I64# res32)
 
+  -- Shrinking/zeroing of subword sizes
+  do
+    assertTrue# (shrink32 -1#Int64 `eq32` -1#Int32)
+    assertTrue# (shrink16 -1#Int64 `eq16` -1#Int16)
+    assertTrue# (shrink8 -1#Int64 `eq8` -1#Int8)
+
+    assertTrue# (shrink32_16 -1#Int32 `eq16` -1#Int16)
+    assertTrue# (shrink32_8 -1#Int32 `eq8` -1#Int8)
+
+
   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#)
   print $ "funFloat result:" ++ show resFloat
   hFlush stdout
@@ -125,8 +162,26 @@ main = do
   hFlush stdout
   assertEqual (14.5 :: Double) resDouble
 
+-- We want to avoid constant folding, hence we hide the eqInt# primops
+{-# NOINLINE eq8 #-}
+{-# NOINLINE eq16 #-}
+{-# NOINLINE eq32 #-}
+eq8 :: Int8# -> Int8# -> Int#
+eq16 :: Int16# -> Int16# -> Int#
+eq32 :: Int32# -> Int32# -> Int#
+eq8 = eqInt8#
+eq16 = eqInt16#
+eq32 = eqInt32#
+
 assertEqual :: (Eq a, Show a) => a -> a -> IO ()
 assertEqual a b =
   if a == b
     then pure ()
     else error $ show a ++ " =/= " ++ show b
+
+assertTrue# :: HasCallStack => Int# -> IO ()
+assertTrue# x =
+  case (I# x) of
+    1 -> pure ()
+    0 -> error $ "assertTrue# failed"
+


=====================================
testsuite/tests/codeGen/should_run/CCallConv.stdout
=====================================
@@ -34,6 +34,16 @@ a7: 0xffffffff -1
 s0: 0xffffffff 4294967295
 s1: 0xffffffff -1
 "fun32 result:8589934582"
+shrink32:
+a0: 0xffffffffffffffff -1
+shrink16:
+a0: 0xffffffffffffffff -1
+shrink8:
+a0: 0xffffffffffffffff -1
+shrink32_16:
+a0: 0xffffffff -1
+shrink32_8:
+a0: 0xffffffff -1
 funFloat:
 a0: 1.000000
 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,
          s1;
 }
 
+int32_t shrink32(int64_t a0) {
+  printf("shrink32:\n");
+  printf("a0: %#llx %lld\n", a0, a0);
+
+  fflush(stdout);
+
+  return a0;
+}
+
+int16_t shrink16(int64_t a0) {
+  printf("shrink16:\n");
+  printf("a0: %#llx %lld\n", a0, a0);
+
+  fflush(stdout);
+
+  return a0;
+}
+
+int8_t shrink8(int64_t a0) {
+  printf("shrink8:\n");
+  printf("a0: %#llx %lld\n", a0, a0);
+
+  fflush(stdout);
+
+  return a0;
+}
+
+int16_t shrink32_16(int32_t a0) {
+  printf("shrink32_16:\n");
+  printf("a0: %#x %d\n", a0, a0);
+
+  fflush(stdout);
+
+  return a0;
+}
+
+int8_t shrink32_8(int32_t a0) {
+  printf("shrink32_8:\n");
+  printf("a0: %#x %d\n", a0, a0);
+
+  fflush(stdout);
+
+  return a0;
+}
+
 float funFloat(float a0, float a1, float a2, float a3, float a4, float a5,
              float a6, float a7, float s0, float s1) {
   printf("funFloat:\n");



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98fa02eb0e652dee1eb9bbd670a2f2c3...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98fa02eb0e652dee1eb9bbd670a2f2c3...
You're receiving this email because of your account on gitlab.haskell.org.

    

Andreas Klebinger (＠AndreasK)

tags

participants (1)