X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=935127c587dcbbacf885e2a9a175784e319a2a19;hp=35f627e48d37aa597a053fd977b4a7c006ba3fa2;hb=49a8e5c021009430d373d6224b29004c7d18c408;hpb=5cb496dc86fac0b6023c08d4a0d7467df8d7b540 diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 35f627e..935127c 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -35,7 +35,6 @@ import Type import SMRep #endif import Name -import OccName import TcType import DynFlags import Outputable @@ -92,37 +91,22 @@ 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 _ safety _ _ (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 safety _ _ 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 -- as ft -> IO Addr is accepted, too. The use of the latter two forms -- is DEPRECATED, though. - checkCg checkCOrAsmOrInterp + checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv checkSafety safety case arg_tys of @@ -135,9 +119,9 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) = _ -> 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 @@ -151,8 +135,20 @@ 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 (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 @@ -162,14 +158,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 && @@ -239,7 +238,7 @@ 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 (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec) + return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec) tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} @@ -248,6 +247,7 @@ tcFExport d = pprPanic "tcFExport" (ppr d) \begin{code} tcCheckFEType :: Type -> ForeignExport -> TcM () tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do + checkCg checkCOrAsmOrLlvm check (isCLabelString str) (badCName str) checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys @@ -257,7 +257,6 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = 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} @@ -298,33 +297,28 @@ 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 _ = 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 @@ -348,6 +342,7 @@ checkCConv StdCallConv = return () #else 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} @@ -385,10 +380,5 @@ 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") - \end{code}