, tcForeignExports
) where
-#include "config.h"
#include "HsVersions.h"
-import HsSyn ( ForeignDecl(..), HsExpr(..),
- MonoBinds(..), ForeignImport(..), ForeignExport(..),
- CImportSpec(..)
- )
-import RnHsSyn ( RenamedForeignDecl )
+import HsSyn
import TcRnMonad
-import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
-import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl )
-import TcExpr ( tcCheckSigma )
+import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
+import TcExpr ( tcPolyExpr )
+import ForeignCall ( CCallConv(..) )
import ErrUtils ( Message )
-import Id ( Id, mkLocalId, setIdLocalExported )
-import PrimRep ( getPrimRepSize, isFloatingRep )
+import Id ( Id, mkLocalId, mkExportedLocalId )
+#if alpha_TARGET_ARCH
import Type ( typePrimRep )
+import SMRep ( argMachRep, primRepToCgRep, primRepHint )
+#endif
import OccName ( mkForeignExportOcc )
import Name ( Name, NamedThing(..), mkExternalName )
import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
toDNType
)
import ForeignCall ( CExportSpec(..), CCallTarget(..),
- isDynamicTarget, isCasmTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
-import CStrings ( CLabelString, isCLabelString )
+ CLabelString, isCLabelString,
+ isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
import PrelNames ( hasKey, ioTyConKey )
-import CmdLineOpts ( dopt_HscLang, HscLang(..) )
+import DynFlags ( DynFlags(..), HscTarget(..) )
import Outputable
+import SrcLoc ( Located(..), srcSpanStart )
+import Bag ( consBag )
+#if alpha_TARGET_ARCH
+import MachOp ( machRepByteWidth, MachHint(FloatHint) )
+#endif
\end{code}
\begin{code}
-- Defines a binding
-isForeignImport :: ForeignDecl name -> Bool
-isForeignImport (ForeignImport _ _ _ _ _) = True
-isForeignImport _ = False
+isForeignImport :: LForeignDecl name -> Bool
+isForeignImport (L _ (ForeignImport _ _ _ _)) = True
+isForeignImport _ = False
-- Exports a binding
-isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignExport _ _ _ _ _) = True
-isForeignExport _ = False
+isForeignExport :: LForeignDecl name -> Bool
+isForeignExport (L _ (ForeignExport _ _ _ _)) = True
+isForeignExport _ = False
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl])
+tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
tcForeignImports decls
- = mapAndUnzipM tcFImport (filter isForeignImport decls)
+ = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
-tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
-tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc)
- = addSrcLoc src_loc $
- addErrCtxt (foreignDeclCtxt fo) $
+tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
+tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
+ = addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
-- can't use sig_ty here because it :: Type and we need HsType Id
-- hence the undefined
- returnM (id, ForeignImport id undefined imp_decl' isDeprec src_loc)
+ returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec)
\end{code}
-- as ft -> IO Addr is accepted, too. The use of the latter two forms
-- is DEPRECATED, though.
checkCg checkCOrAsmOrInterp `thenM_`
+ checkCConv cconv `thenM_`
(case arg_tys of
[arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_`
return idecl
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction target))
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
| isDynamicTarget target -- Foreign import dynamic
= checkCg checkCOrAsmOrInterp `thenM_`
+ checkCConv cconv `thenM_`
case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
[] ->
check False (illegalForeignTyErr empty sig_ty) `thenM_`
checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
return idecl
| otherwise -- Normal foreign import
- = checkCg (if isCasmTarget target
- then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_`
+ = checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_`
+ checkCConv cconv `thenM_`
checkCTarget target `thenM_`
getDOpts `thenM` \ dflags ->
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
checkCTarget (StaticTarget str)
= checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
check (isCLabelString str) (badCName str)
-
-checkCTarget (CasmTarget _)
- = checkCg checkC
\end{code}
On an Alpha, with foreign export dynamic, due to a giant hack when
#include "nativeGen/NCG.h"
#if alpha_TARGET_ARCH
checkFEDArgs arg_tys
- = check (integral_args <= 4) err
+ = check (integral_args <= 32) err
where
- integral_args = sum (map getPrimRepSize $
- filter (not . isFloatingRep) $
- map typePrimRep arg_tys)
- err = ptext SLIT("On Alpha, I can only handle 4 non-floating-point arguments to foreign export dynamic")
+ integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
+ | prim_rep <- map typePrimRep arg_tys,
+ primRepHint prim_rep /= FloatHint ]
+ err = ptext SLIT("On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
#else
checkFEDArgs arg_tys = returnM ()
#endif
%************************************************************************
\begin{code}
-tcForeignExports :: [ForeignDecl Name]
- -> TcM (TcMonoBinds, [TcForeignDecl])
+tcForeignExports :: [LForeignDecl Name]
+ -> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
- = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls)
+ = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
where
combine (binds, fs) fe =
- tcFExport fe `thenM ` \ (b, f) ->
- returnM (b `AndMonoBinds` binds, f:fs)
+ wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
+ returnM (b `consBag` binds, f:fs)
-tcFExport :: RenamedForeignDecl -> TcM (TcMonoBinds, TcForeignDecl)
-tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
- addSrcLoc src_loc $
+tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
- tcCheckSigma (HsVar nm) sig_ty `thenM` \ rhs ->
+ tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs ->
tcCheckFEType sig_ty spec `thenM_`
newUnique `thenM` \ uniq ->
getModule `thenM` \ mod ->
let
- gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc
- id = setIdLocalExported (mkLocalId gnm sig_ty)
- bind = VarMonoBind id rhs
+ gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm))
+ Nothing (srcSpanStart loc)
+ id = mkExportedLocalId gnm sig_ty
+ bind = L loc (VarBind id rhs)
in
- returnM (bind, ForeignExport id undefined spec isDeprec src_loc)
+ returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)
\end{code}
------------ Checking argument types for foreign export ----------------------
checkDotnet other = Just (text "requires .NET support (-filx or win32)")
#endif
-checkC HscC = Nothing
-checkC other = Just (text "requires C code generation (-fvia-C)")
-
checkCOrAsm HscC = Nothing
checkCOrAsm HscAsm = Nothing
checkCOrAsm other
checkCOrAsmOrInterp other
= Just (text "requires interpreted, C or native code generation")
-checkCOrAsmOrDotNet HscC = Nothing
-checkCOrAsmOrDotNet HscAsm = Nothing
-checkCOrAsmOrDotNet HscILX = Nothing
-checkCOrAsmOrDotNet other
- = Just (text "requires C, native or .NET ILX code generation")
-
checkCOrAsmOrDotNetOrInterp HscC = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
checkCOrAsmOrDotNetOrInterp HscILX = Nothing
checkCg check
= getDOpts `thenM` \ dflags ->
- let hscLang = dopt_HscLang dflags in
- case hscLang of
+ let target = hscTarget dflags in
+ case target of
HscNothing -> returnM ()
otherwise ->
- case check hscLang of
+ case check target of
Nothing -> returnM ()
Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
+Calling conventions
+
+\begin{code}
+checkCConv :: CCallConv -> TcM ()
+checkCConv CCallConv = return ()
+#if i386_TARGET_ARCH
+checkCConv StdCallConv = return ()
+#else
+checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
+#endif
+\end{code}
+
Warnings
\begin{code}
projects / ghc-hetmet.git / blobdiff