%
+% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1998
%
\section[TcForeign]{Typechecking \tr{foreign} declarations}
module checks to see if a foreign declaration has got a legal type.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
module TcForeign
(
tcForeignImports
import HsSyn
import TcRnMonad
-import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
-import TcExpr ( tcPolyExpr )
+import TcHsType
+import TcExpr
-import ForeignCall ( CCallConv(..) )
-import ErrUtils ( Message )
-import Id ( Id, mkLocalId, mkExportedLocalId )
+import ForeignCall
+import ErrUtils
+import Id
#if alpha_TARGET_ARCH
-import Type ( typePrimRep )
-import SMRep ( argMachRep, primRepToCgRep, primRepHint )
+import Type
+import SMRep
+import MachOp
#endif
-import OccName ( mkForeignExportOcc )
-import Name ( Name, NamedThing(..), mkExternalName )
-import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
- tcSplitForAllTys,
- isFFIArgumentTy, isFFIImportResultTy,
- isFFIExportResultTy, isFFILabelTy,
- isFFIExternalTy, isFFIDynArgumentTy,
- isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy,
- toDNType
- )
-import ForeignCall ( CExportSpec(..), CCallTarget(..),
- CLabelString, isCLabelString,
- isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
-import PrelNames ( hasKey, ioTyConKey )
-import DynFlags ( DynFlags(..), HscTarget(..) )
+import Name
+import OccName
+import TcType
+import DynFlags
import Outputable
-import SrcLoc ( Located(..), srcSpanStart )
-import Bag ( consBag )
-
-#if alpha_TARGET_ARCH
-import MachOp ( machRepByteWidth, MachHint(FloatHint) )
-#endif
+import SrcLoc
+import Bag
+import Unique
\end{code}
\begin{code}
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
-isForeignImport (L _ (ForeignImport _ _ _ _)) = True
+isForeignImport (L _ (ForeignImport _ _ _)) = True
isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
-isForeignExport (L _ (ForeignExport _ _ _ _)) = True
+isForeignExport (L _ (ForeignExport _ _ _)) = True
isForeignExport _ = False
\end{code}
= mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
-tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
+tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
= addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
let
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 (L loc id) undefined imp_decl' isDeprec)
+ returnM (id, ForeignImport (L loc id) undefined imp_decl')
\end{code}
returnM (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
newUnique `thenM` \ uniq ->
getModule `thenM` \ mod ->
let
- gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm))
- Nothing (srcSpanStart loc)
+ -- We need to give a name to the new top-level binding that
+ -- is *stable* (i.e. the compiler won't change it later),
+ -- because this name will be referred to by the C code stub.
+ -- Furthermore, the name must be unique (see #1533). If the
+ -- same function is foreign-exported multiple times, the
+ -- top-level bindings generated must not have the same name.
+ -- Hence we create an External name (doesn't change), and we
+ -- append a Unique to the string right here.
+ uniq_str = showSDoc (pprUnique uniq)
+ occ = mkVarOcc (occNameString (getOccName nm) ++ '_' : uniq_str)
+ gnm = mkExternalName uniq mod (mkForeignExportOcc occ) loc
id = mkExportedLocalId gnm sig_ty
bind = L loc (VarBind id rhs)
in
- returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)
+ returnM (bind, ForeignExport (L loc id) undefined spec)
\end{code}
------------ Checking argument types for foreign export ----------------------
mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
- = case tcSplitTyConApp_maybe ty of
- Just (io, [res_ty])
- | io `hasKey` ioTyConKey && pred_res_ty res_ty
- -> returnM ()
- _
- -> check (non_io_result_ok && pred_res_ty ty)
- (illegalForeignTyErr result ty)
+ -- (IO t) is ok, and so is any newtype wrapping thereof
+ | Just (io, res_ty, _) <- tcSplitIOType_maybe ty,
+ pred_res_ty res_ty
+ = returnM ()
+
+ | otherwise
+ = check (non_io_result_ok && pred_res_ty ty)
+ (illegalForeignTyErr result ty)
\end{code}
\begin{code}
-checkDotnet HscILX = Nothing
#if defined(mingw32_TARGET_OS)
checkDotnet HscC = Nothing
checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
checkCOrAsmOrDotNetOrInterp HscC = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
-checkCOrAsmOrDotNetOrInterp HscILX = Nothing
checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrDotNetOrInterp other
- = Just (text "requires interpreted, C, native or .NET ILX code generation")
+ = Just (text "requires interpreted, C or native code generation")
checkCg check
= getDOpts `thenM` \ dflags ->
case check target of
Nothing -> returnM ()
Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
-\end{code}
+\end{code}
Calling conventions
projects / ghc-hetmet.git / blobdiff