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.

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