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.

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