, tcForeignExports
) where
-#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import HsSyn
import TcRnMonad
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
-import TcExpr ( tcCheckSigma )
+import TcExpr ( tcPolyExpr )
+import ForeignCall ( CCallConv(..) )
import ErrUtils ( Message )
import Id ( Id, mkLocalId, mkExportedLocalId )
#if alpha_TARGET_ARCH
-import PrimRep ( getPrimRepSize, isFloatingRep )
import Type ( typePrimRep )
+import SMRep ( argMachRep, primRepToCgRep, primRepHint )
#endif
import OccName ( mkForeignExportOcc )
import Name ( Name, NamedThing(..), mkExternalName )
import ForeignCall ( CExportSpec(..), CCallTarget(..),
CLabelString, isCLabelString,
isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
-import MachOp ( machRepByteWidth )
import PrelNames ( hasKey, ioTyConKey )
-import CmdLineOpts ( dopt_HscLang, HscLang(..) )
+import DynFlags ( DynFlags(..), HscTarget(..) )
import Outputable
import SrcLoc ( Located(..), srcSpanStart )
-import Bag ( emptyBag, consBag )
+import Bag ( consBag )
+#if alpha_TARGET_ARCH
+import MachOp ( machRepByteWidth, MachHint(FloatHint) )
+#endif
\end{code}
\begin{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_`
return idecl
| otherwise -- Normal foreign import
= checkCg (checkCOrAsmOrDotNetOrInterp) `thenM_`
+ checkCConv cconv `thenM_`
checkCTarget target `thenM_`
getDOpts `thenM` \ dflags ->
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
checkFEDArgs arg_tys
= check (integral_args <= 32) err
where
- integral_args = sum [ machRepByteWidth rep
- | (rep,hint) <- map typeMachRepRep arg_tys,
- hint /= FloatHint ]
- 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
tcForeignExports :: [LForeignDecl Name]
-> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
- = foldlM combine (emptyBag, []) (filter isForeignExport decls)
+ = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
where
combine (binds, fs) fe =
wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
- tcCheckSigma (nlHsVar nm) sig_ty `thenM` \ rhs ->
+ tcPolyExpr (nlHsVar nm) sig_ty `thenM` \ rhs ->
tcCheckFEType sig_ty spec `thenM_`
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}