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.