From ce131b180738c6f6e9b4ca2224f41314b7db7e88 Mon Sep 17 00:00:00 2001 From: Peter Trommler Date: Thu, 11 Jun 2020 08:31:22 +0200 Subject: 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 | 31 +++++++++++++++++++++++----- compiler/GHC/StgToCmm/Foreign.hs | 2 +- testsuite/tests/ffi/should_run/Makefile | 6 ++++++ testsuite/tests/ffi/should_run/T15933.h | 2 ++ testsuite/tests/ffi/should_run/T15933.hs | 17 +++++++++++++++ testsuite/tests/ffi/should_run/T15933.stdout | 1 + testsuite/tests/ffi/should_run/T15933_c.c | 7 +++++++ testsuite/tests/ffi/should_run/all.T | 2 ++ 8 files changed, 62 insertions(+), 6 deletions(-) create mode 100644 testsuite/tests/ffi/should_run/T15933.h create mode 100644 testsuite/tests/ffi/should_run/T15933.hs create mode 100644 testsuite/tests/ffi/should_run/T15933.stdout create mode 100644 testsuite/tests/ffi/should_run/T15933_c.c 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']) -- cgit v1.2.1