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.

2 files changed, 39 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