From b95dab8b0807533de258e5fe985822ae393f5fef Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 18 Jan 2023 14:33:52 -0500 Subject: Revert "CApiFFI: add ConstPtr for encoding const-qualified pointer return types (#22043)" This reverts commit 99aca26b652603bc62953157a48e419f737d352d. --- compiler/GHC/Builtin/Names.hs | 12 +++--------- compiler/GHC/HsToCore/Foreign/C.hs | 12 ++---------- docs/users_guide/9.6.1-notes.rst | 3 --- docs/users_guide/exts/ffi.rst | 12 ------------ libraries/base/Foreign/C/Types.hs | 6 ------ testsuite/tests/ffi/should_compile/T22034.h | 2 -- testsuite/tests/ffi/should_compile/T22034.hs | 10 ---------- testsuite/tests/ffi/should_compile/T22034_c.c | 9 --------- testsuite/tests/ffi/should_compile/all.T | 1 - 9 files changed, 5 insertions(+), 62 deletions(-) delete mode 100644 testsuite/tests/ffi/should_compile/T22034.h delete mode 100644 testsuite/tests/ffi/should_compile/T22034.hs delete mode 100644 testsuite/tests/ffi/should_compile/T22034_c.c diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 691f500a77..780c0738b3 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -350,7 +350,7 @@ basicKnownKeyNames zipName, foldrName, buildName, augmentName, appendName, -- FFI primitive types that are not wired-in. - stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, + stablePtrTyConName, ptrTyConName, funPtrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, @@ -557,7 +557,7 @@ gHC_PRIM, gHC_PRIM_PANIC, aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST, cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL, gHC_TYPENATS, gHC_TYPENATS_INTERNAL, - dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_TYPES :: Module + dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic") @@ -626,7 +626,6 @@ gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal") dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace") uNSAFE_COERCE = mkBaseModule (fsLit "Unsafe.Coerce") -fOREIGN_C_TYPES = mkBaseModule (fsLit "Foreign.C.Types") gHC_SRCLOC :: Module gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") @@ -1665,10 +1664,6 @@ fingerprintDataConName :: Name fingerprintDataConName = dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey -constPtrConName :: Name -constPtrConName = - tcQual fOREIGN_C_TYPES (fsLit "ConstPtr") constPtrTyConKey - {- ************************************************************************ * * @@ -1870,7 +1865,7 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, eqReprPrimTyConKey, eqPhantPrimTyConKey, compactPrimTyConKey, stackSnapshotPrimTyConKey, - promptTagPrimTyConKey, constPtrTyConKey :: Unique + promptTagPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 @@ -2081,7 +2076,6 @@ typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413 typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414 typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415 typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416 -constPtrTyConKey = mkPreludeTyConUnique 417 {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs index 28ef42e2b9..160e9acc97 100644 --- a/compiler/GHC/HsToCore/Foreign/C.hs +++ b/compiler/GHC/HsToCore/Foreign/C.hs @@ -246,18 +246,10 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header -> DsM ([(Id, Expr TyVar)], CHeader, CStub) dsFCall fn_id co fcall mDeclHeader = do let - (ty,ty1) = (coercionLKind co, coercionRKind co) + ty = coercionLKind co (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty (arg_tys, io_res_ty) = tcSplitFunTys rho - let constQual -- provide 'const' qualifier (#22034) - | (_, res_ty1) <- tcSplitFunTys ty1 - , newty <- maybe res_ty1 snd (tcSplitIOType_maybe res_ty1) - , Just (ptr, _) <- splitTyConApp_maybe newty - , tyConName ptr `elem` [constPtrConName] - = text "const" - | otherwise = empty - args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) @@ -285,7 +277,7 @@ dsFCall fn_id co fcall mDeclHeader = do includes = vcat [ text "#include \"" <> ftext h <> text "\"" | Header _ h <- nub headers ] - fun_proto = constQual <+> cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes + fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes cRet | isVoidRes = cCall | otherwise = text "return" <+> cCall diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst index f0961348f3..e78972a919 100644 --- a/docs/users_guide/9.6.1-notes.rst +++ b/docs/users_guide/9.6.1-notes.rst @@ -167,9 +167,6 @@ Runtime system ``ghc`` library ~~~~~~~~~~~~~~~ -- Add `Foreign.C.Types.ConstPtr` was added to encode ``const``-qualified pointer return - types in foreign declarations when using ``CApiFFI`` extension. - ``ghc-heap`` library ~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/exts/ffi.rst b/docs/users_guide/exts/ffi.rst index f23c223279..b490ac662d 100644 --- a/docs/users_guide/exts/ffi.rst +++ b/docs/users_guide/exts/ffi.rst @@ -437,18 +437,6 @@ specified. The syntax looks like: :: data {-# CTYPE "unistd.h" "useconds_t" #-} T = ... newtype {-# CTYPE "useconds_t" #-} T = ... -In case foreign declarations contain ``const``-qualified pointer return -type, `ConstPtr` from :base-ref:`Foreign.C.Types` may be used to -encode this, e.g. :: - - foreign import capi "header.h f" f :: CInt -> ConstPtr CInt - -which corresponds to - -.. code-block:: c - - const *int f(int); - ``hs_thread_done()`` ~~~~~~~~~~~~~~~~~~~~ diff --git a/libraries/base/Foreign/C/Types.hs b/libraries/base/Foreign/C/Types.hs index 7f74a07bc8..f2c83c4203 100644 --- a/libraries/base/Foreign/C/Types.hs +++ b/libraries/base/Foreign/C/Types.hs @@ -86,11 +86,8 @@ module Foreign.C.Types -- Instances of: Eq and Storable , CFile, CFpos, CJmpBuf - - , ConstPtr(..) ) where -import Foreign.Ptr ( Ptr ) import Foreign.Storable import Data.Bits ( Bits(..), FiniteBits(..) ) import Data.Int ( Int8, Int16, Int32, Int64 ) @@ -226,9 +223,6 @@ INTEGRAL_TYPE(CUIntPtr,"uintptr_t",HTYPE_UINTPTR_T) INTEGRAL_TYPE(CIntMax,"intmax_t",HTYPE_INTMAX_T) INTEGRAL_TYPE(CUIntMax,"uintmax_t",HTYPE_UINTMAX_T) --- | Used to produce 'const' qualifier in C code generator -newtype ConstPtr a = ConstPtr { unConstPtr :: Ptr a } deriving newtype (Show, Eq, Storable) - -- C99 types which are still missing include: -- wint_t, wctrans_t, wctype_t diff --git a/testsuite/tests/ffi/should_compile/T22034.h b/testsuite/tests/ffi/should_compile/T22034.h deleted file mode 100644 index 26c49d3a38..0000000000 --- a/testsuite/tests/ffi/should_compile/T22034.h +++ /dev/null @@ -1,2 +0,0 @@ -const int *foo(); -const double *bar; diff --git a/testsuite/tests/ffi/should_compile/T22034.hs b/testsuite/tests/ffi/should_compile/T22034.hs deleted file mode 100644 index 8c065c3ea1..0000000000 --- a/testsuite/tests/ffi/should_compile/T22034.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE CApiFFI #-} -module T22034 where - -import Foreign.C.Types - -foreign import capi "T22034.h foo" - c_foo :: IO (ConstPtr CInt) - -foreign import capi "T22034.h value bar" - c_bar :: ConstPtr CDouble diff --git a/testsuite/tests/ffi/should_compile/T22034_c.c b/testsuite/tests/ffi/should_compile/T22034_c.c deleted file mode 100644 index e70b5a978f..0000000000 --- a/testsuite/tests/ffi/should_compile/T22034_c.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -const int * foo() { - int *x = malloc(sizeof(int)); - *x = 42; - return x; -} - -const int *bar = 0; diff --git a/testsuite/tests/ffi/should_compile/all.T b/testsuite/tests/ffi/should_compile/all.T index 532f5c3854..d8afeb9f7b 100644 --- a/testsuite/tests/ffi/should_compile/all.T +++ b/testsuite/tests/ffi/should_compile/all.T @@ -43,4 +43,3 @@ test( ], ) test('T15531', normal, compile, ['-Wall']) -test('T22034', [omit_ways(['ghci'])], compile, ['']) -- cgit v1.2.1