summaryrefslogtreecommitdiff
path: root/testsuite/tests/ffi
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 /testsuite/tests/ffi
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.
Diffstat (limited to 'testsuite/tests/ffi')
-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
5 files changed, 152 insertions, 0 deletions
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'])