diff options
-rw-r--r-- | compiler/GHC/HsToCore/Foreign/Decl.hs | 31 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Foreign.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_run/Makefile | 6 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_run/T15933.h | 2 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_run/T15933.hs | 17 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_run/T15933.stdout | 1 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_run/T15933_c.c | 7 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_run/all.T | 2 |
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']) |