diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/HsToCore/Foreign/C.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Foreign/Utils.hs | 29 |
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 |