-> 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,
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
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
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,
bindIOName, returnIOName
)
import BasicTypes ( Activation( NeverActive ) )
+import ErrUtils ( addShortWarnLocLine )
import Outputable
import Maybe ( fromJust )
\end{code}
-- "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}
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}
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,
)
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 )
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
%************************************************************************
\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("\"<unused>\"")
instance Outputable FoType where
- ppr DNType = ptext SLIT("type dotnet")
+ ppr DNType = ptext SLIT("type dotnet")
\end{code}
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 )
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 )
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
| ITexport
| ITlabel
| ITdynamic
+ | ITsafe
| ITunsafe
| ITwith
| ITstdcallconv
isSpecial ITexport = True
isSpecial ITlabel = True
isSpecial ITdynamic = True
+isSpecial ITsafe = True
isSpecial ITunsafe = True
isSpecial ITwith = True
isSpecial ITccallconv = True
( "export", ITexport ),
( "label", ITlabel ),
( "dynamic", ITdynamic ),
+ ( "safe", ITunsafe ),
( "unsafe", ITunsafe ),
( "with", ITwith ),
( "stdcall", ITstdcallconv),
\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
import OccName ( dataName, varName, tcClsName,
occNameSpace, setOccNameSpace, occNameUserString )
import CStrings ( CLabelString )
-import FastString ( unpackFS )
+import FastString ( nullFastString )
import Outputable
-----------------------------------------------------------------------------
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))
-{-
+{- -*-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.
{-
-----------------------------------------------------------------------------
-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)
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.
+
-----------------------------------------------------------------------------
-}
'export' { ITexport }
'label' { ITlabel }
'dynamic' { ITdynamic }
+ 'safe' { ITsafe }
'unsafe' { ITunsafe }
'with' { ITwith }
'stdcall' { ITstdcallconv }
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 }
[ 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
: tyconop { $1 }
| QCONSYM { mkQual tcClsName $1 }
-qtycls :: { RdrName }
- : qtycon { $1 }
-
commas :: { Int }
: commas ',' { $1 + 1 }
| ',' { 2 }
-- 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}
-- 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
\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
\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}
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 _)
%*********************************************************
\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
#include "HsVersions.h"
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
- MonoBinds(..), FoImport(..), FoExport(..)
+ MonoBinds(..), ForeignImport(..), ForeignExport(..),
+ CImportSpec(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
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(..) )
\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}
%************************************************************************
\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 ->
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}
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_`
(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)
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) $
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 ->
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 ----------------------
------------ 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
= 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
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}
projects / ghc-hetmet.git / commitdiff