X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=8f53d6e7b8bd5b49e1544e62d74a8193ce8e73d1;hp=185e592417379e00c1278889fe392ef5eb931681;hb=HEAD;hpb=a74edc69f977205d1aceb3705c4fa34851d4619e diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 185e592..8f53d6e 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -12,11 +12,11 @@ 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} -module TcForeign - ( - tcForeignImports +module TcForeign + ( + tcForeignImports , tcForeignExports - ) where + ) where #include "HsVersions.h" @@ -30,12 +30,7 @@ import TcEnv import ForeignCall import ErrUtils import Id -#if alpha_TARGET_ARCH -import Type -import SMRep -#endif import Name -import OccName import TcType import DynFlags import Outputable @@ -48,18 +43,18 @@ import FastString -- Defines a binding isForeignImport :: LForeignDecl name -> Bool isForeignImport (L _ (ForeignImport _ _ _)) = True -isForeignImport _ = False +isForeignImport _ = False -- Exports a binding isForeignExport :: LForeignDecl name -> Bool isForeignExport (L _ (ForeignExport _ _ _)) = True -isForeignExport _ = False +isForeignExport _ = False \end{code} %************************************************************************ -%* * +%* * \subsection{Imports} -%* * +%* * %************************************************************************ \begin{code} @@ -69,22 +64,22 @@ 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 - -- 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 sig_ty :: Type and - -- we need HsType Id hence the undefined - ; return (id, ForeignImport (L loc id) undefined 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 + -- 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 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} @@ -92,51 +87,38 @@ tcFImport d = pprPanic "tcFImport" (ppr d) ------------ 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 nonIOok (isFFIDotnetTy dflags) res_ty - let (DNCallSpec isStatic kind _ _ _ _) = spec - case kind of - DNMethod | not isStatic -> - case arg_tys of - [] -> addErrTc illegalDNMethodSig - _ - | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig - | otherwise -> return () - _ -> return () - return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty))) - -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) + +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) = ASSERT( null arg_tys ) - do { checkCg checkCOrAsm + do { checkCg checkCOrAsmOrLlvmOrInterp + ; 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 - -- 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 + ; 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 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 + -- as ft -> IO Addr is accepted, too. The use of the latter two forms + -- is DEPRECATED, though. + checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv + checkSafety safety case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok isFFIExportResultTy res1_ty checkForeignRes mustBeIO isFFIDynResultTy res_ty - checkFEDArgs arg1_tys where (arg1_tys, res1_ty) = tcSplitFunTys arg1_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 + checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv + checkSafety safety case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) @@ -148,9 +130,22 @@ 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 (xopt Opt_GHCForeignImportPrim dflags) + (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.") + checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) + 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) + checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) checkCConv cconv + checkSafety safety checkCTarget target dflags <- getDOpts checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -158,14 +153,17 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction t 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 +checkCTarget (StaticTarget str _) = do + checkCg checkCOrAsmOrLlvmOrDotNetOrInterp 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 && @@ -175,40 +173,15 @@ checkMissingAmpersand dflags arg_tys res_ty = return () \end{code} -On an Alpha, with foreign export dynamic, due to a giant hack when -building adjustor thunks, 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" - -checkFEDArgs :: [Type] -> TcM () -#if alpha_TARGET_ARCH -checkFEDArgs arg_tys - = check (integral_args <= 32) err - where - 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 _ = return () -#endif -\end{code} - - %************************************************************************ -%* * +%* * \subsection{Exports} -%* * +%* * %************************************************************************ \begin{code} -tcForeignExports :: [LForeignDecl Name] - -> TcM (LHsBinds TcId, [LForeignDecl TcId]) +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId]) tcForeignExports decls = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls) where @@ -217,25 +190,25 @@ tcForeignExports decls return (b `consBag` binds, f:fs) tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id) -tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) = - addErrCtxt (foreignDeclCtxt fo) $ do +tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) + = addErrCtxt (foreignDeclCtxt fo) $ do - sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty - rhs <- tcPolyExpr (nlHsVar nm) sig_ty + sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + rhs <- tcPolyExpr (nlHsVar nm) sig_ty - tcCheckFEType sig_ty spec + tcCheckFEType sig_ty spec - -- 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). + -- 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). - -- 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) + -- 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 (mkVarBind id rhs, ForeignExport (L loc id) undefined spec) tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} @@ -243,8 +216,10 @@ tcFExport d = pprPanic "tcFExport" (ppr d) \begin{code} tcCheckFEType :: Type -> ForeignExport -> TcM () -tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do +tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do + checkCg checkCOrAsmOrLlvm check (isCLabelString str) (badCName str) + checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok isFFIExportResultTy res_ty where @@ -252,15 +227,14 @@ 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} %************************************************************************ -%* * +%* * \subsection{Miscellaneous} -%* * +%* * %************************************************************************ \begin{code} @@ -272,7 +246,7 @@ checkForeignArgs pred tys go ty = check (pred ty) (illegalForeignTyErr argument ty) ------------ Checking result types for foreign calls ---------------------- --- Check that the type has the form +-- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () @@ -282,82 +256,87 @@ nonIOok = True mustBeIO = False checkForeignRes non_io_result_ok pred_res_ty ty - -- (IO t) is ok, and so is any newtype wrapping thereof + -- (IO t) is ok, and so is any newtype wrapping thereof | Just (_, res_ty, _) <- tcSplitIOType_maybe ty, pred_res_ty res_ty = return () - + | otherwise - = check (non_io_result_ok && pred_res_ty ty) - (illegalForeignTyErr result ty) + = check (non_io_result_ok && pred_res_ty ty) + (illegalForeignTyErr result 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 _ = Just (text "requires .NET support (-filx or win32)") -#endif - -checkCOrAsm :: HscTarget -> Maybe SDoc -checkCOrAsm HscC = Nothing -checkCOrAsm HscAsm = Nothing -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 _ - = Just (text "requires interpreted, C or native code generation") - -checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc -checkCOrAsmOrDotNetOrInterp HscC = Nothing -checkCOrAsmOrDotNetOrInterp HscAsm = Nothing -checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing -checkCOrAsmOrDotNetOrInterp _ - = Just (text "requires interpreted, C or native code generation") +checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc +checkCOrAsmOrLlvm HscC = Nothing +checkCOrAsmOrLlvm HscAsm = Nothing +checkCOrAsmOrLlvm HscLlvm = Nothing +checkCOrAsmOrLlvm _ + = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)") + +checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc +checkCOrAsmOrLlvmOrInterp HscC = Nothing +checkCOrAsmOrLlvmOrInterp HscAsm = Nothing +checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing +checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing +checkCOrAsmOrLlvmOrInterp _ + = Just (text "requires interpreted, C, Llvm or native code generation") + +checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc +checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing +checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing +checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing +checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing +checkCOrAsmOrLlvmOrDotNetOrInterp _ + = Just (text "requires interpreted, C, Llvm or native code generation") checkCg :: (HscTarget -> Maybe SDoc) -> TcM () checkCg check = do - dflags <- getDOpts - let target = hscTarget dflags - case target of - HscNothing -> return () - _ -> - case check target of - Nothing -> return () - Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) + dflags <- getDOpts + let target = hscTarget dflags + case target of + HscNothing -> return () + _ -> + case check target of + Nothing -> return () + Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} - + Calling conventions \begin{code} checkCConv :: CCallConv -> TcM () -checkCConv CCallConv = return () +checkCConv CCallConv = return () #if i386_TARGET_ARCH -checkCConv StdCallConv = return () +checkCConv StdCallConv = return () #else -checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall") +-- This is a warning, not an error. see #3336 +checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") #endif -checkCConv CmmCallConv = panic "checkCConv CmmCallConv" +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 \begin{code} check :: Bool -> Message -> TcM () -check True _ = return () +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, + = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, ptext (sLit "type in foreign declaration:")]) - 4 (hsep [ppr ty]) + 2 (hsep [ppr ty]) -- Used for 'arg_or_res' argument to illegalForeignTyErr argument, result :: SDoc @@ -365,17 +344,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 :: ForeignDecl Name -> SDoc foreignDeclCtxt fo = hang (ptext (sLit "When checking declaration:")) - 4 (ppr fo) - -illegalDNMethodSig :: SDoc -illegalDNMethodSig - = ptext (sLit "'This pointer' expected as last argument") - + 2 (ppr fo) \end{code} -