summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs23
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs9
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs40
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs8
4 files changed, 32 insertions, 48 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 59bde4f0aa..b8ed303dd7 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -41,7 +41,7 @@ import GHC.Core.Predicate
import GHC.Core.Type
import GHC.Driver.Flags
-
+import GHC.Driver.Backend
import GHC.Hs
import GHC.Tc.Errors.Types
@@ -737,12 +737,9 @@ instance Diagnostic TcRnMessage where
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"
+ -> mkSimpleDecorated $
+ fsep (text "Illegal foreign declaration: requires one of these back ends:" :
+ commafyWith (text "or") (map (text . backendDescription) expectedBknds))
TcRnUnsupportedCallConv _decl unsupportedCC
-> mkSimpleDecorated $
@@ -1481,6 +1478,18 @@ instance Diagnostic TcRnMessage where
TcRnUnpromotableThing{}
-> noHints
+
+-- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z",
+-- and so on. The `and` stands for any `conjunction`, which is passed in.
+commafyWith :: SDoc -> [SDoc] -> [SDoc]
+commafyWith _ [] = []
+commafyWith _ [x] = [x]
+commafyWith conjunction [x, y] = [x <+> conjunction <+> y]
+commafyWith conjunction xs = addConjunction $ punctuate comma xs
+ where addConjunction [x, y] = [x, conjunction, y]
+ addConjunction (x : xs) = x : addConjunction xs
+ addConjunction _ = panic "commafyWith expected 2 or more elements"
+
deriveInstanceErrReasonHints :: Class
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index b1f635325a..182818616a 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -62,7 +62,7 @@ module GHC.Tc.Errors.Types (
, CoercibleMsg(..)
, PotentialInstances(..)
, UnsupportedCallConvention(..)
- , ExpectedBackends(..)
+ , ExpectedBackends
, ArgOrResult(..)
) where
@@ -2008,11 +2008,8 @@ data TcRnMessage where
-}
TcRnUnpromotableThing :: !Name -> !PromotionErr -> 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 back ends can handle a requested foreign import or export
+type ExpectedBackends = [Backend]
-- | Specifies which calling convention is unsupported on the current platform
data UnsupportedCallConvention
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 31f47227c8..819c66b2c2 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -268,7 +268,7 @@ tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src)
-- Foreign import label
- = do checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
+ = do checkCg (Right idecl) backendValidityOfCImport
-- NB check res_ty not sig_ty!
-- In case sig_ty is (forall a. ForeignPtr a)
check (isFFILabelTy (mkVisFunTys arg_tys res_ty))
@@ -281,7 +281,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src)
-- 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 (Right idecl) checkCOrAsmOrLlvmOrInterp
+ checkCg (Right idecl) backendValidityOfCImport
cconv' <- checkCConv (Right idecl) cconv
case arg_tys of
[Scaled arg1_mult arg1_ty] -> do
@@ -297,7 +297,7 @@ tcCheckFIType arg_tys res_ty idecl@(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 (Right idecl) checkCOrAsmOrLlvmOrInterp
+ checkCg (Right idecl) backendValidityOfCImport
cconv' <- checkCConv (Right idecl) cconv
case arg_tys of -- The first arg must be Ptr or FunPtr
[] ->
@@ -315,7 +315,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
dflags <- getDynFlags
checkTc (xopt LangExt.GHCForeignImportPrim dflags)
(TcRnForeignImportPrimExtNotSet idecl)
- checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
+ checkCg (Right idecl) backendValidityOfCImport
checkCTarget idecl target
checkTc (playSafe safety)
(TcRnForeignImportPrimSafeAnn idecl)
@@ -324,7 +324,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
return idecl
| otherwise = do -- Normal foreign import
- checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
+ checkCg (Right idecl) backendValidityOfCImport
cconv' <- checkCConv (Right idecl) cconv
checkCTarget idecl target
dflags <- getDynFlags
@@ -342,7 +342,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
-- that the C identifier is valid for C
checkCTarget :: ForeignImport -> CCallTarget -> TcM ()
checkCTarget idecl (StaticTarget _ str _ _) = do
- checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
+ checkCg (Right idecl) backendValidityOfCImport
checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget"
@@ -415,7 +415,7 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do
- checkCg (Left edecl) checkCOrAsmOrLlvm
+ checkCg (Left edecl) backendValidityOfCExport
checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
cconv' <- checkCConv (Left edecl) cconv
checkForeignArgs isFFIExternalTy arg_tys
@@ -497,32 +497,14 @@ checkSafe, noCheckSafe :: Bool
checkSafe = True
noCheckSafe = False
--- | Checking a supported backend is in use
-checkCOrAsmOrLlvm :: Backend -> Validity' ExpectedBackends
-checkCOrAsmOrLlvm ViaC = IsValid
-checkCOrAsmOrLlvm NCG = IsValid
-checkCOrAsmOrLlvm LLVM = IsValid
-checkCOrAsmOrLlvm _ = NotValid COrAsmOrLlvm
-
--- | Checking a supported backend is in use
-checkCOrAsmOrLlvmOrInterp :: Backend -> Validity' ExpectedBackends
-checkCOrAsmOrLlvmOrInterp ViaC = IsValid
-checkCOrAsmOrLlvmOrInterp NCG = IsValid
-checkCOrAsmOrLlvmOrInterp LLVM = IsValid
-checkCOrAsmOrLlvmOrInterp Interpreter = IsValid
-checkCOrAsmOrLlvmOrInterp _ = NotValid COrAsmOrLlvmOrInterp
-
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 expectedBcknd ->
- addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknd
+ case check bcknd of
+ IsValid -> return ()
+ NotValid expectedBcknds ->
+ addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknds
-- Calling conventions
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 874870765f..95cb2f467f 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -858,12 +858,8 @@ tcImpPrags prags
-- when we aren't specialising, or when we aren't generating
-- code. The latter happens when Haddocking the base library;
-- we don't want complaints about lack of INLINABLE pragmas
- not_specialising dflags
- | not (gopt Opt_Specialise dflags) = True
- | otherwise = case backend dflags of
- NoBackend -> True
- Interpreter -> True
- _other -> False
+ not_specialising dflags =
+ not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags))
tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec (name, prag)
View Lorry Controller Status