X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=c947fabc51e57e41bfcae8acdb23673617f901fb;hb=4161ba13916463f8e67259498eacf22744160e1f;hp=1646bfb3a0a4441d69e3882190db3570b9e6e405;hpb=e0eaaf09894f74939166568573b36cb5bdafcfc7;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 1646bfb..c947fab 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -1,48 +1,46 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcIfaceSig]{Type checking of type signatures in interface files}
 
 \begin{code}
-module TcIfaceSig ( tcInterfaceSigs ) where
+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, tcTyVarScope )
-import TcEnv		( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetGlobalValEnv,
-			  tcLookupTyConByKey, tcLookupGlobalValueMaybe,
-			  tcExplicitLookupGlobal,
-			  GlobalValueEnv
+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		( TcEnv, RecTcEnv, tcExtendTyVarEnv, 
+			  tcExtendGlobalValEnv, tcSetEnv,
+			  tcLookupGlobal_maybe, tcLookupRecId, tcEnvIds
 			)
-import TcKind		( TcKind, kindToTcKind )
 
 import RnHsSyn		( RenamedHsDecl )
 import HsCore
-import HsDecls		( HsIdInfo(..), HsStrictnessInfo(..) )
 import Literal		( Literal(..) )
 import CoreSyn
-import CoreUtils	( coreExprType )
+import CoreUtils	( exprType )
 import CoreUnfold
-import MagicUFs		( MagicUnfoldingFun )
-import WwLib		( mkWrapper )
-import PrimOp		( PrimOp(..) )
+import CoreLint		( lintUnfolding )
+import WorkWrap		( mkWrapper )
 
-import MkId		( mkImportedId, mkUserId )
-import Id		( Id, addInlinePragma, isPrimitiveId_maybe, dataConArgTys )
+import Id		( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
+import MkId		( mkCCallOpId )
 import IdInfo
-import SpecEnv		( addToSpecEnv )
-import Type		( mkSynTy, splitAlgTyConApp )
-import TyVar		( mkSysTyVar )
+import DataCon		( dataConSig, dataConArgTys )
+import Type		( mkTyVarTys, splitAlgTyConApp_maybe )
+import Var		( mkTyVar, tyVarKind )
 import Name		( Name )
-import Unique		( rationalTyConKey, uniqueOf )
-import TysWiredIn	( integerTy )
+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
@@ -53,123 +51,111 @@ As always, we do not have to worry about user-pragmas in interface
 signatures.
 
 \begin{code}
-tcInterfaceSigs :: GlobalValueEnv	-- 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 noIdInfo id_infos	`thenTc` \ id_info ->
-	returnTc (mkImportedId 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 []
+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
+
+    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)
 \end{code}
 
 \begin{code}
-tcIdInfo unf_env name ty info info_ins
-  = foldlTc tcPrag noIdInfo info_ins
+tcIdInfo unf_env in_scope_vars name ty info info_ins
+  = foldlTc tcPrag constantIdInfo info_ins
   where
-    tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
-    tcPrag info (HsUpdate upd)  = returnTc (upd   `setUpdateInfo` info)
-    tcPrag info (HsFBType fb)   = returnTc (fb    `setFBTypeInfo` info)
-    tcPrag info (HsArgUsage au) = returnTc (au    `setArgUsageInfo` info)
+    tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
+    tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`	 NoCafRefs)
+    tcPrag info HsCprInfo       = returnTc (info `setCprInfo`	 ReturnsCPR)
 
-    tcPrag info (HsUnfold inline expr)
-	= tcPragExpr unf_env name expr 	`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' 
-		info1 = unfold_info `setUnfoldingInfo` info
-
-		info2 | inline    = IWantToBeINLINEd `setInlinePragInfo` info1
-		      | otherwise = info1
+				Nothing    -> noUnfolding
+				Just expr' -> mkTopUnfolding expr' 
+		info1 = info `setUnfoldingInfo` unfold_info
+		info2 = info1 `setInlinePragInfo` inline_prag
 	  in
 	  returnTc info2
 
-    tcPrag info (HsStrictness strict)
-	= tcStrictness unf_env ty info strict
+    tcPrag info (HsStrictness strict_info)
+	= returnTc (info `setStrictnessInfo` strict_info)
 
-    tcPrag info (HsSpecialise tyvars tys rhs)
-	= tcTyVarScope tyvars		$ \ tyvars' ->
-	  mapTc tcHsType tys		`thenTc` \ tys' -> 
-	  tcPragExpr unf_env name rhs	`thenNF_Tc` \ maybe_rhs' ->
-	  let
-		-- If spec_env isn't looked at, none of this 
-		-- actually takes place
-	    spec_env  = specInfo info
- 	    spec_env' = case maybe_rhs' of
-			  Nothing -> spec_env
-			  Just rhs' -> case addToSpecEnv True {- overlap ok -} spec_env tyvars' tys' rhs' of
-					  Succeeded spec_env' -> spec_env'
-					  Failed err	      -> pprTrace "tcIdInfo: bad specialisation"
-							  	 	  (ppr name <+> ppr err) $
-								 spec_env
-	  in
-	  returnTc (spec_env' `setSpecInfo` info)
+    tcPrag info (HsWorker nm)
+	= tcWorkerInfo unf_env ty info nm
 \end{code}
 
 \begin{code}
-tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
-  = tcWorker unf_env maybe_worker		`thenNF_Tc` \ maybe_worker_id ->
-    uniqSMToTcM (mkWrapper ty demands)		`thenNF_Tc` \ wrap_fn ->
+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 ->
     let
-	-- Watch out! We can't pull on maybe_worker_id too eagerly!
-	info' = case maybe_worker_id of
-			Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $
-					  setInlinePragInfo IWantToBeINLINEd info
+	-- Watch out! We can't pull on unf_env too eagerly!
+	info' = case tcLookupRecId unf_env worker_name of
+		  Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
+                                         `setWorkerInfo`     HasWorker worker_id arity
 
-			Nothing        -> info
-
-	has_worker = maybeToBool maybe_worker_id
+    		  Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
     in
-    returnTc (StrictnessInfo demands has_worker  `setStrictnessInfo` info')
-
--- Boring to write these out, but the result type differs from the arg type...
-tcStrictness unf_env ty info HsBottom
-  = returnTc (BottomGuaranteed `setStrictnessInfo` info)
-\end{code}
-
-\begin{code}
-tcWorker unf_env Nothing = returnNF_Tc Nothing
-
-tcWorker unf_env (Just (worker_name,_))
-  = returnNF_Tc (trace_maybe maybe_worker_id)
+    returnTc info'
   where
-    maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
-
-	-- The trace is so we can see what's getting dropped
-    trace_maybe Nothing  = pprTrace "tcWorker failed:" (ppr worker_name) Nothing
-    trace_maybe (Just x) = Just x
+	-- We are relying here on arity, cpr and 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
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
 an unfolding that isn't going to be looked at.
 
 \begin{code}
-tcPragExpr unf_env name core_expr
+tcPragExpr unf_env name in_scope_vars expr
+  = tcDelay unf_env doc $
+	tcCoreExpr expr		`thenTc` \ core_expr' ->
+
+		-- Check for type consistency in the unfolding
+	tcGetSrcLoc		`thenNF_Tc` \ src_loc -> 
+	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 :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
+tcDelay unf_env doc thing_inside
   = forkNF_Tc (
-	recoverNF_Tc no_unfolding (
-		tcSetGlobalValEnv unf_env $
-		tcCoreExpr core_expr	`thenTc` \ core_expr' ->
-		returnTc (Just core_expr')
+	recoverNF_Tc bad_value (
+		tcSetEnv unf_env thing_inside	`thenTc` \ r ->
+		returnTc (Just r)
     ))			
   where
 	-- The trace tells what wasn't available, for the benefit of
 	-- compiler hackers who want to improve it!
-    no_unfolding = getErrsTc		`thenNF_Tc` \ (warns,errs) ->
-		   returnNF_Tc (pprTrace "tcUnfolding failed with:" 
-				   	 (hang (ppr name) 4 (pprBagOfErrors errs))
+    bad_value = getErrsTc		`thenNF_Tc` \ (warns,errs) ->
+		returnNF_Tc (pprTrace "Failed:" 
+				   	 (hang doc 4 (pprBagOfErrors errs))
 					 Nothing)
 \end{code}
 
@@ -180,12 +166,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
-  = tcLookupGlobalValueMaybe 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]
@@ -194,37 +180,39 @@ 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' ->
+	-- It might not be of kind type
+    returnTc (Type ty')
 
 tcCoreExpr (UfVar name)
   = tcVar name 	`thenTc` \ id ->
     returnTc (Var id)
 
--- rationalTy isn't built in so we have to construct it
--- (the "ty" part of the incoming literal is simply bottom)
-tcCoreExpr (UfLit (NoRepRational lit _)) 
-  = tcLookupTyConByKey rationalTyConKey	`thenNF_Tc` \ rational_tycon ->
-    let
-	rational_ty  = mkSynTy rational_tycon []
-    in
-    returnTc (Lit (NoRepRational lit rational_ty)) 
-
--- Similarly for integers, except that it is wired in
-tcCoreExpr (UfLit (NoRepInteger lit _)) 
-  = returnTc (Lit (NoRepInteger lit integerTy))
+tcCoreExpr (UfLit lit)
+  = returnTc (Lit lit)
 
-tcCoreExpr (UfLit other_lit)
-  = returnTc (Lit other_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 (UfCon con args) 
-  = tcVar con			`thenTc` \ con_id ->
-    mapTc tcCoreArg args	`thenTc` \ args' ->
-    returnTc (Con con_id args')
+tcCoreExpr (UfCCall cc ty)
+  = tcHsType ty 	`thenTc` \ ty' ->
+    tcGetUnique		`thenNF_Tc` \ u ->
+    returnTc (Var (mkCCallOpId u cc ty'))
 
-tcCoreExpr (UfPrim prim args) 
-  = tcCorePrim prim		`thenTc` \ primop ->
-    mapTc tcCoreArg args	`thenTc` \ args' ->
-    returnTc (Prim primop args')
+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 . exprType) args' ++ args'
+    in
+    returnTc (mkApps (Var con_id) con_args)
 
 tcCoreExpr (UfLam bndr body)
   = tcCoreLamBndr bndr 		$ \ bndr' ->
@@ -233,13 +221,18 @@ tcCoreExpr (UfLam bndr body)
 
 tcCoreExpr (UfApp fun arg)
   = tcCoreExpr fun		`thenTc` \ fun' ->
-    tcCoreArg arg		`thenTc` \ arg' ->
+    tcCoreExpr arg		`thenTc` \ arg' ->
     returnTc (App fun' arg')
 
-tcCoreExpr (UfCase scrut alts) 
-  = tcCoreExpr scrut				`thenTc` \ scrut' ->
-    tcCoreAlts (coreExprType scrut') alts	`thenTc` \ alts' ->
-    returnTc (Case scrut' alts')
+tcCoreExpr (UfCase scrut case_bndr alts) 
+  = tcCoreExpr scrut					`thenTc` \ scrut' ->
+    let
+	scrut_ty = exprType scrut'
+	case_bndr' = mkVanillaId case_bndr scrut_ty
+    in
+    tcExtendGlobalValEnv [case_bndr']	$
+    mapTc (tcCoreAlt scrut_ty) alts	`thenTc` \ alts' ->
+    returnTc (Case scrut' case_bndr' alts')
 
 tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
   = tcCoreExpr rhs		`thenTc` \ rhs' ->
@@ -258,35 +251,39 @@ tcCoreExpr (UfLet (UfRec pairs) body)
 tcCoreExpr (UfNote note expr) 
   = tcCoreExpr expr		`thenTc` \ expr' ->
     case note of
-	UfCoerce to_ty -> tcHsTypeKind to_ty	`thenTc` \ (_,to_ty') ->
-			  returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
+	UfCoerce to_ty -> tcHsType to_ty	`thenTc` \ to_ty' ->
+			  returnTc (Note (Coerce to_ty'
+                                                 (exprType expr')) expr')
 	UfInlineCall   -> returnTc (Note InlineCall expr')
-	UfSCC cc       -> returnTc (Note (SCC cc) expr')
-
-tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
-tcCoreNote UfInlineCall = returnTc InlineCall 
+	UfInlineMe     -> returnTc (Note InlineMe   expr')
+	UfSCC cc       -> returnTc (Note (SCC cc)   expr')
 \end{code}
 
 \begin{code}
 tcCoreLamBndr (UfValBinder name ty) thing_inside
   = tcHsType ty			`thenTc` \ ty' ->
     let
-	id = mkUserId name ty'
+	id = mkVanillaId name ty'
     in
     tcExtendGlobalValEnv [id] $
-    thing_inside (ValBinder id)
+    thing_inside id
     
 tcCoreLamBndr (UfTyBinder name kind) thing_inside
   = let
-	tyvar = mkSysTyVar (uniqueOf name) kind
+	tyvar = mkTyVar name kind
     in
-    tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
-    thing_inside (TyBinder tyvar)
+    tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
     
+tcCoreLamBndrs []     thing_inside = thing_inside []
+tcCoreLamBndrs (b:bs) thing_inside
+  = tcCoreLamBndr b	$ \ b' ->
+    tcCoreLamBndrs bs	$ \ bs' ->
+    thing_inside (b':bs')
+
 tcCoreValBndr (UfValBinder name ty) thing_inside
   = tcHsType ty			`thenTc` \ ty' ->
     let
-	id = mkUserId name ty'
+	id = mkVanillaId name ty'
     in
     tcExtendGlobalValEnv [id] $
     thing_inside id
@@ -294,64 +291,66 @@ tcCoreValBndr (UfValBinder name ty) thing_inside
 tcCoreValBndrs bndrs thing_inside		-- Expect them all to be ValBinders
   = mapTc tcHsType tys			`thenTc` \ tys' ->
     let
-	ids = zipWithEqual "tcCoreValBndr" mkUserId names tys'
+	ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
     in
     tcExtendGlobalValEnv ids $
     thing_inside ids
   where
-    names = map (\ (UfValBinder name _) -> name) bndrs
-    tys   = map (\ (UfValBinder _   ty) -> ty)   bndrs
+    names = [name | UfValBinder name _  <- bndrs]
+    tys   = [ty   | UfValBinder _    ty <- bndrs]
 \end{code}    
 
 \begin{code}
-tcCoreArg (UfVarArg v)	 = tcVar v 		`thenTc` \ v' -> returnTc (VarArg v')
-tcCoreArg (UfTyArg ty)	 = tcHsTypeKind ty	`thenTc` \ (_,ty') -> returnTc (TyArg ty')
-tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
-
-tcCoreAlts scrut_ty (UfAlgAlts alts deflt)
-  = mapTc tc_alt alts			`thenTc` \ alts' ->
-    tcCoreDefault scrut_ty deflt	`thenTc` \ deflt' ->
-    returnTc (AlgAlts alts' deflt')
-  where
-    tc_alt (con, names, rhs)
-      =	tcVar con			`thenTc` \ con' ->
-	let
-	    arg_tys		    = dataConArgTys con' inst_tys
-	    (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
-	    arg_ids		    = zipWithEqual "tcCoreAlts" mkUserId names arg_tys
-	in
-	tcExtendGlobalValEnv arg_ids 	$
-	tcCoreExpr rhs			`thenTc` \ rhs' ->
-	returnTc (con', arg_ids, rhs')
-
-tcCoreAlts scrut_ty (UfPrimAlts alts deflt)
-  = mapTc tc_alt alts			`thenTc` \ alts' ->
-    tcCoreDefault scrut_ty deflt	`thenTc` \ deflt' ->
-    returnTc (PrimAlts alts' deflt')
-  where
-    tc_alt (lit, rhs) =	tcCoreExpr rhs		`thenTc` \ rhs' ->
-			returnTc (lit, rhs')
-
-tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault
-tcCoreDefault scrut_ty (UfBindDefault name rhs)
-  = let
-	deflt_id = mkUserId name scrut_ty
+tcCoreAlt scrut_ty (UfDefault, names, rhs)
+  = ASSERT( null names )
+    tcCoreExpr rhs		`thenTc` \ rhs' ->
+    returnTc (DEFAULT, [], rhs')
+  
+tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
+  = ASSERT( null names )
+    tcCoreExpr rhs		`thenTc` \ rhs' ->
+    returnTc (LitAlt lit, [], rhs')
+
+tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
+  = ASSERT( null names )
+    tcCoreExpr rhs		`thenTc` \ rhs' ->
+    tcHsType 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 ->
+    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)
+	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
+		= pprPanic "tcCoreAlts" (ppr (con_name, names, rhs) $$
+					 (ppr main_tyvars <+> ppr ex_tyvars) $$
+					 ppr arg_tys)
+		| otherwise
+#endif
+		= zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
     in
-    tcExtendGlobalValEnv [deflt_id] 	$
-    tcCoreExpr rhs			`thenTc` \ rhs' ->
-    returnTc (BindDefault deflt_id rhs')
-    
-
-tcCorePrim (UfOtherOp op) 
-  = tcVar op		`thenTc` \ op_id ->
-    case isPrimitiveId_maybe op_id of
-	Just prim_op -> returnTc prim_op
-	Nothing	     -> pprPanic "tcCorePrim" (ppr op_id)
-
-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')
+    ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
+    tcExtendTyVarEnv ex_tyvars'			$
+    tcExtendGlobalValEnv arg_ids		$
+    tcCoreExpr rhs					`thenTc` \ rhs' ->
+    returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
 \end{code}
 
 \begin{code}