From 67398e1b2788237218c6345e2c7509b079b16ceb Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 13 Jan 2003 13:19:25 +0000
Subject: [PATCH] [project @ 2003-01-13 13:19:25 by simonpj]
 ------------------------------------ 	Type signature for
 derived con2tag 	------------------------------------

		MERGE TO STABLE

The derived con2tag didn't have a type signature, so we got

	con2tagFoo :: a -> Int#
	con2tagFoo = \x -> getTag x

The getTag generates a case expression, so we get a polymorphic
case.  The polymorphic case simply does not work in *interpreted*
GHC 5.02.3 and as a result neither does con2tag.  Alas.

This commit fixes the problem, by giving a type signature for
con2TagFoo.  But note that getTag in interpreted GHC 5.02 will continue
to fail if used in a polymorphic context.  This problem does not arise
in the HEAD (eval/apply) so I'm going to leave it as a wont-fix bug.
---
 ghc/compiler/typecheck/TcGenDeriv.lhs |   25 ++++++++++++++++++++-----
 1 file changed, 20 insertions(+), 5 deletions(-)

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index ef9b35e..ac6abdf 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -31,7 +31,6 @@ import HsSyn		( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..),
 			  HsBinds(..), HsType(..), HsStmtContext(..),
 			  unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
 			)
-import PrelNames	( )
 import RdrName		( RdrName, mkUnqual, nameRdrName, getRdrName )
 import RdrHsSyn		( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
 import BasicTypes	( RecFlag(..), Fixity(..), FixityDirection(..)
@@ -54,7 +53,7 @@ import PrelNames	-- Lots of Names
 import PrimOp		-- Lots of Names
 import SrcLoc		( generatedSrcLoc, SrcLoc )
 import TyCon		( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
-			  maybeTyConSingleCon, tyConFamilySize
+			  maybeTyConSingleCon, tyConFamilySize, tyConTyVars
 			)
 import TcType		( isUnLiftedType, tcEqType, Type )
 import TysPrim		( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
@@ -1030,13 +1029,29 @@ gen_tag_n_con_monobind
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
   | lots_of_constructors
-  = mk_FunMonoBind (getSrcLoc tycon) rdr_name 
-	[([VarPat a_RDR], HsApp getTag_Expr a_Expr)]
+  = mk_FunMonoBind loc rdr_name [([], get_tag_rhs)]
 
   | otherwise
-  = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
+  = mk_FunMonoBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
 
   where
+    loc = getSrcLoc tycon
+
+	-- Give a signature to the bound variable, so 
+	-- that the case expression generated by getTag is
+	-- monomorphic.  In the push-enter model we get better code.
+    get_tag_rhs = ExprWithTySig 
+			(HsLam (mk_match loc [VarPat a_RDR] 
+					     (HsApp getTag_Expr a_Expr) 
+					     EmptyBinds))
+			(HsForAllTy Nothing [] con2tag_ty)
+				-- Nothing => implicit quantification
+
+    con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon)) 
+		     [HsTyVar (getRdrName tv) | tv <- tyConTyVars tycon]
+		`HsFunTy` 
+		HsTyVar (getRdrName intPrimTyConName)
+
     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
 
     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
-- 
1.7.10.4