[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.

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index ef9b35e..ac6abdf 100644 (file)
--- 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)