{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.Tc.Gen.Foreign
( tcForeignImports
, tcForeignExports
, isForeignImport, isForeignExport
, tcFImport, tcFExport
, tcForeignImports'
, tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
, normaliseFfiType
, nonIOok, mustBeIO
, checkSafe, noCheckSafe
, tcForeignExports'
, tcCheckFEType
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Hs
import GHC.Tc.Utils.Monad
import GHC.Tc.Gen.HsType
import GHC.Tc.Gen.Expr
import GHC.Tc.Utils.Env
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Types.ForeignCall
import GHC.Utils.Error
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Tc.Utils.TcType
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Platform
import GHC.Types.SrcLoc
import GHC.Data.Bag
import GHC.Driver.Hooks
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport (forall p a. UnXRec p => XRec p a -> a
unXRec @name -> ForeignImport {}) = Bool
True
isForeignImport LForeignDecl name
_ = Bool
False
isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport (forall p a. UnXRec p => XRec p a -> a
unXRec @name -> ForeignExport {}) = Bool
True
isForeignExport LForeignDecl name
_ = Bool
False
normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType Type
ty
= do FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
fam_envs Type
ty
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType' FamInstEnvs
env Type
ty0 = Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
Representational RecTcChecker
initRecTc Type
ty0
where
go :: Role -> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go :: Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts Type
ty
| Just Type
ty' <- Type -> Maybe Type
tcView Type
ty
= Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts Type
ty'
| Just (TyCon
tc, [Type]
tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
= Role
-> RecTcChecker
-> TyCon
-> [Type]
-> TcM (Coercion, Type, Bag GlobalRdrElt)
go_tc_app Role
role RecTcChecker
rec_nts TyCon
tc [Type]
tys
| ([TyCoVarBinder]
bndrs, Type
inner_ty) <- Type -> ([TyCoVarBinder], Type)
splitForAllTyCoVarBinders Type
ty
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCoVarBinder]
bndrs)
= do (Coercion
coi, Type
nty1, Bag GlobalRdrElt
gres1) <- Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts Type
inner_ty
forall (m :: * -> *) a. Monad m => a -> m a
return ( [TyCoVar] -> Coercion -> Coercion
mkHomoForAllCos (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyCoVarBinder]
bndrs) Coercion
coi
, [TyCoVarBinder] -> Type -> Type
mkForAllTys [TyCoVarBinder]
bndrs Type
nty1, Bag GlobalRdrElt
gres1 )
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Type -> Coercion
mkReflCo Role
role Type
ty, Type
ty, forall a. Bag a
emptyBag)
go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
-> TcM (Coercion, Type, Bag GlobalRdrElt)
go_tc_app :: Role
-> RecTcChecker
-> TyCon
-> [Type]
-> TcM (Coercion, Type, Bag GlobalRdrElt)
go_tc_app Role
role RecTcChecker
rec_nts TyCon
tc [Type]
tys
| Unique
tc_key forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique
ioTyConKey, Unique
funPtrTyConKey, Unique
funTyConKey]
= TcM (Coercion, Type, Bag GlobalRdrElt)
children_only
| TyCon -> Bool
isNewTyCon TyCon
tc
, Just RecTcChecker
rec_nts' <- RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_nts TyCon
tc
= do { GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; case GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI GlobalRdrEnv
rdr_env TyCon
tc of
Maybe GlobalRdrElt
Nothing -> TcM (Coercion, Type, Bag GlobalRdrElt)
nothing
Just GlobalRdrElt
gre -> do { (Coercion
co', Type
ty', Bag GlobalRdrElt
gres) <- Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts' Type
nt_rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion -> Coercion
mkTransCo Coercion
nt_co Coercion
co', Type
ty', GlobalRdrElt
gre forall a. a -> Bag a -> Bag a
`consBag` Bag GlobalRdrElt
gres) } }
| TyCon -> Bool
isFamilyTyCon TyCon
tc
, (Coercion
co, Type
ty) <- FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type)
normaliseTcApp FamInstEnvs
env Role
role TyCon
tc [Type]
tys
, Bool -> Bool
not (Coercion -> Bool
isReflexiveCo Coercion
co)
= do (Coercion
co', Type
ty', Bag GlobalRdrElt
gres) <- Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
role RecTcChecker
rec_nts Type
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Coercion -> Coercion
mkTransCo Coercion
co Coercion
co', Type
ty', Bag GlobalRdrElt
gres)
| Bool
otherwise
= TcM (Coercion, Type, Bag GlobalRdrElt)
nothing
where
tc_key :: Unique
tc_key = forall a. Uniquable a => a -> Unique
getUnique TyCon
tc
children_only :: TcM (Coercion, Type, Bag GlobalRdrElt)
children_only
= do [(Coercion, Type, Bag GlobalRdrElt)]
xs <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Type
ty Role
r -> Role
-> RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go Role
r RecTcChecker
rec_nts Type
ty) [Type]
tys (Role -> TyCon -> [Role]
tyConRolesX Role
role TyCon
tc)
let ([Coercion]
cos, [Type]
tys', [Bag GlobalRdrElt]
gres) = forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Coercion, Type, Bag GlobalRdrElt)]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return ( HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
role TyCon
tc [Coercion]
cos
, TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys', forall a. [Bag a] -> Bag a
unionManyBags [Bag GlobalRdrElt]
gres)
nt_co :: Coercion
nt_co = Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
role (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
tc) [Type]
tys []
nt_rhs :: Type
nt_rhs = TyCon -> [Type] -> Type
newTyConInstRhs TyCon
tc [Type]
tys
ty :: Type
ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tys
nothing :: TcM (Coercion, Type, Bag GlobalRdrElt)
nothing = forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Type -> Coercion
mkReflCo Role
role Type
ty, Type
ty, forall a. Bag a
emptyBag)
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI GlobalRdrEnv
rdr_env TyCon
tc
| Just DataCon
con <- TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tc
, Just GlobalRdrElt
gre <- GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env (DataCon -> Name
dataConName DataCon
con)
= forall a. a -> Maybe a
Just GlobalRdrElt
gre
| Bool
otherwise
= forall a. Maybe a
Nothing
tcForeignImports :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports :: [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports [LForeignDecl GhcRn]
decls = do
Hooks
hooks <- forall (m :: * -> *). HasHooks m => m Hooks
getHooks
case Hooks
-> Maybe
([LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignImportsHook Hooks
hooks of
Maybe
([LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt))
Nothing -> [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' [LForeignDecl GhcRn]
decls
Just [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
h -> [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
h [LForeignDecl GhcRn]
decls
tcForeignImports' :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' :: [LForeignDecl GhcRn]
-> TcM ([TyCoVar], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' [LForeignDecl GhcRn]
decls
= do { ([TyCoVar]
ids, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
decls, [Bag GlobalRdrElt]
gres) <- forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M LForeignDecl GhcRn
-> TcM (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport [LForeignDecl GhcRn]
decls
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyCoVar]
ids, [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
decls, forall a. [Bag a] -> Bag a
unionManyBags [Bag GlobalRdrElt]
gres) }
tcFImport :: LForeignDecl GhcRn
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport :: LForeignDecl GhcRn
-> TcM (TyCoVar, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport (L SrcSpanAnnA
dloc fo :: ForeignDecl GhcRn
fo@(ForeignImport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = L SrcSpanAnnN
nloc Name
nm, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
hs_ty
, fd_fi :: forall pass. ForeignDecl pass -> ForeignImport
fd_fi = ForeignImport
imp_decl }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
dloc forall a b. (a -> b) -> a -> b
$ forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo) forall a b. (a -> b) -> a -> b
$
do { Type
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> UserTypeCtxt
ForSigCtxt Name
nm) LHsSigType GhcRn
hs_ty
; (Coercion
norm_co, Type
norm_sig_ty, Bag GlobalRdrElt
gres) <- Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType Type
sig_ty
; let
([Scaled Type]
arg_tys, Type
res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys (Type -> Type
dropForAlls Type
norm_sig_ty)
id :: TyCoVar
id = HasDebugCallStack => Name -> Type -> Type -> TyCoVar
mkLocalId Name
nm Type
Many Type
sig_ty
; ForeignImport
imp_decl' <- [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty ForeignImport
imp_decl
; let fi_decl :: ForeignDecl GhcTc
fi_decl = ForeignImport { fd_name :: LIdP GhcTc
fd_name = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
nloc TyCoVar
id
, fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = forall a. HasCallStack => a
undefined
, fd_i_ext :: XForeignImport GhcTc
fd_i_ext = Coercion -> Coercion
mkSymCo Coercion
norm_co
, fd_fi :: ForeignImport
fd_fi = ForeignImport
imp_decl' }
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCoVar
id, forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
dloc ForeignDecl GhcTc
fi_decl, Bag GlobalRdrElt
gres) }
tcFImport LForeignDecl GhcRn
d = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFImport" (forall a. Outputable a => a -> SDoc
ppr LForeignDecl GhcRn
d)
tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty (CImport (L SrcSpan
lc CCallConv
cconv) Located Safety
safety Maybe Header
mh l :: CImportSpec
l@(CLabel CLabelString
_) Located SourceText
src)
= do (Backend -> Validity) -> TcM ()
checkCg Backend -> Validity
checkCOrAsmOrLlvmOrInterp
Validity -> (SDoc -> SDoc) -> TcM ()
check (Type -> Validity
isFFILabelTy ([Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys Type
res_ty)) (SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
Outputable.empty)
CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') Located Safety
safety Maybe Header
mh CImportSpec
l Located SourceText
src)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty (CImport (L SrcSpan
lc CCallConv
cconv) Located Safety
safety Maybe Header
mh CImportSpec
CWrapper Located SourceText
src) = do
(Backend -> Validity) -> TcM ()
checkCg Backend -> Validity
checkCOrAsmOrLlvmOrInterp
CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
case [Scaled Type]
arg_tys of
[Scaled Type
arg1_mult Type
arg1_ty] -> do
Type -> TcM ()
checkNoLinearFFI Type
arg1_mult
(Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity
isFFIExternalTy [Scaled Type]
arg1_tys
Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe Type -> Validity
isFFIExportResultTy Type
res1_ty
Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
mustBeIO Bool
checkSafe (Type -> Type -> Validity
isFFIDynTy Type
arg1_ty) Type
res_ty
where
([Scaled Type]
arg1_tys, Type
res1_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
arg1_ty
[Scaled Type]
_ -> SDoc -> TcM ()
addErrTc (SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
Outputable.empty (String -> SDoc
text String
"One argument expected"))
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') Located Safety
safety Maybe Header
mh CImportSpec
CWrapper Located SourceText
src)
tcCheckFIType [Scaled Type]
arg_tys Type
res_ty idecl :: ForeignImport
idecl@(CImport (L SrcSpan
lc CCallConv
cconv) (L SrcSpan
ls Safety
safety) Maybe Header
mh
(CFunction CCallTarget
target) Located SourceText
src)
| CCallTarget -> Bool
isDynamicTarget CCallTarget
target = do
(Backend -> Validity) -> TcM ()
checkCg Backend -> Validity
checkCOrAsmOrLlvmOrInterp
CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
case [Scaled Type]
arg_tys of
[] ->
SDoc -> TcM ()
addErrTc (SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
Outputable.empty (String -> SDoc
text String
"At least one argument expected"))
(Scaled Type
arg1_mult Type
arg1_ty:[Scaled Type]
arg_tys) -> do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let curried_res_ty :: Type
curried_res_ty = [Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys Type
res_ty
Type -> TcM ()
checkNoLinearFFI Type
arg1_mult
Validity -> (SDoc -> SDoc) -> TcM ()
check (Type -> Type -> Validity
isFFIDynTy Type
curried_res_ty Type
arg1_ty)
(SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
argument)
(Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Safety -> Type -> Validity
isFFIArgumentTy DynFlags
dflags Safety
safety) [Scaled Type]
arg_tys
Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity
isFFIImportResultTy DynFlags
dflags) Type
res_ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target) Located SourceText
src
| CCallConv
cconv forall a. Eq a => a -> a -> Bool
== CCallConv
PrimCallConv = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> SDoc -> TcM ()
checkTc (Extension -> DynFlags -> Bool
xopt Extension
LangExt.GHCForeignImportPrim DynFlags
dflags)
(String -> SDoc
text String
"Use GHCForeignImportPrim to allow `foreign import prim'.")
(Backend -> Validity) -> TcM ()
checkCg Backend -> Validity
checkCOrAsmOrLlvmOrInterp
CCallTarget -> TcM ()
checkCTarget CCallTarget
target
Bool -> SDoc -> TcM ()
checkTc (Safety -> Bool
playSafe Safety
safety)
(String -> SDoc
text String
"The safe/unsafe annotation should not be used with `foreign import prim'.")
(Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Type -> Validity
isFFIPrimArgumentTy DynFlags
dflags) [Scaled Type]
arg_tys
Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity
isFFIPrimResultTy DynFlags
dflags) Type
res_ty
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignImport
idecl
| Bool
otherwise = do
(Backend -> Validity) -> TcM ()
checkCg Backend -> Validity
checkCOrAsmOrLlvmOrInterp
CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
CCallTarget -> TcM ()
checkCTarget CCallTarget
target
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs (DynFlags -> Safety -> Type -> Validity
isFFIArgumentTy DynFlags
dflags Safety
safety) [Scaled Type]
arg_tys
Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
checkSafe (DynFlags -> Type -> Validity
isFFIImportResultTy DynFlags
dflags) Type
res_ty
DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand DynFlags
dflags (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) Type
res_ty
case CCallTarget
target of
StaticTarget SourceText
_ CLabelString
_ Maybe Unit
_ Bool
False
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
arg_tys) ->
SDoc -> TcM ()
addErrTc (String -> SDoc
text String
"`value' imports cannot have function types")
CCallTarget
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan CCallConv
-> Located Safety
-> Maybe Header
-> CImportSpec
-> Located SourceText
-> ForeignImport
CImport (forall l e. l -> e -> GenLocated l e
L SrcSpan
lc CCallConv
cconv') (forall l e. l -> e -> GenLocated l e
L SrcSpan
ls Safety
safety) Maybe Header
mh (CCallTarget -> CImportSpec
CFunction CCallTarget
target) Located SourceText
src
checkCTarget :: CCallTarget -> TcM ()
checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget SourceText
_ CLabelString
str Maybe Unit
_ Bool
_) = do
(Backend -> Validity) -> TcM ()
checkCg Backend -> Validity
checkCOrAsmOrLlvmOrInterp
Bool -> SDoc -> TcM ()
checkTc (CLabelString -> Bool
isCLabelString CLabelString
str) (CLabelString -> SDoc
badCName CLabelString
str)
checkCTarget CCallTarget
DynamicTarget = forall a. String -> a
panic String
"checkCTarget DynamicTarget"
checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
checkMissingAmpersand DynFlags
dflags [Type]
arg_tys Type
res_ty
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
arg_tys Bool -> Bool -> Bool
&& Type -> Bool
isFunPtrTy Type
res_ty Bool -> Bool -> Bool
&&
WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnDodgyForeignImports DynFlags
dflags
= WarnReason -> SDoc -> TcM ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDodgyForeignImports)
(String -> SDoc
text String
"possible missing & in foreign import of FunPtr")
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
tcForeignExports :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports [LForeignDecl GhcRn]
decls = do
Hooks
hooks <- forall (m :: * -> *). HasHooks m => m Hooks
getHooks
case Hooks
-> Maybe
([LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignExportsHook Hooks
hooks of
Maybe
([LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
Nothing -> [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' [LForeignDecl GhcRn]
decls
Just [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
h -> [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
h [LForeignDecl GhcRn]
decls
tcForeignExports' :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' [LForeignDecl GhcRn]
decls
= forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall {ann}.
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
Bag GlobalRdrElt)
-> GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
Bag GlobalRdrElt)
combine (forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds, [], forall a. Bag a
emptyBag) (forall a. (a -> Bool) -> [a] -> [a]
filter forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport [LForeignDecl GhcRn]
decls)
where
combine :: (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
Bag GlobalRdrElt)
-> GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcRn)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
[GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)],
Bag GlobalRdrElt)
combine (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds, [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)]
fs, Bag GlobalRdrElt
gres1) (L SrcSpanAnn' ann
loc ForeignDecl GhcRn
fe) = do
(GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b, ForeignDecl GhcTc
f, Bag GlobalRdrElt
gres2) <- forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
loc (ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport ForeignDecl GhcRn
fe)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
b forall a. a -> Bag a -> Bag a
`consBag` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds, forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' ann
loc ForeignDecl GhcTc
f forall a. a -> [a] -> [a]
: [GenLocated (SrcSpanAnn' ann) (ForeignDecl GhcTc)]
fs, Bag GlobalRdrElt
gres1 forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag GlobalRdrElt
gres2)
tcFExport :: ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport :: ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport fo :: ForeignDecl GhcRn
fo@(ForeignExport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
fd_name = L SrcSpanAnnN
loc Name
nm, fd_sig_ty :: forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty = LHsSigType GhcRn
hs_ty, fd_fe :: forall pass. ForeignDecl pass -> ForeignExport
fd_fe = ForeignExport
spec })
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt (ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo) forall a b. (a -> b) -> a -> b
$ do
Type
sig_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType (Name -> UserTypeCtxt
ForSigCtxt Name
nm) LHsSigType GhcRn
hs_ty
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Name
nm) Type
sig_ty
(Coercion
norm_co, Type
norm_sig_ty, Bag GlobalRdrElt
gres) <- Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType Type
sig_ty
ForeignExport
spec' <- Type -> ForeignExport -> TcM ForeignExport
tcCheckFEType Type
norm_sig_ty ForeignExport
spec
TyCoVar
id <- Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TyCoVar
mkStableIdFromName Name
nm Type
sig_ty (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
loc) OccName -> OccName
mkForeignExportOcc
forall (m :: * -> *) a. Monad m => a -> m a
return ( forall (p :: Pass).
IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind TyCoVar
id GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
, ForeignExport { fd_name :: LIdP GhcTc
fd_name = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc TyCoVar
id
, fd_sig_ty :: LHsSigType GhcTc
fd_sig_ty = forall a. HasCallStack => a
undefined
, fd_e_ext :: XForeignExport GhcTc
fd_e_ext = Coercion
norm_co, fd_fe :: ForeignExport
fd_fe = ForeignExport
spec' }
, Bag GlobalRdrElt
gres)
tcFExport ForeignDecl GhcRn
d = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcFExport" (forall a. Outputable a => a -> SDoc
ppr ForeignDecl GhcRn
d)
tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
tcCheckFEType Type
sig_ty (CExport (L SrcSpan
l (CExportStatic SourceText
esrc CLabelString
str CCallConv
cconv)) Located SourceText
src) = do
(Backend -> Validity) -> TcM ()
checkCg Backend -> Validity
checkCOrAsmOrLlvm
Bool -> SDoc -> TcM ()
checkTc (CLabelString -> Bool
isCLabelString CLabelString
str) (CLabelString -> SDoc
badCName CLabelString
str)
CCallConv
cconv' <- CCallConv -> TcM CCallConv
checkCConv CCallConv
cconv
(Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity
isFFIExternalTy [Scaled Type]
arg_tys
Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
nonIOok Bool
noCheckSafe Type -> Validity
isFFIExportResultTy Type
res_ty
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan CExportSpec
-> Located SourceText -> ForeignExport
CExport (forall l e. l -> e -> GenLocated l e
L SrcSpan
l (SourceText -> CLabelString -> CCallConv -> CExportSpec
CExportStatic SourceText
esrc CLabelString
str CCallConv
cconv')) Located SourceText
src)
where
([Scaled Type]
arg_tys, Type
res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys (Type -> Type
dropForAlls Type
sig_ty)
checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs Type -> Validity
pred [Scaled Type]
tys = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Scaled Type -> TcM ()
go [Scaled Type]
tys
where
go :: Scaled Type -> TcM ()
go (Scaled Type
mult Type
ty) = Type -> TcM ()
checkNoLinearFFI Type
mult forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Validity -> (SDoc -> SDoc) -> TcM ()
check (Type -> Validity
pred Type
ty) (SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
argument)
checkNoLinearFFI :: Mult -> TcM ()
checkNoLinearFFI :: Type -> TcM ()
checkNoLinearFFI Type
Many = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkNoLinearFFI Type
_ = SDoc -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
argument
(String -> SDoc
text String
"Linear types are not supported in FFI declarations, see #18472")
checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
checkForeignRes Bool
non_io_result_ok Bool
check_safe Type -> Validity
pred_res_ty Type
ty
| Just (TyCon
_, Type
res_ty) <- Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
ty
=
Validity -> (SDoc -> SDoc) -> TcM ()
check (Type -> Validity
pred_res_ty Type
res_ty) (SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
result)
| Type -> Bool
tcIsForAllTy Type
ty
= SDoc -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
result (String -> SDoc
text String
"Unexpected nested forall")
| Bool -> Bool
not Bool
non_io_result_ok
= SDoc -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
result (String -> SDoc
text String
"IO result type expected")
| Bool
otherwise
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case Type -> Validity
pred_res_ty Type
ty of
NotValid SDoc
msg -> SDoc -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
result SDoc
msg
Validity
_ | Bool
check_safe Bool -> Bool -> Bool
&& DynFlags -> Bool
safeInferOn DynFlags
dflags
-> WarningMessages -> TcM ()
recordUnsafeInfer forall a. Bag a
emptyBag
Validity
_ | Bool
check_safe Bool -> Bool -> Bool
&& DynFlags -> Bool
safeLanguageOn DynFlags
dflags
-> SDoc -> TcM ()
addErrTc (SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
result SDoc
safeHsErr)
Validity
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () }
where
safeHsErr :: SDoc
safeHsErr =
String -> SDoc
text String
"Safe Haskell is on, all FFI imports must be in the IO monad"
nonIOok, mustBeIO :: Bool
nonIOok :: Bool
nonIOok = Bool
True
mustBeIO :: Bool
mustBeIO = Bool
False
checkSafe, noCheckSafe :: Bool
checkSafe :: Bool
checkSafe = Bool
True
noCheckSafe :: Bool
noCheckSafe = Bool
False
checkCOrAsmOrLlvm :: Backend -> Validity
checkCOrAsmOrLlvm :: Backend -> Validity
checkCOrAsmOrLlvm Backend
ViaC = Validity
IsValid
checkCOrAsmOrLlvm Backend
NCG = Validity
IsValid
checkCOrAsmOrLlvm Backend
LLVM = Validity
IsValid
checkCOrAsmOrLlvm Backend
_
= SDoc -> Validity
NotValid (String -> SDoc
text String
"requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
checkCOrAsmOrLlvmOrInterp :: Backend -> Validity
checkCOrAsmOrLlvmOrInterp :: Backend -> Validity
checkCOrAsmOrLlvmOrInterp Backend
ViaC = Validity
IsValid
checkCOrAsmOrLlvmOrInterp Backend
NCG = Validity
IsValid
checkCOrAsmOrLlvmOrInterp Backend
LLVM = Validity
IsValid
checkCOrAsmOrLlvmOrInterp Backend
Interpreter = Validity
IsValid
checkCOrAsmOrLlvmOrInterp Backend
_
= SDoc -> Validity
NotValid (String -> SDoc
text String
"requires interpreted, unregisterised, llvm or native code generation")
checkCg :: (Backend -> Validity) -> TcM ()
checkCg :: (Backend -> Validity) -> TcM ()
checkCg Backend -> Validity
check = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let bcknd :: Backend
bcknd = DynFlags -> Backend
backend DynFlags
dflags
case Backend
bcknd of
Backend
NoBackend -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Backend
_ ->
case Backend -> Validity
check Backend
bcknd of
Validity
IsValid -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
NotValid SDoc
err -> SDoc -> TcM ()
addErrTc (String -> SDoc
text String
"Illegal foreign declaration:" SDoc -> SDoc -> SDoc
<+> SDoc
err)
checkCConv :: CCallConv -> TcM CCallConv
checkCConv :: CCallConv -> TcM CCallConv
checkCConv CCallConv
CCallConv = forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv CCallConv
CApiConv = forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CApiConv
checkCConv CCallConv
StdCallConv = do DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
if Platform -> Arch
platformArch Platform
platform forall a. Eq a => a -> a -> Bool
== Arch
ArchX86
then forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
StdCallConv
else do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnsupportedCallingConventions DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> TcM ()
addWarnTc (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnsupportedCallingConventions)
(String -> SDoc
text String
"the 'stdcall' calling convention is unsupported on this platform," SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"treating as ccall")
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
CCallConv
checkCConv CCallConv
PrimCallConv = do SDoc -> TcM ()
addErrTc (String -> SDoc
text String
"The `prim' calling convention can only be used with `foreign import'")
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
PrimCallConv
checkCConv CCallConv
JavaScriptCallConv = do DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) forall a. Eq a => a -> a -> Bool
== Arch
ArchJavaScript
then forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
JavaScriptCallConv
else do SDoc -> TcM ()
addErrTc (String -> SDoc
text String
"The `javascript' calling convention is unsupported on this platform")
forall (m :: * -> *) a. Monad m => a -> m a
return CCallConv
JavaScriptCallConv
check :: Validity -> (SDoc -> SDoc) -> TcM ()
check :: Validity -> (SDoc -> SDoc) -> TcM ()
check Validity
IsValid SDoc -> SDoc
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
check (NotValid SDoc
doc) SDoc -> SDoc
err_fn = SDoc -> TcM ()
addErrTc (SDoc -> SDoc
err_fn SDoc
doc)
illegalForeignTyErr :: SDoc -> SDoc -> SDoc
illegalForeignTyErr :: SDoc -> SDoc -> SDoc
illegalForeignTyErr SDoc
arg_or_res SDoc
extra
= SDoc -> Int -> SDoc -> SDoc
hang SDoc
msg Int
2 SDoc
extra
where
msg :: SDoc
msg = [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Unacceptable", SDoc
arg_or_res
, String -> SDoc
text String
"type in foreign declaration:"]
argument, result :: SDoc
argument :: SDoc
argument = String -> SDoc
text String
"argument"
result :: SDoc
result = String -> SDoc
text String
"result"
badCName :: CLabelString -> SDoc
badCName :: CLabelString -> SDoc
badCName CLabelString
target
= [SDoc] -> SDoc
sep [SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr CLabelString
target) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a valid C identifier"]
foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
foreignDeclCtxt ForeignDecl GhcRn
fo
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"When checking declaration:")
Int
2 (forall a. Outputable a => a -> SDoc
ppr ForeignDecl GhcRn
fo)