summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Builtin/Names.hs12
-rw-r--r--compiler/GHC/HsToCore/Foreign/C.hs12
-rw-r--r--docs/users_guide/9.6.1-notes.rst3
-rw-r--r--docs/users_guide/exts/ffi.rst12
-rw-r--r--libraries/base/Foreign/C/Types.hs6
-rw-r--r--testsuite/tests/ffi/should_compile/T22034.h2
-rw-r--r--testsuite/tests/ffi/should_compile/T22034.hs10
-rw-r--r--testsuite/tests/ffi/should_compile/T22034_c.c9
-rw-r--r--testsuite/tests/ffi/should_compile/all.T1
9 files changed, 62 insertions, 5 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 07a3bd2f9d..a9802e3e95 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_TYPES :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic")
@@ -627,6 +627,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_TYPES = mkBaseModule (fsLit "Foreign.C.Types")
gHC_SRCLOC :: Module
gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
@@ -1665,6 +1666,10 @@ fingerprintDataConName :: Name
fingerprintDataConName =
dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey
+constPtrConName :: Name
+constPtrConName =
+ tcQual fOREIGN_C_TYPES (fsLit "ConstPtr") constPtrTyConKey
+
{-
************************************************************************
* *
@@ -1866,7 +1871,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
@@ -2077,6 +2082,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..28ef42e2b9 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 (#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)
@@ -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 dfd800d11b..ef3078bbfa 100644
--- a/docs/users_guide/9.6.1-notes.rst
+++ b/docs/users_guide/9.6.1-notes.rst
@@ -157,6 +157,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..f23c223279 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.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 f2c83c4203..7f74a07bc8 100644
--- a/libraries/base/Foreign/C/Types.hs
+++ b/libraries/base/Foreign/C/Types.hs
@@ -86,8 +86,11 @@ 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 )
@@ -223,6 +226,9 @@ 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
new file mode 100644
index 0000000000..26c49d3a38
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/T22034.h
@@ -0,0 +1,2 @@
+const int *foo();
+const double *bar;
diff --git a/testsuite/tests/ffi/should_compile/T22034.hs b/testsuite/tests/ffi/should_compile/T22034.hs
new file mode 100644
index 0000000000..8c065c3ea1
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/T22034.hs
@@ -0,0 +1,10 @@
+{-# 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
new file mode 100644
index 0000000000..e70b5a978f
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/T22034_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..532f5c3854 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('T22034', [omit_ways(['ghci'])], compile, [''])
View Lorry Controller Status