X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=fdb7ce5f23fd9c9b0b2fa060e192a364437893c3;hp=68942387f8f7fa41080d7d19d3dca135d9000fec;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=f37e239fb5e81fc493e0ea1af98178bf1f7ceaba diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 6894238..fdb7ce5 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} @@ -22,37 +23,24 @@ module TcForeign import HsSyn import TcRnMonad -import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcExpr ( tcPolyExpr ) +import TcHsType +import TcExpr +import TcEnv -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 #endif -import OccName ( mkForeignExportOcc ) -import Name ( Name, NamedThing(..), mkExternalName ) -import TcType ( Type, tcSplitFunTys, - tcSplitForAllTys, tcSplitIOType_maybe, - isFFIArgumentTy, isFFIImportResultTy, - isFFIExportResultTy, isFFILabelTy, - isFFIExternalTy, isFFIDynArgumentTy, - isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy, - toDNType - ) -import ForeignCall ( CExportSpec(..), CCallTarget(..), - CLabelString, isCLabelString, - isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) -import DynFlags ( DynFlags(..), HscTarget(..) ) +import Name +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 FastString \end{code} \begin{code} @@ -80,95 +68,114 @@ tcForeignImports decls tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id) tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl) - = addErrCtxt (foreignDeclCtxt fo) $ - tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_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). - in - 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') + + ; 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 _ arg_tys res_ty (DNImport spec) - = checkCg checkDotnet `thenM_` - getDOpts `thenM` \ dflags -> - checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_` - checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_` - let (DNCallSpec isStatic kind _ _ _ _) = spec in - (case kind of - DNMethod | not isStatic -> - case arg_tys of - [] -> addErrTc illegalDNMethodSig - _ - | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig - | otherwise -> returnM () - _ -> returnM ()) `thenM_` - returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty))) - -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) - = checkCg checkCOrAsm `thenM_` - check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_` - return idecl - -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) - = -- Foreign wrapper (former f.e.d.) +tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport + +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) + = ASSERT( null arg_tys ) + do { checkCg checkCOrAsmOrInterp + ; 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 + -- 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 `thenM_` - checkCConv cconv `thenM_` - (case arg_tys of - [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_` - checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_` - checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_` - checkFEDArgs arg1_tys - where - (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_` + checkCg checkCOrAsmOrInterp + 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)) - | isDynamicTarget target -- Foreign import dynamic - = checkCg checkCOrAsmOrInterp `thenM_` - checkCConv cconv `thenM_` - case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr - [] -> - check False (illegalForeignTyErr empty sig_ty) `thenM_` - return idecl - (arg1_ty:arg_tys) -> - getDOpts `thenM` \ dflags -> - check (isFFIDynArgumentTy arg1_ty) - (illegalForeignTyErr argument arg1_ty) `thenM_` - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_` - return idecl - | otherwise -- Normal foreign import - = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_` - checkCConv cconv `thenM_` - checkCTarget target `thenM_` - getDOpts `thenM` \ dflags -> - checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_` - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_` - return idecl +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) + return idecl + (arg1_ty:arg_tys) -> do + dflags <- getDOpts + check (isFFIDynArgumentTy arg1_ty) + (illegalForeignTyErr argument arg1_ty) + 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 (StaticTarget str) - = checkCg checkCOrAsmOrDotNetOrInterp `thenM_` +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 @@ -180,16 +187,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") + err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic") #else -checkFEDArgs arg_tys = returnM () +checkFEDArgs _ = return () #endif \end{code} @@ -206,41 +215,42 @@ tcForeignExports :: [LForeignDecl Name] tcForeignExports decls = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls) where - combine (binds, fs) fe = - wrapLocSndM tcFExport fe `thenM` \ (b, f) -> - returnM (b `consBag` binds, f:fs) + combine (binds, fs) fe = do + (b, f) <- wrapLocSndM tcFExport fe + 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) $ + addErrCtxt (foreignDeclCtxt fo) $ do - tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> - tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs -> + sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty + rhs <- tcPolyExpr (nlHsVar nm) sig_ty - tcCheckFEType sig_ty spec `thenM_` + 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). - newUnique `thenM` \ uniq -> - getModule `thenM` \ mod -> - let - gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) - Nothing (srcSpanStart loc) - id = mkExportedLocalId gnm sig_ty - bind = L loc (VarBind id rhs) - in - returnM (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 (mkVarBind 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 _)) - = check (isCLabelString str) (badCName str) `thenM_` - checkForeignArgs isFFIExternalTy arg_tys `thenM_` +tcCheckFEType :: Type -> ForeignExport -> TcM () +tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do + checkCg checkCOrAsm + check (isCLabelString str) (badCName str) + checkCConv cconv + checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok isFFIExportResultTy res_ty where -- Drop the foralls before inspecting n @@ -261,8 +271,7 @@ tcCheckFEType sig_ty (CExport (CExportStatic str _)) ------------ Checking argument types for foreign import ---------------------- checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM () checkForeignArgs pred tys - = mappM go tys `thenM_` - returnM () + = mapM_ go tys where go ty = check (pred ty) (illegalForeignTyErr argument ty) @@ -272,14 +281,15 @@ 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 - = returnM () + = return () | otherwise = check (non_io_result_ok && pred_res_ty ty) @@ -287,42 +297,37 @@ checkForeignRes non_io_result_ok pred_res_ty 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)") -#else -checkDotnet other = 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 HscILX = Nothing checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing -checkCOrAsmOrDotNetOrInterp other - = Just (text "requires interpreted, C, native or .NET ILX code generation") +checkCOrAsmOrDotNetOrInterp _ + = Just (text "requires interpreted, C or native code generation") -checkCg check - = getDOpts `thenM` \ dflags -> - let target = hscTarget dflags in +checkCg :: (HscTarget -> Maybe SDoc) -> TcM () +checkCg check = do + dflags <- getDOpts + let target = hscTarget dflags case target of - HscNothing -> returnM () - otherwise -> + HscNothing -> return () + _ -> case check target of - Nothing -> returnM () + Nothing -> return () Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) -\end{code} +\end{code} Calling conventions @@ -332,36 +337,45 @@ 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 \begin{code} check :: Bool -> Message -> TcM () -check True _ = returnM () +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:")]) + = 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" badCName :: CLabelString -> Message badCName target - = sep [quotes (ppr target) <+> ptext SLIT("is not a valid C identifier")] + = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] +foreignDeclCtxt :: ForeignDecl Name -> SDoc foreignDeclCtxt fo - = hang (ptext SLIT("When checking declaration:")) + = hang (ptext (sLit "When checking declaration:")) 4 (ppr fo) - -illegalDNMethodSig - = ptext SLIT("'This pointer' expected as last argument") - \end{code}