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

6 files changed, 35 insertions, 0 deletions

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'])