module GHC.Tc.Gen.Foreign
( tcForeignImports
, tcForeignExports
, isForeignImport, isForeignExport
, tcFImport, tcFExport
, tcForeignImports'
, tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
, normaliseFfiType
, nonIOok, mustBeIO
, checkSafe, noCheckSafe
, tcForeignExports'
, tcCheckFEType
) where
import GHC.Prelude
import GHC.Hs
import GHC.Tc.Errors.Types
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.Reduction
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 ( zipWithM )
import Control.Monad.Trans.Writer.CPS
( WriterT, runWriterT, tell )
import Control.Monad.Trans.Class
( lift )
isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignImport (unXRec @name -> ForeignImport {}) = True
isForeignImport _ = False
isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
isForeignExport (unXRec @name -> ForeignExport {}) = True
isForeignExport _ = False
normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType ty
= do fam_envs <- tcGetFamInstEnvs
normaliseFfiType' fam_envs ty
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
where
go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction
go role rec_nts ty
| Just ty' <- tcView ty
= go role rec_nts ty'
| Just (tc, tys) <- splitTyConApp_maybe ty
= go_tc_app role rec_nts tc tys
| (bndrs, inner_ty) <- splitForAllTyCoVarBinders ty
, not (null bndrs)
= do redn <- go role rec_nts inner_ty
return $ mkHomoForAllRedn bndrs redn
| otherwise
= return $ mkReflRedn role ty
go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
-> WriterT (Bag GlobalRdrElt) TcM Reduction
go_tc_app role rec_nts tc tys
| tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey]
= children_only
| isNewTyCon tc
, Just rec_nts' <- checkRecTc rec_nts tc
= do { rdr_env <- lift $ getGlobalRdrEnv
; case checkNewtypeFFI rdr_env tc of
Nothing -> nothing
Just gre ->
do { redn <- go role rec_nts' nt_rhs
; tell (unitBag gre)
; return $ nt_co `mkTransRedn` redn } }
| isFamilyTyCon tc
, Reduction co ty <- normaliseTcApp env role tc tys
, not (isReflexiveCo co)
= do redn <- go role rec_nts ty
return $ co `mkTransRedn` redn
| otherwise
= nothing
where
tc_key = getUnique tc
children_only
= do { args <- unzipRedns <$>
zipWithM ( \ ty r -> go r rec_nts ty )
tys (tyConRolesX role tc)
; return $ mkTyConAppRedn role tc args }
nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys []
nt_rhs = newTyConInstRhs tc tys
ty = mkTyConApp tc tys
nothing = return $ mkReflRedn role ty
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI rdr_env tc
| Just con <- tyConSingleDataCon_maybe tc
, Just gre <- lookupGRE_Name rdr_env (dataConName con)
= Just gre
| otherwise
= Nothing
tcForeignImports :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports decls = do
hooks <- getHooks
case tcForeignImportsHook hooks of
Nothing -> tcForeignImports' decls
Just h -> h decls
tcForeignImports' :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignImports' decls
= do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
filter isForeignImport decls
; return (ids, decls, unionManyBags gres) }
tcFImport :: LForeignDecl GhcRn
-> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
, fd_fi = imp_decl }))
= setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo) $
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
; let
(arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty)
id = mkLocalId nm Many sig_ty
; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
; let fi_decl = ForeignImport { fd_name = L nloc id
, fd_sig_ty = undefined
, fd_i_ext = mkSymCo norm_co
, fd_fi = imp_decl' }
; return (id, L dloc fi_decl, gres) }
tcFImport d = pprPanic "tcFImport" (ppr d)
tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src)
= do checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
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 idecl@(CImport (L lc cconv) safety mh CWrapper src) = do
checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv (Right idecl) cconv
case arg_tys of
[Scaled arg1_mult arg1_ty] -> do
checkNoLinearFFI arg1_mult
checkForeignArgs isFFIExternalTy arg1_tys
checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty
checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
_ -> 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
checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv (Right idecl) cconv
case arg_tys of
[] ->
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)
(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)
(TcRnForeignImportPrimExtNotSet idecl)
checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
checkCTarget idecl target
checkTc (playSafe safety)
(TcRnForeignImportPrimSafeAnn idecl)
checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
return idecl
| otherwise = do
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 idecl (map scaledThing arg_tys) res_ty
case target of
StaticTarget _ _ _ False
| not (null arg_tys) ->
addErrTc (TcRnForeignFunctionImportAsValue idecl)
_ -> return ()
return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
checkCTarget :: ForeignImport -> CCallTarget -> TcM ()
checkCTarget idecl (StaticTarget _ str _ _) = do
checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp
checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget"
checkMissingAmpersand :: ForeignImport -> [Type] -> Type -> TcM ()
checkMissingAmpersand idecl arg_tys res_ty
| null arg_tys && isFunPtrTy res_ty
= addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl
| otherwise
= return ()
tcForeignExports :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports decls = do
hooks <- getHooks
case tcForeignExportsHook hooks of
Nothing -> tcForeignExports' decls
Just h -> h decls
tcForeignExports' :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
tcForeignExports' decls
= foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
where
combine (binds, fs, gres1) (L loc fe) = do
(b, f, gres2) <- setSrcSpanA loc (tcFExport fe)
return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
tcFExport :: ForeignDecl GhcRn
-> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })
= addErrCtxt (foreignDeclCtxt fo) $ do
sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty
(Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
spec' <- tcCheckFEType norm_sig_ty spec
id <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc
return ( mkVarBind id rhs
, ForeignExport { fd_name = L loc id
, fd_sig_ty = undefined
, fd_e_ext = norm_co
, fd_fe = spec' }
, gres)
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
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)
where
(arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty)
checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM ()
checkForeignArgs pred tys = mapM_ go tys
where
go (Scaled mult ty) = checkNoLinearFFI mult >>
check (pred ty) (TcRnIllegalForeignType (Just Arg))
checkNoLinearFFI :: Mult -> TcM ()
checkNoLinearFFI Many = return ()
checkNoLinearFFI _ = addErrTc $ TcRnIllegalForeignType (Just Arg)
LinearTypesNotAllowed
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
=
check (pred_res_ty res_ty)
(TcRnIllegalForeignType (Just Result))
| tcIsForAllTy ty
= addErrTc $ TcRnIllegalForeignType (Just Result) UnexpectedNestedForall
| not non_io_result_ok
= addErrTc $ TcRnIllegalForeignType (Just Result) IOResultExpected
| otherwise
= do { dflags <- getDynFlags
; case pred_res_ty ty of
NotValid msg -> addErrTc $ TcRnIllegalForeignType (Just Result) msg
_ | check_safe && safeInferOn dflags
-> recordUnsafeInfer emptyMessages
_ | check_safe && safeLanguageOn dflags
-> addErrTc (TcRnIllegalForeignType (Just Result) SafeHaskellMustBeInIO)
_ -> return () }
nonIOok, mustBeIO :: Bool
nonIOok = True
mustBeIO = False
checkSafe, noCheckSafe :: Bool
checkSafe = True
noCheckSafe = False
checkCOrAsmOrLlvm :: Backend -> Validity' ExpectedBackends
checkCOrAsmOrLlvm ViaC = IsValid
checkCOrAsmOrLlvm NCG = IsValid
checkCOrAsmOrLlvm LLVM = IsValid
checkCOrAsmOrLlvm _ = NotValid COrAsmOrLlvm
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
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
let msg = TcRnUnsupportedCallConv decl StdCallConvUnsupported
addDiagnosticTc msg
return CCallConv
checkCConv decl PrimCallConv = do
addErrTc $ TcRnUnsupportedCallConv decl PrimCallConvUnsupported
return PrimCallConv
checkCConv decl JavaScriptCallConv = do
dflags <- getDynFlags
if platformArch (targetPlatform dflags) == ArchJavaScript
then return JavaScriptCallConv
else do
addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported
return JavaScriptCallConv
check :: Validity' IllegalForeignTypeReason
-> (IllegalForeignTypeReason -> TcRnMessage)
-> TcM ()
check IsValid _ = return ()
check (NotValid reason) mkMessage = addErrTc (mkMessage reason)
foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
foreignDeclCtxt fo
= hang (text "When checking declaration:")
2 (ppr fo)