X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=a8e63a331b50b22e1f31c8b064354c0d7236cb31;hb=5e3f005d3012472e422d4ffd7dca5c21a80fca80;hp=c84c3c8ca41ad5dfb48075801f57a1bf4240f292;hpb=1deb7f3446202e677be9d9b7a88000ec4f2ff85b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index c84c3c8..a8e63a3 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -20,43 +20,171 @@ module TcForeign #include "HsVersions.h" import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - ExtName(Dynamic), isDynamicExtName, MonoBinds(..), - OutPat(..), ForKind(..) + MonoBinds(..), FoImport(..), FoExport(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) import TcMonad -import TcEnv ( newLocalId ) -import TcType ( tcSplitRhoTy, zonkTcTypeToType ) -import TcMonoType ( tcHsBoxedSigType ) -import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, - TcForeignExportDecl ) -import TcExpr ( tcId, tcPolyExpr ) +import TcEnv ( newLocalName ) +import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) +import TcExpr ( tcExpr ) import Inst ( emptyLIE, LIE, plusLIE ) import ErrUtils ( Message ) -import Id ( Id, idName, mkVanillaId ) +import Id ( Id, mkLocalId ) import Name ( nameOccName ) -import Type ( splitFunTys - , splitTyConApp_maybe - , splitForAllTys +import PrimRep ( getPrimRepSize, isFloatingRep ) +import Type ( typePrimRep ) +import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys, + isFFIArgumentTy, isFFIImportResultTy, + isFFIExportResultTy, isFFILabelTy, + isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy ) -import TysWiredIn ( isFFIArgumentTy, isFFIResultTy, - isFFIExternalTy, isAddrTy, - isFFIDynResultTy, isFFILabelTy - ) -import Type ( Type ) -import Unique +import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget ) +import CStrings ( CLabelString, isCLabelString ) +import PrelNames ( hasKey, ioTyConKey ) +import CmdLineOpts ( dopt_HscLang, HscLang(..) ) import Outputable \end{code} \begin{code} -tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl]) +-- Defines a binding +isForeignImport :: ForeignDecl name -> Bool +isForeignImport (ForeignImport _ _ _ _) = True +isForeignImport _ = False + +-- Exports a binding +isForeignExport :: ForeignDecl name -> Bool +isForeignExport (ForeignExport _ _ _ _) = True +isForeignExport _ = False +\end{code} + +%************************************************************************ +%* * +\subsection{Imports} +%* * +%************************************************************************ + +\begin{code} +tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) tcForeignImports decls = mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] -tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl]) +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 -> + 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 + in + tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenNF_Tc_` + returnTc (id, ForeignImport id undefined imp_decl src_loc) +\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 `thenNF_Tc_` + checkFEDArgs arg1_tys + where + (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty + other -> addErrTc (illegalForeignTyErr empty sig_ty) + +tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety)) + | 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 + + | 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 + +-- This makes a convenient place to check +-- that the C identifier is valid for C +checkCTarget (StaticTarget str) + = checkCg checkCOrAsmOrDotNetOrInterp `thenNF_Tc_` + check (isCLabelString str) (badCName str) + +checkCTarget (CasmTarget _) + = checkCg checkC +\end{code} + +On a SPARC, with foreign export dynamic, due to a giant hack when building +adjustor thunks, we only allow 16 bytes of arguments! + +So for example, args (Int,Double,Int) would be OK (1+2+1) +as would (Int,Int,Int,Int) (1+1+1+1) but not (Int,Double,Double) (1+2+2). + +On an Alpha, due to a similar hack, 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 + +\begin{code} +#include "nativeGen/NCG.h" +#if sparc_TARGET_ARCH +checkFEDArgs arg_tys + = check (words_of_args <= 4) err + where + words_of_args = sum (map (getPrimRepSize . typePrimRep) arg_tys) + err = ptext SLIT("On SPARC, I can only handle 4 words of arguments to foreign export dynamic") +#else +#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 = returnNF_Tc () +#endif +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection{Exports} +%* * +%************************************************************************ + +\begin{code} +tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) tcForeignExports decls = foldlTc combine (emptyLIE, EmptyMonoBinds, []) [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] @@ -65,167 +193,142 @@ tcForeignExports decls = 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 +tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) +tcFExport fo@(ForeignExport nm hs_ty spec src_loc) = + tcAddSrcLoc src_loc $ + tcAddErrCtxt (foreignDeclCtxt fo) $ --- exports a binding -isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm) -isForeignExport _ = False + tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> + tcExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie) -> -\end{code} + tcCheckFEType sig_ty spec `thenTc_` -\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) $ - tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> - 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 True t_ty arg_tys res_ty `thenTc_` - let i = (mkVanillaId 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) $ - tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> - let - -- drop the foralls before inspecting the structure - -- of the foreign type. - (_, t_ty) = splitForAllTys sig_ty - in - check (isFFILabelTy t_ty) - (illegalForeignTyErr False{-result-} sig_ty) `thenTc_` - let i = (mkVanillaId nm sig_ty) in - returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc)) - -tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) = - tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ - - tcHsBoxedSigType 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 (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_` - let i = (mkVanillaId nm ty) in - returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) - -tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl) -tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = - tcAddSrcLoc src_loc $ - tcAddErrCtxt (foreignDeclCtxt fo) $ - - tcHsBoxedSigType hs_ty `thenTc` \ sig_ty -> - tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) -> - - 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 -- 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` \ i -> - let - bind = VarMonoBind i rhs - in - returnTc (lie, bind, ForeignDecl i imp_exp undefined ext_nm cconv src_loc) - -- ^^^^^^^^^ - -- ToDo: fill the type field in with something sensible. + newLocalName nm `thenNF_Tc` \ id_name -> + let + id = mkLocalId id_name sig_ty + bind = VarMonoBind id rhs + in + returnTc (lie, bind, ForeignExport id undefined spec src_loc) +\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_` + 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} -checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s () -checkForeignImport is_dynamic is_safe 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 is_safe)) xs `thenTc_` - checkForeignRes True {-NonIO ok-} isFFIResultTy res - | otherwise = - mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_` - checkForeignRes True {-NonIO ok-} 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 - -- and it must return IO t - -- * result type is an Addr or IO Addr - case args of - [arg] -> - case splitFunTys arg of - (arg_tys, res_ty) -> - mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_` - checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_` - checkForeignRes False {-Must be IO-} isFFIDynResultTy res - _ -> check False (illegalForeignTyErr True{-Arg-} ty) - | otherwise = - mapTc (checkForeignArg isFFIExternalTy) args `thenTc_` - checkForeignRes True {-NonIO ok-} isFFIResultTy res - -checkForeignArg :: (Type -> Bool) -> Type -> TcM s () -checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty) +------------ Checking argument types for foreign import ---------------------- +checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM () +checkForeignArgs pred tys + = mapNF_Tc go tys `thenNF_Tc_` returnNF_Tc () + 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 -> TcM s () -checkForeignRes non_io_result_ok pred_res_ty ty = - case (splitTyConApp_maybe ty) of - Just (io, [res_ty]) +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_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 - -> returnTc () - _ + -> returnNF_Tc () + _ -> check (non_io_result_ok && pred_res_ty ty) - (illegalForeignTyErr False{-Res-} ty) + (illegalForeignTyErr result ty) \end{code} +\begin{code} +checkDotNet HscILX = Nothing +checkDotNet other = Just (text "requires .NET code generation (-filx)") + +checkC HscC = Nothing +checkC other = Just (text "requires C code generation (-fvia-C)") + +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") + +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 +checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing +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) +\end{code} + Warnings \begin{code} -check :: Bool -> Message -> TcM s () +check :: Bool -> Message -> NF_TcM () check True _ = returnTc () -check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc () +check _ the_err = addErrTc the_err -illegalForeignTyErr isArg ty - = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, ptext SLIT("type in foreign declaration:")]) +illegalForeignTyErr arg_or_res ty + = hang (hsep [ptext SLIT("Unacceptable"), arg_or_res, + ptext SLIT("type in foreign declaration:")]) 4 (hsep [ppr ty]) - where - arg_or_res - | isArg = ptext SLIT("argument") - | otherwise = ptext SLIT("result") -foreignDeclCtxt fo = - hang (ptext SLIT("When checking declaration:")) - 4 (ppr fo) +-- Used for 'arg_or_res' argument to illegalForeignTyErr +argument = text "argument" +result = text "result" + +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) \end{code} +