[project @ 2003-02-19 15:54:05 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcGenDeriv.lhs

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index ef9b35e..bafa008 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,
@@ -855,10 +854,11 @@ gen_Read_binds get_fixity tycon
                        BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
 
        -- When reading field labels we might encounter
-       --      a = 3
+       --      a  = 3
+       --      _a = 3
        -- or   (#) = 4
        -- Note the parens!
-    read_lbl lbl | isAlpha (head lbl_str) 
+    read_lbl lbl | is_id_start (head lbl_str) 
                 = [bindLex (ident_pat lbl_lit)]
                 | otherwise
                 = [read_punc "(", 
@@ -867,6 +867,7 @@ gen_Read_binds get_fixity tycon
                 where  
                   lbl_str = occNameUserString (getOccName (fieldLabelName lbl)) 
                   lbl_lit = mkHsString lbl_str
+                  is_id_start c = isAlpha c || c == '_'
 \end{code}
 
 
@@ -1030,13 +1031,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)