[Git][ghc/ghc][wip/T15933] FFI: Fix pass small ints in foreign call wrappers

[Peter Trommler]

Peter Trommler pushed to branch wip/T15933 at Glasgow Haskell Compiler / GHC


Commits:
2c5755fa by Peter Trommler at 2020-06-12T17:20:13+02:00
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 a value read a word from the parameter
array and then cast that word to the target type.

Fixes #15933

- - - - -


8 changed files:

- compiler/GHC/HsToCore/Foreign/Decl.hs
- compiler/GHC/StgToCmm/Foreign.hs
- testsuite/tests/ffi/should_run/Makefile
- + testsuite/tests/ffi/should_run/T15933.h
- + testsuite/tests/ffi/should_run/T15933.hs
- + testsuite/tests/ffi/should_run/T15933.stdout
- + testsuite/tests/ffi/should_run/T15933_c.c
- testsuite/tests/ffi/should_run/all.T


Changes:

=====================================
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)
 


=====================================
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)
-


=====================================
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


=====================================
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);


=====================================
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


=====================================
testsuite/tests/ffi/should_run/T15933.stdout
=====================================
@@ -0,0 +1 @@
+10


=====================================
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);
+}


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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c5755fa781fe6d6ddb778be4df9ed3d8ca0091a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2c5755fa781fe6d6ddb778be4df9ed3d8ca0091a
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200612/89351797/attachment-0001.html>