X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=b2ddda6bb21d93e47b46a439e668c83799aa5d99;hb=1553c7788e7f663bfc55813158325d695a21a229;hp=440ef584eb67027d1d0526114450671655a0e928;hpb=c4c72cb2a7b414b4c97ffa1e9abe1a94e483ee48;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 440ef58..b2ddda6 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -20,29 +20,33 @@ module TcForeign #include "HsVersions.h" import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - MonoBinds(..), FoImport(..), FoExport(..) + MonoBinds(..), ForeignImport(..), ForeignExport(..), + CImportSpec(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) import TcMonad -import TcEnv ( newLocalId ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl ) -import TcExpr ( tcPolyExpr ) +import TcExpr ( tcExpr ) import Inst ( emptyLIE, LIE, plusLIE ) import ErrUtils ( Message ) -import Id ( Id, mkLocalId ) -import Name ( nameOccName ) -import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy, - isFFIExportResultTy, - isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy, - isFFILabelTy - ) -import PrimRep ( getPrimRepSize ) +import Id ( Id, mkLocalId, setIdLocalExported ) +import PrimRep ( getPrimRepSize, isFloatingRep ) +import Module ( Module ) import Type ( typePrimRep ) -import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys ) -import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget ) +import OccName ( mkForeignExportOcc ) +import Name ( NamedThing(..), mkExternalName ) +import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, + tcSplitForAllTys, + isFFIArgumentTy, isFFIImportResultTy, + isFFIExportResultTy, isFFILabelTy, + isFFIExternalTy, isFFIDynArgumentTy, + isFFIDynResultTy, isForeignPtrTy + ) +import ForeignCall ( CExportSpec(..), CCallTarget(..), + isDynamicTarget, isCasmTarget ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) import CmdLineOpts ( dopt_HscLang, HscLang(..) ) @@ -53,13 +57,13 @@ import Outputable \begin{code} -- Defines a binding isForeignImport :: ForeignDecl name -> Bool -isForeignImport (ForeignImport _ _ _ _) = True -isForeignImport _ = False +isForeignImport (ForeignImport _ _ _ _ _) = True +isForeignImport _ = False -- Exports a binding isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignExport _ _ _ _) = True -isForeignExport _ = False +isForeignExport (ForeignExport _ _ _ _ _) = True +isForeignExport _ = False \end{code} %************************************************************************ @@ -71,10 +75,11 @@ isForeignExport _ = False \begin{code} tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) tcForeignImports decls = - mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] + 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) +tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> @@ -86,7 +91,9 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) 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) + -- can't use sig_ty here because it :: Type and we need HsType Id + -- hence the undefined + returnTc (id, ForeignImport id undefined imp_decl isDeprec src_loc) \end{code} @@ -95,15 +102,17 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) tcCheckFIType _ _ _ (DNImport _) = checkCg checkDotNet -tcCheckFIType sig_ty arg_tys res_ty (LblImport _) +tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _)) = 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_` +tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ 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 `thenNF_Tc_` case arg_tys of [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenNF_Tc_` checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenNF_Tc_` @@ -113,10 +122,10 @@ tcCheckFIType sig_ty arg_tys res_ty (CDynImport _) (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty other -> addErrTc (illegalForeignTyErr empty sig_ty) -tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety)) +tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target)) | isDynamicTarget target -- Foreign import dynamic = checkCg checkCOrAsmOrInterp `thenNF_Tc_` - case arg_tys of -- The first arg must be Addr + case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> check False (illegalForeignTyErr empty sig_ty) (arg1_ty:arg_tys) -> getDOptsTc `thenNF_Tc` \ dflags -> check (isFFIDynArgumentTy arg1_ty) @@ -148,6 +157,10 @@ 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} @@ -159,8 +172,18 @@ checkFEDArgs arg_tys 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} @@ -171,34 +194,38 @@ checkFEDArgs arg_tys = returnNF_Tc () %************************************************************************ \begin{code} -tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) -tcForeignExports decls = +tcForeignExports :: Module -> [RenamedHsDecl] + -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) +tcForeignExports mod decls = foldlTc combine (emptyLIE, EmptyMonoBinds, []) - [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] + [foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] where combine (lie, binds, fs) fe = - tcFExport fe `thenTc ` \ (a_lie, b, f) -> + tcFExport mod fe `thenTc ` \ (a_lie, b, f) -> returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs) -tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) -tcFExport fo@(ForeignExport nm hs_ty spec src_loc) = +tcFExport :: Module -> RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) +tcFExport mod fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> - tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) -> + tcExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie) -> tcCheckFEType sig_ty spec `thenTc_` - -- 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 -> + + tcGetUnique `thenNF_Tc` \ uniq -> let - bind = VarMonoBind id rhs + gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc + id = setIdLocalExported (mkLocalId gnm sig_ty) + bind = VarMonoBind id rhs in - returnTc (lie, bind, ForeignExport id undefined spec src_loc) + returnTc (lie, bind, ForeignExport id undefined spec isDeprec src_loc) \end{code} ------------ Checking argument types for foreign export ---------------------- @@ -227,10 +254,14 @@ tcCheckFEType sig_ty (CExport (CExportStatic str _)) ------------ Checking argument types for foreign import ---------------------- checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM () checkForeignArgs pred tys - = mapNF_Tc go tys `thenNF_Tc_` returnNF_Tc () + = mapNF_Tc go tys `thenNF_Tc_` + returnNF_Tc () where - go ty = check (pred ty) (illegalForeignTyErr argument ty) - + go ty = check (pred ty) (illegalForeignTyErr argument ty) `thenNF_Tc_` + warnTc (isForeignPtrTy ty) foreignPtrWarn + -- + foreignPtrWarn = + text "`ForeignPtr' as argument type in a foreign import is deprecated" ------------ Checking result types for foreign calls ---------------------- -- Check that the type has the form @@ -286,11 +317,11 @@ 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) + HscNothing -> returnNF_Tc () + otherwise -> + case check hscLang of + Nothing -> returnNF_Tc () + Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} Warnings @@ -317,3 +348,4 @@ foreignDeclCtxt fo = hang (ptext SLIT("When checking declaration:")) 4 (ppr fo) \end{code} +