X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=d78bb20fac10d3cf658d49a3474679b8dab65e59;hb=3f1b316d7035c55cd712cd39a9981339bcef2e8c;hp=4be039bd9326fe0f522a691b69e6125b079cb561;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 4be039b..d78bb20 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1998 % \section[TcForeign]{Typechecking \tr{foreign} declarations} @@ -11,6 +12,13 @@ is restricted to what the outside world understands (read C), and this module checks to see if a foreign declaration has got a legal type. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcForeign ( tcForeignImports @@ -22,49 +30,36 @@ module TcForeign import HsSyn import TcRnMonad -import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcExpr ( tcPolyExpr ) +import TcHsType +import TcExpr -import ForeignCall ( CCallConv(..) ) -import ErrUtils ( Message ) -import Id ( Id, mkLocalId, mkExportedLocalId ) +import ForeignCall +import ErrUtils +import Id #if alpha_TARGET_ARCH -import Type ( typePrimRep ) -import SMRep ( argMachRep, primRepToCgRep, primRepHint ) +import Type +import SMRep +import MachOp #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 ForeignCall ( CExportSpec(..), CCallTarget(..), - CLabelString, isCLabelString, - isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) -import PrelNames ( hasKey, ioTyConKey ) -import DynFlags ( DynFlags(..), HscTarget(..) ) +import Name +import OccName +import TcType +import DynFlags import Outputable -import SrcLoc ( Located(..), srcSpanStart ) -import Bag ( consBag ) - -#if alpha_TARGET_ARCH -import MachOp ( machRepByteWidth, MachHint(FloatHint) ) -#endif +import SrcLoc +import Bag +import Unique \end{code} \begin{code} -- Defines a binding isForeignImport :: LForeignDecl name -> Bool -isForeignImport (L _ (ForeignImport _ _ _ _)) = True +isForeignImport (L _ (ForeignImport _ _ _)) = True isForeignImport _ = False -- Exports a binding isForeignExport :: LForeignDecl name -> Bool -isForeignExport (L _ (ForeignExport _ _ _ _)) = True +isForeignExport (L _ (ForeignExport _ _ _)) = True isForeignExport _ = False \end{code} @@ -80,7 +75,7 @@ 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) +tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl) = addErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> let @@ -96,7 +91,7 @@ tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec) 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) + returnM (id, ForeignImport (L loc id) undefined imp_decl') \end{code} @@ -212,7 +207,7 @@ tcForeignExports decls returnM (b `consBag` binds, f:fs) tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id) -tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) = +tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) = addErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> @@ -228,12 +223,21 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) = newUnique `thenM` \ uniq -> getModule `thenM` \ mod -> let - gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) - Nothing (srcSpanStart loc) + -- We need to give a name to the new top-level binding that + -- is *stable* (i.e. the compiler won't change it later), + -- because this name will be referred to by the C code stub. + -- Furthermore, the name must be unique (see #1533). If the + -- same function is foreign-exported multiple times, the + -- top-level bindings generated must not have the same name. + -- Hence we create an External name (doesn't change), and we + -- append a Unique to the string right here. + uniq_str = showSDoc (pprUnique uniq) + occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str) + gnm = mkExternalName uniq mod (mkForeignExportOcc occ) loc id = mkExportedLocalId gnm sig_ty bind = L loc (VarBind id rhs) in - returnM (bind, ForeignExport (L loc id) undefined spec isDeprec) + returnM (bind, ForeignExport (L loc id) undefined spec) \end{code} ------------ Checking argument types for foreign export ---------------------- @@ -277,17 +281,17 @@ 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) + -- (IO t) is ok, and so is any newtype wrapping thereof + | Just (io, res_ty, _) <- tcSplitIOType_maybe ty, + pred_res_ty res_ty + = returnM () + + | otherwise + = 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)") @@ -308,10 +312,9 @@ checkCOrAsmOrInterp other 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") + = Just (text "requires interpreted, C or native code generation") checkCg check = getDOpts `thenM` \ dflags -> @@ -322,7 +325,7 @@ checkCg check case check target of Nothing -> returnM () Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) -\end{code} +\end{code} Calling conventions