diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index d9ded5a883d32dee44e4416fb9de6d29c9493f89..2c228b58e0f6a14866de6db6b1d78cd7a45ab454 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -1564,6 +1564,7 @@ data PrimRep data PrimOrVoidRep = VoidRep | NVRep PrimRep -- See Note [VoidRep] in GHC.Types.RepType + deriving (Data.Data, Eq, Ord, Show) data PrimElemRep = Int8ElemRep diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index b3e6a98d45b7e1cdcc3fc238645ca6f16f057095..ee5d42d96c0c5f3a98f3cea6c9cb15b8c6adba75 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -47,6 +47,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import Data.Maybe +import GHC.Types.RepType (typePrimRep1) {- Desugaring of @ccall@s consists of adding some state manipulation, @@ -137,7 +138,9 @@ unboxArg :: CoreExpr -- The supplied argument, not representa unboxArg arg -- Primitive types: nothing to unbox - | isPrimitiveType arg_ty + | isPrimitiveType arg_ty || + -- Same for (# #) + (isUnboxedTupleType arg_ty && typePrimRep1 arg_ty == VoidRep) = return (arg, \body -> body) -- Recursive newtypes diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 4483c7d65d81bc2debad63de9496924d00c71a6f..e1870c50448501112130153dd76768f91a161116 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -85,6 +85,7 @@ import Control.Monad.Trans.Class ( lift ) import Data.Maybe (isJust) import GHC.Builtin.Types (unitTyCon) +import GHC.Types.RepType (typePrimRep1) -- Defines a binding isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool @@ -297,7 +298,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh l@(CLabel return (CImport src (L lc cconv') safety mh l) tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper) = do - -- Foreign wrapper (former f.e.d.) + -- Foreign wrapper (former foreign export dynamic) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. -- The use of the latter form is DEPRECATED, though. @@ -463,6 +464,21 @@ tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic esrc str cconv))) = ------------ Checking argument types for foreign import ---------------------- checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM () +checkForeignArgs _pred [(Scaled mult ty)] + -- If there is a single argument allow: + -- foo :: (# #) -> T + | isUnboxedTupleType ty + , VoidRep <- typePrimRep1 ty + = do + checkNoLinearFFI mult + dflags <- getDynFlags + case (validIfUnliftedFFITypes dflags) of + IsValid -> checkNoLinearFFI mult + NotValid needs_uffi -> addErrTc $ + TcRnIllegalForeignType + (Just Arg) + (TypeCannotBeMarshaled ty needs_uffi) + -- = check (validIfUnliftedFFITypes dflags) (TypeCannotBeMarshaled (Just Arg)) >> checkNoLinearFFI mult checkForeignArgs pred tys = mapM_ go tys where go (Scaled mult ty) = checkNoLinearFFI mult >> diff --git a/docs/users_guide/9.12.1-notes.rst b/docs/users_guide/9.12.1-notes.rst index 61d3ddf1ab553d911f69a77cdde8567b3e88e47f..834c8a51a7df685530858420a27b06225d09f436 100644 --- a/docs/users_guide/9.12.1-notes.rst +++ b/docs/users_guide/9.12.1-notes.rst @@ -32,6 +32,9 @@ Language - Unboxed Float#/Double# literals now support the HexFloatLiterals extension (`#22155 <https://gitlab.haskell.org/ghc/ghc/-/issues/22155>`_). +- UnliftedFFITypes: GHC will now accept ffi types like: ``(# #) -> T`` where ``(# #)`` + is used as the one and only function argument. + Compiler ~~~~~~~~ diff --git a/docs/users_guide/exts/ffi.rst b/docs/users_guide/exts/ffi.rst index e3bf1a75727ea535059d8df6ff39d785594c04fd..8de4bce3cffeb01e86475d809debfcf80ad2f0bf 100644 --- a/docs/users_guide/exts/ffi.rst +++ b/docs/users_guide/exts/ffi.rst @@ -121,9 +121,13 @@ Unlifted FFI Types The following unlifted unboxed types may be used as basic foreign types (see FFI Chapter, Section 8.6) for both ``safe`` and ``unsafe`` foreign calls: ``Int#``, ``Word#``, ``Char#``, ``Float#``, -``Double#``, ``Addr#``, and ``StablePtr# a``. Several unlifted boxed -types may be used as arguments to FFI calls, subject to these -restrictions: +``Double#``, ``Addr#``, and ``StablePtr# a``. +Additionally ``(# #)`` can be used if it's the first and only function argument. +This allows more flexible importing of functions which don't require ordering +through IO. + +Several unlifted boxed types may be used as arguments to FFI calls, +subject to these restrictions: * Valid arguments for ``foreign import unsafe`` FFI calls: ``Array#``, ``SmallArray#``, ``ByteArray#``, and the mutable diff --git a/testsuite/tests/ffi/should_run/T24818.hs b/testsuite/tests/ffi/should_run/T24818.hs new file mode 100644 index 0000000000000000000000000000000000000000..66acd3f3ab11bd01b703489d7bfdd1de50b326db --- /dev/null +++ b/testsuite/tests/ffi/should_run/T24818.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE MagicHash #-} + +-- | Test that `foreign import prim` imports handle `State#` in arguments correctly. +module Main where + +-- import GHC.IO +import GHC.Exts +import GHC.Int + +foreign import prim "a_number_cmm" + cmm_number :: (# #) -> Int# + +foreign import ccall "a_number_c" + c_number :: (# #) -> Int64# + +main :: IO () +main = do + print $ I# (cmm_number (# #)) + print $ I64# (c_number (# #)) diff --git a/testsuite/tests/ffi/should_run/T24818.stdout b/testsuite/tests/ffi/should_run/T24818.stdout new file mode 100644 index 0000000000000000000000000000000000000000..c44a0751a737381e28d3e17299cc0a26383fd004 --- /dev/null +++ b/testsuite/tests/ffi/should_run/T24818.stdout @@ -0,0 +1,2 @@ +37 +38 diff --git a/testsuite/tests/ffi/should_run/T24818_c.c b/testsuite/tests/ffi/should_run/T24818_c.c new file mode 100644 index 0000000000000000000000000000000000000000..7b2796ef4e5547d6358a28aa3c4ade915fb15c96 --- /dev/null +++ b/testsuite/tests/ffi/should_run/T24818_c.c @@ -0,0 +1,8 @@ +#include <stddef.h> +#include <stdint.h> + +int64_t a_number_c(void) +{ + return 38; +} + diff --git a/testsuite/tests/ffi/should_run/T24818_cmm.cmm b/testsuite/tests/ffi/should_run/T24818_cmm.cmm new file mode 100644 index 0000000000000000000000000000000000000000..9248bc56de598e015cf8e0748355d59413423221 --- /dev/null +++ b/testsuite/tests/ffi/should_run/T24818_cmm.cmm @@ -0,0 +1,5 @@ +#include "Cmm.h" + +a_number_cmm() { + return (37); +} diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T index 4dcecb0e098ab2642af615789b6298f5bcc99eba..ef689e7b25aa208da4b25ce587c17f847f9569eb 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -272,3 +272,4 @@ test('T24314', test('T24598', req_cmm, compile_and_run, ['T24598_cmm.cmm']) test('T24598b', req_cmm, compile_and_run, ['T24598b_cmm.cmm']) test('T24598c', req_cmm, compile_and_run, ['T24598c_cmm.cmm']) +test('T24818', [req_cmm, req_c], compile_and_run, ['-XUnliftedFFITypes T24818_cmm.cmm T24818_c.c'])