diff options
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 120 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 117 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Foreign.hs | 188 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/TcType.hs | 98 | ||||
-rw-r--r-- | compiler/GHC/Types/Hint.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Types/Hint/Ppr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Utils/Error.hs | 2 |
7 files changed, 385 insertions, 149 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 2c9b013e17..6cdfe963c7 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -48,6 +48,7 @@ import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc) import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank (Rank(..)) import GHC.Tc.Utils.TcType +import GHC.Types.Basic (UnboxedTupleOrSum(..), unboxedTupleOrSumExtension) import GHC.Types.Error import GHC.Types.FieldLabel (flIsOverloaded) import GHC.Types.Hint.Ppr () -- Outputable GhcHint @@ -712,6 +713,88 @@ instance Diagnostic TcRnMessage where (pprWithArising tidy_wanteds) + TcRnForeignImportPrimExtNotSet _decl + -> mkSimpleDecorated $ + text "Use GHCForeignImportPrim to allow `foreign import prim'." + + TcRnForeignImportPrimSafeAnn _decl + -> mkSimpleDecorated $ + text "The safe/unsafe annotation should not be used with `foreign import prim'." + + TcRnForeignFunctionImportAsValue _decl + -> mkSimpleDecorated $ + text "`value' imports cannot have function types" + + TcRnFunPtrImportWithoutAmpersand _decl + -> mkSimpleDecorated $ + text "possible missing & in foreign import of FunPtr" + + TcRnIllegalForeignDeclBackend _decl _backend expectedBknds + -> mkSimpleDecorated $ text "Illegal foreign declaration:" <+> + case expectedBknds of + COrAsmOrLlvm -> + text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)" + COrAsmOrLlvmOrInterp -> + text "requires interpreted, unregisterised, llvm or native code generation" + + TcRnUnsupportedCallConv _decl unsupportedCC + -> mkSimpleDecorated $ + case unsupportedCC of + StdCallConvUnsupported -> + text "the 'stdcall' calling convention is unsupported on this platform," + $$ text "treating as ccall" + PrimCallConvUnsupported -> + text "The `prim' calling convention can only be used with `foreign import'" + JavaScriptCallConvUnsupported -> + text "The `javascript' calling convention is unsupported on this platform" + + TcRnIllegalForeignType mArgOrResult reason + -> mkSimpleDecorated $ hang msg 2 extra + where + arg_or_res = case mArgOrResult of + Nothing -> empty + Just Arg -> text "argument" + Just Result -> text "result" + msg = hsep [ text "Unacceptable", arg_or_res + , text "type in foreign declaration:"] + extra = + case reason of + TypeCannotBeMarshaled ty why -> + let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" + in case why of + NotADataType -> + quotes (ppr ty) <+> text "is not a data type" + NewtypeDataConNotInScope Nothing -> + hang innerMsg 2 $ text "because its data constructor is not in scope" + NewtypeDataConNotInScope (Just tc) -> + hang innerMsg 2 $ + text "because the data constructor for" + <+> quotes (ppr tc) <+> text "is not in scope" + UnliftedFFITypesNeeded -> + innerMsg $$ text "To marshal unlifted types, use UnliftedFFITypes" + NotABoxedMarshalableTyCon -> innerMsg + ForeignLabelNotAPtr -> + innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)" + NotSimpleUnliftedType -> + innerMsg $$ text "foreign import prim only accepts simple unlifted types" + ForeignDynNotPtr expected ty -> + vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text " Actual:" <+> ppr ty ] + SafeHaskellMustBeInIO -> + text "Safe Haskell is on, all FFI imports must be in the IO monad" + IOResultExpected -> + text "IO result type expected" + UnexpectedNestedForall -> + text "Unexpected nested forall" + LinearTypesNotAllowed -> + text "Linear types are not supported in FFI declarations, see #18472" + OneArgExpected -> + text "One argument expected" + AtLeastOneArgExpected -> + text "At least one argument expected" + TcRnInvalidCIdentifier target + -> mkSimpleDecorated $ + sep [quotes (ppr target) <+> text "is not a valid C identifier"] + diagnosticReason = \case TcRnUnknownMessage m -> diagnosticReason m @@ -955,6 +1038,24 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnWarnDefaulting {} -> WarningWithFlag Opt_WarnTypeDefaults + TcRnForeignImportPrimExtNotSet{} + -> ErrorWithoutFlag + TcRnForeignImportPrimSafeAnn{} + -> ErrorWithoutFlag + TcRnForeignFunctionImportAsValue{} + -> ErrorWithoutFlag + TcRnFunPtrImportWithoutAmpersand{} + -> WarningWithFlag Opt_WarnDodgyForeignImports + TcRnIllegalForeignDeclBackend{} + -> ErrorWithoutFlag + TcRnUnsupportedCallConv _ unsupportedCC + -> case unsupportedCC of + StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions + _ -> ErrorWithoutFlag + TcRnIllegalForeignType{} + -> ErrorWithoutFlag + TcRnInvalidCIdentifier{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -1196,6 +1297,25 @@ instance Diagnostic TcRnMessage where -> noHints TcRnWarnDefaulting {} -> noHints + TcRnForeignImportPrimExtNotSet{} + -> noHints + TcRnForeignImportPrimSafeAnn{} + -> noHints + TcRnForeignFunctionImportAsValue{} + -> noHints + TcRnFunPtrImportWithoutAmpersand{} + -> noHints + TcRnIllegalForeignDeclBackend{} + -> noHints + TcRnUnsupportedCallConv{} + -> noHints + TcRnIllegalForeignType _ reason + -> case reason of + TypeCannotBeMarshaled _ why + | NewtypeDataConNotInScope{} <- why -> [SuggestImportingDataCon] + _ -> noHints + TcRnInvalidCIdentifier{} + -> noHints deriveInstanceErrReasonHints :: Class -> UsingGeneralizedNewtypeDeriving diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 58e984011a..7a44ab08ef 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -57,6 +57,9 @@ module GHC.Tc.Errors.Types ( , HoleError(..) , CoercibleMsg(..) , PotentialInstances(..) + , UnsupportedCallConvention(..) + , ExpectedBackends(..) + , ArgOrResult(..) ) where import GHC.Prelude @@ -68,9 +71,10 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence (EvBindsVar) import GHC.Tc.Types.Origin (CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol), UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing, FRROrigin) import GHC.Tc.Types.Rank (Rank) -import GHC.Tc.Utils.TcType (TcType) +import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType) import GHC.Types.Error import GHC.Types.FieldLabel (FieldLabelString) +import GHC.Types.ForeignCall (CLabelString) import GHC.Types.Name (Name, OccName, getSrcLoc) import GHC.Types.Name.Reader import GHC.Types.SrcLoc @@ -90,6 +94,7 @@ import GHC.Core.PatSyn (PatSyn) import GHC.Core.Predicate (EqRel, predTypeEqRel) import GHC.Core.TyCon (TyCon, TyConFlavour) import GHC.Core.Type (Kind, Type, ThetaType, PredType) +import GHC.Driver.Backend (Backend) import GHC.Unit.State (UnitState) import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic @@ -1689,6 +1694,116 @@ data TcRnMessage where -- (so we should give a Template Haskell hint) -> TcRnMessage + {- TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import + is declared using the @prim@ calling convention without having turned on + the -XGHCForeignImportPrim extension. + + Example(s): + foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #) + + Test cases: None + -} + TcRnForeignImportPrimExtNotSet :: ForeignImport -> TcRnMessage + + {- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe + annotation should not be used with @prim@ foreign imports. + + Example(s): + foreign import prim unsafe "my_primop_cmm" :: ... + + Test cases: None + -} + TcRnForeignImportPrimSafeAnn :: ForeignImport -> TcRnMessage + + {- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@ + imports cannot have function types. + + Example(s): + foreign import capi "math.h value sqrt" f :: CInt -> CInt + + Test cases: ffi/should_fail/capi_value_function + -} + TcRnForeignFunctionImportAsValue :: ForeignImport -> TcRnMessage + + {- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@ + that informs the user of a possible missing @&@ in the declaration of a + foreign import with a 'FunPtr' return type. + + Example(s): + foreign import ccall "f" f :: FunPtr (Int -> IO ()) + + Test cases: ffi/should_compile/T1357 + -} + TcRnFunPtrImportWithoutAmpersand :: ForeignImport -> TcRnMessage + + {- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration + is not compatible with the code generation backend being used. + + Example(s): None + + Test cases: None + -} + TcRnIllegalForeignDeclBackend + :: Either ForeignExport ForeignImport + -> Backend + -> ExpectedBackends + -> TcRnMessage + + {- TcRnUnsupportedCallConv informs the user that the calling convention specified + for a foreign export declaration is not compatible with the target platform. + It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of + @stdcall@ but is otherwise considered an error. + + Example(s): None + + Test cases: None + -} + TcRnUnsupportedCallConv :: Either ForeignExport ForeignImport -> UnsupportedCallConvention -> TcRnMessage + + {- TcRnIllegalForeignType is an error for when a type appears in a foreign + function signature that is not compatible with the FFI. + + Example(s): None + + Test cases: ffi/should_fail/T3066 + ffi/should_fail/ccfail004 + ffi/should_fail/T10461 + ffi/should_fail/T7506 + ffi/should_fail/T5664 + safeHaskell/ghci/p6 + safeHaskell/safeLanguage/SafeLang08 + ffi/should_fail/T16702 + linear/should_fail/LinearFFI + ffi/should_fail/T7243 + -} + TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage + + {- TcRnInvalidCIdentifier indicates a C identifier that is not valid. + + Example(s): + foreign import prim safe "not valid" cmm_test2 :: Int# -> Int# + + Test cases: th/T10638 + -} + TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage + +-- | Specifies which backend code generators where expected for an FFI declaration +data ExpectedBackends + = COrAsmOrLlvm -- ^ C, Asm, or LLVM + | COrAsmOrLlvmOrInterp -- ^ C, Asm, LLVM, or interpreted + deriving Eq + +-- | Specifies which calling convention is unsupported on the current platform +data UnsupportedCallConvention + = StdCallConvUnsupported + | PrimCallConvUnsupported + | JavaScriptCallConvUnsupported + deriving Eq + +-- | Whether the error pertains to a function argument or a result. +data ArgOrResult + = Arg | Result + -- | Which parts of a record field are affected by a particular error or warning. data RecordFieldPart = RecordFieldConstructor !Name diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index b1c38a7166..53e880c0f6 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -266,22 +266,23 @@ tcFImport d = pprPanic "tcFImport" (ppr d) tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) +tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src) -- Foreign import label - = do checkCg checkCOrAsmOrLlvmOrInterp + = do checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) - check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) - cconv' <- checkCConv cconv + check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) + (TcRnIllegalForeignType Nothing) + cconv' <- checkCConv (Right idecl) cconv return (CImport (L lc cconv') safety mh l src) -tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do +tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src) = do -- Foreign wrapper (former f.e.d.) -- 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. - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv + checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv (Right idecl) cconv case arg_tys of [Scaled arg1_mult arg1_ty] -> do checkNoLinearFFI arg1_mult @@ -290,73 +291,66 @@ tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected")) + _ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected) return (CImport (L lc cconv') safety mh CWrapper src) tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh (CFunction target) src) | isDynamicTarget target = do -- Foreign import dynamic - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv + checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv (Right idecl) cconv case arg_tys of -- The first arg must be Ptr or FunPtr [] -> - addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected")) + addErrTc (TcRnIllegalForeignType Nothing AtLeastOneArgExpected) (Scaled arg1_mult arg1_ty:arg_tys) -> do dflags <- getDynFlags let curried_res_ty = mkVisFunTys arg_tys res_ty checkNoLinearFFI arg1_mult check (isFFIDynTy curried_res_ty arg1_ty) - (illegalForeignTyErr argument) + (TcRnIllegalForeignType (Just Arg)) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src | cconv == PrimCallConv = do dflags <- getDynFlags checkTc (xopt LangExt.GHCForeignImportPrim dflags) - (TcRnUnknownMessage $ mkPlainError noHints $ - text "Use GHCForeignImportPrim to allow `foreign import prim'.") - checkCg checkCOrAsmOrLlvmOrInterp - checkCTarget target + (TcRnForeignImportPrimExtNotSet idecl) + checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCTarget idecl target checkTc (playSafe safety) - (TcRnUnknownMessage $ mkPlainError noHints $ - text "The safe/unsafe annotation should not be used with `foreign import prim'.") + (TcRnForeignImportPrimSafeAnn idecl) checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty return idecl | otherwise = do -- Normal foreign import - checkCg checkCOrAsmOrLlvmOrInterp - cconv' <- checkCConv cconv - checkCTarget target + checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + cconv' <- checkCConv (Right idecl) cconv + checkCTarget idecl target dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - checkMissingAmpersand (map scaledThing arg_tys) res_ty + checkMissingAmpersand idecl (map scaledThing arg_tys) res_ty case target of StaticTarget _ _ _ False | not (null arg_tys) -> - addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ - text "`value' imports cannot have function types") + addErrTc (TcRnForeignFunctionImportAsValue idecl) _ -> return () return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src - -- This makes a convenient place to check -- that the C identifier is valid for C -checkCTarget :: CCallTarget -> TcM () -checkCTarget (StaticTarget _ str _ _) = do - checkCg checkCOrAsmOrLlvmOrInterp - checkTc (isCLabelString str) (badCName str) - -checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" +checkCTarget :: ForeignImport -> CCallTarget -> TcM () +checkCTarget idecl (StaticTarget _ str _ _) = do + checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) +checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: [Type] -> Type -> TcM () -checkMissingAmpersand arg_tys res_ty +checkMissingAmpersand :: ForeignImport -> [Type] -> Type -> TcM () +checkMissingAmpersand idecl arg_tys res_ty | null arg_tys && isFunPtrTy res_ty - = addDiagnosticTc $ TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyForeignImports) noHints - (text "possible missing & in foreign import of FunPtr") + = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl | otherwise = return () @@ -420,10 +414,10 @@ tcFExport d = pprPanic "tcFExport" (ppr d) -- ------------ Checking argument types for foreign export ---------------------- tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport -tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do - checkCg checkCOrAsmOrLlvm - checkTc (isCLabelString str) (badCName str) - cconv' <- checkCConv cconv +tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do + checkCg (Left edecl) checkCOrAsmOrLlvm + checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) + cconv' <- checkCConv (Left edecl) cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty return (CExport (L l (CExportStatic esrc str cconv')) src) @@ -441,16 +435,16 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do -} ------------ Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM () +checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM () checkForeignArgs pred tys = mapM_ go tys where go (Scaled mult ty) = checkNoLinearFFI mult >> - check (pred ty) (illegalForeignTyErr argument) + check (pred ty) (TcRnIllegalForeignType (Just Arg)) checkNoLinearFFI :: Mult -> TcM () -- No linear types in FFI (#18472) checkNoLinearFFI Many = return () -checkNoLinearFFI _ = addErrTc $ illegalForeignTyErr argument - (text "Linear types are not supported in FFI declarations, see #18472") +checkNoLinearFFI _ = addErrTc $ TcRnIllegalForeignType (Just Arg) + LinearTypesNotAllowed ------------ Checking result types for foreign calls ---------------------- -- | Check that the type has the form @@ -461,27 +455,28 @@ checkNoLinearFFI _ = addErrTc $ illegalForeignTyErr argument -- We also check that the Safe Haskell condition of FFI imports having -- results in the IO monad holds. -- -checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () +checkForeignRes :: Bool -> Bool -> (Type -> Validity' IllegalForeignTypeReason) -> Type -> TcM () checkForeignRes non_io_result_ok check_safe pred_res_ty ty | Just (_, res_ty) <- tcSplitIOType_maybe ty = -- Got an IO result type, that's always fine! - check (pred_res_ty res_ty) (illegalForeignTyErr result) + check (pred_res_ty res_ty) + (TcRnIllegalForeignType (Just Result)) -- We disallow nested foralls in foreign types -- (at least, for the time being). See #16702. | tcIsForAllTy ty - = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall") + = addErrTc $ TcRnIllegalForeignType (Just Result) UnexpectedNestedForall -- Case for non-IO result type with FFI Import | not non_io_result_ok - = addErrTc $ illegalForeignTyErr result (text "IO result type expected") + = addErrTc $ TcRnIllegalForeignType (Just Result) IOResultExpected | otherwise = do { dflags <- getDynFlags ; case pred_res_ty ty of -- Handle normal typecheck fail, we want to handle this first and -- only report safe haskell errors if the normal type check is OK. - NotValid msg -> addErrTc $ illegalForeignTyErr result msg + NotValid msg -> addErrTc $ TcRnIllegalForeignType (Just Result) msg -- handle safe infer fail _ | check_safe && safeInferOn dflags @@ -489,13 +484,10 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- handle safe language typecheck fail _ | check_safe && safeLanguageOn dflags - -> addErrTc (illegalForeignTyErr result safeHsErr) + -> addErrTc (TcRnIllegalForeignType (Just Result) SafeHaskellMustBeInIO) -- success! non-IO return is fine _ -> return () } - where - safeHsErr = - text "Safe Haskell is on, all FFI imports must be in the IO monad" nonIOok, mustBeIO :: Bool nonIOok = True @@ -506,84 +498,64 @@ checkSafe = True noCheckSafe = False -- | Checking a supported backend is in use -checkCOrAsmOrLlvm :: Backend -> Validity +checkCOrAsmOrLlvm :: Backend -> Validity' ExpectedBackends checkCOrAsmOrLlvm ViaC = IsValid checkCOrAsmOrLlvm NCG = IsValid checkCOrAsmOrLlvm LLVM = IsValid -checkCOrAsmOrLlvm _ - = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") +checkCOrAsmOrLlvm _ = NotValid COrAsmOrLlvm -- | Checking a supported backend is in use -checkCOrAsmOrLlvmOrInterp :: Backend -> Validity +checkCOrAsmOrLlvmOrInterp :: Backend -> Validity' ExpectedBackends checkCOrAsmOrLlvmOrInterp ViaC = IsValid checkCOrAsmOrLlvmOrInterp NCG = IsValid checkCOrAsmOrLlvmOrInterp LLVM = IsValid checkCOrAsmOrLlvmOrInterp Interpreter = IsValid -checkCOrAsmOrLlvmOrInterp _ - = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") +checkCOrAsmOrLlvmOrInterp _ = NotValid COrAsmOrLlvmOrInterp -checkCg :: (Backend -> Validity) -> TcM () -checkCg check = do +checkCg :: Either ForeignExport ForeignImport -> (Backend -> Validity' ExpectedBackends) -> TcM () +checkCg decl check = do dflags <- getDynFlags let bcknd = backend dflags case bcknd of NoBackend -> return () _ -> case check bcknd of - IsValid -> return () - NotValid err -> - addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal foreign declaration:" <+> err) + IsValid -> return () + NotValid expectedBcknd -> + addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknd -- Calling conventions -checkCConv :: CCallConv -> TcM CCallConv -checkCConv CCallConv = return CCallConv -checkCConv CApiConv = return CApiConv -checkCConv StdCallConv = do dflags <- getDynFlags - let platform = targetPlatform dflags - if platformArch platform == ArchX86 - then return StdCallConv - else do -- This is a warning, not an error. see #3336 - let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnUnsupportedCallingConventions) - noHints - (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") - addDiagnosticTc msg - return CCallConv -checkCConv PrimCallConv = do - addErrTc $ TcRnUnknownMessage $ mkPlainError noHints - (text "The `prim' calling convention can only be used with `foreign import'") +checkCConv :: Either ForeignExport ForeignImport -> CCallConv -> TcM CCallConv +checkCConv _ CCallConv = return CCallConv +checkCConv _ CApiConv = return CApiConv +checkCConv decl StdCallConv = do + dflags <- getDynFlags + let platform = targetPlatform dflags + if platformArch platform == ArchX86 + then return StdCallConv + else do -- This is a warning, not an error. see #3336 + let msg = TcRnUnsupportedCallConv decl StdCallConvUnsupported + addDiagnosticTc msg + return CCallConv +checkCConv decl PrimCallConv = do + addErrTc $ TcRnUnsupportedCallConv decl PrimCallConvUnsupported return PrimCallConv -checkCConv JavaScriptCallConv = do dflags <- getDynFlags - if platformArch (targetPlatform dflags) == ArchJavaScript - then return JavaScriptCallConv - else do - addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "The `javascript' calling convention is unsupported on this platform") - return JavaScriptCallConv +checkCConv decl JavaScriptCallConv = do + dflags <- getDynFlags + if platformArch (targetPlatform dflags) == ArchJavaScript + then return JavaScriptCallConv + else do + addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported + return JavaScriptCallConv -- Warnings -check :: Validity -> (SDoc -> TcRnMessage) -> TcM () -check IsValid _ = return () -check (NotValid doc) err_fn = addErrTc (err_fn doc) - -illegalForeignTyErr :: SDoc -> SDoc -> TcRnMessage -illegalForeignTyErr arg_or_res extra - = TcRnUnknownMessage $ mkPlainError noHints $ hang msg 2 extra - where - msg = hsep [ text "Unacceptable", arg_or_res - , text "type in foreign declaration:"] - --- Used for 'arg_or_res' argument to illegalForeignTyErr -argument, result :: SDoc -argument = text "argument" -result = text "result" - -badCName :: CLabelString -> TcRnMessage -badCName target - = TcRnUnknownMessage $ mkPlainError noHints $ - sep [quotes (ppr target) <+> text "is not a valid C identifier"] +check :: Validity' IllegalForeignTypeReason + -> (IllegalForeignTypeReason -> TcRnMessage) + -> TcM () +check IsValid _ = return () +check (NotValid reason) mkMessage = addErrTc (mkMessage reason) foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc foreignDeclCtxt fo diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 090415b16d..ee687b68f7 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -115,6 +115,8 @@ module GHC.Tc.Utils.TcType ( --------------------------------- -- Foreign import and export + IllegalForeignTypeReason(..), + TypeCannotBeMarshaledReason(..), isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool isFFIImportResultTy, -- :: DynFlags -> Type -> Bool isFFIExportResultTy, -- :: Type -> Bool @@ -232,7 +234,7 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Error( Validity'(..), Validity ) +import GHC.Utils.Error( Validity'(..) ) import qualified GHC.LanguageExtensions as LangExt import Data.IORef @@ -2143,23 +2145,45 @@ tcSplitIOType_maybe ty _ -> Nothing -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity +-- | Reason why a type in an FFI signature is invalid +data IllegalForeignTypeReason + = TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason + | ForeignDynNotPtr + !Type -- ^ Expected type + !Type -- ^ Actual type + | SafeHaskellMustBeInIO + | IOResultExpected + | UnexpectedNestedForall + | LinearTypesNotAllowed + | OneArgExpected + | AtLeastOneArgExpected + +-- | Reason why a type cannot be marshalled through the FFI. +data TypeCannotBeMarshaledReason + = NotADataType + | NewtypeDataConNotInScope !(Maybe TyCon) + | UnliftedFFITypesNeeded + | NotABoxedMarshalableTyCon + | ForeignLabelNotAPtr + | NotSimpleUnliftedType + +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import' isFFIArgumentTy dflags safety ty = checkRepTyCon (legalOutgoingTyCon dflags safety) ty -isFFIExternalTy :: Type -> Validity +isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason -- Types that are allowed as arguments of a 'foreign export' isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty -isFFIImportResultTy :: DynFlags -> Type -> Validity +isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason isFFIImportResultTy dflags ty = checkRepTyCon (legalFIResultTyCon dflags) ty -isFFIExportResultTy :: Type -> Validity +isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty -isFFIDynTy :: Type -> Type -> Validity +isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason -- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of -- either, and the wrapped function type must be equal to the given type. -- We assume that all types have been run through normaliseFfiType, so we don't @@ -2173,19 +2197,18 @@ isFFIDynTy expected ty , eqType ty' expected = IsValid | otherwise - = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma - , text " Actual:" <+> ppr ty ]) + = NotValid (ForeignDynNotPtr expected ty) -isFFILabelTy :: Type -> Validity +isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason -- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. isFFILabelTy ty = checkRepTyCon ok ty where ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey = IsValid | otherwise - = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") + = NotValid ForeignLabelNotAPtr -isFFIPrimArgumentTy :: DynFlags -> Type -> Validity +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import prim' -- Currently they must all be simple unlifted types, or the well-known type -- Any, which can be used to pass the address to a Haskell object on the heap to @@ -2194,7 +2217,7 @@ isFFIPrimArgumentTy dflags ty | isAnyTy ty = IsValid | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty -isFFIPrimResultTy :: DynFlags -> Type -> Validity +isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid result type for a 'foreign import prim' Currently -- it must be an unlifted type, including unboxed tuples, unboxed -- sums, or the well-known type Any. @@ -2212,22 +2235,20 @@ isFunPtrTy ty -- normaliseFfiType gets run before checkRepTyCon, so we don't -- need to worry about looking through newtypes or type functions -- here; that's already been taken care of. -checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity +checkRepTyCon + :: (TyCon -> Validity' TypeCannotBeMarshaledReason) + -> Type + -> Validity' IllegalForeignTypeReason checkRepTyCon check_tc ty - = case splitTyConApp_maybe ty of + = fmap (TypeCannotBeMarshaled ty) $ case splitTyConApp_maybe ty of Just (tc, tys) - | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) - | otherwise -> case check_tc tc of - IsValid -> IsValid - NotValid extra -> NotValid (msg $$ extra) - Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") + | isNewTyCon tc -> NotValid (mk_nt_reason tc tys) + | otherwise -> check_tc tc + Nothing -> NotValid NotADataType where - msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" mk_nt_reason tc tys - | null tys = text "because its data constructor is not in scope" - | otherwise = text "because the data constructor for" - <+> quotes (ppr tc) <+> text "is not in scope" - nt_fix = text "Possible fix: import the data constructor to bring it into scope" + | null tys = NewtypeDataConNotInScope Nothing + | otherwise = NewtypeDataConNotInScope (Just tc) {- Note [Foreign import dynamic] @@ -2250,23 +2271,23 @@ These chaps do the work; they are not exported ---------------------------------------------- -} -legalFEArgTyCon :: TyCon -> Validity +legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason legalFEArgTyCon tc -- It's illegal to make foreign exports that take unboxed -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 = boxedMarshalableTyCon tc -legalFIResultTyCon :: DynFlags -> TyCon -> Validity +legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason legalFIResultTyCon dflags tc | tc == unitTyCon = IsValid | otherwise = marshalableTyCon dflags tc -legalFEResultTyCon :: TyCon -> Validity +legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason legalFEResultTyCon tc | tc == unitTyCon = IsValid | otherwise = boxedMarshalableTyCon tc -legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason -- Checks validity of types going from Haskell -> external world legalOutgoingTyCon dflags _ tc = marshalableTyCon dflags tc @@ -2281,7 +2302,7 @@ legalOutgoingTyCon dflags _ tc marshalablePrimTyCon :: TyCon -> Bool marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind tc)) -marshalableTyCon :: DynFlags -> TyCon -> Validity +marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason marshalableTyCon dflags tc | marshalablePrimTyCon tc , not (null (tyConPrimRep tc)) -- Note [Marshalling void] @@ -2289,7 +2310,7 @@ marshalableTyCon dflags tc | otherwise = boxedMarshalableTyCon tc -boxedMarshalableTyCon :: TyCon -> Validity +boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason boxedMarshalableTyCon tc | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey , int32TyConKey, int64TyConKey @@ -2303,17 +2324,17 @@ boxedMarshalableTyCon tc ] = IsValid - | otherwise = NotValid empty + | otherwise = NotValid NotABoxedMarshalableTyCon -legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason -- Check args of 'foreign import prim', only allow simple unlifted types. legalFIPrimArgTyCon dflags tc | marshalablePrimTyCon tc = validIfUnliftedFFITypes dflags | otherwise - = NotValid unlifted_only + = NotValid NotSimpleUnliftedType -legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason -- Check result type of 'foreign import prim'. Allow simple unlifted -- types and also unboxed tuple and sum result types. legalFIPrimResultTyCon dflags tc @@ -2325,15 +2346,12 @@ legalFIPrimResultTyCon dflags tc = validIfUnliftedFFITypes dflags | otherwise - = NotValid unlifted_only + = NotValid $ NotSimpleUnliftedType -unlifted_only :: SDoc -unlifted_only = text "foreign import prim only accepts simple unlifted types" - -validIfUnliftedFFITypes :: DynFlags -> Validity +validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason validIfUnliftedFFITypes dflags | xopt LangExt.UnliftedFFITypes dflags = IsValid - | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") + | otherwise = NotValid UnliftedFFITypesNeeded {- Note [Marshalling void] diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs index 4182e40b3f..6304b1d7fd 100644 --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -330,6 +330,7 @@ data GhcHint Triggered by: 'GHC.Tc.Errors.Types.TcRnIncorrectNameSpace'. -} | SuggestAppropriateTHTick NameSpace + {-| Suggests enabling -ddump-splices to help debug an issue when a 'Name' is not in scope or is used in multiple different namespaces (e.g. both as a data constructor @@ -383,6 +384,12 @@ data GhcHint -} | ImportSuggestion ImportSuggestion + {-| Suggest importing a data constructor to bring it into scope + Triggered by: 'GHC.Tc.Errors.Types.TcRnTypeCannotBeMarshaled' + + Test cases: ccfail004 + -} + | SuggestImportingDataCon -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs index 9fd39e2a53..5ed31571b0 100644 --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -179,6 +179,8 @@ instance Outputable GhcHint where <+> pprQuotedList parents ImportSuggestion import_suggestion -> pprImportSuggestion import_suggestion + SuggestImportingDataCon + -> text "Import the data constructor to bring it into scope" perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index fb981452b6..7d2eb34c3b 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -194,6 +195,7 @@ mkPlainErrorMsgEnvelope locn msg = data Validity' a = IsValid -- ^ Everything is fine | NotValid a -- ^ A problem, and some indication of why + deriving Functor -- | Monomorphic version of @Validity'@ specialised for 'SDoc's. type Validity = Validity' SDoc |