[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: compiler: Allow more types in GHCForeignImportPrim
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Apr 4 22:20:25 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f4a1d762 by Ben Gamari at 2024-04-04T18:20:01-04:00
compiler: Allow more types in GHCForeignImportPrim
For many, many years `GHCForeignImportPrim` has suffered from the rather
restrictive limitation of not allowing any non-trivial types in arguments
or results. This limitation was justified by the code generator allegely
barfing in the presence of such types.
However, this restriction appears to originate well before the NCG
rewrite and the new NCG does not appear to have any trouble with such
types (see the added `T24598` test). Lift this restriction.
Fixes #24598.
- - - - -
c52eb51a by Alan Zimmerman at 2024-04-04T18:20:02-04:00
EPA: Use EpaLocation not SrcSpan in ForeignDecls
This allows us to update them for makeDeltaAst in ghc-exactprint
- - - - -
19 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- compiler/GHC/ThToHs.hs
- testsuite/tests/ffi/should_fail/ccfail001.stderr
- + testsuite/tests/ffi/should_run/T24598.hs
- + testsuite/tests/ffi/should_run/T24598.stdout
- + testsuite/tests/ffi/should_run/T24598_cmm.cmm
- + testsuite/tests/ffi/should_run/T24598b.hs
- + testsuite/tests/ffi/should_run/T24598b.stdout
- + testsuite/tests/ffi/should_run/T24598b_cmm.cmm
- + testsuite/tests/ffi/should_run/T24598c.hs
- + testsuite/tests/ffi/should_run/T24598c.stdout
- + testsuite/tests/ffi/should_run/T24598c_cmm.cmm
- testsuite/tests/ffi/should_run/all.T
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1131,10 +1131,10 @@ type instance XForeignExport GhcTc = Coercion
type instance XXForeignDecl (GhcPass _) = DataConCantHappen
-type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity
+type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
type instance XXForeignImport (GhcPass _) = DataConCantHappen
-type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity
+type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
type instance XXForeignExport (GhcPass _) = DataConCantHappen
-- pretty printing of foreign declarations
@@ -1399,6 +1399,6 @@ type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (Maybe Role) = EpAnnCO
-type instance Anno CCallConv = SrcSpan
-type instance Anno Safety = SrcSpan
-type instance Anno CExportSpec = SrcSpan
+type instance Anno CCallConv = EpaLocation
+type instance Anno Safety = EpaLocation
+type instance Anno CExportSpec = EpaLocation
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2095,15 +2095,15 @@ instance ToHie (LocatedA (ForeignDecl GhcRn)) where
instance ToHie (ForeignImport GhcRn) where
toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $
- [ locOnly a
- , locOnly b
- , locOnly c
+ [ locOnlyE a
+ , locOnlyE b
+ , locOnlyE c
]
instance ToHie (ForeignExport GhcRn) where
toHie (CExport (L b _) (L a _)) = concatM $
- [ locOnly a
- , locOnly b
+ [ locOnlyE a
+ , locOnlyE b
]
instance ToHie (LocatedA (WarnDecls GhcRn)) where
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -533,6 +533,10 @@ locOnly (RealSrcSpan span _) = do
pure [Node e span []]
locOnly _ = pure []
+locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a]
+locOnlyE (EpaSpan s) = locOnly s
+locOnlyE _ = pure []
+
mkScope :: (HasLoc a) => a -> Scope
mkScope a = case getHasLoc a of
(RealSrcSpan sp _) -> LocalScope sp
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -39,6 +39,7 @@ module GHC.Parser.Annotation (
-- ** Annotations in 'GenLocated'
LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,
SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,
+ LocatedE,
-- ** Annotation data types used in 'GenLocated'
@@ -644,6 +645,8 @@ type SrcSpanAnnL = EpAnn AnnList
type SrcSpanAnnP = EpAnn AnnPragma
type SrcSpanAnnC = EpAnn AnnContext
+type LocatedE = GenLocated EpaLocation
+
-- | General representation of a 'GenLocated' type carrying a
-- parameterised annotation type.
type LocatedAn an = GenLocated (EpAnn an)
@@ -1049,9 +1052,12 @@ reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a
class HasAnnotation e where
noAnnSrcSpan :: SrcSpan -> e
-instance HasAnnotation (SrcSpan) where
+instance HasAnnotation SrcSpan where
noAnnSrcSpan l = l
+instance HasAnnotation EpaLocation where
+ noAnnSrcSpan l = EpaSpan l
+
instance (NoAnn ann) => HasAnnotation (EpAnn ann) where
noAnnSrcSpan l = EpAnn (spanAsAnchor l) noAnn emptyComments
@@ -1452,6 +1458,10 @@ instance (Outputable a, OutputableBndr e)
pprInfixOcc = pprInfixOcc . unLoc
pprPrefixOcc = pprPrefixOcc . unLoc
+instance (Outputable e)
+ => Outputable (GenLocated EpaLocation e) where
+ ppr = pprLocated
+
instance Outputable ParenType where
ppr t = text (show t)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2766,7 +2766,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
-- name (cf section 8.5.1 in Haskell 2010 report).
mkCImport = do
let e = unpackFS entity
- case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
+ case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of
Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $
PsErrMalformedEntityString
Just importSpec -> return importSpec
@@ -2782,7 +2782,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
then mkExtName (unLoc v)
else entity
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
- importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget
+ importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget
returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport
{ fd_i_ext = ann
@@ -2796,7 +2796,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
-- the string "foo" is ambiguous: either a header or a C identifier. The
-- C identifier case comes first in the alternatives below, so we pick
-- that one.
-parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
+parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String
-> Located SourceText
-> Maybe (ForeignImport (GhcPass p))
parseCImport cconv safety nm str sourceText =
@@ -2826,7 +2826,7 @@ parseCImport cconv safety nm str sourceText =
| id_char c -> pfail
_ -> return ()
- mk h n = CImport sourceText cconv safety h n
+ mk h n = CImport (reLoc sourceText) (reLoc cconv) (reLoc safety) h n
hdr_char c = not (isSpace c)
-- header files are filenames, which can contain
@@ -2861,7 +2861,7 @@ mkExport :: Located CCallConv
mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
= return $ \ann -> ForD noExtField $
ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty
- , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) }
+ , fd_fe = CExport (L (l2l le) esrc) (L (l2l lc) (CExportStatic esrc entity' cconv)) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -84,7 +84,6 @@ import Control.Monad.Trans.Writer.CPS
import Control.Monad.Trans.Class
( lift )
import Data.Maybe (isJust)
-import GHC.Types.RepType (tyConPrimRep)
import GHC.Builtin.Types (unitTyCon)
-- Defines a binding
@@ -737,7 +736,6 @@ marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind
marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon dflags tc
| marshalablePrimTyCon tc
- , not (null (tyConPrimRep tc)) -- Note [Marshalling void]
= validIfUnliftedFFITypes dflags
| otherwise
= boxedMarshalableTyCon tc
@@ -772,7 +770,6 @@ legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledRe
-- types and also unboxed tuple and sum result types.
legalFIPrimResultTyCon dflags tc
| marshalablePrimTyCon tc
- , not (null (tyConPrimRep tc)) -- Note [Marshalling void]
= validIfUnliftedFFITypes dflags
| isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc
@@ -786,13 +783,3 @@ validIfUnliftedFFITypes dflags
| xopt LangExt.UnliftedFFITypes dflags = IsValid
| otherwise = NotValid UnliftedFFITypesNeeded
-{-
-Note [Marshalling void]
-~~~~~~~~~~~~~~~~~~~~~~~
-We don't treat State# (whose PrimRep is VoidRep) as marshalable.
-In turn that means you can't write
- foreign import foo :: Int -> State# RealWorld
-
-Reason: the back end falls over with panic "primRepHint:VoidRep";
- and there is no compelling reason to permit it
--}
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -799,7 +799,8 @@ cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD (ImportF callconv safety from nm ty) =
- do { l <- getL
+ do { ls <- getL
+ ; let l = l2l ls
; if -- the prim and javascript calling conventions do not support headers
-- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
| callconv == TH.Prim || callconv == TH.JavaScript
@@ -809,7 +810,7 @@ cvtForD (ImportF callconv safety from nm ty) =
True)))
| Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')
(mkFastString (TH.nameBase nm))
- from (L l $ quotedSourceText from)
+ from (L ls $ quotedSourceText from)
-> mk_imp impspec
| otherwise
-> failWith $ InvalidCCallImpent from }
@@ -831,7 +832,8 @@ cvtForD (ImportF callconv safety from nm ty) =
cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
- ; l <- getL
+ ; ls <- getL
+ ; let l = l2l ls
; let astxt = mkFastString as
; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt)
astxt
=====================================
testsuite/tests/ffi/should_fail/ccfail001.stderr
=====================================
@@ -1,6 +1,8 @@
-ccfail001.hs:10:1: error: [GHC-89401]
+ccfail001.hs:10:1: error: [GHC-10964]
• Unacceptable result type in foreign declaration:
‘State# RealWorld’ cannot be marshalled in a foreign call
+ UnliftedFFITypes is required to marshal unlifted types
• When checking declaration:
foreign import ccall safe foo :: Int -> State# RealWorld
+ Suggested fix: Perhaps you intended to use UnliftedFFITypes
=====================================
testsuite/tests/ffi/should_run/T24598.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+
+-- | Test that `foreign import prim` imports handle `State#` in results correctly.
+module Main where
+
+import GHC.IO
+import GHC.Int
+import GHC.Exts
+
+foreign import prim "hello"
+ hello# :: State# RealWorld -> (# State# RealWorld, Int# #)
+
+main :: IO ()
+main = hello >>= print
+
+hello :: IO Int
+hello = IO $ \s -> case hello# s of (# s', n# #) -> (# s', I# n# #)
=====================================
testsuite/tests/ffi/should_run/T24598.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/ffi/should_run/T24598_cmm.cmm
=====================================
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+
+hello() {
+ return (42);
+}
=====================================
testsuite/tests/ffi/should_run/T24598b.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.Int
+import GHC.Exts
+
+foreign import prim "hello"
+ hello# :: Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
+
+main :: IO ()
+main = hello 21 >>= print
+
+hello :: Int -> IO Int
+hello (I# n#) = IO $ \s ->
+ case hello# n# s of (# s', n# #) -> (# s', I# n# #)
+
=====================================
testsuite/tests/ffi/should_run/T24598b.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/ffi/should_run/T24598b_cmm.cmm
=====================================
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+
+hello(W_ n) {
+ return (2*n);
+}
=====================================
testsuite/tests/ffi/should_run/T24598c.hs
=====================================
@@ -0,0 +1,21 @@
+{-# 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
+
+foreign import prim "hello"
+ hello# :: State# RealWorld -> State# RealWorld
+
+main :: IO ()
+main = hello
+
+hello :: IO ()
+hello = IO $ \s ->
+ case hello# s of s' -> (# s', () #)
+
=====================================
testsuite/tests/ffi/should_run/T24598c.stdout
=====================================
@@ -0,0 +1 @@
+hello
=====================================
testsuite/tests/ffi/should_run/T24598c_cmm.cmm
=====================================
@@ -0,0 +1,15 @@
+#include "Cmm.h"
+
+#if !defined(UnregisterisedCompiler)
+import CLOSURE test_str;
+#endif
+
+section "data" {
+ test_str: bits8[] "hello";
+}
+
+hello() {
+ CInt r;
+ (r) = ccall puts(test_str "ptr");
+ return ();
+}
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -268,3 +268,7 @@ test('T24314',
# libffi-wasm doesn't support more than 4 args yet
when(arch('wasm32'), skip)],
compile_and_run, ['T24314_c.c'])
+
+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'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -738,9 +738,9 @@ printStringAtAAC capture (EpaDelta d cs) s = do
-- ---------------------------------------------------------------------
-markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m ()
-markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return ()
-markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return ()
+markExternalSourceTextE :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation
+markExternalSourceTextE l NoSourceText txt = printStringAtAA l txt
+markExternalSourceTextE l (SourceText txt) _ = printStringAtAA l (unpackFS txt)
-- ---------------------------------------------------------------------
@@ -1587,6 +1587,15 @@ instance (ExactPrint a) => ExactPrint (Located a) where
exact (L l a) = L l <$> markAnnotated a
+instance (ExactPrint a) => ExactPrint (LocatedE a) where
+ getAnnotationEntry (L l _) = Entry l [] emptyComments NoFlushComments CanUpdateAnchorOnly
+ setAnnotationAnchor (L _ a) anc _ts _cs = L anc a
+
+ exact (L la a) = do
+ debugM $ "LocatedE a:la loc=" ++ show (ss2range $ locA la)
+ a' <- markAnnotated a
+ return (L la a')
+
instance (ExactPrint a) => ExactPrint (LocatedA a) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs
@@ -2009,11 +2018,15 @@ instance ExactPrint (ForeignDecl GhcPs) where
instance ExactPrint (ForeignImport GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do
+ exact (CImport (L ls src) cconv safety@(L l _) mh imp) = do
cconv' <- markAnnotated cconv
- unless (ll == noSrcSpan) $ markAnnotated safety >> return ()
- unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return ()
- return (CImport (L ls src) cconv' safety mh imp)
+ safety' <- if notDodgyE l
+ then markAnnotated safety
+ else return safety
+ ls' <- if notDodgyE ls
+ then markExternalSourceTextE ls src ""
+ else return ls
+ return (CImport (L ls' src) cconv' safety' mh imp)
-- ---------------------------------------------------------------------
@@ -2023,8 +2036,10 @@ instance ExactPrint (ForeignExport GhcPs) where
exact (CExport (L ls src) spec) = do
debugM $ "CExport starting"
spec' <- markAnnotated spec
- unless (ls == noSrcSpan) $ markExternalSourceText ls src ""
- return (CExport (L ls src) spec')
+ ls' <- if notDodgyE ls
+ then markExternalSourceTextE ls src ""
+ else return ls
+ return (CExport (L ls' src) spec')
-- ---------------------------------------------------------------------
@@ -3240,6 +3255,12 @@ markMaybeDodgyStmts an stmts =
return (an, r)
else return (an, stmts)
+notDodgyE :: EpaLocation -> Bool
+notDodgyE anc =
+ case anc of
+ EpaSpan s -> isGoodSrcSpan s
+ EpaDelta{} -> True
+
-- ---------------------------------------------------------------------
instance ExactPrint (HsPragE GhcPs) where
getAnnotationEntry HsPragSCC{} = NoEntryVal
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/94543adb99830343aa651973697a36342450cee5...c52eb51a530ef4e6e6cf108056e87a74aecdeae1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/94543adb99830343aa651973697a36342450cee5...c52eb51a530ef4e6e6cf108056e87a74aecdeae1
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240404/78de0ee8/attachment-0001.html>
More information about the ghc-commits
mailing list