X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=d13b4bbf9bb0b729eb4cd4664a6cb7d0a199a009;hb=b0d844cf3400e9487d6c8327446e86fbaa10cd6f;hp=2b689acaa99248456750f86142fa883ed468cc9a;hpb=7caedc52dde9fb7f773fb3a1d5fc0f7b2d8de848;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 2b689ac..d13b4bb 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -17,229 +17,333 @@ module TcForeign , tcForeignExports ) where +#include "config.h" #include "HsVersions.h" -import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - ExtName(..), isDynamic, MonoBinds(..), - OutPat(..), ForKind(..) - ) -import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) - -import TcMonad -import TcEnv ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue ) -import TcType ( tcInstTcType, tcInstSigType, tcSplitRhoTy, zonkTcTypeToType ) -import TcMonoType ( tcHsType ) -import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..), - TcForeignExportDecl ) -import TcExpr ( tcId, tcPolyExpr ) -import Inst ( emptyLIE, LIE, plusLIE ) -import CoreSyn - -import ErrUtils ( Message ) -import Id ( Id, idName ) -import Name ( nameOccName ) -import MkId ( mkUserId ) -import Type ( isUnpointedType - , splitFunTys - , splitTyConApp_maybe - , splitForAllTys - , splitRhoTy - , isForAllTy - , mkForAllTys - ) -import TyVar ( emptyTyVarEnv ) +import HsSyn +import TcRnMonad +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) +import TcExpr ( tcCheckSigma ) -import TysWiredIn ( isFFIArgumentTy, isFFIResultTy, - isFFIExternalTy, isAddrTy +import ErrUtils ( Message ) +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, + tcSplitForAllTys, + isFFIArgumentTy, isFFIImportResultTy, + isFFIExportResultTy, isFFILabelTy, + isFFIExternalTy, isFFIDynArgumentTy, + isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy, + toDNType ) -import Type ( Type ) -import Unique -import Unify ( unifyTauTy ) +import ForeignCall ( CExportSpec(..), CCallTarget(..), + isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) +import CStrings ( CLabelString, isCLabelString ) +import PrelNames ( hasKey, ioTyConKey ) +import CmdLineOpts ( dopt_HscLang, HscLang(..) ) import Outputable -import Util -import CmdLineOpts ( opt_GlasgowExts ) -import Maybes ( maybeToBool ) +import SrcLoc ( Located(..), srcSpanStart ) +import Bag ( emptyBag, consBag ) \end{code} \begin{code} -tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl]) -tcForeignImports decls = - mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] - -tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE s, TcMonoBinds s, [TcForeignExportDecl s]) -tcForeignExports decls = - foldlTc combine (emptyLIE, EmptyMonoBinds, []) - [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] - where - combine (lie, binds, fs) fe = - tcFExport fe `thenTc ` \ (a_lie, b, f) -> - returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs) - --- defines a binding -isForeignImport :: ForeignDecl name -> Bool -isForeignImport (ForeignDecl _ k _ dyn _ _) = - case k of - FoImport _ -> True - FoExport -> case dyn of { Dynamic -> True ; _ -> False } - FoLabel -> True - --- exports a binding -isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm) -isForeignExport _ = False - +-- Defines a binding +isForeignImport :: LForeignDecl name -> Bool +isForeignImport (L _ (ForeignImport _ _ _ _)) = True +isForeignImport _ = False + +-- Exports a binding +isForeignExport :: LForeignDecl name -> Bool +isForeignExport (L _ (ForeignExport _ _ _ _)) = True +isForeignExport _ = False \end{code} +%************************************************************************ +%* * +\subsection{Imports} +%* * +%************************************************************************ + \begin{code} -tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl) -tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) = - tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsType hs_ty `thenTc` \ sig_ty -> - let +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) = splitForAllTys sig_ty + (_, 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 - case splitFunTys t_ty of - (arg_tys, res_ty) -> - checkForeignExport True t_ty arg_tys res_ty `thenTc_` - let i = (mkUserId nm sig_ty) in - returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc)) - -tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) = - tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsType hs_ty `thenTc` \ sig_ty -> - let - -- drop the foralls before inspecting the structure - -- of the foreign type. - (_, t_ty) = splitForAllTys sig_ty - in - check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_` - let i = (mkUserId nm sig_ty) in - returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv 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} -tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = - tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsType hs_ty `thenTc` \ ty -> - -- Check that the type has the right shape - -- and that the argument and result types are acceptable. - let - -- drop the foralls before inspecting the structure - -- of the foreign type. - (_, t_ty) = splitForAllTys ty - in - case splitFunTys t_ty of - (arg_tys, res_ty) -> - checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_` - let i = (mkUserId nm ty) in - returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) +------------ Checking types for foreign import ---------------------- +\begin{code} +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_` + (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) ) `thenM_` + return idecl + +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) `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 (checkCOrAsmOrDotNetOrInterp) `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 `thenM_` + check (isCLabelString str) (badCName str) +\end{code} -tcFExport :: RenamedForeignDecl -> TcM s (LIE s, TcMonoBinds s, TcForeignExportDecl s) -tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = - tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ +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). - tcHsType hs_ty `thenTc` \ sig_ty -> - tcInstSigType sig_ty `thenNF_Tc` \ sig_tc_ty -> - tcPolyExpr (HsVar nm) sig_tc_ty `thenTc` \ (rhs, lie, _, _, _) -> +The check is needed for both via-C and native-code routes - let - -- drop the foralls before inspecting the structure - -- of the foreign type. - (_, t_ty) = splitForAllTys sig_ty - in - case splitFunTys t_ty of - (arg_tys, res_ty) -> - checkForeignExport False t_ty arg_tys res_ty `thenTc_` - -- we're exporting a function, but at a type possibly more constrained - -- than its declared/inferred type. Hence the need +\begin{code} +#include "nativeGen/NCG.h" +#if alpha_TARGET_ARCH +checkFEDArgs arg_tys + = check (integral_args <= 4) err + where + integral_args = sum (map getPrimRepSize $ + filter (not . isFloatingRep) $ + map typePrimRep arg_tys) + err = ptext SLIT("On Alpha, I can only handle 4 non-floating-point arguments to foreign export dynamic") +#else +checkFEDArgs arg_tys = returnM () +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection{Exports} +%* * +%************************************************************************ + +\begin{code} +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId]) +tcForeignExports decls + = foldlM combine (emptyBag, []) (filter isForeignExport decls) + where + combine (binds, fs) fe = + wrapLocSndM tcFExport fe `thenM` \ (b, f) -> + returnM (b `consBag` binds, f:fs) + +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 -> + tcCheckSigma (nlHsVar nm) sig_ty `thenM` \ rhs -> + + 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 -- to create a local binding which will call the exported function -- at a particular type (and, maybe, overloading). - newLocalId (nameOccName nm) sig_tc_ty `thenNF_Tc` \ i -> - let - i2 = TcId i - bind = VarMonoBind i2 rhs - in - returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc) - -- ^^^^^^^^^ - -- ToDo: fill the type field in with something sensible. + newUnique `thenM` \ uniq -> + getModule `thenM` \ mod -> + let + 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 (L loc id) undefined spec isDeprec) \end{code} +------------ Checking argument types for foreign export ---------------------- \begin{code} -checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s () -checkForeignImport is_dynamic ty args res - | is_dynamic = - -- * first arg has got to be an Addr - case args of - [] -> check False (illegalForeignTyErr True{-Arg-} ty) - (x:xs) -> - check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_` - mapTc (checkForeignArg isFFIArgumentTy) xs `thenTc_` - checkForeignRes (isFFIResultTy) res - | otherwise = - mapTc (checkForeignArg isFFIArgumentTy) args `thenTc_` - checkForeignRes (isFFIResultTy) res - -checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s () -checkForeignExport is_dynamic ty args res - | is_dynamic = - -- * the first (and only!) arg has got to be a function type - -- * result type is an Addr - case args of - [arg] -> - case splitFunTys arg of - (arg_tys, res_ty) -> - mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_` - checkForeignRes (isFFIResultTy) res_ty `thenTc_` - checkForeignRes (isAddrTy) res - _ -> check False (illegalForeignTyErr True{-Arg-} ty) - | otherwise = - mapTc (checkForeignArg isFFIExternalTy) args `thenTc_` - checkForeignRes (isFFIResultTy) res - -check :: Bool -> Message -> TcM s () -check True _ = returnTc () -check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc () - -checkForeignArg :: (Type -> Bool) -> Type -> TcM s () -checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty) +tcCheckFEType sig_ty (CExport (CExportStatic str _)) + = check (isCLabelString str) (badCName str) `thenM_` + checkForeignArgs isFFIExternalTy arg_tys `thenM_` + checkForeignRes nonIOok isFFIExportResultTy res_ty + where + -- Drop the foralls before inspecting n + -- the structure of the foreign type. + (_, t_ty) = tcSplitForAllTys sig_ty + (arg_tys, res_ty) = tcSplitFunTys t_ty +\end{code} + + +%************************************************************************ +%* * +\subsection{Miscellaneous} +%* * +%************************************************************************ + +\begin{code} +------------ Checking argument types for foreign import ---------------------- +checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM () +checkForeignArgs pred tys + = 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) and that t satisfies the given predicate. +-- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: (Type -> Bool) -> Type -> TcM s () -checkForeignRes pred_res_ty ty = - case (splitTyConApp_maybe ty) of - Just (io, [res_ty]) - | (uniqueOf io) == ioTyConKey && - pred_res_ty res_ty - -> returnTc () - _ | pred_res_ty ty -> returnTc () - | otherwise -> check False (illegalForeignTyErr False{-Res-} ty) - +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () + +nonIOok = True +mustBeIO = False + +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 + -> returnM () + _ + -> check (non_io_result_ok && pred_res_ty ty) + (illegalForeignTyErr result ty) \end{code} +\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 + +checkCOrAsm HscC = Nothing +checkCOrAsm HscAsm = Nothing +checkCOrAsm other + = Just (text "requires via-C or native code generation (-fvia-C)") + +checkCOrAsmOrInterp HscC = Nothing +checkCOrAsmOrInterp HscAsm = Nothing +checkCOrAsmOrInterp HscInterpreted = Nothing +checkCOrAsmOrInterp other + = Just (text "requires interpreted, C or native code generation") + +checkCOrAsmOrDotNetOrInterp HscC = Nothing +checkCOrAsmOrDotNetOrInterp HscAsm = Nothing +checkCOrAsmOrDotNetOrInterp HscILX = Nothing +checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing +checkCOrAsmOrDotNetOrInterp other + = Just (text "requires interpreted, C, native or .NET ILX code generation") + +checkCg check + = getDOpts `thenM` \ dflags -> + let hscLang = dopt_HscLang dflags in + case hscLang of + HscNothing -> returnM () + otherwise -> + case check hscLang of + Nothing -> returnM () + Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) +\end{code} + Warnings \begin{code} -illegalForeignTyErr isArg ty - = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration")]) - 4 (hsep [ ptext SLIT("type:"), ppr ty]) - where - arg_or_res - | isArg = ptext SLIT("argument") - | otherwise = ptext SLIT("result") +check :: Bool -> Message -> TcM () +check True _ = returnM () +check _ the_err = addErrTc the_err + +illegalForeignTyErr arg_or_res ty + = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, + ptext SLIT("type in foreign declaration:")]) + 4 (hsep [ppr ty]) + +-- Used for 'arg_or_res' argument to illegalForeignTyErr +argument = text "argument" +result = text "result" -foreignDeclCtxt fo = - hang (ptext SLIT("When checking a foreign declaration:")) - 4 (ppr fo) +badCName :: CLabelString -> Message +badCName target + = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")] + +foreignDeclCtxt fo + = hang (ptext SLIT("When checking declaration:")) + 4 (ppr fo) + +illegalDNMethodSig + = ptext SLIT("'This pointer' expected as last argument") \end{code} +