X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=3236ec06491ea5cb74af8cfedc4353728e753451;hb=c00aaade52ab407c10d14e970f42f8100cb45ead;hp=615dea832f575ffcbc66ebaae090e28ef8eff0ae;hpb=cbdeae8fc8a1c72d20d89241acae8a313214b51c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 615dea8..3236ec0 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -26,28 +26,25 @@ import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) import TcMonad import TcEnv ( newLocalId ) -import TcMonoType ( tcHsLiftedSigType ) -import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, - TcForeignExportDecl ) +import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) import TcExpr ( tcPolyExpr ) import Inst ( emptyLIE, LIE, plusLIE ) import ErrUtils ( Message ) import Id ( Id, mkLocalId ) import Name ( nameOccName ) -import Type ( splitFunTys - , splitTyConApp_maybe - , splitForAllTys +import PrimRep ( getPrimRepSize ) +import Type ( typePrimRep ) +import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys, + isFFIArgumentTy, isFFIImportResultTy, + isFFIExportResultTy, isFFILabelTy, + isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy ) -import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy, - isFFIExportResultTy, - isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy, - isFFILabelTy - ) -import Type ( Type ) -import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget ) +import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) +import CmdLineOpts ( dopt_HscLang, HscLang(..) ) import Outputable \end{code} @@ -79,12 +76,12 @@ tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsLiftedSigType hs_ty `thenTc` \ sig_ty -> + tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> let -- drop the foralls before inspecting the structure -- of the foreign type. - (_, t_ty) = splitForAllTys sig_ty - (arg_tys, res_ty) = splitFunTys t_ty + (_, 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_` @@ -95,26 +92,30 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) ------------ Checking types for foreign import ---------------------- \begin{code} tcCheckFIType _ _ _ (DNImport _) - = returnNF_Tc () -- No error checking yet + = checkCg checkDotNet tcCheckFIType sig_ty arg_tys res_ty (LblImport _) - = check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) + = 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 + checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenNF_Tc_` + checkFEDArgs arg1_tys where - (arg1_tys, res1_ty) = splitFunTys arg1_ty + (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 - = case arg_tys of -- The first arg must be Addr + = 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) @@ -123,15 +124,53 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety)) checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty | otherwise -- Normal foreign import - = getDOptsTc `thenNF_Tc` \ dflags -> + = 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) | not (isCLabelString str) = addErrTc (badCName str) -checkCTarget other = returnNF_Tc () +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") +#elsif alpha_TARGET_ARCH +checkFEDArgs arg_tys + = check (integral_args <= 4) err + where + integral_args = sum (map (getPrimRepSize . filter (not . isFloatingRep) + . 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 \end{code} @@ -156,8 +195,8 @@ tcFExport fo@(ForeignExport nm hs_ty spec src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ - tcHsLiftedSigType hs_ty `thenTc` \ sig_ty -> - tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) -> + tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> + tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) -> tcCheckFEType sig_ty spec `thenTc_` @@ -182,8 +221,8 @@ tcCheckFEType sig_ty (CExport (CExportStatic str _)) where -- Drop the foralls before inspecting n -- the structure of the foreign type. - (_, t_ty) = splitForAllTys sig_ty - (arg_tys, res_ty) = splitFunTys t_ty + (_, t_ty) = tcSplitForAllTys sig_ty + (arg_tys, res_ty) = tcSplitFunTys t_ty \end{code} @@ -212,16 +251,58 @@ checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM () nonIOok = True mustBeIO = False -checkForeignRes non_io_result_ok pred_res_ty ty = - case (splitTyConApp_maybe ty) of - Just (io, [res_ty]) +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 () - _ + _ -> 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)") + +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} @@ -230,7 +311,8 @@ check True _ = returnTc () 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:")]) + = 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 @@ -238,9 +320,11 @@ argument = text "argument" result = text "result" badCName :: CLabelString -> Message -badCName target = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")] +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) + 4 (ppr fo) \end{code} +