From bf2c2c351c62e3ba307187b43ac719a667649c1a Mon Sep 17 00:00:00 2001 From: nineonine Date: Fri, 17 Jun 2022 18:38:38 -0700 Subject: 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. --- compiler/GHC/HsToCore/Foreign/C.hs | 22 +++++----- compiler/GHC/HsToCore/Foreign/Utils.hs | 29 +++++++++++++ testsuite/tests/ffi/should_run/T14624.hs | 53 +++++++++++++++++++++++ testsuite/tests/ffi/should_run/T14624.stdout | 15 +++++++ testsuite/tests/ffi/should_run/T14624_c.c | 65 ++++++++++++++++++++++++++++ testsuite/tests/ffi/should_run/T14624_c.h | 17 ++++++++ testsuite/tests/ffi/should_run/all.T | 2 + 7 files changed, 191 insertions(+), 12 deletions(-) create mode 100644 testsuite/tests/ffi/should_run/T14624.hs create mode 100644 testsuite/tests/ffi/should_run/T14624.stdout create mode 100644 testsuite/tests/ffi/should_run/T14624_c.c create mode 100644 testsuite/tests/ffi/should_run/T14624_c.h 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 +#include +#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']) -- cgit v1.2.1