[Git][ghc/ghc][wip/andreask/ffi_callbacks] Fix ffi callbacks with >6 args and non-64bit args.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Mon Jan 29 14:32:45 UTC 2024
Andreas Klebinger pushed to branch wip/andreask/ffi_callbacks at Glasgow Haskell Compiler / GHC
Commits:
0db2a48d by Andreas Klebinger at 2024-01-29T15:19:17+01:00
Fix ffi callbacks with >6 args and non-64bit args.
Check for ptr/int arguments rather than 64-bit width arguments when counting
integer register arguments.
The old approach broke when we stopped using exclusively W64-sized types to represent
sub-word sized integers.
Fixes #24314
- - - - -
5 changed files:
- compiler/GHC/HsToCore/Foreign/C.hs
- + testsuite/tests/ffi/should_run/T24314.hs
- + testsuite/tests/ffi/should_run/T24314.stdout
- + testsuite/tests/ffi/should_run/T24314_c.c
- testsuite/tests/ffi/should_run/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Foreign/C.hs
=====================================
@@ -400,17 +400,11 @@ mkFExportCBits :: DynFlags
Int -- total size of arguments
)
mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
- = ( header_bits
+ =
+ ( header_bits
, CStub body [] []
, type_string,
- sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
- -- NB. the calculation here isn't strictly speaking correct.
- -- We have a primitive Haskell type (eg. Int#, Double#), and
- -- we want to know the size, when passed on the C stack, of
- -- the associated C type (eg. HsInt, HsDouble). We don't have
- -- this information to hand, but we know what GHC's conventions
- -- are for passing around the primitive Haskell types, so we
- -- use that instead. I hope the two coincide --SDM
+ aug_arg_size
)
where
platform = targetPlatform dflags
@@ -449,6 +443,19 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
| isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info
| otherwise = arg_info
+ aug_arg_size = sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info]
+ -- NB. the calculation here isn't strictly speaking correct.
+ -- We have a primitive Haskell type (eg. Int#, Double#), and
+ -- we want to know the size, when passed on the C stack, of
+ -- the associated C type (eg. HsInt, HsDouble). We don't have
+ -- this information to hand, but we know what GHC's conventions
+ -- are for passing around the primitive Haskell types, so we
+ -- use that instead. I hope the two coincide --SDM
+ -- AK: This seems just wrong, the code here uses widthInBytes, but when
+ -- we pass args on the haskell stack we always extend to multiples of 8
+ -- to my knowledge. Not sure if it matters though so I won't touch this
+ -- for now.
+
stable_ptr_arg =
(text "the_stableptr", text "StgStablePtr", undefined,
typeCmmType platform (mkStablePtrPrimTy alphaTy))
@@ -604,8 +611,11 @@ insertRetAddr platform CCallConv args
-> [(SDoc, SDoc, Type, CmmType)]
go 6 args = ret_addr_arg platform : args
go n (arg@(_,_,_,rep):args)
- | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
- | otherwise = arg : go n args
+ -- Int type fitting into int register
+ | (isBitsType rep && typeWidth rep <= W64 || isGcPtrType rep)
+ = arg : go (n+1) args
+ | otherwise
+ = arg : go n args
go _ [] = []
in go 0 args
_ ->
=====================================
testsuite/tests/ffi/should_run/T24314.hs
=====================================
@@ -0,0 +1,103 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main (main, one32) where
+
+import Data.Int
+import Data.Word
+import Foreign.C.String
+import Foreign.Ptr
+
+{-# NOINLINE all64 #-}
+all64 :: Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> IO ()
+all64 = \p1 p2 p3 p4 p5 p6 p7 p8 -> do
+ putStrLn "Callback with only 64-bit parameters..."
+ putStrLn $ "P1: " ++ show p1
+ putStrLn $ "P2: " ++ show p2
+ putStrLn $ "P3: " ++ show p3
+ putStrLn $ "P4: " ++ show p4
+ putStrLn $ "P5: " ++ show p5
+ putStrLn $ "P6: " ++ show p6
+ putStrLn $ "P7: " ++ show p7
+ putStrLn $ "P8: " ++ show p8
+
+{-# NOINLINE one32 #-}
+one32 :: One32
+one32 = \p1 p2 p3 p4 p5 p6 p7 p8 -> do
+ putStrLn "Callback with one 32-bit parameter and the rest 64-bit..."
+ putStrLn $ "P1: " ++ show p1
+ putStrLn $ "P2: " ++ show p2
+ putStrLn $ "P3: " ++ show p3
+ putStrLn $ "P4: " ++ show p4
+ putStrLn $ "P5: " ++ show p5
+ putStrLn $ "P6: " ++ show p6
+ putStrLn $ "P7: " ++ show p7
+ putStrLn $ "P8: " ++ show p8
+
+{-# NOINLINE oneF #-}
+oneF :: OneF
+oneF = \p1 p2 p3 p4 p5 p6 p7 p8 -> do
+ putStrLn "Callback with one float parameter and the rest 64-bit..."
+ putStrLn $ "P1: " ++ show p1
+ putStrLn $ "P2: " ++ show p2
+ putStrLn $ "P3: " ++ show p3
+ putStrLn $ "P4: " ++ show p4
+ putStrLn $ "P5: " ++ show p5
+ putStrLn $ "P6: " ++ show p6
+ putStrLn $ "P7: " ++ show p7
+ putStrLn $ "P8: " ++ show p8
+
+two32 :: Two32
+two32 = \p1 p2 p3 p4 p5 p6 p7 p8 -> do
+ putStrLn "Callback with two 32-bit parameters and the rest 64-bit..."
+ putStrLn $ "P1: " ++ show p1
+ putStrLn $ "P2: " ++ show p2
+ putStrLn $ "P3: " ++ show p3
+ putStrLn $ "P4: " ++ show p4
+ putStrLn $ "P5: " ++ show p5
+ putStrLn $ "P6: " ++ show p6
+ putStrLn $ "P7: " ++ show p7
+ putStrLn $ "P8: " ++ show p8
+
+allKinds :: AllKinds
+allKinds = \p1 p2 p3 p4 p5 p6
+ p11 p12 p13 p14 p15 p16
+ p21 p22 p23 p24 p25 p26
+ p31 p32 p33 p34 p35 p36 -> do
+ putStrLn "Callback with all kinds of arguments"
+ putStrLn $ show (p1, p2, p3, p4, p5, p6)
+ putStrLn $ show (p11, p12, p13, p14, p15, p16)
+ putStrLn $ show (p21, p22, p23, p24, p25, p26)
+ putStrLn $ show (p31, p32, p33, p34, p35, p36)
+
+
+
+main :: IO ()
+main = do
+ (all64Ptr :: FunPtr All64) <- wrapAll64 all64
+ (one32Ptr :: FunPtr One32) <- wrapOne32 one32
+ (oneFPtr :: FunPtr OneF) <- wrapOneF oneF
+ (two32Ptr :: FunPtr Two32) <- wrapTwo32 two32
+ (allKindsPtr :: FunPtr AllKinds) <- wrapAllKinds allKinds
+ callMe all64Ptr one32Ptr oneFPtr two32Ptr allKindsPtr
+ freeHaskellFunPtr all64Ptr
+ freeHaskellFunPtr one32Ptr
+ freeHaskellFunPtr oneFPtr
+ freeHaskellFunPtr two32Ptr
+ freeHaskellFunPtr allKindsPtr
+
+type DynamicWrapper f = f -> IO (FunPtr f)
+type All64 = Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> IO ()
+type One32 = Word64 -> Word64 -> Word32 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> IO ()
+type OneF = Word64 -> Word64 -> Float -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> IO ()
+type Two32 = Word64 -> Word32 -> Word32 -> Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> IO ()
+type AllKinds = Word8 -> Word16 -> Word32 -> Word64 -> Float -> Double
+ -> Word8 -> Word16 -> Word32 -> Word64 -> Float -> Double
+ -> Word8 -> Word16 -> Word32 -> Word64 -> Float -> Double
+ -> Word8 -> Word16 -> Word32 -> Word64 -> Float -> Double -> IO ()
+
+foreign import ccall "callMe" callMe :: FunPtr All64 -> FunPtr One32 -> FunPtr OneF -> FunPtr Two32 -> FunPtr AllKinds -> IO ()
+foreign import ccall "wrapper" wrapAll64 :: DynamicWrapper All64
+foreign import ccall "wrapper" wrapOne32 :: DynamicWrapper One32
+foreign import ccall "wrapper" wrapOneF :: DynamicWrapper OneF
+foreign import ccall "wrapper" wrapTwo32 :: DynamicWrapper Two32
+foreign import ccall "wrapper" wrapAllKinds :: DynamicWrapper AllKinds
=====================================
testsuite/tests/ffi/should_run/T24314.stdout
=====================================
@@ -0,0 +1,41 @@
+Callback with only 64-bit parameters...
+P1: 1
+P2: 2
+P3: 3
+P4: 4
+P5: 5
+P6: 6
+P7: 7
+P8: 8
+Callback with one 32-bit parameter and the rest 64-bit...
+P1: 1
+P2: 2
+P3: 3
+P4: 4
+P5: 5
+P6: 6
+P7: 7
+P8: 8
+Callback with two 32-bit parameters and the rest 64-bit...
+P1: 1
+P2: 2
+P3: 3
+P4: 4
+P5: 5
+P6: 6
+P7: 7
+P8: 8
+Callback with one float parameter and the rest 64-bit...
+P1: 1
+P2: 2
+P3: 3.0
+P4: 4
+P5: 5
+P6: 6
+P7: 7
+P8: 8
+Callback with all kinds of arguments
+(1,2,3,4,5.0,6.0)
+(11,12,13,14,15.0,16.0)
+(21,22,23,24,25.0,26.0)
+(31,32,33,34,35.0,36.0)
=====================================
testsuite/tests/ffi/should_run/T24314_c.c
=====================================
@@ -0,0 +1,30 @@
+#include <stddef.h>
+#include <stdint.h>
+
+
+
+
+typedef void (*PtrAll64)(uint64_t p1, uint64_t p2, uint64_t p3, uint64_t p4, uint64_t p5, uint64_t p6, uint64_t p7, uint64_t p8);
+typedef void (*PtrOne32)(uint64_t p1, uint64_t p2, uint32_t p3, uint64_t p4, uint64_t p5, uint64_t p6, uint64_t p7, uint64_t p8);
+typedef void (*PtrOneF)(uint64_t p1, uint64_t p2, float p3, uint64_t p4, uint64_t p5, uint64_t p6, uint64_t p7, uint64_t p8);
+typedef void (*PtrTwo32)(uint64_t p1, uint32_t p2, uint32_t p3, uint64_t p4, uint64_t p5, uint64_t p6, uint64_t p7, uint64_t p8);
+
+typedef void (*PtrAllKinds)(uint8_t p1, uint16_t p2, uint32_t p3, uint64_t p4, float p5, double p6,
+ uint8_t p11, uint16_t p12, uint32_t p13, uint64_t p14, float p15, double p16,
+ uint8_t p21, uint16_t p22, uint32_t p23, uint64_t p24, float p25, double p26,
+ uint8_t p31, uint16_t p32, uint32_t p33, uint64_t p34, float p35, double p36);
+
+
+void callMe(PtrAll64 ptrAll64, PtrOne32 ptrOne32, PtrOneF ptrOneF, PtrTwo32 ptrTwo32, PtrAllKinds ptrAllKinds)
+{
+ (*ptrAll64)(1,2,3,4,5,6,7,8);
+ (*ptrOne32)(1,2,3,4,5,6,7,8);
+ (*ptrTwo32)(1,2,3,4,5,6,7,8);
+ (*ptrOneF)(1,2,3,4,5,6,7,8);
+ (*ptrAllKinds) (1,2,3,4,5,6,
+ 11,12,13,14,15,16,
+ 21,22,23,24,25,26,
+ 31,32,33,34,35,36
+ );
+
+}
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -261,3 +261,9 @@ test('T22159',
[unless(opsys('mingw32'), skip),
extra_files(['T22159_c.c'])],
makefile_test, ['T22159'])
+
+test('T24314',
+ [extra_files(['T24314_c.c']),
+ # libffi-wasm doesn't support more than 4 args yet
+ when(arch('wasm32'), skip)],
+ compile_and_run, ['T24314_c.c'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0db2a48d4fa7c6d913f151de05ad94883a2b19c5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0db2a48d4fa7c6d913f151de05ad94883a2b19c5
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240129/34c27b5d/attachment-0001.html>
More information about the ghc-commits
mailing list