X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=8f53d6e7b8bd5b49e1544e62d74a8193ce8e73d1;hp=73fd449d32ce7e9bcb87fe255e238664e130af6b;hb=HEAD;hpb=c4c2f7ecc229de0059018aebac1f6a444a382900 diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 73fd449..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" @@ -43,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} @@ -64,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} @@ -93,15 +93,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) 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) + ; 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. + -- 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 @@ -174,14 +174,14 @@ checkMissingAmpersand dflags arg_tys res_ty \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 @@ -190,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 (mkVarBind 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} @@ -232,9 +232,9 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do %************************************************************************ -%* * +%* * \subsection{Miscellaneous} -%* * +%* * %************************************************************************ \begin{code} @@ -246,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 () @@ -256,14 +256,14 @@ 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} @@ -272,7 +272,7 @@ checkCOrAsmOrLlvm HscC = Nothing checkCOrAsmOrLlvm HscAsm = Nothing checkCOrAsmOrLlvm HscLlvm = Nothing checkCOrAsmOrLlvm _ - = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)") + = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)") checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc checkCOrAsmOrLlvmOrInterp HscC = Nothing @@ -280,7 +280,7 @@ checkCOrAsmOrLlvmOrInterp HscAsm = Nothing checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing checkCOrAsmOrLlvmOrInterp _ - = Just (text "requires interpreted, C, Llvm or native code generation") + = Just (text "requires interpreted, C, Llvm or native code generation") checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing @@ -288,33 +288,33 @@ checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing checkCOrAsmOrLlvmOrDotNetOrInterp _ - = Just (text "requires interpreted, C, Llvm or native code generation") + = 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 -- 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") +checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") #endif checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'") -checkCConv CmmCallConv = panic "checkCConv CmmCallConv" +checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} Deprecated "threadsafe" calls @@ -329,12 +329,12 @@ 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:")]) 2 (hsep [ppr ty]) @@ -344,12 +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:")) 2 (ppr fo) \end{code} -