X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=da180d8394617d54475c6a934c22837ee71f2709;hb=469c3333ae5954cee58cdb1575b41fb1a3c34f06;hp=4bce6a4b00554b0ba889588035e616467b05e416;hpb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 4bce6a4..da180d8 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -4,24 +4,19 @@
 \section[TcIfaceSig]{Type checking of type signatures in interface files}
 
 \begin{code}
-module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
+module TcIfaceSig ( tcInterfaceSigs, tcDelay, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( HsDecl(..), IfaceSig(..), HsTupCon(..) )
+import HsSyn		( TyClDecl(..), HsTupCon(..) )
 import TcMonad
-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
-
-import TcEnv		( ValueEnv, tcExtendTyVarEnv, 
-			  tcExtendGlobalValEnv, tcSetValueEnv,
-			  tcLookupValueMaybe,
-			  explicitLookupValue, badCon, badPrimOp, valueEnvIds
+import TcMonoType	( tcIfaceType )
+import TcEnv		( RecTcEnv, tcExtendTyVarEnv, 
+			  tcExtendGlobalValEnv, tcSetEnv, tcEnvIds,
+			  tcLookupGlobal_maybe, tcLookupRecId_maybe
 			)
 
-import RnHsSyn		( RenamedHsDecl )
+import RnHsSyn		( RenamedTyClDecl )
 import HsCore
 import Literal		( Literal(..) )
 import CoreSyn
@@ -30,19 +25,20 @@ import CoreUnfold
 import CoreLint		( lintUnfolding )
 import WorkWrap		( mkWrapper )
 
-import Id		( Id, mkId, mkVanillaId,
-			  isDataConWrapId_maybe
-			)
-import MkId		( mkCCallOpId )
+import Id		( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe )
+import Module		( Module )
+import MkId		( mkFCallId )
 import IdInfo
-import DataCon		( dataConSig, dataConArgTys )
-import Type		( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitAlgTyConApp_maybe, splitFunTys, unUsgTy )
+import TyCon		( tyConDataCons )
+import DataCon		( DataCon, dataConId, dataConSig, dataConArgTys )
+import Type		( mkTyVarTys, splitTyConApp )
+import TysWiredIn	( tupleCon )
 import Var		( mkTyVar, tyVarKind )
-import Name		( Name, NamedThing(..), isLocallyDefined )
-import Demand		( wwLazy )
+import Name		( Name, nameIsLocalOrFrom )
 import ErrUtils		( pprBagOfErrors )
 import Outputable	
-import Util		( zipWithEqual )
+import Util		( zipWithEqual, dropList, equalLength )
+import HscTypes		( TyThing(..) )
 \end{code}
 
 Ultimately, type signatures in interfaces will have pragmatic
@@ -53,34 +49,46 @@ As always, we do not have to worry about user-pragmas in interface
 signatures.
 
 \begin{code}
-tcInterfaceSigs :: ValueEnv		-- Envt to use when checking unfoldings
-		-> [RenamedHsDecl]	-- Ignore non-sig-decls in these decls
-		-> TcM s [Id]
+tcInterfaceSigs :: RecTcEnv		-- Envt to use when checking unfoldings
+		-> Module		-- This module
+		-> [RenamedTyClDecl]	-- Ignore non-sig-decls in these decls
+		-> TcM [Id]
 		
 
-tcInterfaceSigs unf_env decls
+tcInterfaceSigs unf_env mod decls
   = listTc [ do_one name ty id_infos src_loc
-	   | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+	   | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
   where
-    in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+    in_scope_vars = filter (nameIsLocalOrFrom mod . idName) (tcEnvIds unf_env)
+		-- Oops: using isLocalId instead can give a black hole
+		-- because it looks at the idinfo
+
+	-- When we have hi-boot files, an unfolding might refer to
+	-- something defined in this module, so we must build a
+	-- suitable in-scope set.  This thunk will only be poked
+	-- if -dcore-lint is on.
 
     do_one name ty id_infos src_loc
       = tcAddSrcLoc src_loc 		 		$	
 	tcAddErrCtxt (ifaceSigCtxt name)		$
-	tcHsType ty					`thenTc` \ sigma_ty ->
+	tcIfaceType 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)
+		 sigma_ty id_infos			`thenTc` \ id_info ->
+	returnTc (mkVanillaGlobal name sigma_ty id_info)
 \end{code}
 
 \begin{code}
-tcIdInfo unf_env in_scope_vars name ty info info_ins
-  = foldlTc tcPrag vanillaIdInfo info_ins
+tcIdInfo unf_env in_scope_vars name ty info_ins
+  = foldlTc tcPrag init_info info_ins 
   where
-    tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
-    tcPrag info (HsUpdate upd)  = returnTc (info `setUpdateInfo` upd)
+    -- set the CgInfo to something sensible but uninformative before
+    -- we start, because the default CgInfo is a panic.
+    init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo
+
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`	 NoCafRefs)
-    tcPrag info HsCprInfo       = returnTc (info `setCprInfo`	 ReturnsCPR)
+
+    tcPrag info (HsArity arity) = 
+	returnTc (info `setArityInfo` arity)
 
     tcPrag info (HsUnfold inline_prag expr)
 	= tcPragExpr unf_env name in_scope_vars expr 	`thenNF_Tc` \ maybe_expr' ->
@@ -96,37 +104,32 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins
 	  returnTc info2
 
     tcPrag info (HsStrictness strict_info)
-	= returnTc (info `setStrictnessInfo` strict_info)
+	= returnTc (info `setAllStrictnessInfo` Just strict_info)
 
-    tcPrag info (HsWorker nm)
-	= tcWorkerInfo unf_env ty info nm
+    tcPrag info (HsWorker nm arity)
+	= tcWorkerInfo unf_env ty info nm arity
 \end{code}
 
 \begin{code}
-tcWorkerInfo unf_env ty info worker_name
-  | not (hasArity arity_info)
-  = pprPanic "Worker with no arity info" (ppr worker_name)
- 
-  | otherwise
-  = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
+tcWorkerInfo unf_env ty info worker_name arity
+  = uniqSMToTcM (mkWrapper ty strict_sig) `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`  mkTopUnfolding (wrap_fn worker_id)
-                                               `setWorkerInfo`     HasWorker worker_id arity
+	info' = case tcLookupRecId_maybe 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
-	-- We are relying here on arity, cpr and strictness info always appearing 
+    	-- We are relying here on strictness info always appearing 
 	-- before worker info,  fingers crossed ....
-      arity_info = arityInfo info
-      arity      = arityLowerBound arity_info
-      cpr_info   = cprInfo info
-      (demands, res_bot)    = case strictnessInfo info of
-			 	StrictnessInfo d r -> (d,r)
-				_                  -> (take arity (repeat wwLazy),False)	-- Noncommittal
+      strict_sig = case newStrictnessInfo info of
+		 	Just sig -> sig
+			Nothing  -> pprPanic "Worker info but no strictness for" (ppr worker_name)
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
@@ -134,23 +137,23 @@ an unfolding that isn't going to be looked at.
 
 \begin{code}
 tcPragExpr unf_env name in_scope_vars expr
-  = tcDelay unf_env doc $
+  = tcDelay unf_env doc Nothing $
 	tcCoreExpr expr		`thenTc` \ core_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'  -- ignore warnings
+	getDOptsTc		`thenNF_Tc` \ dflags ->
+	case lintUnfolding dflags src_loc in_scope_vars core_expr' of
+	  (Nothing,_)       -> returnTc (Just 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 unf_env doc thing_inside
+tcDelay :: RecTcEnv -> SDoc -> a -> TcM a -> NF_TcM a
+tcDelay unf_env doc bad_ans thing_inside
   = forkNF_Tc (
 	recoverNF_Tc bad_value (
-		tcSetValueEnv unf_env thing_inside	`thenTc` \ r ->
-		returnTc (Just r)
+		tcSetEnv unf_env thing_inside
     ))			
   where
 	-- The trace tells what wasn't available, for the benefit of
@@ -158,7 +161,7 @@ tcDelay unf_env doc thing_inside
     bad_value = getErrsTc		`thenNF_Tc` \ (warns,errs) ->
 		returnNF_Tc (pprTrace "Failed:" 
 				   	 (hang doc 4 (pprBagOfErrors errs))
-					 Nothing)
+					 bad_ans)
 \end{code}
 
 
@@ -168,12 +171,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]
@@ -182,10 +185,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)
-  = tcHsType ty		`thenTc` \ ty' ->
+  = tcIfaceType ty		`thenTc` \ ty' ->
 	-- It might not be of kind type
     returnTc (Type ty')
 
@@ -199,22 +202,24 @@ tcCoreExpr (UfLit 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' ->
+  = tcIfaceType ty		`thenTc` \ ty' ->
     returnTc (Lit (MachLitLit lit ty'))
 
-tcCoreExpr (UfCCall cc ty)
-  = tcHsType ty 	`thenTc` \ ty' ->
+tcCoreExpr (UfFCall cc ty)
+  = tcIfaceType ty 	`thenTc` \ ty' ->
     tcGetUnique		`thenNF_Tc` \ u ->
-    returnTc (Var (mkCCallOpId u cc ty'))
+    returnTc (Var (mkFCallId u cc ty'))
 
-tcCoreExpr (UfTuple (HsTupCon name _) args) 
-  = tcVar name			`thenTc` \ con_id ->
-    mapTc tcCoreExpr args	`thenTc` \ args' ->
+tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args) 
+  = mapTc tcCoreExpr args	`thenTc` \ args' ->
     let
 	-- Put the missing type arguments back in
-	con_args = map (Type . unUsgTy . exprType) args' ++ args'
+	con_args = map (Type . exprType) args' ++ args'
     in
     returnTc (mkApps (Var con_id) con_args)
+  where
+    con_id = dataConId (tupleCon boxity arity)
+    
 
 tcCoreExpr (UfLam bndr body)
   = tcCoreLamBndr bndr 		$ \ bndr' ->
@@ -230,7 +235,7 @@ tcCoreExpr (UfCase scrut case_bndr alts)
   = tcCoreExpr scrut					`thenTc` \ scrut' ->
     let
 	scrut_ty = exprType scrut'
-	case_bndr' = mkVanillaId case_bndr scrut_ty
+	case_bndr' = mkLocalId case_bndr scrut_ty
     in
     tcExtendGlobalValEnv [case_bndr']	$
     mapTc (tcCoreAlt scrut_ty) alts	`thenTc` \ alts' ->
@@ -253,22 +258,19 @@ tcCoreExpr (UfLet (UfRec pairs) body)
 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 (exprType expr'))) expr')
+	UfCoerce to_ty -> tcIfaceType to_ty	`thenTc` \ to_ty' ->
+			  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 
 \end{code}
 
 \begin{code}
 tcCoreLamBndr (UfValBinder name ty) thing_inside
-  = tcHsType ty			`thenTc` \ ty' ->
+  = tcIfaceType ty		`thenTc` \ ty' ->
     let
-	id = mkVanillaId name ty'
+	id = mkLocalId name ty'
     in
     tcExtendGlobalValEnv [id] $
     thing_inside id
@@ -286,17 +288,17 @@ tcCoreLamBndrs (b:bs) thing_inside
     thing_inside (b':bs')
 
 tcCoreValBndr (UfValBinder name ty) thing_inside
-  = tcHsType ty			`thenTc` \ ty' ->
+  = tcIfaceType ty			`thenTc` \ ty' ->
     let
-	id = mkVanillaId name ty'
+	id = mkLocalId name ty'
     in
     tcExtendGlobalValEnv [id] $
     thing_inside id
     
 tcCoreValBndrs bndrs thing_inside		-- Expect them all to be ValBinders
-  = mapTc tcHsType tys			`thenTc` \ tys' ->
+  = mapTc tcIfaceType tys		`thenTc` \ tys' ->
     let
-	ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
+	ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
     in
     tcExtendGlobalValEnv ids $
     thing_inside ids
@@ -319,43 +321,49 @@ tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
 tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
   = ASSERT( null names )
     tcCoreExpr rhs		`thenTc` \ rhs' ->
-    tcHsType ty			`thenTc` \ ty' ->
+    tcIfaceType ty		`thenTc` \ ty' ->
     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 alt@(UfDataAlt con_name, names, rhs)
-  = tcVar con_name		`thenTc` \ con_id ->
+tcCoreAlt scrut_ty alt@(con, names, rhs)
+  = tcConAlt con	`thenTc` \ con ->
     let
-	con = case isDataConWrapId_maybe con_id of
-		Just con -> con
-		Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
-
 	(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 
-	(_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
-				    Just stuff -> stuff
-				    Nothing -> pprPanic "tcCoreAlt" (ppr alt)
+	(tycon, inst_tys)   = splitTyConApp scrut_ty	-- NB: not tcSplitTyConApp
+							-- We are looking at Core here
 	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
+	id_names	    = dropList ex_tyvars names
 	arg_ids
 #ifdef DEBUG
-		| length id_names /= length arg_tys
-		= pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
+		| not (equalLength id_names arg_tys)
+		= pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
 					 (ppr main_tyvars <+> ppr ex_tyvars) $$
 					 ppr arg_tys)
 		| otherwise
 #endif
-		= zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
+		= zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
     in
-    ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
+    ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars )
     tcExtendTyVarEnv ex_tyvars'			$
     tcExtendGlobalValEnv arg_ids		$
     tcCoreExpr rhs					`thenTc` \ rhs' ->
     returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+
+
+tcConAlt :: UfConAlt Name -> TcM DataCon
+tcConAlt (UfTupleAlt (HsTupCon _ boxity arity))
+  = returnTc (tupleCon boxity arity)
+
+tcConAlt (UfDataAlt con_name)
+  = tcVar con_name	`thenTc` \ con_id ->
+    returnTc (case isDataConWrapId_maybe con_id of
+		    Just con -> con
+		    Nothing  -> pprPanic "tcCoreAlt" (ppr con_id))
 \end{code}
 
 \begin{code}