X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=f8aef7fb30dda1caeed90b9ba4c93da1004356ff;hb=22df1e2a699d6eda6d5ada5073bc97c9f35e2947;hp=3b880c0c61c7a6c3190ade7ace1b487c9e19ec02;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 3b880c0..f8aef7f 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -17,24 +17,21 @@ module TcForeign , tcForeignExports ) where -#include "config.h" #include "HsVersions.h" -import HsSyn ( ForeignDecl(..), HsExpr(..), - MonoBinds(..), ForeignImport(..), ForeignExport(..), - CImportSpec(..) - ) -import RnHsSyn ( RenamedForeignDecl ) +import HsSyn import TcRnMonad import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl ) import TcExpr ( tcCheckSigma ) +import ForeignCall ( CCallConv(..) ) import ErrUtils ( Message ) -import Id ( Id, mkLocalId, setIdLocalExported ) -import PrimRep ( getPrimRepSize, isFloatingRep ) +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, @@ -46,24 +43,29 @@ import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, toDNType ) import ForeignCall ( CExportSpec(..), CCallTarget(..), + CLabelString, isCLabelString, isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) -import CStrings ( CLabelString, isCLabelString ) 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} %************************************************************************ @@ -73,14 +75,13 @@ isForeignExport _ = False %************************************************************************ \begin{code} -tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl]) +tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id]) tcForeignImports decls - = mapAndUnzipM tcFImport (filter isForeignImport decls) + = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls) -tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) -tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) - = addSrcLoc src_loc $ - addErrCtxt (foreignDeclCtxt fo) $ +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 @@ -95,7 +96,7 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec 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 id undefined imp_decl' isDeprec src_loc) + returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec) \end{code} @@ -129,6 +130,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) -- 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_` @@ -139,9 +141,10 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_` return idecl -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target)) | isDynamicTarget target -- Foreign import dynamic = 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_` @@ -155,6 +158,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction targe return idecl | otherwise -- Normal foreign import = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_` + checkCConv cconv `thenM_` checkCTarget target `thenM_` getDOpts `thenM` \ dflags -> checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` @@ -179,12 +183,12 @@ The check is needed for both via-C and native-code routes #include "nativeGen/NCG.h" #if alpha_TARGET_ARCH checkFEDArgs arg_tys - = check (integral_args <= 4) err + = check (integral_args <= 32) 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") + 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 @@ -198,22 +202,21 @@ checkFEDArgs arg_tys = returnM () %************************************************************************ \begin{code} -tcForeignExports :: [ForeignDecl Name] - -> TcM (TcMonoBinds, [TcForeignDecl]) +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId]) tcForeignExports decls - = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls) + = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls) where combine (binds, fs) fe = - tcFExport fe `thenM ` \ (b, f) -> - returnM (b `AndMonoBinds` binds, f:fs) + wrapLocSndM tcFExport fe `thenM` \ (b, f) -> + returnM (b `consBag` binds, f:fs) -tcFExport :: RenamedForeignDecl -> TcM (TcMonoBinds, TcForeignDecl) -tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = - addSrcLoc src_loc $ +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 (HsVar nm) sig_ty `thenM` \ rhs -> + tcCheckSigma (nlHsVar nm) sig_ty `thenM` \ rhs -> tcCheckFEType sig_ty spec `thenM_` @@ -226,11 +229,11 @@ tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = getModule `thenM` \ mod -> let gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) - Nothing src_loc - id = setIdLocalExported (mkLocalId gnm sig_ty) - bind = VarMonoBind id rhs + Nothing (srcSpanStart loc) + id = mkExportedLocalId gnm sig_ty + bind = L loc (VarBind id rhs) in - returnM (bind, ForeignExport id undefined spec isDeprec src_loc) + returnM (bind, ForeignExport (L loc id) undefined spec isDeprec) \end{code} ------------ Checking argument types for foreign export ---------------------- @@ -312,15 +315,27 @@ checkCOrAsmOrDotNetOrInterp other checkCg check = getDOpts `thenM` \ dflags -> - let hscLang = dopt_HscLang dflags in - case hscLang of + let target = hscTarget dflags in + case target of HscNothing -> returnM () otherwise -> - case check hscLang of + 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}