X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=f51000d72ac2150370530ee166fcc3ae88e9a4a6;hb=9d0c8f842e35dde3d570580cf62a32779f66a6de;hp=57ef40a3ad9a23ba03ba8977441dceccaac80b30;hpb=64c61e5cd4dbad9585dbe9e5e59ede4e0af4fe82;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 57ef40a..f51000d 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -12,24 +12,20 @@ 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 , tcForeignExports ) where +#include "HsVersions.h" + import HsSyn import TcRnMonad import TcHsType import TcExpr +import TcEnv import ForeignCall import ErrUtils @@ -37,7 +33,6 @@ import Id #if alpha_TARGET_ARCH import Type import SMRep -import MachOp #endif import Name import OccName @@ -46,7 +41,6 @@ import DynFlags import Outputable import SrcLoc import Bag -import Unique import FastString \end{code} @@ -75,32 +69,34 @@ tcForeignImports decls tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id) tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl) - = addErrCtxt (foreignDeclCtxt fo) $ do - sig_ty <- tcHsSigType (ForSigCtxt nm) hs_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 + = addErrCtxt (foreignDeclCtxt fo) $ + do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_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 -- Use a LocalId to obey the invariant that locally-defined -- things are LocalIds. However, it does not need zonking, -- (so TcHsSyn.zonkForeignExports ignores it). - imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl - -- can't use sig_ty here because it :: Type and we need HsType Id - -- hence the undefined - return (id, ForeignImport (L loc id) undefined imp_decl') + ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl + -- Can't use sig_ty here because sig_ty :: Type and + -- we need HsType Id hence the undefined + ; return (id, ForeignImport (L loc id) undefined imp_decl') } +tcFImport d = pprPanic "tcFImport" (ppr d) \end{code} ------------ Checking types for foreign import ---------------------- \begin{code} +tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport tcCheckFIType _ arg_tys res_ty (DNImport spec) = do checkCg checkDotnet dflags <- getDOpts checkForeignArgs (isFFIDotnetTy dflags) arg_tys - checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty + checkForeignRes nonIOok (isFFIDotnetTy dflags) res_ty let (DNCallSpec isStatic kind _ _ _ _) = spec case kind of DNMethod | not isStatic -> @@ -112,12 +108,15 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do _ -> return () return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty))) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) = do - checkCg checkCOrAsm - check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) - return idecl +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) + = ASSERT( null arg_tys ) + do { checkCg checkCOrAsm + ; checkSafety safety + ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) + ; return idecl } -- NB check res_ty not sig_ty! + -- In case sig_ty is (forall a. ForeignPtr a) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do -- 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 @@ -125,6 +124,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do -- is DEPRECATED, though. checkCg checkCOrAsmOrInterp checkCConv cconv + checkSafety safety case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok isFFIExportResultTy res1_ty @@ -132,13 +132,14 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do checkFEDArgs arg1_tys where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - other -> addErrTc (illegalForeignTyErr empty sig_ty) + _ -> addErrTc (illegalForeignTyErr empty sig_ty) return idecl -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrInterp checkCConv cconv + checkSafety safety case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) @@ -150,20 +151,44 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction t checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty return idecl + | cconv == PrimCallConv = do + dflags <- getDOpts + check (dopt Opt_GHCForeignImportPrim dflags) + (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.") + checkCg (checkCOrAsmOrDotNetOrInterp) + checkCTarget target + check (playSafe safety) + (text "The safe/unsafe annotation should not be used with `foreign import prim'.") + checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys + -- prim import result is more liberal, allows (#,,#) + checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty + return idecl | otherwise = do -- Normal foreign import checkCg (checkCOrAsmOrDotNetOrInterp) checkCConv cconv + checkSafety safety checkCTarget target dflags <- getDOpts checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + checkMissingAmpersand dflags arg_tys res_ty return idecl -- This makes a convenient place to check -- that the C identifier is valid for C +checkCTarget :: CCallTarget -> TcM () checkCTarget (StaticTarget str) = do checkCg checkCOrAsmOrDotNetOrInterp check (isCLabelString str) (badCName str) +checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" + +checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () +checkMissingAmpersand dflags arg_tys res_ty + | null arg_tys && isFunPtrTy res_ty && + dopt Opt_WarnDodgyForeignImports dflags + = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) + | otherwise + = return () \end{code} On an Alpha, with foreign export dynamic, due to a giant hack when @@ -175,16 +200,18 @@ The check is needed for both via-C and native-code routes \begin{code} #include "nativeGen/NCG.h" + +checkFEDArgs :: [Type] -> TcM () #if alpha_TARGET_ARCH checkFEDArgs arg_tys = check (integral_args <= 32) err where - integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep + integral_args = sum [ (widthInBytes . 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 = return () +checkFEDArgs _ = return () #endif \end{code} @@ -219,31 +246,22 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) = -- to create a local binding which will call the exported function -- at a particular type (and, maybe, overloading). - uniq <- newUnique - mod <- getModule - let - -- 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) - - return (bind, ForeignExport (L loc id) undefined spec) + + -- 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. + id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc + return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec) +tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} ------------ Checking argument types for foreign export ---------------------- \begin{code} -tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do +tcCheckFEType :: Type -> ForeignExport -> TcM () +tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do check (isCLabelString str) (badCName str) + checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok isFFIExportResultTy res_ty where @@ -251,6 +269,7 @@ tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do -- the structure of the foreign type. (_, t_ty) = tcSplitForAllTys sig_ty (arg_tys, res_ty) = tcSplitFunTys t_ty +tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d) \end{code} @@ -275,12 +294,13 @@ checkForeignArgs pred tys -- checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () +nonIOok, mustBeIO :: Bool nonIOok = True mustBeIO = False checkForeignRes non_io_result_ok pred_res_ty ty -- (IO t) is ok, and so is any newtype wrapping thereof - | Just (io, res_ty, _) <- tcSplitIOType_maybe ty, + | Just (_, res_ty, _) <- tcSplitIOType_maybe ty, pred_res_ty res_ty = return () @@ -290,36 +310,41 @@ checkForeignRes non_io_result_ok pred_res_ty ty \end{code} \begin{code} +checkDotnet :: HscTarget -> Maybe SDoc #if defined(mingw32_TARGET_OS) checkDotnet HscC = Nothing checkDotnet _ = Just (text "requires C code generation (-fvia-C)") #else -checkDotnet other = Just (text "requires .NET support (-filx or win32)") +checkDotnet _ = Just (text "requires .NET support (-filx or win32)") #endif +checkCOrAsm :: HscTarget -> Maybe SDoc checkCOrAsm HscC = Nothing checkCOrAsm HscAsm = Nothing -checkCOrAsm other +checkCOrAsm _ = Just (text "requires via-C or native code generation (-fvia-C)") +checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc checkCOrAsmOrInterp HscC = Nothing checkCOrAsmOrInterp HscAsm = Nothing checkCOrAsmOrInterp HscInterpreted = Nothing -checkCOrAsmOrInterp other +checkCOrAsmOrInterp _ = Just (text "requires interpreted, C or native code generation") +checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc checkCOrAsmOrDotNetOrInterp HscC = Nothing checkCOrAsmOrDotNetOrInterp HscAsm = Nothing checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing -checkCOrAsmOrDotNetOrInterp other +checkCOrAsmOrDotNetOrInterp _ = Just (text "requires interpreted, C or native code generation") +checkCg :: (HscTarget -> Maybe SDoc) -> TcM () checkCg check = do dflags <- getDOpts let target = hscTarget dflags case target of HscNothing -> return () - otherwise -> + _ -> case check target of Nothing -> return () Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) @@ -333,8 +358,18 @@ checkCConv CCallConv = return () #if i386_TARGET_ARCH checkCConv StdCallConv = return () #else -checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall") +checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall") #endif +checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") +checkCConv CmmCallConv = panic "checkCConv CmmCallConv" +\end{code} + +Deprecated "threadsafe" calls + +\begin{code} +checkSafety :: Safety -> TcM () +checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.") +checkSafety _ = return () \end{code} Warnings @@ -344,12 +379,14 @@ check :: Bool -> Message -> TcM () check True _ = return () check _ the_err = addErrTc the_err +illegalForeignTyErr :: SDoc -> Type -> SDoc illegalForeignTyErr arg_or_res ty = 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 +argument, result :: SDoc argument = text "argument" result = text "result" @@ -357,11 +394,13 @@ badCName :: CLabelString -> Message badCName target = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] +foreignDeclCtxt :: ForeignDecl Name -> SDoc foreignDeclCtxt fo = hang (ptext (sLit "When checking declaration:")) 4 (ppr fo) -illegalDNMethodSig +illegalDNMethodSig :: SDoc +illegalDNMethodSig = ptext (sLit "'This pointer' expected as last argument") \end{code}