[project @ 1998-10-21 11:28:00 by sof]

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

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 675a792..9264fb5 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -11,13 +11,14 @@ module TcIfaceSig ( tcInterfaceSigs ) where
 import HsSyn           ( HsDecl(..), IfaceSig(..) )
 import TcMonad
 import TcMonoType      ( tcHsType, tcHsTypeKind, tcTyVarScope )
-import TcEnv           ( tcExtendTyVarEnv, tcExtendGlobalValEnv,
+import TcEnv           ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetGlobalValEnv,
                          tcLookupTyConByKey, tcLookupGlobalValueMaybe,
-                         tcExplicitLookupGlobal
+                         tcExplicitLookupGlobal,
+                         GlobalValueEnv
                        )
 import TcKind          ( TcKind, kindToTcKind )
 
-import RnHsSyn         ( RenamedHsDecl(..) )
+import RnHsSyn         ( RenamedHsDecl )
 import HsCore
 import HsDecls         ( HsIdInfo(..), HsStrictnessInfo(..) )
 import Literal         ( Literal(..) )
@@ -27,6 +28,7 @@ import CoreUnfold
 import MagicUFs                ( MagicUnfoldingFun )
 import WwLib           ( mkWrapper )
 import PrimOp          ( PrimOp(..) )
+import CallConv                ( cCallConv )
 
 import MkId            ( mkImportedId, mkUserId )
 import Id              ( Id, addInlinePragma, isPrimitiveId_maybe, dataConArgTys )
@@ -52,7 +54,7 @@ As always, we do not have to worry about user-pragmas in interface
 signatures.
 
 \begin{code}
-tcInterfaceSigs :: TcEnv s             -- Envt to use when checking unfoldings
+tcInterfaceSigs :: GlobalValueEnv      -- Envt to use when checking unfoldings
                -> [RenamedHsDecl]      -- Ignore non-sig-decls in these decls
                -> TcM s [Id]
                
@@ -100,8 +102,12 @@ tcIdInfo unf_env name ty info info_ins
        = tcStrictness unf_env ty info strict
 
     tcPrag info (HsSpecialise tyvars tys rhs)
-       = tcTyVarScope tyvars           $ \ tyvars' ->
-         mapTc tcHsType tys            `thenTc` \ tys' -> 
+       = tcTyVarScope tyvars                   $ \ tyvars' ->
+         mapAndUnzipTc tcHsTypeKind tys        `thenTc` \ (kinds, tys') -> 
+               -- Assume that the kinds match the kinds of the 
+               -- type variables of the function; this is, after all, an
+               -- interface file generated by the compiler!
+
          tcPragExpr unf_env name rhs   `thenNF_Tc` \ maybe_rhs' ->
          let
                -- If spec_env isn't looked at, none of this 
@@ -159,7 +165,7 @@ an unfolding that isn't going to be looked at.
 tcPragExpr unf_env name core_expr
   = forkNF_Tc (
        recoverNF_Tc no_unfolding (
-               tcSetEnv unf_env $
+               tcSetGlobalValEnv unf_env $
                tcCoreExpr core_expr    `thenTc` \ core_expr' ->
                returnTc (Just core_expr')
     ))                 
@@ -265,27 +271,6 @@ tcCoreExpr (UfNote note expr)
 tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
 tcCoreNote UfInlineCall = returnTc InlineCall 
 \end{code}
-    returnTc (Note note' expr') 
-
-tcCoreExpr (UfLam bndr body)
-  = tcCoreLamBndr bndr                 $ \ bndr' ->
-    tcCoreExpr body            `thenTc` \ body' ->
-    returnTc (Lam bndr' body')
-
-tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
-  = tcCoreExpr rhs             `thenTc` \ rhs' ->
-    tcCoreValBndr bndr                 $ \ bndr' ->
-    tcCoreExpr body            `thenTc` \ body' ->
-    returnTc (Let (NonRec bndr' rhs') body')
-
-tcCoreExpr (UfLet (UfRec pairs) body)
-  = tcCoreValBndrs bndrs       $ \ bndrs' ->
-    mapTc tcCoreExpr rhss      `thenTc` \ rhss' ->
-    tcCoreExpr body            `thenTc` \ body' ->
-    returnTc (Let (Rec (bndrs' `zip` rhss')) body')
-  where
-    (bndrs, rhss) = unzip pairs
-\end{code}
 
 \begin{code}
 tcCoreLamBndr (UfValBinder name ty) thing_inside
@@ -371,7 +356,7 @@ tcCorePrim (UfOtherOp op)
 tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
   = mapTc tcHsType arg_tys     `thenTc` \ arg_tys' ->
     tcHsType res_ty            `thenTc` \ res_ty' ->
-    returnTc (CCallOp str casm gc arg_tys' res_ty')
+    returnTc (CCallOp (Left str) casm gc cCallConv arg_tys' res_ty')
 \end{code}
 
 \begin{code}