X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=d13b4bbf9bb0b729eb4cd4664a6cb7d0a199a009;hb=b0d844cf3400e9487d6c8327446e86fbaa10cd6f;hp=bcf44f10f2f8249ae01ace0711f6caea495e81cf;hpb=6da624257303de84702e5e1e17adcafb0b82731c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index bcf44f1..d13b4bb 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -17,24 +17,21 @@ module TcForeign , tcForeignExports ) where +#include "config.h" #include "HsVersions.h" -import HsSyn ( ForeignDecl(..), HsExpr(..), - MonoBinds(..), ForeignImport(..), ForeignExport(..), - CImportSpec(..) - ) -import RnHsSyn ( RenamedForeignDecl ) +import HsSyn import TcRnMonad -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) -import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl ) -import TcExpr ( tcExpr ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) +import TcExpr ( tcCheckSigma ) import ErrUtils ( Message ) -import Id ( Id, mkLocalId, mkVanillaGlobal, setIdLocalExported ) -import IdInfo ( noCafIdInfo ) +import Id ( Id, mkLocalId, mkExportedLocalId ) +#if alpha_TARGET_ARCH import PrimRep ( getPrimRepSize, isFloatingRep ) import Type ( typePrimRep ) +#endif import OccName ( mkForeignExportOcc ) import Name ( Name, NamedThing(..), mkExternalName ) import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, @@ -42,27 +39,30 @@ import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, isFFIArgumentTy, isFFIImportResultTy, isFFIExportResultTy, isFFILabelTy, isFFIExternalTy, isFFIDynArgumentTy, - isFFIDynResultTy, + isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy, + toDNType ) -import ForeignCall ( CExportSpec(..), CCallTarget(..), CCallConv(..), - isDynamicTarget, isCasmTarget ) +import ForeignCall ( CExportSpec(..), CCallTarget(..), + isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) import CmdLineOpts ( dopt_HscLang, HscLang(..) ) import Outputable +import SrcLoc ( Located(..), srcSpanStart ) +import Bag ( emptyBag, consBag ) \end{code} \begin{code} -- Defines a binding -isForeignImport :: ForeignDecl name -> Bool -isForeignImport (ForeignImport _ _ _ _ _) = True -isForeignImport _ = False +isForeignImport :: LForeignDecl name -> Bool +isForeignImport (L _ (ForeignImport _ _ _ _)) = True +isForeignImport _ = False -- Exports a binding -isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignExport _ _ _ _ _) = True -isForeignExport _ = False +isForeignExport :: LForeignDecl name -> Bool +isForeignExport (L _ (ForeignExport _ _ _ _)) = True +isForeignExport _ = False \end{code} %************************************************************************ @@ -72,84 +72,98 @@ isForeignExport _ = False %************************************************************************ \begin{code} -tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl]) +tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id]) tcForeignImports decls - = mapAndUnzipM tcFImport (filter isForeignImport decls) + = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls) -tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) -tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) - = addSrcLoc src_loc $ - addErrCtxt (foreignDeclCtxt fo) $ +tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id) +tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec) + = addErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> let -- drop the foralls before inspecting the structure -- 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 (L loc id) undefined imp_decl' isDeprec) \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 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_` + (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_` + = checkCg (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 checkCTarget (StaticTarget str) = checkCg checkCOrAsmOrDotNetOrInterp `thenM_` check (isCLabelString str) (badCName str) - -checkCTarget (CasmTarget _) - = checkCg checkC \end{code} On an Alpha, with foreign export dynamic, due to a giant hack when @@ -182,22 +196,21 @@ checkFEDArgs arg_tys = returnM () %************************************************************************ \begin{code} -tcForeignExports :: [ForeignDecl Name] - -> TcM (TcMonoBinds, [TcForeignDecl]) +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId]) tcForeignExports decls - = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls) + = foldlM combine (emptyBag, []) (filter isForeignExport decls) where combine (binds, fs) fe = - tcFExport fe `thenM ` \ (b, f) -> - returnM (b `AndMonoBinds` binds, f:fs) + wrapLocSndM tcFExport fe `thenM` \ (b, f) -> + returnM (b `consBag` binds, f:fs) -tcFExport :: RenamedForeignDecl -> TcM (TcMonoBinds, TcForeignDecl) -tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = - addSrcLoc src_loc $ +tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id) +tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) = addErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> - tcExpr (HsVar nm) sig_ty `thenM` \ rhs -> + tcCheckSigma (nlHsVar nm) sig_ty `thenM` \ rhs -> tcCheckFEType sig_ty spec `thenM_` @@ -209,11 +222,12 @@ tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = newUnique `thenM` \ uniq -> getModule `thenM` \ mod -> let - gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc - id = setIdLocalExported (mkLocalId gnm sig_ty) - bind = VarMonoBind id rhs + gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) + Nothing (srcSpanStart loc) + id = mkExportedLocalId gnm sig_ty + bind = L loc (VarBind id rhs) in - returnM (bind, ForeignExport id undefined spec isDeprec src_loc) + returnM (bind, ForeignExport (L loc id) undefined spec isDeprec) \end{code} ------------ Checking argument types for foreign export ---------------------- @@ -267,12 +281,14 @@ 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)") - checkCOrAsm HscC = Nothing checkCOrAsm HscAsm = Nothing checkCOrAsm other @@ -284,12 +300,6 @@ checkCOrAsmOrInterp HscInterpreted = Nothing checkCOrAsmOrInterp other = Just (text "requires interpreted, C or native code generation") -checkCOrAsmOrDotNet HscC = Nothing -checkCOrAsmOrDotNet HscAsm = Nothing -checkCOrAsmOrDotNet HscILX = Nothing -checkCOrAsmOrDotNet other - = Just (text "requires C, native or .NET ILX code generation") - checkCOrAsmOrDotNetOrInterp HscC = Nothing checkCOrAsmOrDotNetOrInterp HscAsm = Nothing checkCOrAsmOrDotNetOrInterp HscILX = Nothing @@ -331,5 +341,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}