FFI: Fix pass small ints in foreign call wrappers

The Haskell calling convention requires integer parameters smaller
than wordsize to be promoted to wordsize (where the upper bits are
don't care). To access such small integer parameter read a word from
the parameter array and then cast that word to the small integer
target type.

Fixes #15933

compiler/GHC/HsToCore/Foreign/Decl.hs

@@ -533,15 +533,36 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
                 SDoc,           -- C type
                 Type,           -- Haskell type
                 CmmType)]       -- the CmmType
-  arg_info  = [ let stg_type = showStgType ty in
-                (arg_cname n stg_type,
+  arg_info  = [ let stg_type = showStgType ty
+                    cmm_type = typeCmmType platform (getPrimTyOf ty)
+                    stack_type
+                      = if int_promote (typeTyCon ty)
+                        then text "HsWord"
+                        else stg_type
+                in
+                (arg_cname n stg_type stack_type,
                  stg_type,
                  ty,
-                 typeCmmType platform (getPrimTyOf ty))
+                 cmm_type)
               | (ty,n) <- zip arg_htys [1::Int ..] ]
 
-  arg_cname n stg_ty
-        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
+  int_promote ty_con
+    | ty_con `hasKey` int8TyConKey = True
+    | ty_con `hasKey` int16TyConKey = True
+    | ty_con `hasKey` int32TyConKey
+    , platformWordSizeInBytes platform > 4
+    = True
+    | ty_con `hasKey` word8TyConKey = True
+    | ty_con `hasKey` word16TyConKey = True
+    | ty_con `hasKey` word32TyConKey
+    , platformWordSizeInBytes platform > 4
+    = True
+    | otherwise = False
+
+
+  arg_cname n stg_ty stack_ty
+        | libffi    = parens (stg_ty) <> char '*' <>
+                      parens (stack_ty <> char '*') <>
                       text "args" <> brackets (int (n-1))
         | otherwise = text ('a':show n)
 

compiler/GHC/StgToCmm/Foreign.hs

@@ -74,6 +74,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
               | otherwise            = Nothing
 
               -- ToDo: this might not be correct for 64-bit API
+              -- This is correct for the PowerPC ELF ABI version 1 and 2.
             arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)
                                      (platformWordSizeInBytes platform)
         ; cmm_args <- getFCallArgs stg_args typ
@@ -634,4 +635,3 @@ typeToStgFArgType typ
   -- a type in a foreign function signature with a representationally
   -- equivalent newtype.
   tycon = tyConAppTyCon (unwrapType typ)
-

testsuite/tests/ffi/should_run/Makefile

@@ -43,3 +43,9 @@ Capi_Ctype_002:
 	'$(TEST_HC)' $(TEST_HC_OPTS) Capi_Ctype_A_002.o Capi_Ctype_002.o -o Capi_Ctype_002
 	./Capi_Ctype_002
 
+.PHONY: T15933
+T15933:
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c T15933_c.c
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c T15933.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) T15933_c.o T15933.o -o T15933
+	./T15933

testsuite/tests/ffi/should_run/T15933.h

+typedef void(*hs_callback)(int x);
+extern void function_in_c(hs_callback cb);

testsuite/tests/ffi/should_run/T15933.hs

+module Main(main) where
+
+import Foreign
+import Foreign.C
+
+type HsCallback = CInt -> IO ()
+
+foreign import ccall "T15933.h function_in_c"
+  functionInC :: FunPtr HsCallback -> IO ()
+
+foreign import ccall "wrapper"
+  wrap :: HsCallback -> IO (FunPtr HsCallback)
+
+main = do
+  f <- wrap $ \x -> print x
+  functionInC f
+  freeHaskellFunPtr f

testsuite/tests/ffi/should_run/T15933.stdout

+10

testsuite/tests/ffi/should_run/T15933_c.c

+#include "T15933.h"
+
+void function_in_c(hs_callback cb)
+{
+    int x = 10;
+    cb(x);
+}

testsuite/tests/ffi/should_run/all.T

@@ -194,6 +194,8 @@ test('T12134', [omit_ways(['ghci'])], compile_and_run, ['T12134_c.c'])
 
 test('T12614', [omit_ways(['ghci'])], compile_and_run, ['T12614_c.c'])
 
+test('T15933', extra_files(['T15933_c.c', 'T15933.h']), makefile_test, ['T15933'])
+
 test('T16650a', [omit_ways(['ghci'])], compile_and_run, ['T16650a_c.c'])
 
 test('T16650b', [omit_ways(['ghci'])], compile_and_run, ['T16650b_c.c'])