X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=4be039bd9326fe0f522a691b69e6125b079cb561;hb=04feba252e40d16101b92948cd1e13c7bc1f3062;hp=d13b4bbf9bb0b729eb4cd4664a6cb7d0a199a009;hpb=b0d844cf3400e9487d6c8327446e86fbaa10cd6f;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index d13b4bb..4be039b 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -17,20 +17,20 @@ module TcForeign
         , tcForeignExports
 	) where
 
-#include "config.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 )
@@ -43,14 +43,17 @@ import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
 			  toDNType
 			)
 import ForeignCall	( CExportSpec(..), CCallTarget(..), 
+			  CLabelString, isCLabelString,
 			  isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) 
-import CStrings		( CLabelString, isCLabelString )
 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}
@@ -127,6 +130,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
    	-- 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_`
@@ -137,9 +141,10 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
         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_`
@@ -153,6 +158,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction targe
 	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_`
@@ -177,12 +183,12 @@ The check is needed for both via-C and native-code routes
 #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
@@ -199,7 +205,7 @@ checkFEDArgs arg_tys = returnM ()
 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) ->
@@ -210,7 +216,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
    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_`
 
@@ -309,15 +315,27 @@ checkCOrAsmOrDotNetOrInterp other
 
 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}