[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:
b71eb384 by Peter Trommler at 2020-06-12T17:36:07+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 small integer parameter read a word from
the parameter array and then cast that word to the small integer
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/b71eb384dae5830b9266e02e0e4a1c10497062d1

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b71eb384dae5830b9266e02e0e4a1c10497062d1
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/e9ea5bbc/attachment-0001.html>