summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authornineonine <mail4chemik@gmail.com>2022-06-17 18:38:38 -0700
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-07-01 08:15:56 -0400
commitd072217016ceae7c557f638e91a365fa5ab7779c (patch)
treea07878552e0931b03702521bdfa3b5d87a7914c9
parent70e47489f1fa87a0ee5656950c00b54f69823fc6 (diff)
downloadhaskell-d072217016ceae7c557f638e91a365fa5ab7779c.tar.gz
Fix panic with UnliftedFFITypes+CApiFFI (#14624)
When declaring foreign import using CAPI calling convention, using unlifted unboxed types would result in compiler panic. There was an attempt to fix the situation in #9274, however it only addressed some of the ByteArray cases. This patch fixes other missed cases for all prims that may be used as basic foreign types.
-rw-r--r--compiler/GHC/HsToCore/Foreign/C.hs22
-rw-r--r--compiler/GHC/HsToCore/Foreign/Utils.hs29
-rw-r--r--testsuite/tests/ffi/should_run/T14624.hs53
-rw-r--r--testsuite/tests/ffi/should_run/T14624.stdout15
-rw-r--r--testsuite/tests/ffi/should_run/T14624_c.c65
-rw-r--r--testsuite/tests/ffi/should_run/T14624_c.h17
-rw-r--r--testsuite/tests/ffi/should_run/all.T2
7 files changed, 191 insertions, 12 deletions
diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs
index 555db51840..69ae4962d8 100644
--- a/compiler/GHC/HsToCore/Foreign/C.hs
+++ b/compiler/GHC/HsToCore/Foreign/C.hs
@@ -281,11 +281,10 @@ dsFCall fn_id co fcall mDeclHeader = do
cRet
| isVoidRes = cCall
| otherwise = text "return" <+> cCall
- cCall = if isFun
- then ppr cName <> parens argVals
- else if null arg_tys
- then ppr cName
- else panic "dsFCall: Unexpected arguments to FFI value import"
+ cCall
+ | isFun = ppr cName <> parens argVals
+ | null arg_tys = ppr cName
+ | otherwise = panic "dsFCall: Unexpected arguments to FFI value import"
raw_res_ty = case tcSplitIOType_maybe io_res_ty of
Just (_ioTyCon, res_ty) -> res_ty
Nothing -> io_res_ty
@@ -358,12 +357,12 @@ toCType = f False
-- through one layer of type synonym etc.
| Just t' <- coreView t
= f voidOK t'
- -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
- -- (which is marshalled like a Ptr)
- | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t
- = (Nothing, text "const void*")
- | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
- = (Nothing, text "void*")
+ -- Handle 'UnliftedFFITypes' argument
+ | Just tyCon <- tyConAppTyConPicky_maybe t
+ , isPrimTyCon tyCon
+ , Just cType <- ppPrimTyConStgType tyCon
+ = (Nothing, text cType)
+
-- Otherwise we don't know the C type. If we are allowing
-- void then return that; otherwise something has gone wrong.
| voidOK = (Nothing, text "void")
@@ -624,4 +623,3 @@ fun_type_arg_stdcall_info platform StdCallConv ty
in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)
fun_type_arg_stdcall_info _ _other_conv _
= Nothing
-
diff --git a/compiler/GHC/HsToCore/Foreign/Utils.hs b/compiler/GHC/HsToCore/Foreign/Utils.hs
index c632adabbe..80b6908aaf 100644
--- a/compiler/GHC/HsToCore/Foreign/Utils.hs
+++ b/compiler/GHC/HsToCore/Foreign/Utils.hs
@@ -1,7 +1,10 @@
+{-# LANGUAGE MultiWayIf #-}
+
module GHC.HsToCore.Foreign.Utils
( Binding
, getPrimTyOf
, primTyDescChar
+ , ppPrimTyConStgType
)
where
@@ -74,3 +77,29 @@ primTyDescChar !platform ty
(signed_word, unsigned_word) = case platformWordSize platform of
PW4 -> ('W','w')
PW8 -> ('L','l')
+
+-- | Printed C Type to be used with CAPI calling convention
+ppPrimTyConStgType :: TyCon -> Maybe String
+ppPrimTyConStgType tc =
+ if | tc == charPrimTyCon -> Just "StgChar"
+ | tc == intPrimTyCon -> Just "StgInt"
+ | tc == int8PrimTyCon -> Just "StgInt8"
+ | tc == int16PrimTyCon -> Just "StgInt16"
+ | tc == int32PrimTyCon -> Just "StgInt32"
+ | tc == int64PrimTyCon -> Just "StgInt64"
+ | tc == wordPrimTyCon -> Just "StgWord"
+ | tc == word8PrimTyCon -> Just "StgWord8"
+ | tc == word16PrimTyCon -> Just "StgWord16"
+ | tc == word32PrimTyCon -> Just "StgWord32"
+ | tc == word64PrimTyCon -> Just "StgWord64"
+ | tc == floatPrimTyCon -> Just "StgFloat"
+ | tc == doublePrimTyCon -> Just "StgDouble"
+ | tc == addrPrimTyCon -> Just "StgAddr"
+ | tc == stablePtrPrimTyCon -> Just "StgStablePtr"
+ | tc == arrayPrimTyCon -> Just "const StgAddr"
+ | tc == mutableArrayPrimTyCon -> Just "StgAddr"
+ | tc == byteArrayPrimTyCon -> Just "const StgAddr"
+ | tc == mutableByteArrayPrimTyCon -> Just "StgAddr"
+ | tc == smallArrayPrimTyCon -> Just "const StgAddr"
+ | tc == smallMutableArrayPrimTyCon -> Just "StgAddr"
+ | otherwise -> Nothing
diff --git a/testsuite/tests/ffi/should_run/T14624.hs b/testsuite/tests/ffi/should_run/T14624.hs
new file mode 100644
index 0000000000..a8c6ef5d37
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T14624.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.Float
+import GHC.Int
+import GHC.IO
+import GHC.Word
+import Foreign.C.Types
+
+foreign import capi "T14624_c.h f_char" c_f_char :: Char# -> Int#
+foreign import capi "T14624_c.h f_int" c_f_int :: Int# -> Int#
+foreign import capi "T14624_c.h f_int8" c_f_int8 :: Int8# -> Int8#
+foreign import capi "T14624_c.h f_int16" c_f_int16 :: Int16# -> Int16#
+foreign import capi "T14624_c.h f_int32" c_f_int32 :: Int32# -> Int32#
+foreign import capi "T14624_c.h f_int64" c_f_int64 :: Int64# -> Int64#
+foreign import capi "T14624_c.h f_word" c_f_word :: Word# -> Word#
+foreign import capi "T14624_c.h f_word8" c_f_word8 :: Word8# -> Word8#
+foreign import capi "T14624_c.h f_word16" c_f_word16 :: Word16# -> Word16#
+foreign import capi "T14624_c.h f_word32" c_f_word32 :: Word32# -> Word32#
+foreign import capi "T14624_c.h f_word64" c_f_word64 :: Word64# -> Word64#
+foreign import capi "T14624_c.h f_float" c_f_float :: Float# -> Float#
+foreign import capi "T14624_c.h f_double" c_f_double :: Double# -> Double# -> Double#
+foreign import capi "T14624_c.h f_addr" c_f_addr :: Addr# -> Addr#
+foreign import capi "T14624_c.h f_stable_ptr" c_f_stable_ptr :: StablePtr# a -> StablePtr# a
+
+main :: IO ()
+main = do
+ print (I# (c_f_char '\0'#))
+ print (I# (c_f_int (case maxBound @Int of (I# i) -> i)))
+ print (I8# (c_f_int8 (intToInt8# 127#)))
+ print (I16# (c_f_int16 (intToInt16# 32767#)))
+ print (I32# (c_f_int32 (intToInt32# 2147483647#)))
+ print (I64# (c_f_int64 (case maxBound @Int64 of (I64# i) -> i)))
+
+ print (W# (c_f_word (case maxBound @Word of (W# i) -> i)))
+ print (W8# (c_f_word8 (int8ToWord8# (intToInt8# 255#))))
+ print (W16# (c_f_word16 (int16ToWord16# (intToInt16# 65535#))))
+ print (W32# (c_f_word32 (int32ToWord32# (intToInt32# 4294967295#))))
+ print (W64# (c_f_word64 (int64ToWord64# (intToInt64# 18446744073709551615#))))
+
+ print (F# (c_f_float 3.0#))
+ print (D# (c_f_double 909.0## 909.0##))
+
+ print (I# (eqAddr# (c_f_addr nullAddr#) "909"#))
+ let io = IO $ \s0 -> case makeStablePtr# () s0 of
+ (# s1, sp #) -> (# s1, I# ((eqStablePtr# (c_f_stable_ptr sp) sp) -# 1#) #)
+ io >>= print
diff --git a/testsuite/tests/ffi/should_run/T14624.stdout b/testsuite/tests/ffi/should_run/T14624.stdout
new file mode 100644
index 0000000000..94052bf673
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T14624.stdout
@@ -0,0 +1,15 @@
+0
+0
+0
+0
+0
+0
+0
+0
+0
+0
+0
+0.0
+0.0
+0
+0
diff --git a/testsuite/tests/ffi/should_run/T14624_c.c b/testsuite/tests/ffi/should_run/T14624_c.c
new file mode 100644
index 0000000000..4c75be3a05
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T14624_c.c
@@ -0,0 +1,65 @@
+#include <stdint.h>
+#include <math.h>
+#include "T14624_c.h"
+#include "Rts.h"
+
+StgChar f_char(StgChar c) {
+ return c;
+}
+
+StgInt f_int(StgInt a) {
+ return a - STG_INT_MAX;
+}
+
+StgInt8 f_int8(StgInt8 a) {
+ return a - STG_INT8_MAX;
+}
+
+StgInt16 f_int16(StgInt16 a) {
+ return a - STG_INT16_MAX;
+}
+
+StgInt32 f_int32(StgInt32 a) {
+ return a - STG_INT32_MAX;
+}
+
+StgInt64 f_int64(StgInt64 a) {
+ return a - STG_INT64_MAX;
+}
+
+StgWord f_word(StgWord a) {
+ return a - STG_WORD_MAX;
+}
+
+StgWord8 f_word8(StgWord8 a) {
+ return a - STG_WORD8_MAX;
+}
+
+StgWord16 f_word16(StgWord16 a) {
+ return a - STG_WORD16_MAX;
+}
+
+StgWord32 f_word32(StgWord32 a) {
+ return a - STG_WORD32_MAX;
+}
+
+StgWord64 f_word64(StgWord64 a) {
+ return a - STG_WORD64_MAX;
+}
+
+StgFloat f_float(StgFloat a) {
+ StgFloat a1 = a;
+ return (a / a1) - 1;
+}
+
+StgDouble f_double(StgDouble a, StgDouble b) {
+ return fmod(a, b);
+}
+
+void* f_addr(void* a) {
+ return a;
+}
+
+void* f_stable_ptr(void* a) {
+ return a;
+}
diff --git a/testsuite/tests/ffi/should_run/T14624_c.h b/testsuite/tests/ffi/should_run/T14624_c.h
new file mode 100644
index 0000000000..4a7cb254a6
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T14624_c.h
@@ -0,0 +1,17 @@
+#include "Rts.h"
+
+StgChar f_char(StgChar);
+StgInt f_int(StgInt);
+StgInt8 f_int8(StgInt8);
+StgInt16 f_int16(StgInt16);
+StgInt32 f_int32(StgInt32);
+StgInt64 f_int64(StgInt64);
+StgWord f_word(StgWord);
+StgWord8 f_word8(StgWord8);
+StgWord16 f_word16(StgWord16);
+StgWord32 f_word32(StgWord32);
+StgWord64 f_word64(StgWord64);
+StgFloat f_float(StgFloat);
+StgDouble f_double(StgDouble, StgDouble);
+void* f_addr(void*);
+void* f_stable_ptr(void*);
diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T
index 5402de20c7..b6d0a8e1c3 100644
--- a/testsuite/tests/ffi/should_run/all.T
+++ b/testsuite/tests/ffi/should_run/all.T
@@ -187,6 +187,8 @@ test('T12134', [omit_ways(['ghci'])], compile_and_run, ['T12134_c.c'])
test('T12614', [omit_ways(['ghci'])], compile_and_run, ['T12614_c.c'])
+test('T14624', [omit_ways(['ghci'])], compile_and_run, ['T14624_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'])