X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=ec2cffe89b1fd879930cf4664896682bf2e6959a;hb=a7d8f43718b167689c0a4a4c23b33a325e0239f1;hp=dadf8be67a87eac7884c7c2ed895fb22747e9068;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index dadf8be..ec2cffe 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -17,18 +17,19 @@ module TcForeign , tcForeignExports ) where +#include "config.h" #include "HsVersions.h" -import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), +import HsSyn ( ForeignDecl(..), HsExpr(..), MonoBinds(..), ForeignImport(..), ForeignExport(..), CImportSpec(..) ) -import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) +import RnHsSyn ( RenamedForeignDecl ) import TcRnMonad import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl ) -import TcExpr ( tcExpr ) +import TcExpr ( tcCheckSigma ) import ErrUtils ( Message ) import Id ( Id, mkLocalId, mkVanillaGlobal, setIdLocalExported ) @@ -36,16 +37,17 @@ import IdInfo ( noCafIdInfo ) import PrimRep ( getPrimRepSize, isFloatingRep ) import Type ( typePrimRep ) import OccName ( mkForeignExportOcc ) -import Name ( NamedThing(..), mkExternalName ) +import Name ( Name, NamedThing(..), mkExternalName ) import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys, isFFIArgumentTy, isFFIImportResultTy, isFFIExportResultTy, isFFILabelTy, isFFIExternalTy, isFFIDynArgumentTy, - isFFIDynResultTy, + isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy, + toDNType ) import ForeignCall ( CExportSpec(..), CCallTarget(..), CCallConv(..), - isDynamicTarget, isCasmTarget ) + isDynamicTarget, isCasmTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) import CmdLineOpts ( dopt_HscLang, HscLang(..) ) @@ -72,10 +74,9 @@ isForeignExport _ = False %************************************************************************ \begin{code} -tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) -tcForeignImports decls = - mapAndUnzipM tcFImport - [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] +tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl]) +tcForeignImports decls + = mapAndUnzipM tcFImport (filter isForeignImport decls) tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) @@ -87,68 +88,80 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) -- of the foreign type. (_, t_ty) = tcSplitForAllTys sig_ty (arg_tys, res_ty) = tcSplitFunTys t_ty - id = mkVanillaGlobal nm sig_ty noCafIdInfo - -- Foreign-imported things don't neeed zonking etc - -- They are rather like constructors; we make the final - -- Global Id right away. + id = mkLocalId nm sig_ty + -- Use a LocalId to obey the invariant that locally-defined + -- things are LocalIds. However, it does not need zonking, + -- (so TcHsSyn.zonkForeignExports ignores it). in - tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM_` + tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' -> -- can't use sig_ty here because it :: Type and we need HsType Id -- hence the undefined - returnM (id, ForeignImport id undefined imp_decl isDeprec src_loc) + returnM (id, ForeignImport id undefined imp_decl' isDeprec src_loc) \end{code} ------------ Checking types for foreign import ---------------------- \begin{code} -tcCheckFIType _ _ _ (DNImport _) - = checkCg checkDotNet - -tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _)) +tcCheckFIType _ arg_tys res_ty (DNImport spec) + = checkCg checkDotnet `thenM_` + getDOpts `thenM` \ dflags -> + checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_` + checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_` + let (DNCallSpec isStatic kind _ _ _ _) = spec in + (case kind of + DNMethod | not isStatic -> + case arg_tys of + [] -> addErrTc illegalDNMethodSig + _ + | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig + | otherwise -> returnM () + _ -> returnM ()) `thenM_` + returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty))) + +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = checkCg checkCOrAsm `thenM_` - check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) + check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_` + return idecl -tcCheckFIType sig_ty arg_tys res_ty (CImport cconv _ _ _ CWrapper) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = -- 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) as well -- as ft -> IO Addr is accepted, too. The use of the latter two forms -- is DEPRECATED, though. - checkCg (if cconv == StdCallConv - then checkC - else checkCOrAsmOrInterp) `thenM_` - -- the native code gen can't handle foreign import stdcall "wrapper", - -- because it doesn't emit the '@n' suffix on the label of the - -- C stub function. Infrastructure changes are required to make this - -- happen; MachLabel will need to carry around information about - -- the arity of the foreign call. - case arg_tys of - [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_` - checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_` - checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_` + checkCg checkCOrAsmOrInterp `thenM_` + (case arg_tys of + [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_` + checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_` + checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_` checkFEDArgs arg1_tys where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - other -> addErrTc (illegalForeignTyErr empty sig_ty) + other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_` + return idecl -tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction target)) | isDynamicTarget target -- Foreign import dynamic = checkCg checkCOrAsmOrInterp `thenM_` case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr - [] -> check False (illegalForeignTyErr empty sig_ty) - (arg1_ty:arg_tys) -> getDOpts `thenM` \ dflags -> - check (isFFIDynArgumentTy arg1_ty) - (illegalForeignTyErr argument arg1_ty) `thenM_` - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty - + [] -> + check False (illegalForeignTyErr empty sig_ty) `thenM_` + return idecl + (arg1_ty:arg_tys) -> + getDOpts `thenM` \ dflags -> + check (isFFIDynArgumentTy arg1_ty) + (illegalForeignTyErr argument arg1_ty) `thenM_` + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` + checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_` + return idecl | otherwise -- Normal foreign import = checkCg (if isCasmTarget target then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_` checkCTarget target `thenM_` getDOpts `thenM` \ dflags -> checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_` + return idecl -- This makes a convenient place to check -- that the C identifier is valid for C @@ -190,11 +203,10 @@ checkFEDArgs arg_tys = returnM () %************************************************************************ \begin{code} -tcForeignExports :: [RenamedHsDecl] +tcForeignExports :: [ForeignDecl Name] -> TcM (TcMonoBinds, [TcForeignDecl]) -tcForeignExports decls = - foldlM combine (EmptyMonoBinds, []) - [foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] +tcForeignExports decls + = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls) where combine (binds, fs) fe = tcFExport fe `thenM ` \ (b, f) -> @@ -206,7 +218,7 @@ tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = addErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> - tcExpr (HsVar nm) sig_ty `thenM` \ rhs -> + tcCheckSigma (HsVar nm) sig_ty `thenM` \ rhs -> tcCheckFEType sig_ty spec `thenM_` @@ -276,8 +288,13 @@ checkForeignRes non_io_result_ok pred_res_ty ty \end{code} \begin{code} -checkDotNet HscILX = Nothing -checkDotNet other = Just (text "requires .NET code generation (-filx)") +checkDotnet HscILX = Nothing +#if defined(mingw32_TARGET_OS) +checkDotnet HscC = Nothing +checkDotnet _ = Just (text "requires C code generation (-fvia-C)") +#else +checkDotnet other = Just (text "requires .NET support (-filx or win32)") +#endif checkC HscC = Nothing checkC other = Just (text "requires C code generation (-fvia-C)") @@ -340,5 +357,9 @@ badCName target foreignDeclCtxt fo = hang (ptext SLIT("When checking declaration:")) 4 (ppr fo) + +illegalDNMethodSig + = ptext SLIT("'This pointer' expected as last argument") + \end{code}