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

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

+{-# 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

+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

+#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,10 @@ test('T22159',
      [unless(opsys('mingw32'), skip),
       extra_files(['T22159_c.c'])],
      makefile_test, ['T22159'])
+
+test('T24314',
+     [extra_files(['T24314_c.c']),
+      req_c,
+      # libffi-wasm doesn't support more than 4 args yet
+      when(arch('wasm32'), skip)],
+     compile_and_run, ['T24314_c.c'])