From 0299e1a135c5805e09ed8e2271b3b17fc8a04869 Mon Sep 17 00:00:00 2001 From: chak Date: Mon, 4 Feb 2002 03:40:33 +0000 Subject: [PATCH] [project @ 2002-02-04 03:40:31 by chak] Foreign import/export declarations now conform to FFI Addendum Version 1.0 * The old form of foreign declarations is still supported, but generates deprecation warnings. * There are some rather exotic old-style declarations which have become invalid as they are interpreted differently under the new scheme and there is no (easy) way to determine which style the programmer had in mind (eg, importing a C function with the name `wrapper' where the external name is explicitly given will not work in some situations - depends on whether an `unsafe' was specified and similar things). * Some "new" old-style forms have been introduced to make parsing a little bit easier (ie, avoid shift/reduce conflicts between new-style and old-style grammar rules), but they are few, arcane, and don't really hurt (and I won't tell what they are, you need to find that out by yourself ;-) * The FFI Addendum doesn't specify whether a header file that is requested for inclusion by multiple foreign declarations should be included only once or multiple times. GHC at the moment includes an header as often as it appears in a foreign declaration. For properly written headers, it doesn't make a difference anyway... * Library object specifications are currently silently ignored. The feature was mainly requested for external calls in .NET (ie, calls which invoke C routines when Haskell is compiled to ILX), but those don't seem to be supported yet. * Foreign label declarations are currently broken, but they were already broken before I started messing with the stuff. The code is moderately tested. All modules in lib/std/ and hslibs/lang/ (using old-style declarations) still compile fine and I have run a couple of tests on the different forms of new-style declarations. --- ghc/compiler/deSugar/Desugar.lhs | 6 +- ghc/compiler/deSugar/DsForeign.lhs | 69 ++++++++---- ghc/compiler/hsSyn/HsDecls.lhs | 137 +++++++++++++++++------ ghc/compiler/main/HscMain.lhs | 21 +++- ghc/compiler/parser/Lex.lhs | 3 + ghc/compiler/parser/ParseUtil.lhs | 142 ++++++++++++++++++++---- ghc/compiler/parser/Parser.y | 197 +++++++++++++++++++++++++--------- ghc/compiler/prelude/ForeignCall.lhs | 14 +-- ghc/compiler/rename/RnNames.lhs | 2 +- ghc/compiler/rename/RnSource.lhs | 15 +-- ghc/compiler/typecheck/TcForeign.lhs | 73 +++++++------ ghc/compiler/typecheck/TcHsSyn.lhs | 4 +- 12 files changed, 507 insertions(+), 176 deletions(-) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index d4154b4..261f319 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -51,7 +51,7 @@ deSugar :: DynFlags -> PersistentCompilerState -> HomeSymbolTable -> Module -> PrintUnqualified -> TcResults - -> IO (ModDetails, (SDoc, SDoc, [CoreBndr])) + -> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr])) deSugar dflags pcs hst mod_name unqual (TcResults {tc_env = type_env, @@ -130,7 +130,7 @@ deSugarExpr dflags pcs hst mod_name unqual tc_expr dsProgram mod_name all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> - dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) -> + dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code, headers) -> let ds_binds = [Rec (foreign_binds ++ core_prs)] -- Notice that we put the whole lot in a big Rec, even the foreign binds @@ -142,7 +142,7 @@ dsProgram mod_name all_binds rules fo_decls local_binders = mkVarSet (bindersOfBinds ds_binds) in mapDs (dsRule local_binders) rules `thenDs` \ rules' -> - returnDs (ds_binds, rules', (h_code, c_code, fe_binders)) + returnDs (ds_binds, rules', (h_code, c_code, headers, fe_binders)) where auto_scc | opt_SccProfilingOn = TopLevel | otherwise = NoSccs diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 3cbc72a..1bf2b90 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -15,7 +15,8 @@ import CoreSyn import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper ) import DsMonad -import HsSyn ( ForeignDecl(..), FoExport(..), FoImport(..) ) +import HsSyn ( ForeignDecl(..), ForeignExport(..), + ForeignImport(..), CImportSpec(..) ) import TcHsSyn ( TypecheckedForeignDecl ) import CoreUtils ( exprType, mkInlineMe ) import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal, @@ -47,6 +48,7 @@ import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName, bindIOName, returnIOName ) import BasicTypes ( Activation( NeverActive ) ) +import ErrUtils ( addShortWarnLocLine ) import Outputable import Maybe ( fromJust ) \end{code} @@ -77,17 +79,29 @@ dsForeigns :: Module -- "foreign exported" functions. , SDoc -- C stubs to use when calling -- "foreign exported" functions. + , [FAST_STRING] -- headers that need to be included + -- into C code generated for this module ) dsForeigns mod_name fos - = foldlDs combine ([], [], empty, empty) fos + = foldlDs combine ([], [], empty, empty, []) fos where - combine (acc_feb, acc_f, acc_h, acc_c) (ForeignImport id _ spec _) - = dsFImport mod_name id spec `thenDs` \ (bs, h, c) -> - returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c) - - combine (acc_feb, acc_f, acc_h, acc_c) (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) _) - = dsFExport mod_name id (idType id) ext_nm cconv False `thenDs` \ (feb, b, h, c) -> - returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c) + combine (acc_feb, acc_f, acc_h, acc_c, acc_header) + (ForeignImport id _ spec depr loc) + = dsFImport mod_name id spec `thenDs` \(bs, h, c, hd) -> + warnDepr depr loc `thenDs` \_ -> + returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c, hd ++ acc_header) + + combine (acc_feb, acc_f, acc_h, acc_c, acc_header) + (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc) + = dsFExport mod_name id (idType id) + ext_nm cconv False `thenDs` \(feb, b, h, c) -> + warnDepr depr loc `thenDs` \_ -> + returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c, acc_header) + + warnDepr False _ = returnDs () + warnDepr True loc = dsWarn (addShortWarnLocLine loc msg) + where + msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax") \end{code} @@ -114,23 +128,38 @@ However, we create a worker/wrapper pair, thus: The strictness/CPR analyser won't do this automatically because it doesn't look inside returned tuples; but inlining this wrapper is a Really Good Idea because it exposes the boxing to the call site. - \begin{code} dsFImport :: Module -> Id - -> FoImport + -> ForeignImport + -> DsM ([Binding], SDoc, SDoc, [FAST_STRING]) +dsFImport modName id (CImport cconv safety header lib spec) = + dsCImport modName id spec cconv safety `thenDs` \(ids, h, c) -> + returnDs (ids, h, c, if _NULL_ header then [] else [header]) + -- FIXME: the `lib' field is needed for .NET ILX generation when invoking + -- routines that are external to the .NET runtime, but GHC doesn't + -- support such calls yet; if `_NULL_ lib', the value was not given +dsFImport modName id (DNImport spec) = + dsFCall modName id (DNCall spec) `thenDs` \(ids, h, c) -> + returnDs (ids, h, c, []) + +dsCImport :: Module + -> Id + -> CImportSpec + -> CCallConv + -> Safety -> DsM ([Binding], SDoc, SDoc) -dsFImport mod_name lbl_id (LblImport ext_nm) - = ASSERT(fromJust res_ty `eqType` addrPrimTy) -- typechecker ensures this - returnDs ([(lbl_id, rhs)], empty, empty) +dsCImport modName id (CLabel cid) _ _ = + ASSERT(fromJust res_ty `eqType` addrPrimTy) -- typechecker ensures this + returnDs ([(id, rhs)], empty, empty) where - (res_ty, fo_rhs) = resultWrapper (idType lbl_id) - rhs = fo_rhs (mkLit (MachLabel ext_nm)) - -dsFImport mod_name fn_id (CImport spec) = dsFCall mod_name fn_id (CCall spec) -dsFImport mod_name fn_id (DNImport spec) = dsFCall mod_name fn_id (DNCall spec) -dsFImport mod_name fn_id (CDynImport cconv) = dsFExportDynamic mod_name fn_id cconv + (resTy, foRhs) = resultWrapper (idType id) + rhs = foRhs (mkLit (MachLabel cid)) +dsCImport modName id (CFunction target) cconv safety = + dsFCall modName id (CCall (CCallSpec target cconv safety)) +dsCImport modName id CWrapper cconv _ = + dsFExportDynamic modName id cconv \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 36a6a28..7eae5ff 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -10,7 +10,8 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, module HsDecls ( HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..), DefaultDecl(..), - ForeignDecl(..), FoImport(..), FoExport(..), FoType(..), + ForeignDecl(..), ForeignImport(..), ForeignExport(..), + CImportSpec(..), FoType(..), ConDecl(..), ConDetails(..), BangType(..), getBangType, getBangStrictness, unbangedType, DeprecDecl(..), DeprecTxt, @@ -35,7 +36,8 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, ) import CoreSyn ( CoreRule(..), RuleName ) import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..) ) -import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv ) +import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, + CExportSpec(..)) -- others: import Name ( NamedThing ) @@ -87,13 +89,13 @@ data HsDecl name pat hsDeclName :: (NamedThing name, Outputable name, Outputable pat) => HsDecl name pat -> name #endif -hsDeclName (TyClD decl) = tyClDeclName decl -hsDeclName (InstD decl) = instDeclName decl -hsDeclName (ForD decl) = forDeclName decl -hsDeclName (FixD (FixitySig name _ _)) = name +hsDeclName (TyClD decl) = tyClDeclName decl +hsDeclName (InstD decl) = instDeclName decl +hsDeclName (ForD decl) = foreignDeclName decl +hsDeclName (FixD (FixitySig name _ _)) = name -- Others don't make sense #ifdef DEBUG -hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) +hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) #endif @@ -719,43 +721,110 @@ instance (Outputable name) %************************************************************************ \begin{code} + +-- foreign declarations are distinguished as to whether they define or use a +-- Haskell name +-- +-- * the Boolean value indicates whether the pre-standard deprecated syntax +-- has been used +-- data ForeignDecl name - = ForeignImport name (HsType name) FoImport SrcLoc - | ForeignExport name (HsType name) FoExport SrcLoc + = ForeignImport name (HsType name) ForeignImport Bool SrcLoc -- defines name + | ForeignExport name (HsType name) ForeignExport Bool SrcLoc -- uses name -forDeclName (ForeignImport n _ _ _) = n -forDeclName (ForeignExport n _ _ _) = n +-- yield the Haskell name defined or used in a foreign declaration +-- +foreignDeclName :: ForeignDecl name -> name +foreignDeclName (ForeignImport n _ _ _ _) = n +foreignDeclName (ForeignExport n _ _ _ _) = n -data FoImport - = LblImport CLabelString -- foreign label - | CImport CCallSpec -- foreign import - | CDynImport CCallConv -- foreign export dynamic - | DNImport DNCallSpec -- foreign import dotnet +-- specification of an imported external entity in dependence on the calling +-- convention +-- +data ForeignImport = -- import of a C entity + -- + -- * the two strings specifying a header file or library + -- may be empty, which indicates the absence of a + -- header or object specification (both are not used + -- in the case of `CWrapper' and when `CFunction' + -- has a dynamic target) + -- + -- * the calling convention is irrelevant for code + -- generation in the case of `CLabel', but is needed + -- for pretty printing + -- + -- * `Safety' is irrelevant for `CLabel' and `CWrapper' + -- + CImport CCallConv -- ccall or stdcall + Safety -- safe or unsafe + FastString -- name of C header + FastString -- name of library object + CImportSpec -- details of the C entity + + -- import of a .NET function + -- + | DNImport DNCallSpec + +-- details of an external C entity +-- +data CImportSpec = CLabel CLabelString -- import address of a C label + | CFunction CCallTarget -- static or dynamic function + | CWrapper -- wrapper to expose closures + -- (former f.e.d.) -data FoExport = CExport CExportSpec +-- specification of an externally exported entity in dependence on the calling +-- convention +-- +data ForeignExport = CExport CExportSpec -- contains the calling convention + | DNExport -- presently unused +-- abstract type imported from .NET +-- data FoType = DNType -- In due course we'll add subtype stuff - deriving( Eq ) -- Used for equality instance for TyClDecl + deriving (Eq) -- Used for equality instance for TyClDecl + + +-- pretty printing of foreign declarations +-- instance Outputable name => Outputable (ForeignDecl name) where - ppr (ForeignImport nm ty (LblImport lbl) src_loc) - = ptext SLIT("foreign label") <+> ppr lbl <+> ppr nm <+> dcolon <+> ppr ty - ppr (ForeignImport nm ty decl src_loc) - = ptext SLIT("foreign import") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty - ppr (ForeignExport nm ty decl src_loc) - = ptext SLIT("foreign export") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty - -instance Outputable FoImport where - ppr (CImport d) = ppr d - ppr (CDynImport conv) = text "dynamic" <+> ppr conv - ppr (DNImport d) = ptext SLIT("dotnet") <+> ppr d - ppr (LblImport l) = ptext SLIT("label") <+> ppr l - -instance Outputable FoExport where - ppr (CExport d) = ppr d + ppr (ForeignImport n ty fimport _ _) = + ptext SLIT("foreign import") <+> ppr fimport <+> + ppr n <+> dcolon <+> ppr ty + ppr (ForeignExport n ty fexport _ _) = + ptext SLIT("foreign export") <+> ppr fexport <+> + ppr n <+> dcolon <+> ppr ty + +instance Outputable ForeignImport where + ppr (DNImport spec) = + ptext SLIT("dotnet") <+> ppr spec + ppr (CImport cconv safety header lib spec) = + ppr cconv <+> ppr safety <+> + char '"' <> pprCEntity header lib spec <> char '"' + where + pprCEntity header lib (CLabel lbl) = + ptext SLIT("static") <+> ptext header <+> char '&' <> + pprLib lib <> ppr lbl + pprCEntity header lib (CFunction (StaticTarget lbl)) = + ptext SLIT("static") <+> ptext header <+> char '&' <> + pprLib lib <> ppr lbl + pprCEntity header lib (CFunction (DynamicTarget)) = + ptext SLIT("dynamic") + pprCEntity header lib (CFunction (CasmTarget _)) = + panic "HsDecls.pprCEntity: malformed C function target" + pprCEntity _ _ (CWrapper) = ptext SLIT("wrapper") + -- + pprLib lib | nullFastString lib = empty + | otherwise = char '[' <> ppr lib <> char ']' + +instance Outputable ForeignExport where + ppr (CExport (CExportStatic lbl cconv)) = + ppr cconv <+> char '"' <> ppr lbl <> char '"' + ppr (DNExport ) = + ptext SLIT("dotnet") <+> ptext SLIT("\"\"") instance Outputable FoType where - ppr DNType = ptext SLIT("type dotnet") + ppr DNType = ptext SLIT("type dotnet") \end{code} diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index ddf75e0..9bf5b10 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -69,6 +69,7 @@ import CodeOutput ( codeOutput ) import Module ( ModuleName, moduleName, mkHomeModule, moduleUserString, lookupModuleEnv ) import CmdLineOpts +import DriverState ( v_HCHeader ) import ErrUtils ( dumpIfSet_dyn, showPass, printError ) import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) @@ -83,7 +84,8 @@ import Name ( Name, nameModule, nameOccName, getName, isGlobalName ) import NameEnv ( emptyNameEnv, mkNameEnv ) import Module ( Module ) -import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO ) +import IOExts ( newIORef, readIORef, writeIORef, modifyIORef, + unsafePerformIO ) import Monad ( when ) import Maybe ( isJust, fromJust ) @@ -334,7 +336,22 @@ hscRecomp ghci_mode dflags have_object mod_name_to_Module nm = do m <- findModule nm ; return (fst (fromJust m)) - (h_code,c_code,fe_binders) = foreign_stuff + (h_code, c_code, headers, fe_binders) = foreign_stuff + + -- turn the list of headers requested in foreign import + -- declarations into a string suitable for emission into generated + -- C code... + -- + foreign_headers = + unlines + . map (\fname -> "#include \"" ++ _UNPK_ fname ++ "\"") + . reverse + $ headers + + -- ...and add the string to the headers requested via command line + -- options + -- + ; modifyIORef v_HCHeader (++ foreign_headers) ; imported_modules <- mapM mod_name_to_Module imported_module_names diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 1a7855c..dfc3945 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -118,6 +118,7 @@ data Token | ITexport | ITlabel | ITdynamic + | ITsafe | ITunsafe | ITwith | ITstdcallconv @@ -292,6 +293,7 @@ isSpecial ITforall = True isSpecial ITexport = True isSpecial ITlabel = True isSpecial ITdynamic = True +isSpecial ITsafe = True isSpecial ITunsafe = True isSpecial ITwith = True isSpecial ITccallconv = True @@ -306,6 +308,7 @@ ghcExtensionKeywordsFM = listToUFM $ ( "export", ITexport ), ( "label", ITlabel ), ( "dynamic", ITdynamic ), + ( "safe", ITunsafe ), ( "unsafe", ITunsafe ), ( "with", ITwith ), ( "stdcall", ITstdcallconv), diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 6f20e83..7d2d2b9 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -5,34 +5,48 @@ \begin{code} module ParseUtil ( - parseError -- String -> Pa + parseError -- String -> Pa , mkVanillaCon, mkRecCon, - , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp + , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , groupBindings - , mkExtName -- RdrName -> ExtName - - , checkPrec -- String -> P String - , checkContext -- HsType -> P HsContext - , checkInstType -- HsType -> P HsType - , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) - , checkPattern -- HsExp -> P HsPat - , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat] - , checkDo -- [Stmt] -> P [Stmt] - , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + , CallConv(..) + , mkImport -- CallConv -> Safety + -- -> (FAST_STRING, RdrName, RdrNameHsType) + -- -> SrcLoc + -- -> P RdrNameHsDecl + , mkExport -- CallConv + -- -> (FAST_STRING, RdrName, RdrNameHsType) + -- -> SrcLoc + -- -> P RdrNameHsDecl + , mkExtName -- RdrName -> CLabelString + + , checkPrec -- String -> P String + , checkContext -- HsType -> P HsContext + , checkInstType -- HsType -> P HsType + , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) + , checkPattern -- HsExp -> P HsPat + , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat] + , checkDo -- [Stmt] -> P [Stmt] + , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl ) where #include "HsVersions.h" +import List ( isSuffixOf ) + import Lex import HsSyn -- Lots of it +import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), + DNCallSpec(..)) import SrcLoc import RdrHsSyn ( RdrBinding(..), RdrNameHsType, RdrNameBangType, RdrNameContext, - RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs, - RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails, + RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, + RdrNameGRHSs, RdrNameHsRecordBinds, + RdrNameMonoBinds, RdrNameConDetails, RdrNameHsDecl, mkNPlusKPat ) import RdrName @@ -40,7 +54,7 @@ import PrelNames ( unitTyCon_RDR ) import OccName ( dataName, varName, tcClsName, occNameSpace, setOccNameSpace, occNameUserString ) import CStrings ( CLabelString ) -import FastString ( unpackFS ) +import FastString ( nullFastString ) import Outputable ----------------------------------------------------------------------------- @@ -298,13 +312,105 @@ mkRecConstrOrUpdate exp fs@(_:_) mkRecConstrOrUpdate _ _ = parseError "Empty record update" --- Supplying the ext_name in a foreign decl is optional ; if it +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- supported calling conventions +-- +data CallConv = CCall CCallConv -- ccall or stdcall + | DNCall -- .NET + +-- construct a foreign import declaration +-- +mkImport :: CallConv + -> Safety + -> (FAST_STRING, RdrName, RdrNameHsType) + -> SrcLoc + -> P RdrNameHsDecl +mkImport (CCall cconv) safety (entity, v, ty) loc = + parseCImport entity cconv safety v `thenP` \importSpec -> + returnP $ ForD (ForeignImport v ty importSpec False loc) +mkImport (DNCall ) _ (entity, v, ty) loc = + returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc) + +-- parse the entity string of a foreign import declaration for the `ccall' or +-- `stdcall' calling convention' +-- +parseCImport :: FAST_STRING + -> CCallConv + -> Safety + -> RdrName + -> P ForeignImport +parseCImport entity cconv safety v + -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak + | entity == SLIT ("dynamic") = + returnP $ CImport cconv safety _NIL_ _NIL_ (CFunction DynamicTarget) + | entity == SLIT ("wrapper") = + returnP $ CImport cconv safety _NIL_ _NIL_ CWrapper + | otherwise = parse0 (_UNPK_ entity) + where + -- using the static keyword? + parse0 (' ': rest) = parse0 rest + parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest + parse0 rest = parse1 rest + -- check for header file name + parse1 "" = parse4 "" _NIL_ False _NIL_ + parse1 (' ':rest) = parse1 rest + parse1 str@('&':_ ) = parse2 str _NIL_ + parse1 str@('[':_ ) = parse3 str _NIL_ False + parse1 str + | ".h" `isSuffixOf` first = parse2 rest (_PK_ first) + | otherwise = parse4 str _NIL_ False _NIL_ + where + (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str + -- check for address operator (indicating a label import) + parse2 "" header = parse4 "" header False _NIL_ + parse2 (' ':rest) header = parse2 rest header + parse2 ('&':rest) header = parse3 rest header True + parse2 str@('[':_ ) header = parse3 str header False + parse2 str header = parse4 str header False _NIL_ + -- check for library object name + parse3 (' ':rest) header isLbl = parse3 rest header isLbl + parse3 ('[':rest) header isLbl = + case break (== ']') rest of + (lib, ']':rest) -> parse4 rest header isLbl (_PK_ lib) + _ -> parseError "Missing ']' in entity" + parse3 str header isLbl = parse4 str header isLbl _NIL_ + -- check for name of C function + parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib + parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib + parse4 str header isLbl lib + | all (== ' ') rest = build (_PK_ first) header isLbl lib + | otherwise = parseError "Malformed entity string" + where + (first, rest) = break (== ' ') str + -- + build cid header False lib = returnP $ + CImport cconv safety header lib (CFunction (StaticTarget cid)) + build cid header True lib = returnP $ + CImport cconv safety header lib (CLabel cid ) + +-- construct a foreign export declaration +-- +mkExport :: CallConv + -> (FAST_STRING, RdrName, RdrNameHsType) + -> SrcLoc + -> P RdrNameHsDecl +mkExport (CCall cconv) (entity, v, ty) loc = returnP $ + ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc) + where + entity' | nullFastString entity = mkExtName v + | otherwise = entity +mkExport DNCall (entity, v, ty) loc = + parseError "Foreign export is not yet supported for .NET" + +-- Supplying the ext_name in a foreign decl is optional; if it -- isn't there, the Haskell name is assumed. Note that no transformation -- of the Haskell name is then performed, so if you foreign export (++), -- it's external name will be "++". Too bad; it's important because we don't -- want z-encoding (e.g. names with z's in them shouldn't be doubled) -- (This is why we use occNameUserString.) - +-- mkExtName :: RdrName -> CLabelString mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm)) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 55e0de0..e3f305f 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ -{- +{- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.82 2002/01/29 09:58:18 simonpj Exp $ +$Id: Parser.y,v 1.83 2002/02/04 03:40:32 chak Exp $ Haskell grammar. @@ -43,8 +43,7 @@ import Outputable {- ----------------------------------------------------------------------------- -Conflicts: 14 shift/reduce - (note: it's currently 21 -- JRL, 31/1/2000) +Conflicts: 21 shift/reduce, -=chak[4Feb2] 8 for abiguity in 'if x then y else z + 1' (shift parses as 'if x then y else (z + 1)', as per longest-parse rule) @@ -66,6 +65,9 @@ Conflicts: 14 shift/reduce Only sensible parse is 'x @ (Rec{..})', which is what resolving to shift gives us. +6 for conflicts between `fdecl' and `fdeclDEPRECATED', which are resolved + correctly, and moreover, should go away when `fdeclDEPRECATED' is removed. + ----------------------------------------------------------------------------- -} @@ -102,6 +104,7 @@ Conflicts: 14 shift/reduce 'export' { ITexport } 'label' { ITlabel } 'dynamic' { ITdynamic } + 'safe' { ITsafe } 'unsafe' { ITunsafe } 'with' { ITwith } 'stdcall' { ITstdcallconv } @@ -368,44 +371,123 @@ topdecl :: { RdrBinding } in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) } | srcloc 'default' '(' types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) } - | 'foreign' fordecl { RdrHsDecl $2 } + | 'foreign' fdecl { RdrHsDecl $2 } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } | decl { $1 } -fordecl :: { RdrNameHsDecl } -fordecl : srcloc 'label' ext_name varid '::' sigtype - { ForD (ForeignImport $4 $6 (LblImport ($3 `orElse` mkExtName $4)) $1) } - - - ----------- ccall/stdcall decls ------------ - | srcloc 'import' ccallconv ext_name unsafe_flag varid_no_unsafe '::' sigtype - { let - call_spec = CCallSpec (StaticTarget ($4 `orElse` mkExtName $6)) $3 $5 - in - ForD (ForeignImport $6 $8 (CImport call_spec) $1) - } - - | srcloc 'import' ccallconv 'dynamic' unsafe_flag varid_no_unsafe '::' sigtype - { let - call_spec = CCallSpec DynamicTarget $3 $5 - in - ForD (ForeignImport $6 $8 (CImport call_spec) $1) - } - - | srcloc 'export' ccallconv ext_name varid '::' sigtype - { ForD (ForeignExport $5 $7 (CExport (CExportStatic ($4 `orElse` mkExtName $5) $3)) $1) } - - | srcloc 'export' ccallconv 'dynamic' varid '::' sigtype - { ForD (ForeignImport $5 $7 (CDynImport $3) $1) } - - - ----------- .NET decls ------------ - | srcloc 'import' 'dotnet' ext_name varid '::' sigtype - { ForD (ForeignImport $5 $7 (DNImport (DNCallSpec ($4 `orElse` mkExtName $5))) $1) } - - | srcloc 'import' 'dotnet' 'type' ext_name tycon - { TyClD (ForeignType $6 $5 DNType $1) } +-- for the time being, the following accepts foreign declarations conforming +-- to the FFI Addendum, Version 1.0 as well as pre-standard declarations +-- +-- * a flag indicates whether pre-standard declarations have been used and +-- triggers a deprecation warning further down the road +-- +-- NB: The first two rules could be combined into one by replacing `safety1' +-- with `safety'. However, the combined rule conflicts with the +-- DEPRECATED rules. +-- +fdecl :: { RdrNameHsDecl } +fdecl : srcloc 'import' callconv safety1 fspec {% mkImport $3 $4 $5 $1 } + | srcloc 'import' callconv fspec {% mkImport $3 PlaySafe $4 $1 } + | srcloc 'export' callconv fspec {% mkExport $3 $4 $1 } + -- the following syntax is DEPRECATED + | srcloc fdecl1DEPRECATED { ForD ($2 True $1) } + | srcloc fdecl2DEPRECATED { $2 $1 } + +fdecl1DEPRECATED :: { Bool -> SrcLoc -> ForeignDecl RdrName } +fdecl1DEPRECATED + ----------- DEPRECATED label decls ------------ + : 'label' ext_name varid '::' sigtype + { ForeignImport $3 $5 (CImport defaultCCallConv PlaySafe _NIL_ _NIL_ + (CLabel ($2 `orElse` mkExtName $3))) } + + ----------- DEPRECATED ccall/stdcall decls ------------ + -- + -- NB: This business with the case expression below may seem overly + -- complicated, but it is necessary to avoid some conflicts. + + -- DEPRECATED variant #1: lack of a calling convention specification + -- (import) + | 'import' {-no callconv-} ext_name safety varid_no_unsafe '::' sigtype + { let + target = StaticTarget ($2 `orElse` mkExtName $4) + in + ForeignImport $4 $6 (CImport defaultCCallConv $3 _NIL_ _NIL_ + (CFunction target)) } + + -- DEPRECATED variant #2: external name consists of two separate strings + -- (module name and function name) (import) + | 'import' callconv STRING STRING safety varid_no_unsafe '::' sigtype + {% case $2 of + DNCall -> parseError "Illegal format of .NET foreign import" + CCall cconv -> returnP $ + let + imp = CFunction (StaticTarget $4) + in + ForeignImport $6 $8 (CImport cconv $5 _NIL_ _NIL_ imp) } + + -- DEPRECATED variant #3: `unsafe' after entity + | 'import' callconv STRING 'unsafe' varid_no_unsafe '::' sigtype + {% case $2 of + DNCall -> parseError "Illegal format of .NET foreign import" + CCall cconv -> returnP $ + let + imp = CFunction (StaticTarget $3) + in + ForeignImport $5 $7 (CImport cconv PlayRisky _NIL_ _NIL_ imp) } + + -- DEPRECATED variant #4: use of the special identifier `dynamic' without + -- an explicit calling convention (import) + | 'import' {-no callconv-} 'dynamic' safety varid_no_unsafe '::' sigtype + { ForeignImport $4 $6 (CImport defaultCCallConv $3 _NIL_ _NIL_ + (CFunction DynamicTarget)) } + + -- DEPRECATED variant #5: use of the special identifier `dynamic' (import) + | 'import' callconv 'dynamic' safety varid_no_unsafe '::' sigtype + {% case $2 of + DNCall -> parseError "Illegal format of .NET foreign import" + CCall cconv -> returnP $ + ForeignImport $5 $7 (CImport cconv $4 _NIL_ _NIL_ + (CFunction DynamicTarget)) } + + -- DEPRECATED variant #6: lack of a calling convention specification + -- (export) + | 'export' {-no callconv-} ext_name varid '::' sigtype + { ForeignExport $3 $5 (CExport (CExportStatic ($2 `orElse` mkExtName $3) + defaultCCallConv)) } + + -- DEPRECATED variant #7: external name consists of two separate strings + -- (module name and function name) (export) + | 'export' callconv STRING STRING varid '::' sigtype + {% case $2 of + DNCall -> parseError "Illegal format of .NET foreign import" + CCall cconv -> returnP $ + ForeignExport $5 $7 + (CExport (CExportStatic $4 cconv)) } + + -- DEPRECATED variant #8: use of the special identifier `dynamic' without + -- an explicit calling convention (export) + | 'export' {-no callconv-} 'dynamic' varid '::' sigtype + { ForeignImport $3 $5 (CImport defaultCCallConv PlaySafe _NIL_ _NIL_ + CWrapper) } + + -- DEPRECATED variant #9: use of the special identifier `dynamic' (export) + | 'export' callconv 'dynamic' varid '::' sigtype + {% case $2 of + DNCall -> parseError "Illegal format of .NET foreign import" + CCall cconv -> returnP $ + ForeignImport $4 $6 (CImport cconv PlaySafe _NIL_ _NIL_ CWrapper) } + + ----------- DEPRECATED .NET decls ------------ + -- NB: removed the .NET call declaration, as it is entirely subsumed + -- by the new standard FFI declarations + +fdecl2DEPRECATED :: { SrcLoc -> RdrNameHsDecl } +fdecl2DEPRECATED + : 'import' 'dotnet' 'type' ext_name tycon + { \loc -> TyClD (ForeignType $5 $4 DNType loc) } + -- left this one unchanged for the moment as type imports are not + -- covered currently by the FFI standard -=chak decls :: { [RdrBinding] } : decls ';' decl { $3 : $1 } @@ -497,17 +579,31 @@ deprecation :: { RdrBinding } [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] } ----------------------------------------------------------------------------- --- Foreign import/export - -ccallconv :: { CCallConv } - : 'stdcall' { StdCallConv } - | 'ccall' { CCallConv } - | {- empty -} { defaultCCallConv } - -unsafe_flag :: { Safety } - : 'unsafe' { PlayRisky } - | {- empty -} { PlaySafe } - +-- Foreign declarations + +callconv :: { CallConv } + : 'stdcall' { CCall StdCallConv } + | 'ccall' { CCall CCallConv } + | 'dotnet' { DNCall } + +safety :: { Safety } + : 'unsafe' { PlayRisky } + | 'safe' { PlaySafe } + | {- empty -} { PlaySafe } + +safety1 :: { Safety } + : 'unsafe' { PlayRisky } + | 'safe' { PlaySafe } + -- only needed to avoid conflicts with the DEPRECATED rules + +fspec :: { (FAST_STRING, RdrName, RdrNameHsType) } + : STRING varid '::' sigtype { ($1 , $2, $4) } + | varid '::' sigtype { (SLIT(""), $1, $3) } + -- if the entity string is missing, it defaults to the empty string; + -- the meaning of an empty entity string depends on the calling + -- convention + +-- DEPRECATED syntax ext_name :: { Maybe CLabelString } : STRING { Just $1 } | STRING STRING { Just $2 } -- Ignore "module name" for now @@ -1147,9 +1243,6 @@ qtyconop :: { RdrName } : tyconop { $1 } | QCONSYM { mkQual tcClsName $1 } -qtycls :: { RdrName } - : qtycon { $1 } - commas :: { Int } : commas ',' { $1 + 1 } | ',' { 2 } diff --git a/ghc/compiler/prelude/ForeignCall.lhs b/ghc/compiler/prelude/ForeignCall.lhs index bceb024..9df1c40 100644 --- a/ghc/compiler/prelude/ForeignCall.lhs +++ b/ghc/compiler/prelude/ForeignCall.lhs @@ -42,7 +42,7 @@ data ForeignCall -- We may need more clues to distinguish foreign calls -- but this simple printer will do for now instance Outputable ForeignCall where - ppr (CCall cc) = ppr cc + ppr (CCall cc) = ppr cc ppr (DNCall dn) = ppr dn \end{code} @@ -59,7 +59,7 @@ data Safety -- Show used just for Show Lex.Token, I think instance Outputable Safety where - ppr PlaySafe = empty + ppr PlaySafe = ptext SLIT("safe") ppr PlayRisky = ptext SLIT("unsafe") playSafe PlaySafe = True @@ -118,11 +118,11 @@ platforms. \begin{code} data CCallConv = CCallConv | StdCallConv - deriving( Eq ) + deriving (Eq) instance Outputable CCallConv where - ppr StdCallConv = ptext SLIT("__stdcall") - ppr CCallConv = ptext SLIT("_ccall") + ppr StdCallConv = ptext SLIT("stdcall") + ppr CCallConv = ptext SLIT("ccall") defaultCCallConv :: CCallConv defaultCCallConv = CCallConv @@ -170,10 +170,10 @@ instance Outputable CCallSpec where \begin{code} data DNCallSpec = DNCallSpec FastString - deriving( Eq ) + deriving (Eq) instance Outputable DNCallSpec where - ppr (DNCallSpec s) = text "DotNet" <+> ptext s + ppr (DNCallSpec s) = char '"' <> ptext s <> char '"' \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 508c224..133b19d 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -243,7 +243,7 @@ getLocalDeclBinders mod (ValD binds) new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name -> returnRn (Avail name) -getLocalDeclBinders mod (ForD (ForeignImport nm _ _ loc)) +getLocalDeclBinders mod (ForD (ForeignImport nm _ _ _ loc)) = newTopBinder mod nm loc `thenRn` \ name -> returnRn [Avail name] getLocalDeclBinders mod (ForD _) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index b8071b3..b5386a3 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -127,20 +127,23 @@ rnSourceDecl (DefD (DefaultDecl tys src_loc)) %********************************************************* \begin{code} -rnHsForeignDecl (ForeignImport name ty spec src_loc) +rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc) = pushSrcLocRn src_loc $ lookupTopBndrRn name `thenRn` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) -> - returnRn (ForeignImport name' ty' spec src_loc, fvs `plusFV` extras spec) + returnRn (ForeignImport name' ty' spec isDeprec src_loc, + fvs `plusFV` extras spec) where - extras (CDynImport _) = mkFVs [newStablePtrName, deRefStablePtrName, bindIOName, returnIOName] - extras other = emptyFVs + extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName, + deRefStablePtrName, + bindIOName, returnIOName] + extras _ = emptyFVs -rnHsForeignDecl (ForeignExport name ty spec src_loc) +rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc) = pushSrcLocRn src_loc $ lookupOccRn name `thenRn` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) -> - returnRn (ForeignExport name' ty' spec src_loc, + returnRn (ForeignExport name' ty' spec isDeprec src_loc, mkFVs [bindIOName, returnIOName] `plusFV` fvs) fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index a8e63a3..43c861a 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -20,7 +20,8 @@ module TcForeign #include "HsVersions.h" import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), - MonoBinds(..), FoImport(..), FoExport(..) + MonoBinds(..), ForeignImport(..), ForeignExport(..), + CImportSpec(..) ) import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) @@ -36,12 +37,15 @@ import Id ( Id, mkLocalId ) import Name ( nameOccName ) import PrimRep ( getPrimRepSize, isFloatingRep ) import Type ( typePrimRep ) -import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys, +import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, + tcSplitForAllTys, isFFIArgumentTy, isFFIImportResultTy, isFFIExportResultTy, isFFILabelTy, - isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy + isFFIExternalTy, isFFIDynArgumentTy, + isFFIDynResultTy, isForeignPtrTy ) -import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget ) +import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), + isDynamicTarget, isCasmTarget ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) import CmdLineOpts ( dopt_HscLang, HscLang(..) ) @@ -52,13 +56,13 @@ import Outputable \begin{code} -- Defines a binding isForeignImport :: ForeignDecl name -> Bool -isForeignImport (ForeignImport _ _ _ _) = True -isForeignImport _ = False +isForeignImport (ForeignImport _ _ _ _ _) = True +isForeignImport _ = False -- Exports a binding isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignExport _ _ _ _) = True -isForeignExport _ = False +isForeignExport (ForeignExport _ _ _ _ _) = True +isForeignExport _ = False \end{code} %************************************************************************ @@ -70,10 +74,11 @@ isForeignExport _ = False \begin{code} tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) tcForeignImports decls = - mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] + mapAndUnzipTc tcFImport + [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) -tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) +tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty -> @@ -85,7 +90,7 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) id = mkLocalId nm sig_ty in tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenNF_Tc_` - returnTc (id, ForeignImport id undefined imp_decl src_loc) + returnTc (id, ForeignImport id undefined imp_decl isDeprec src_loc) \end{code} @@ -94,14 +99,16 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) tcCheckFIType _ _ _ (DNImport _) = checkCg checkDotNet -tcCheckFIType sig_ty arg_tys res_ty (LblImport _) +tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _)) = checkCg checkCOrAsm `thenNF_Tc_` check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) -tcCheckFIType sig_ty arg_tys res_ty (CDynImport _) - = -- Foreign export dynamic - -- The first (and only!) arg has got to be a function type - -- and it must return IO t; result type is IO Addr +tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ CWrapper) + = -- 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 checkCOrAsm `thenNF_Tc_` case arg_tys of [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenNF_Tc_` @@ -112,10 +119,10 @@ tcCheckFIType sig_ty arg_tys res_ty (CDynImport _) (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty other -> addErrTc (illegalForeignTyErr empty sig_ty) -tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety)) +tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target)) | isDynamicTarget target -- Foreign import dynamic = checkCg checkCOrAsmOrInterp `thenNF_Tc_` - case arg_tys of -- The first arg must be Addr + case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> check False (illegalForeignTyErr empty sig_ty) (arg1_ty:arg_tys) -> getDOptsTc `thenNF_Tc` \ dflags -> check (isFFIDynArgumentTy arg1_ty) @@ -187,14 +194,14 @@ checkFEDArgs arg_tys = returnNF_Tc () tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) tcForeignExports decls = foldlTc combine (emptyLIE, EmptyMonoBinds, []) - [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] + [foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] where combine (lie, binds, fs) fe = tcFExport fe `thenTc ` \ (a_lie, b, f) -> returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs) tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) -tcFExport fo@(ForeignExport nm hs_ty spec src_loc) = +tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ @@ -203,8 +210,8 @@ tcFExport fo@(ForeignExport nm hs_ty spec src_loc) = tcCheckFEType sig_ty spec `thenTc_` - -- we're exporting a function, but at a type possibly more constrained - -- than its declared/inferred type. Hence the need + -- 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). newLocalName nm `thenNF_Tc` \ id_name -> @@ -212,7 +219,7 @@ tcFExport fo@(ForeignExport nm hs_ty spec src_loc) = id = mkLocalId id_name sig_ty bind = VarMonoBind id rhs in - returnTc (lie, bind, ForeignExport id undefined spec src_loc) + returnTc (lie, bind, ForeignExport id undefined spec isDeprec src_loc) \end{code} ------------ Checking argument types for foreign export ---------------------- @@ -241,10 +248,14 @@ tcCheckFEType sig_ty (CExport (CExportStatic str _)) ------------ Checking argument types for foreign import ---------------------- checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM () checkForeignArgs pred tys - = mapNF_Tc go tys `thenNF_Tc_` returnNF_Tc () + = mapNF_Tc go tys `thenNF_Tc_` + returnNF_Tc () where - go ty = check (pred ty) (illegalForeignTyErr argument ty) - + go ty = check (pred ty) (illegalForeignTyErr argument ty) `thenNF_Tc_` + warnTc (isForeignPtrTy ty) foreignPtrWarn + -- + foreignPtrWarn = + text "`ForeignPtr' as argument type in a foreign import is deprecated" ------------ Checking result types for foreign calls ---------------------- -- Check that the type has the form @@ -300,11 +311,11 @@ checkCg check = getDOptsTc `thenNF_Tc` \ dflags -> let hscLang = dopt_HscLang dflags in case hscLang of - HscNothing -> returnNF_Tc () - otherwise -> - case check hscLang of - Nothing -> returnNF_Tc () - Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) + HscNothing -> returnNF_Tc () + otherwise -> + case check hscLang of + Nothing -> returnNF_Tc () + Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} Warnings diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index fb6634a..2c8ce25 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -743,9 +743,9 @@ zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] zonkForeignExports ls = mapNF_Tc zonkForeignExport ls zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) -zonkForeignExport (ForeignExport i hs_ty spec src_loc) = +zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) = zonkIdOcc i `thenNF_Tc` \ i' -> - returnNF_Tc (ForeignExport i' undefined spec src_loc) + returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc) \end{code} \begin{code} -- 1.7.10.4