diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-08-26 15:09:03 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-09-08 03:00:22 -0400 |
commit | fb1e0a5da67f075ae4f487e111fcf69d1dfcd42f (patch) | |
tree | bdc550ef2f1f229b01bec816620bf58bfefc358a | |
parent | ebbb1fa20f0acb545e9c35576bc0e6f6ec1170a5 (diff) | |
download | haskell-fb1e0a5da67f075ae4f487e111fcf69d1dfcd42f.tar.gz |
ffi: Don't allow wrapper stub with CApi convention
Fixes #20272
-rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Parser/Errors/Types.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_fail/all.T | 2 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_fail/capi_wrapper.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/ffi/should_fail/capi_wrapper.stderr | 3 |
6 files changed, 28 insertions, 4 deletions
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 1d34129474..9396961cab 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -469,6 +469,7 @@ instance Diagnostic PsMessage where [ text "Parse error" <> colon <+> quotes (ppr arr) , text "Record constructors in GADTs must use an ordinary, non-linear arrow." ] + PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."] diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m @@ -580,6 +581,7 @@ instance Diagnostic PsMessage where PsErrInvalidPackageName{} -> ErrorWithoutFlag PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag + PsErrInvalidCApiImport {} -> ErrorWithoutFlag diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m @@ -737,6 +739,7 @@ instance Diagnostic PsMessage where PsErrUnexpectedTypeInDecl{} -> noHints PsErrInvalidPackageName{} -> noHints PsErrIllegalGadtRecordMultiplicity{} -> noHints + PsErrInvalidCApiImport {} -> noHints psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc psHeaderMessageDiagnostic = \case diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index 8f1df7308e..181f793741 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -440,6 +440,8 @@ data PsMessage -- | Illegal linear arrow or multiplicity annotation in GADT record syntax | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs) + | PsErrInvalidCApiImport + newtype StarIsType = StarIsType Bool -- | Extra details about a parse error, which helps diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 4eab0c1486..af92355240 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2528,9 +2528,13 @@ mkImport :: Located CCallConv -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = case unLoc cconv of - CCallConv -> mkCImport - CApiConv -> mkCImport - StdCallConv -> mkCImport + CCallConv -> returnSpec =<< mkCImport + CApiConv -> do + imp <- mkCImport + if isCWrapperImport imp + then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport + else returnSpec imp + StdCallConv -> returnSpec =<< mkCImport PrimCallConv -> mkOtherImport JavaScriptCallConv -> mkOtherImport where @@ -2543,7 +2547,10 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrMalformedEntityString - Just importSpec -> returnSpec importSpec + Just importSpec -> return importSpec + + isCWrapperImport (CImport _ _ _ CWrapper _) = True + isCWrapperImport _ = False -- currently, all the other import conventions only support a symbol name in -- the entity string. If it is missing, we use the function name instead. diff --git a/testsuite/tests/ffi/should_fail/all.T b/testsuite/tests/ffi/should_fail/all.T index afe4370273..ce1c10534e 100644 --- a/testsuite/tests/ffi/should_fail/all.T +++ b/testsuite/tests/ffi/should_fail/all.T @@ -24,3 +24,5 @@ test('UnsafeReenter', [omit_ways(threaded_ways), exit_code(1)], compile_and_run, ['UnsafeReenterC.c']) + +test('capi_wrapper', normal, compile_fail, ['']) diff --git a/testsuite/tests/ffi/should_fail/capi_wrapper.hs b/testsuite/tests/ffi/should_fail/capi_wrapper.hs new file mode 100644 index 0000000000..eb29e617e8 --- /dev/null +++ b/testsuite/tests/ffi/should_fail/capi_wrapper.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CApiFFI #-} +import Foreign + +foreign import capi "wrapper" + wrapBool :: Bool -> IO (FunPtr Bool) + +main = pure () diff --git a/testsuite/tests/ffi/should_fail/capi_wrapper.stderr b/testsuite/tests/ffi/should_fail/capi_wrapper.stderr new file mode 100644 index 0000000000..607e228ddd --- /dev/null +++ b/testsuite/tests/ffi/should_fail/capi_wrapper.stderr @@ -0,0 +1,3 @@ + +capi_wrapper.hs:4:21: error: + Wrapper stubs can't be used with CApiFFI. |