FFI: Fix pass small ints in foreign call wrapperswip/T15933

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

8 files changed, 62 insertions, 6 deletions

diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index cb1cb6fe11..9ed161f18b 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/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)
 
diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs
index 72dae672ba..0681d41f96 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs
+++ b/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)
-
diff --git a/testsuite/tests/ffi/should_run/Makefile b/testsuite/tests/ffi/should_run/Makefile
index a4a716adb7..cd264113c7 100644
--- a/testsuite/tests/ffi/should_run/Makefile
+++ b/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
diff --git a/testsuite/tests/ffi/should_run/T15933.h b/testsuite/tests/ffi/should_run/T15933.h
new file mode 100644
index 0000000000..b4339fc99b
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T15933.h
@@ -0,0 +1,2 @@
+typedef void(*hs_callback)(int x);
+extern void function_in_c(hs_callback cb);
diff --git a/testsuite/tests/ffi/should_run/T15933.hs b/testsuite/tests/ffi/should_run/T15933.hs
new file mode 100644
index 0000000000..f9286ad41b
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T15933.hs
@@ -0,0 +1,17 @@
+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
diff --git a/testsuite/tests/ffi/should_run/T15933.stdout b/testsuite/tests/ffi/should_run/T15933.stdout
new file mode 100644
index 0000000000..f599e28b8a
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T15933.stdout
@@ -0,0 +1 @@
+10
diff --git a/testsuite/tests/ffi/should_run/T15933_c.c b/testsuite/tests/ffi/should_run/T15933_c.c
new file mode 100644
index 0000000000..b8b77242f1
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T15933_c.c
@@ -0,0 +1,7 @@
+#include "T15933.h"
+
+void function_in_c(hs_callback cb)
+{
+    int x = 10;
+    cb(x);
+}
diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T
index a0984a28fe..fb840861e6 100644
--- a/testsuite/tests/ffi/should_run/all.T
+++ b/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'])