Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/8fb03bfd768ea0d5c666bbe07a50cb05214bbe92 >--------------------------------------------------------------- commit 8fb03bfd768ea0d5c666bbe07a50cb05214bbe92 Author: Ian Lynagh <[email protected]> Date: Sun Mar 18 15:42:31 2012 +0000 If we say we're treating StdCall as CCall, then actually do so >--------------------------------------------------------------- compiler/typecheck/TcForeign.lhs | 45 +++++++++++++++++++------------------ 1 files changed, 23 insertions(+), 22 deletions(-) diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index ab85039..777c03f 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -48,8 +48,6 @@ import Platform import SrcLoc import Bag import FastString - -import Control.Monad \end{code} \begin{code} @@ -210,14 +208,14 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) ; 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 (CImport cconv safety mh 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 + cconv' <- checkCConv cconv case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty @@ -226,23 +224,22 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) - return idecl + return (CImport cconv' safety mh CWrapper) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp - checkCConv cconv + cconv' <- checkCConv cconv case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) - return idecl (arg1_ty:arg_tys) -> do dflags <- getDynFlags check (isFFIDynArgumentTy arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return idecl + return $ CImport cconv' safety mh (CFunction target) | cconv == PrimCallConv = do dflags <- getDynFlags check (xopt Opt_GHCForeignImportPrim dflags) @@ -257,7 +254,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar return idecl | otherwise = do -- Normal foreign import checkCg checkCOrAsmOrLlvmOrDotNetOrInterp - checkCConv cconv + cconv' <- checkCConv cconv checkCTarget target dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -268,7 +265,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | not (null arg_tys) -> addErrTc (text "`value' imports cannot have function types") _ -> return () - return idecl + return $ CImport cconv' safety mh (CFunction target) -- This makes a convenient place to check @@ -315,7 +312,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) (norm_co, norm_sig_ty) <- normaliseFfiType sig_ty - tcCheckFEType norm_sig_ty spec + spec' <- tcCheckFEType norm_sig_ty spec -- we're exporting a function, but at a type possibly more -- constrained than its declared/inferred type. Hence the need @@ -327,20 +324,21 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) -- 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 norm_co spec) + return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec') tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} ------------ Checking argument types for foreign export ---------------------- \begin{code} -tcCheckFEType :: Type -> ForeignExport -> TcM () +tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do checkCg checkCOrAsmOrLlvm check (isCLabelString str) (badCName str) - checkCConv cconv + cconv' <- checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty + return (CExport (CExportStatic str cconv')) where -- Drop the foralls before inspecting n -- the structure of the foreign type. @@ -449,15 +447,18 @@ checkCg check = do Calling conventions \begin{code} -checkCConv :: CCallConv -> TcM () -checkCConv CCallConv = return () -checkCConv CApiConv = return () +checkCConv :: CCallConv -> TcM CCallConv +checkCConv CCallConv = return CCallConv +checkCConv CApiConv = return CApiConv checkCConv StdCallConv = do dflags <- getDynFlags let platform = targetPlatform dflags - unless (platformArch platform == ArchX86) $ - -- This is a warning, not an error. see #3336 - addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") -checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + if platformArch platform == ArchX86 + then return StdCallConv + else do -- This is a warning, not an error. see #3336 + addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + return CCallConv +checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") + return PrimCallConv checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
