diff options
-rw-r--r-- | compiler/GHC/Builtin/Names.hs | 12 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Foreign/C.hs | 12 | ||||
-rw-r--r-- | docs/users_guide/9.6.1-notes.rst | 3 | ||||
-rw-r--r-- | docs/users_guide/exts/ffi.rst | 12 | ||||
-rw-r--r-- | libraries/base/Data/Data.hs | 4 | ||||
-rw-r--r-- | libraries/base/Foreign/C/ConstPtr.hs | 45 | ||||
-rw-r--r-- | libraries/base/Foreign/Storable.hs | 6 | ||||
-rw-r--r-- | libraries/base/base.cabal | 1 | ||||
-rw-r--r-- | libraries/base/changelog.md | 8 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_compile/T22043.h | 2 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_compile/T22043.hs | 11 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_compile/T22043_c.c | 9 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_compile/all.T | 1 |
13 files changed, 118 insertions, 8 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 780c0738b3..3d8a990622 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, + stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, 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 :: Module + dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_CONSTPTR :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic") @@ -626,6 +626,7 @@ 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_CONSTPTR = mkBaseModule (fsLit "Foreign.C.ConstPtr") gHC_SRCLOC :: Module gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") @@ -1664,6 +1665,10 @@ fingerprintDataConName :: Name fingerprintDataConName = dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey +constPtrConName :: Name +constPtrConName = + tcQual fOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey + {- ************************************************************************ * * @@ -1865,7 +1870,7 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, eqReprPrimTyConKey, eqPhantPrimTyConKey, compactPrimTyConKey, stackSnapshotPrimTyConKey, - promptTagPrimTyConKey :: Unique + promptTagPrimTyConKey, constPtrTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 @@ -2076,6 +2081,7 @@ 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 160e9acc97..b937c00df7 100644 --- a/compiler/GHC/HsToCore/Foreign/C.hs +++ b/compiler/GHC/HsToCore/Foreign/C.hs @@ -246,10 +246,18 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header -> DsM ([(Id, Expr TyVar)], CHeader, CStub) dsFCall fn_id co fcall mDeclHeader = do let - ty = coercionLKind co + (ty,ty1) = (coercionLKind co, coercionRKind co) (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty (arg_tys, io_res_ty) = tcSplitFunTys rho + let constQual -- provide 'const' qualifier (#22043) + | (_, res_ty1) <- tcSplitFunTys ty1 + , newty <- maybe res_ty1 snd (tcSplitIOType_maybe res_ty1) + , Just (ptr, _) <- splitTyConApp_maybe newty + , tyConName ptr == constPtrConName + = text "const" + | otherwise = empty + args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) @@ -277,7 +285,7 @@ dsFCall fn_id co fcall mDeclHeader = do includes = vcat [ text "#include \"" <> ftext h <> text "\"" | Header _ h <- nub headers ] - fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes + fun_proto = constQual <+> 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 e78972a919..f0961348f3 100644 --- a/docs/users_guide/9.6.1-notes.rst +++ b/docs/users_guide/9.6.1-notes.rst @@ -167,6 +167,9 @@ 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 b490ac662d..37d96a0a68 100644 --- a/docs/users_guide/exts/ffi.rst +++ b/docs/users_guide/exts/ffi.rst @@ -437,6 +437,18 @@ 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.ConstPtr` 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/Data/Data.hs b/libraries/base/Data/Data.hs index b6102d4cf3..1a081484a9 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -140,6 +140,7 @@ import Data.Word -- So we can give Data instance for Word8, ... import GHC.Real -- So we can give Data instance for Ratio --import GHC.IOBase -- So we can give Data instance for IO, Handle import GHC.Ptr -- So we can give Data instance for Ptr +import Foreign.C.ConstPtr -- So we can give Data instance for ConstPtr import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr import Foreign.Ptr (IntPtr(..), WordPtr(..)) -- So we can give Data instance for IntPtr and WordPtr @@ -1227,6 +1228,9 @@ instance Data a => Data (Ptr a) where dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr" dataCast1 x = gcast1 x +-- | @since 4.18.0.0 +deriving instance Data a => Data (ConstPtr a) + ------------------------------------------------------------------------------ -- | @since 4.8.0.0 diff --git a/libraries/base/Foreign/C/ConstPtr.hs b/libraries/base/Foreign/C/ConstPtr.hs new file mode 100644 index 0000000000..5e5d06cf95 --- /dev/null +++ b/libraries/base/Foreign/C/ConstPtr.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.C.ConstPtr +-- Copyright : (c) GHC Developers +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- This module provides typed @const@ pointers to foreign data. It is part +-- of the Foreign Function Interface (FFI). +-- +----------------------------------------------------------------------------- + +module Foreign.C.ConstPtr ( + ConstPtr(..) +) where + +import GHC.Base +import GHC.Ptr +import GHC.Show + +-- | A pointer with the C @const@ qualifier. For instance, an argument of type +-- @ConstPtr CInt@ would be marshalled as @const int*@. +-- +-- While @const@-ness generally does not matter for @ccall@ imports (since +-- @const@ and non-@const@ pointers typically have equivalent calling +-- conventions), it does matter for @capi@ imports. See GHC #22043. +-- +-- @since 4.18.0.0 +-- +type ConstPtr :: Type -> Type +type role ConstPtr phantom +newtype ConstPtr a = ConstPtr { unConstPtr :: Ptr a } + deriving (Eq, Ord) + +-- doesn't use record syntax +instance Show (ConstPtr a) where + showsPrec d (ConstPtr p) = showParen (d > 10) $ showString "ConstPtr " . showsPrec 11 p diff --git a/libraries/base/Foreign/Storable.hs b/libraries/base/Foreign/Storable.hs index 844ec7a494..25d8cf1b02 100644 --- a/libraries/base/Foreign/Storable.hs +++ b/libraries/base/Foreign/Storable.hs @@ -1,5 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | @@ -42,6 +45,7 @@ import GHC.Word import GHC.Ptr import GHC.Base import GHC.Fingerprint.Type +import Foreign.C.ConstPtr import Data.Bits import GHC.Real @@ -280,3 +284,5 @@ pokeFingerprint p0 (Fingerprint high low) = do pokeW64 (castPtr p0) 8 high pokeW64 (castPtr p0 `plusPtr` 8) 8 low + +deriving newtype instance Storable (ConstPtr a) diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index a57335db1d..d615108c58 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -169,6 +169,7 @@ Library Debug.Trace Foreign Foreign.C + Foreign.C.ConstPtr Foreign.C.Error Foreign.C.String Foreign.C.Types diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index e9318b2414..4e8d5e6078 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -1,9 +1,11 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) ## 4.18.0.0 *TBA* + * `Foreign.C.ConstPtr.ConstrPtr` was added to encode `const`-qualified + pointer types in foreign declarations when using `CApiFFI` extension. ([CLC proposal #117](https://github.com/haskell/core-libraries-committee/issues/117)) * Add `forall a. Functor (p a)` superclass for `Bifunctor p` ([CLC proposal #91](https://github.com/haskell/core-libraries-committee/issues/91)) - * Add `Functor` instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and - `(,,,,,) a b c d e f` + * Add Functor instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and + `(,,,,,) a b c d e f`. * Exceptions thrown by weak pointer finalizers are now reported via a global exception handler. * Add `GHC.Weak.Finalize.{get,set}FinalizerExceptionHandler` which allows the @@ -42,7 +44,7 @@ ([CLC proposal #90](https://github.com/haskell/core-libraries-committee/issues/90)) * Add `Eq` and `Ord` instances for `Generically1`. * Relax instances for Functor combinators; put superclass on Class1 and Class2 - to make non-breaking ([CLC proposal #10](https://github.com/haskell/core-libraries-committee/issues/10), + to make non-breaking ([CLC proposal #10](https://github.com/haskell/core-libraries-committee/issues/10), [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/functor-combinator-instances-and-class1s.md)) * Add `gcdetails_block_fragmentation_bytes` to `GHC.Stats.GCDetails` to track heap fragmentation. * `GHC.TypeLits` and `GHC.TypeNats` now export the `natSing`, `symbolSing`, diff --git a/testsuite/tests/ffi/should_compile/T22043.h b/testsuite/tests/ffi/should_compile/T22043.h new file mode 100644 index 0000000000..26c49d3a38 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/T22043.h @@ -0,0 +1,2 @@ +const int *foo(); +const double *bar; diff --git a/testsuite/tests/ffi/should_compile/T22043.hs b/testsuite/tests/ffi/should_compile/T22043.hs new file mode 100644 index 0000000000..4e2b7b7e0c --- /dev/null +++ b/testsuite/tests/ffi/should_compile/T22043.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CApiFFI #-} +module T22043 where + +import Foreign.C.Types +import Foreign.C.ConstPtr + +foreign import capi "T22043.h foo" + c_foo :: IO (ConstPtr CInt) + +foreign import capi "T22043.h value bar" + c_bar :: ConstPtr CDouble diff --git a/testsuite/tests/ffi/should_compile/T22043_c.c b/testsuite/tests/ffi/should_compile/T22043_c.c new file mode 100644 index 0000000000..e70b5a978f --- /dev/null +++ b/testsuite/tests/ffi/should_compile/T22043_c.c @@ -0,0 +1,9 @@ +#include <stdlib.h> + +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 d8afeb9f7b..6b4c557a07 100644 --- a/testsuite/tests/ffi/should_compile/all.T +++ b/testsuite/tests/ffi/should_compile/all.T @@ -43,3 +43,4 @@ test( ], ) test('T15531', normal, compile, ['-Wall']) +test('T22043', [omit_ways(['ghci'])], compile, ['']) |