Commit 01f7052c authored by Peter Trommler's avatar Peter Trommler 🥁 Committed by Marge Bot
Browse files

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
parent bd761185
......@@ -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)
......
......@@ -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)
......@@ -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
typedef void(*hs_callback)(int x);
extern void function_in_c(hs_callback cb);
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
#include "T15933.h"
void function_in_c(hs_callback cb)
{
int x = 10;
cb(x);
}
......@@ -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'])
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment