X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=727a3c21453ddeed0a8b0febec3132e739de082b;hb=f23ba2b294429ccbdeb80f0344ec08f6abf61bb7;hp=4aba2a126664e51f7adfe9eb39ebcc912cea073b;hpb=9d787ef5a8072b6c1f576f2de1b66edfa59813ed;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 4aba2a1..727a3c2 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -8,48 +8,39 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( HsDecl(..), IfaceSig(..) )
+import HsSyn		( HsDecl(..), TyClDecl(..), HsTupCon(..) )
 import TcMonad
-import TcMonoType	( tcHsType, tcHsTypeKind, 
+import TcMonoType	( tcHsType )
 				-- NB: all the tyars in interface files are kinded,
 				-- so tcHsType will do the Right Thing without
 				-- having to mess about with zonking
-			  tcExtendTyVarScope
-			)
-import TcEnv		( ValueEnv, tcExtendTyVarEnv, 
-			  tcExtendGlobalValEnv, tcSetValueEnv,
-			  tcLookupTyConByKey, tcLookupValueMaybe,
-			  explicitLookupValue, badCon, badPrimOp
+
+import TcEnv		( TcEnv, RecTcEnv, tcExtendTyVarEnv, 
+			  tcExtendGlobalValEnv, tcSetEnv,
+			  tcLookupGlobal_maybe, tcLookupRecId, tcEnvIds
 			)
-import TcType		( TcKind, kindToTcKind )
 
 import RnHsSyn		( RenamedHsDecl )
 import HsCore
-import CallConv		( cCallConv )
-import Const		( Con(..), Literal(..) )
+import Literal		( Literal(..) )
 import CoreSyn
-import CoreUtils	( coreExprType )
+import CoreUtils	( exprType )
 import CoreUnfold
 import CoreLint		( lintUnfolding )
-import WwLib		( mkWrapper )
-import PrimOp		( PrimOp(..) )
+import WorkWrap		( mkWrapper )
 
-import Id		( Id, mkId, mkVanillaId,
-			  isPrimitiveId_maybe, isDataConId_maybe
-			)
+import Id		( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
+import MkId		( mkCCallOpId )
 import IdInfo
 import DataCon		( dataConSig, dataConArgTys )
-import Type		( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
-import Var		( IdOrTyVar, mkTyVar, tyVarKind )
-import VarEnv
-import Name		( Name, NamedThing(..) )
-import Unique		( rationalTyConKey )
-import TysWiredIn	( integerTy, stringTy )
+import Type		( mkTyVarTys, splitAlgTyConApp_maybe )
+import Var		( mkTyVar, tyVarKind )
+import Name		( Name, isLocallyDefined )
 import Demand		( wwLazy )
 import ErrUtils		( pprBagOfErrors )
-import Maybes		( maybeToBool, MaybeErr(..) )
 import Outputable	
 import Util		( zipWithEqual )
+import HscTypes		( TyThing(..) )
 \end{code}
 
 Ultimately, type signatures in interfaces will have pragmatic
@@ -60,53 +51,51 @@ As always, we do not have to worry about user-pragmas in interface
 signatures.
 
 \begin{code}
-tcInterfaceSigs :: ValueEnv		-- Envt to use when checking unfoldings
+tcInterfaceSigs :: RecTcEnv		-- Envt to use when checking unfoldings
 		-> [RenamedHsDecl]	-- Ignore non-sig-decls in these decls
-		-> TcM s [Id]
+		-> TcM [Id]
 		
 
-tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
-  = tcAddSrcLoc src_loc (
-    tcAddErrCtxt (ifaceSigCtxt name) (
-	tcHsType ty						`thenTc` \ sigma_ty ->
-	tcIdInfo unf_env name sigma_ty vanillaIdInfo id_infos	`thenTc` \ id_info ->
+tcInterfaceSigs unf_env decls
+  = listTc [ do_one name ty id_infos src_loc
+	   | TyClD (IfaceSig name ty id_infos src_loc) <- decls]
+  where
+    in_scope_vars = []	-- I think this will be OK
+			-- If so, don't pass it around
+			-- Was: filter isLocallyDefined (tcEnvIds unf_env)
+
+    do_one name ty id_infos src_loc
+      = tcAddSrcLoc src_loc 		 		$	
+	tcAddErrCtxt (ifaceSigCtxt name)		$
+	tcHsType ty					`thenTc` \ sigma_ty ->
+	tcIdInfo unf_env in_scope_vars name 
+		 sigma_ty vanillaIdInfo id_infos	`thenTc` \ id_info ->
 	returnTc (mkId name sigma_ty id_info)
-    ))						`thenTc` \ sig_id ->
-    tcInterfaceSigs unf_env rest		`thenTc` \ sig_ids ->
-    returnTc (sig_id : sig_ids)
-
-tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
-
-tcInterfaceSigs unf_env [] = returnTc []
 \end{code}
 
 \begin{code}
-tcIdInfo unf_env name ty info info_ins
+tcIdInfo unf_env in_scope_vars name ty info info_ins
   = foldlTc tcPrag vanillaIdInfo info_ins
   where
     tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
-    tcPrag info (HsUpdate upd)  = returnTc (info `setUpdateInfo` upd)
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`	 NoCafRefs)
-    tcPrag info (HsCprInfo cpr_info)     = returnTc (info `setCprInfo` cpr_info)
+    tcPrag info HsCprInfo       = returnTc (info `setCprInfo`	 ReturnsCPR)
 
-    tcPrag info (HsUnfold inline_prag maybe_expr)
-	= (case maybe_expr of
-		Just expr -> tcPragExpr unf_env name [] expr
-		Nothing   -> returnNF_Tc Nothing
-	  )				 	`thenNF_Tc` \ maybe_expr' ->
+    tcPrag info (HsUnfold inline_prag expr)
+	= tcPragExpr unf_env name in_scope_vars expr 	`thenNF_Tc` \ maybe_expr' ->
 	  let
 		-- maybe_expr doesn't get looked at if the unfolding
 		-- is never inspected; so the typecheck doesn't even happen
 		unfold_info = case maybe_expr' of
 				Nothing    -> noUnfolding
-				Just expr' -> mkUnfolding expr' 
+				Just expr' -> mkTopUnfolding expr' 
 		info1 = info `setUnfoldingInfo` unfold_info
 		info2 = info1 `setInlinePragInfo` inline_prag
 	  in
 	  returnTc info2
 
-    tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
-	= returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
+    tcPrag info (HsStrictness strict_info)
+	= returnTc (info `setStrictnessInfo` strict_info)
 
     tcPrag info (HsWorker nm)
 	= tcWorkerInfo unf_env ty info nm
@@ -118,14 +107,14 @@ tcWorkerInfo unf_env ty info worker_name
   = pprPanic "Worker with no arity info" (ppr worker_name)
  
   | otherwise
-  = uniqSMToTcM (mkWrapper ty arity demands cpr_info) `thenNF_Tc` \ wrap_fn ->
+  = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
     let
 	-- Watch out! We can't pull on unf_env too eagerly!
-	info' = case explicitLookupValue unf_env worker_name of
-			Just worker_id -> info `setUnfoldingInfo`  mkUnfolding (wrap_fn worker_id)
-                                               `setWorkerInfo`     Just worker_id
+	info' = case tcLookupRecId unf_env worker_name of
+		  Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
+                                         `setWorkerInfo`     HasWorker worker_id arity
 
-    			Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
+    		  Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
     in
     returnTc info'
   where
@@ -134,9 +123,9 @@ tcWorkerInfo unf_env ty info worker_name
       arity_info = arityInfo info
       arity      = arityLowerBound arity_info
       cpr_info   = cprInfo info
-      demands    = case strictnessInfo info of
-			StrictnessInfo d _ -> d
-			_                  -> repeat wwLazy	-- Noncommittal
+      (demands, res_bot)    = case strictnessInfo info of
+			 	StrictnessInfo d r -> (d,r)
+				_                  -> (take arity (repeat wwLazy),False)	-- Noncommittal
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
@@ -149,17 +138,18 @@ tcPragExpr unf_env name in_scope_vars expr
 
 		-- Check for type consistency in the unfolding
 	tcGetSrcLoc		`thenNF_Tc` \ src_loc -> 
-	case lintUnfolding src_loc in_scope_vars core_expr' of
-	  Nothing       -> returnTc core_expr'
-	  Just fail_msg -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
+	getDOptsTc		`thenTc` \ dflags ->
+	case lintUnfolding dflags src_loc in_scope_vars core_expr' of
+	  (Nothing,_)       -> returnTc core_expr'  -- ignore warnings
+	  (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
   where
     doc = text "unfolding of" <+> ppr name
 
-tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a)
+tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
 tcDelay unf_env doc thing_inside
   = forkNF_Tc (
 	recoverNF_Tc bad_value (
-		tcSetValueEnv unf_env thing_inside	`thenTc` \ r ->
+		tcSetEnv unf_env thing_inside	`thenTc` \ r ->
 		returnTc (Just r)
     ))			
   where
@@ -178,12 +168,12 @@ Variables in unfoldings
 ****** Why? Because we know all the types and want to bind them to real Ids.
 
 \begin{code}
-tcVar :: Name -> TcM s Id
+tcVar :: Name -> TcM Id
 tcVar name
-  = tcLookupValueMaybe name	`thenNF_Tc` \ maybe_id ->
+  = tcLookupGlobal_maybe name	`thenNF_Tc` \ maybe_id ->
     case maybe_id of {
-	Just id -> returnTc id;
-	Nothing -> failWithTc (noDecl name)
+	Just (AnId id)	-> returnTc id;
+	Nothing		-> failWithTc (noDecl name)
     }
 
 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
@@ -192,10 +182,10 @@ noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
 UfCore expressions.
 
 \begin{code}
-tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
+tcCoreExpr :: UfExpr Name -> TcM CoreExpr
 
 tcCoreExpr (UfType ty)
-  = tcHsTypeKind ty	`thenTc` \ (_, ty') ->
+  = tcHsType ty		`thenTc` \ ty' ->
 	-- It might not be of kind type
     returnTc (Type ty')
 
@@ -203,19 +193,28 @@ tcCoreExpr (UfVar name)
   = tcVar name 	`thenTc` \ id ->
     returnTc (Var id)
 
-tcCoreExpr (UfCon con args) 
-  = tcUfCon con			`thenTc` \ con' ->
-    mapTc tcCoreExpr args	`thenTc` \ args' ->
-    returnTc (Con con' args')
+tcCoreExpr (UfLit lit)
+  = returnTc (Lit lit)
+
+-- The dreaded lit-lits are also similar, except here the type
+-- is read in explicitly rather than being implicit
+tcCoreExpr (UfLitLit lit ty)
+  = tcHsType ty		`thenTc` \ ty' ->
+    returnTc (Lit (MachLitLit lit ty'))
 
-tcCoreExpr (UfTuple name args) 
-  = tcUfDataCon name		`thenTc` \ con ->
+tcCoreExpr (UfCCall cc ty)
+  = tcHsType ty 	`thenTc` \ ty' ->
+    tcGetUnique		`thenNF_Tc` \ u ->
+    returnTc (Var (mkCCallOpId u cc ty'))
+
+tcCoreExpr (UfTuple (HsTupCon name _) args) 
+  = tcVar name			`thenTc` \ con_id ->
     mapTc tcCoreExpr args	`thenTc` \ args' ->
     let
 	-- Put the missing type arguments back in
-	con_args = map (Type . unUsgTy . coreExprType) args' ++ args'
+	con_args = map (Type . exprType) args' ++ args'
     in
-    returnTc (Con con con_args)
+    returnTc (mkApps (Var con_id) con_args)
 
 tcCoreExpr (UfLam bndr body)
   = tcCoreLamBndr bndr 		$ \ bndr' ->
@@ -230,7 +229,7 @@ tcCoreExpr (UfApp fun arg)
 tcCoreExpr (UfCase scrut case_bndr alts) 
   = tcCoreExpr scrut					`thenTc` \ scrut' ->
     let
-	scrut_ty = coreExprType scrut'
+	scrut_ty = exprType scrut'
 	case_bndr' = mkVanillaId case_bndr scrut_ty
     in
     tcExtendGlobalValEnv [case_bndr']	$
@@ -255,60 +254,11 @@ tcCoreExpr (UfNote note expr)
   = tcCoreExpr expr		`thenTc` \ expr' ->
     case note of
 	UfCoerce to_ty -> tcHsType to_ty	`thenTc` \ to_ty' ->
-			  returnTc (Note (Coerce (unUsgTy to_ty')
-                                                 (unUsgTy (coreExprType expr'))) expr')
+			  returnTc (Note (Coerce to_ty'
+                                                 (exprType expr')) expr')
 	UfInlineCall   -> returnTc (Note InlineCall expr')
 	UfInlineMe     -> returnTc (Note InlineMe   expr')
 	UfSCC cc       -> returnTc (Note (SCC cc)   expr')
-
-tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
-tcCoreNote UfInlineCall = returnTc InlineCall 
-
-
--- rationalTy isn't built in so, we have to construct it
--- (the "ty" part of the incoming literal is simply bottom)
-tcUfCon (UfLitCon (NoRepRational lit _)) 
-  = tcLookupTyConByKey rationalTyConKey	`thenNF_Tc` \ rational_tycon ->
-    let
-	rational_ty  = mkSynTy rational_tycon []
-    in
-    returnTc (Literal (NoRepRational lit rational_ty)) 
-
--- Similarly for integers and strings, except that they are wired in
-tcUfCon (UfLitCon (NoRepInteger lit _)) 
-  = returnTc (Literal (NoRepInteger lit integerTy))
-tcUfCon (UfLitCon (NoRepStr lit _))
-  = returnTc (Literal (NoRepStr lit stringTy))
-
-tcUfCon (UfLitCon other_lit)
-  = returnTc (Literal other_lit)
-
--- The dreaded lit-lits are also similar, except here the type
--- is read in explicitly rather than being implicit
-tcUfCon (UfLitLitCon lit ty)
-  = tcHsType ty		`thenTc` \ ty' ->
-    returnTc (Literal (MachLitLit lit ty'))
-
-tcUfCon (UfDataCon name) = tcUfDataCon name
-
-tcUfCon (UfPrimOp name)
-  = tcVar name		`thenTc` \ op_id ->
-    case isPrimitiveId_maybe op_id of
-	Just op -> returnTc (PrimOp op)
-	Nothing -> failWithTc (badPrimOp name)
-
-tcUfCon (UfCCallOp str is_dyn casm gc)
-  = case is_dyn of
-       True  -> 
-          tcGetUnique `thenNF_Tc` \ u ->
-	  returnTc (PrimOp (CCallOp (Right u) casm gc cCallConv))
-       False -> returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
-
-tcUfDataCon name
-  = tcVar name		`thenTc` \ con_id ->
-    case isDataConId_maybe con_id of
-	Just con -> returnTc (DataCon con)
-	Nothing  -> failWithTc (badCon name)
 \end{code}
 
 \begin{code}
@@ -358,34 +308,36 @@ tcCoreAlt scrut_ty (UfDefault, names, rhs)
     tcCoreExpr rhs		`thenTc` \ rhs' ->
     returnTc (DEFAULT, [], rhs')
   
-tcCoreAlt scrut_ty (UfLitCon lit, names, rhs)
+tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
   = ASSERT( null names )
     tcCoreExpr rhs		`thenTc` \ rhs' ->
-    returnTc (Literal lit, [], rhs')
+    returnTc (LitAlt lit, [], rhs')
 
-tcCoreAlt scrut_ty (UfLitLitCon str ty, names, rhs)
+tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
   = ASSERT( null names )
     tcCoreExpr rhs		`thenTc` \ rhs' ->
     tcHsType ty			`thenTc` \ ty' ->
-    returnTc (Literal (MachLitLit str ty'), [], rhs')
+    returnTc (LitAlt (MachLitLit str ty'), [], rhs')
 
 -- A case alternative is made quite a bit more complicated
 -- by the fact that we omit type annotations because we can
 -- work them out.  True enough, but its not that easy!
-tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs)
+tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
   = tcVar con_name		`thenTc` \ con_id ->
     let
-	con			= case isDataConId_maybe con_id of
-					Just con -> con
-					Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
+	con = case isDataConWrapId_maybe con_id of
+		Just con -> con
+		Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
 
 	(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 
-	(tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
-	ex_tyvars'		= [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] 
-	ex_tys'			= mkTyVarTys ex_tyvars'
-	arg_tys			= dataConArgTys con (inst_tys ++ ex_tys')
-	id_names		= drop (length ex_tyvars) names
+	(_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
+				    Just stuff -> stuff
+				    Nothing -> pprPanic "tcCoreAlt" (ppr alt)
+	ex_tyvars'	    = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] 
+	ex_tys'		    = mkTyVarTys ex_tyvars'
+	arg_tys		    = dataConArgTys con (inst_tys ++ ex_tys')
+	id_names	    = drop (length ex_tyvars) names
 	arg_ids
 #ifdef DEBUG
 		| length id_names /= length arg_tys
@@ -400,7 +352,7 @@ tcCoreAlt scrut_ty (UfDataCon con_name, names, rhs)
     tcExtendTyVarEnv ex_tyvars'			$
     tcExtendGlobalValEnv arg_ids		$
     tcCoreExpr rhs					`thenTc` \ rhs' ->
-    returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs')
+    returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
 \end{code}
 
 \begin{code}