Simon's big boxy-type commit

[ghc-hetmet.git] / ghc / compiler / typecheck / TcForeign.lhs

diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index e18a485..4be039b 100644 (file)
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -17,17 +17,21 @@ 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 Type            ( typePrimRep )
+import SMRep           ( argMachRep, primRepToCgRep, primRepHint )
+#endif
 import OccName         ( mkForeignExportOcc )
 import Name            ( Name, NamedThing(..), mkExternalName )
 import TcType          ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
@@ -39,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}
@@ -123,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_`
@@ -133,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_`
@@ -149,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_`
@@ -173,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
@@ -195,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) ->
@@ -206,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_`
 
@@ -305,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}