X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=4be039bd9326fe0f522a691b69e6125b079cb561;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=00c39a799a243ce4719ea0e01c24f2536f89003f;hpb=1dfaee318171836b32f6b33a14231c69adfdef2f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 00c39a7..4be039b 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -19,45 +19,53 @@ module TcForeign #include "HsVersions.h" -import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - MonoBinds(..), FoImport(..), FoExport(..) - ) -import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) +import HsSyn -import TcMonad -import TcEnv ( newLocalId ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) -import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) +import TcRnMonad +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcExpr ( tcPolyExpr ) -import Inst ( emptyLIE, LIE, plusLIE ) +import ForeignCall ( CCallConv(..) ) import ErrUtils ( Message ) -import Id ( Id, mkLocalId ) -import Name ( nameOccName ) -import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy, - isFFIExportResultTy, - isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy, - isFFILabelTy +import Id ( Id, mkLocalId, mkExportedLocalId ) +#if alpha_TARGET_ARCH +import Type ( typePrimRep ) +import SMRep ( argMachRep, primRepToCgRep, primRepHint ) +#endif +import OccName ( mkForeignExportOcc ) +import Name ( Name, NamedThing(..), mkExternalName ) +import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, + tcSplitForAllTys, + isFFIArgumentTy, isFFIImportResultTy, + isFFIExportResultTy, isFFILabelTy, + isFFIExternalTy, isFFIDynArgumentTy, + isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy, + toDNType ) -import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys ) -import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget ) -import CStrings ( CLabelString, isCLabelString ) +import ForeignCall ( CExportSpec(..), CCallTarget(..), + CLabelString, isCLabelString, + isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) import PrelNames ( hasKey, ioTyConKey ) -import CmdLineOpts ( dopt_HscLang, HscLang(..) ) +import DynFlags ( DynFlags(..), HscTarget(..) ) import Outputable +import SrcLoc ( Located(..), srcSpanStart ) +import Bag ( consBag ) +#if alpha_TARGET_ARCH +import MachOp ( machRepByteWidth, MachHint(FloatHint) ) +#endif \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} %************************************************************************ @@ -67,76 +75,123 @@ isForeignExport _ = False %************************************************************************ \begin{code} -tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) -tcForeignImports decls = - mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] - -tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) -tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> +tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id]) +tcForeignImports decls + = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls) + +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 = 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 `thenNF_Tc_` - returnTc (id, ForeignImport id undefined imp_decl src_loc) + 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 (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 (LblImport _) - = checkCg checkCOrAsm `thenNF_Tc_` - check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) - -tcCheckFIType sig_ty arg_tys res_ty (CDynImport _) - = -- Foreign export dynamic - -- The first (and only!) arg has got to be a function type - -- and it must return IO t; result type is IO Addr - checkCg checkCOrAsm `thenNF_Tc_` - case arg_tys of - [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenNF_Tc_` - checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenNF_Tc_` - checkForeignRes mustBeIO isFFIDynResultTy res_ty +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) `thenM_` + return idecl + +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_` + checkCConv cconv `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 (CCallSpec target _ safety)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target)) | isDynamicTarget target -- Foreign import dynamic - = checkCg checkCOrAsmOrInterp `thenNF_Tc_` - case arg_tys of -- The first arg must be Addr - [] -> check False (illegalForeignTyErr empty sig_ty) - (arg1_ty:arg_tys) -> getDOptsTc `thenNF_Tc` \ dflags -> - check (isFFIDynArgumentTy arg1_ty) - (illegalForeignTyErr argument arg1_ty) `thenNF_Tc_` - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_` - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty - + = checkCg checkCOrAsmOrInterp `thenM_` + checkCConv cconv `thenM_` + case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr + [] -> + 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) `thenNF_Tc_` - checkCTarget target `thenNF_Tc_` - getDOptsTc `thenNF_Tc` \ dflags -> - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_` - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_` + checkCConv cconv `thenM_` + checkCTarget target `thenM_` + getDOpts `thenM` \ dflags -> + checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` + 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 `thenNF_Tc_` + = checkCg checkCOrAsmOrDotNetOrInterp `thenM_` check (isCLabelString str) (badCName str) +\end{code} + +On an Alpha, with foreign export dynamic, due to a giant hack when +building adjustor thunks, we only allow 4 integer arguments with +foreign export dynamic (i.e., 32 bytes of arguments after padding each +argument to a quadword, excluding floating-point arguments). + +The check is needed for both via-C and native-code routes -checkCTarget (CasmTarget _) - = checkCg checkC +\begin{code} +#include "nativeGen/NCG.h" +#if alpha_TARGET_ARCH +checkFEDArgs arg_tys + = check (integral_args <= 32) err + where + integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep + | prim_rep <- map typePrimRep arg_tys, + primRepHint prim_rep /= FloatHint ] + err = ptext SLIT("On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic") +#else +checkFEDArgs arg_tys = returnM () +#endif \end{code} @@ -147,42 +202,46 @@ checkCTarget (CasmTarget _) %************************************************************************ \begin{code} -tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) -tcForeignExports decls = - foldlTc combine (emptyLIE, EmptyMonoBinds, []) - [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId]) +tcForeignExports decls + = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls) where - combine (lie, binds, fs) fe = - tcFExport fe `thenTc ` \ (a_lie, b, f) -> - returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs) + combine (binds, fs) fe = + wrapLocSndM tcFExport fe `thenM` \ (b, f) -> + returnM (b `consBag` binds, f:fs) -tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) -tcFExport fo@(ForeignExport nm hs_ty spec src_loc) = - tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ +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 `thenTc` \ sig_ty -> - tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) -> + tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> + tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs -> - tcCheckFEType sig_ty spec `thenTc_` + tcCheckFEType sig_ty spec `thenM_` - -- we're exporting a function, but at a type possibly more constrained - -- than its declared/inferred type. Hence the need + -- we're exporting a function, but at a type possibly more + -- constrained than its declared/inferred type. Hence the need -- to create a local binding which will call the exported function -- at a particular type (and, maybe, overloading). - newLocalId (nameOccName nm) sig_ty src_loc `thenNF_Tc` \ id -> + + newUnique `thenM` \ uniq -> + getModule `thenM` \ mod -> let - 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 - returnTc (lie, bind, ForeignExport id undefined spec src_loc) + returnM (bind, ForeignExport (L loc id) undefined spec isDeprec) \end{code} ------------ Checking argument types for foreign export ---------------------- \begin{code} tcCheckFEType sig_ty (CExport (CExportStatic str _)) - = check (isCLabelString str) (badCName str) `thenNF_Tc_` - checkForeignArgs isFFIExternalTy arg_tys `thenNF_Tc_` + = check (isCLabelString str) (badCName str) `thenM_` + checkForeignArgs isFFIExternalTy arg_tys `thenM_` checkForeignRes nonIOok isFFIExportResultTy res_ty where -- Drop the foralls before inspecting n @@ -201,18 +260,18 @@ tcCheckFEType sig_ty (CExport (CExportStatic str _)) \begin{code} ------------ Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM () +checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM () checkForeignArgs pred tys - = mapNF_Tc go tys `thenNF_Tc_` returnNF_Tc () + = mappM go tys `thenM_` + returnM () where go ty = check (pred ty) (illegalForeignTyErr argument ty) - ------------ Checking result types for foreign calls ---------------------- -- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM () +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () nonIOok = True mustBeIO = False @@ -221,19 +280,21 @@ checkForeignRes non_io_result_ok pred_res_ty ty = case tcSplitTyConApp_maybe ty of Just (io, [res_ty]) | io `hasKey` ioTyConKey && pred_res_ty res_ty - -> returnNF_Tc () + -> returnM () _ -> check (non_io_result_ok && pred_res_ty ty) (illegalForeignTyErr result ty) \end{code} -\begin{code} -checkDotNet HscILX = Nothing -checkDotNet other = Just (text "requires .NET code generation (-filx)") +\begin{code} +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 @@ -245,12 +306,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 @@ -259,21 +314,33 @@ checkCOrAsmOrDotNetOrInterp other = Just (text "requires interpreted, C, native or .NET ILX code generation") checkCg check - = getDOptsTc `thenNF_Tc` \ dflags -> - let hscLang = dopt_HscLang dflags in - case hscLang of - HscNothing -> returnNF_Tc () - otherwise -> - case check hscLang of - Nothing -> returnNF_Tc () - Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) + = getDOpts `thenM` \ dflags -> + let target = hscTarget dflags in + case target of + HscNothing -> returnM () + otherwise -> + case check target of + Nothing -> returnM () + Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} +Calling conventions + +\begin{code} +checkCConv :: CCallConv -> TcM () +checkCConv CCallConv = return () +#if i386_TARGET_ARCH +checkCConv StdCallConv = return () +#else +checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall") +#endif +\end{code} + Warnings \begin{code} -check :: Bool -> Message -> NF_TcM () -check True _ = returnTc () +check :: Bool -> Message -> TcM () +check True _ = returnM () check _ the_err = addErrTc the_err illegalForeignTyErr arg_or_res ty @@ -292,4 +359,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} +