X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcForeign.lhs;h=d18fe5f4839e2e90617d263d7d898dfb0115109d;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=b5b08f357df6f532347008ed4712fb44648ec6d7;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index b5b08f3..d18fe5f 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -17,7 +17,7 @@ module TcForeign
         , tcForeignExports
 	) where
 
-#include "config.h"
+#include "../includes/ghcconfig.h"
 #include "HsVersions.h"
 
 import HsSyn
@@ -27,7 +27,11 @@ import TcHsType		( tcHsSigType, UserTypeCtxt(..) )
 import TcExpr		( tcCheckSigma )			
 
 import ErrUtils		( Message )
-import Id		( Id, mkLocalId, setIdLocalExported )
+import Id		( Id, mkLocalId, mkExportedLocalId )
+#if alpha_TARGET_ARCH
+import PrimRep		( getPrimRepSize, isFloatingRep )
+import Type		( typePrimRep )
+#endif
 import OccName		( mkForeignExportOcc )
 import Name		( Name, NamedThing(..), mkExternalName )
 import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
@@ -39,8 +43,9 @@ import TcType		( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
 			  toDNType
 			)
 import ForeignCall	( CExportSpec(..), CCallTarget(..), 
+			  CLabelString, isCLabelString,
 			  isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) 
-import CStrings		( CLabelString, isCLabelString )
+import MachOp		( machRepByteWidth )
 import PrelNames	( hasKey, ioTyConKey )
 import CmdLineOpts	( dopt_HscLang, HscLang(..) )
 import Outputable
@@ -173,11 +178,11 @@ 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)
+    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")
 #else
 checkFEDArgs arg_tys = returnM ()
@@ -220,7 +225,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
    let
         gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) 
 			      Nothing (srcSpanStart loc)
-	id   = setIdLocalExported (mkLocalId gnm sig_ty)
+	id   = mkExportedLocalId gnm sig_ty
 	bind = L loc (VarBind id rhs)
    in
    returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)