X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;fp=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=35dbf199e670e9266d9caca5a48f686dfd85c347;hp=959f0c890c7ac639fb596743ead82b34b88f7a3b;hb=a8407757462804dfd51708d6cfdda0417a91bf8e;hpb=c61a92e89e2458f327a65613e45a1cac6e8ecc74

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 959f0c8..35dbf19 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -1289,17 +1289,19 @@ kind2 = liftedTypeKind `mkArrowKind` kind1
 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
-gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
-gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
-toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
-dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
-dataCast1_RDR  = varQual_RDR gENERICS (fsLit "dataCast1")
-dataCast2_RDR  = varQual_RDR gENERICS (fsLit "dataCast2")
-gcast1_RDR     = varQual_RDR tYPEABLE (fsLit "gcast1")
-gcast2_RDR     = varQual_RDR tYPEABLE (fsLit "gcast2")
-mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
-mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
-conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
+gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
+gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
+toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
+dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")
+dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")
+dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")
+gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")
+gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")
+mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")
+constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")
+mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")
+dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")
+conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
 \end{code}
@@ -1656,70 +1658,70 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 fiddling around.
 
 \begin{code}
-genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
+genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
 genAuxBind loc (GenCon2Tag tycon)
-  | lots_of_constructors
-  = mk_FunBind loc rdr_name [([], get_tag_rhs)]
-
-  | otherwise
-  = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
-
+  = (mk_FunBind loc rdr_name eqns, 
+     L loc (TypeSig (L loc rdr_name) sig_ty))
   where
     rdr_name = con2tag_RDR tycon
 
-    tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
-	-- We can't use gerRdrName because that makes an Exact  RdrName
-	-- and we can't put them in the LocalRdrEnv
+    sig_ty = genForAllTy loc tycon $ \hs_tc_app ->
+             hs_tc_app `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon)
 
-	-- 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 = L loc $ ExprWithTySig 
-			(nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) 
-					      (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
-			(noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs)) 
-                                                     (noLoc []) con2tag_ty))
+    lots_of_constructors = tyConFamilySize tycon > 8
+                        -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
+                        -- but we don't do vectored returns any more.
 
-    con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
-		`nlHsFunTy` 
-		nlHsTyVar (getRdrName intPrimTyCon)
+    eqns | lots_of_constructors = [get_tag_eqn]
+         | otherwise = map mk_eqn (tyConDataCons tycon)
 
-    lots_of_constructors = tyConFamilySize tycon > 8
-                                -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
-                                -- but we don't do vectored returns any more.
+    get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
 
-    mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
-    mk_stuff con = ([nlWildConPat con], 
-		    nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
+    mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
+    mk_eqn con = ([nlWildConPat con], 
+		  nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
 
 genAuxBind loc (GenTag2Con tycon)
-  = mk_FunBind loc rdr_name 
+  = ASSERT( null (tyConTyVars tycon) )
+    (mk_FunBind loc rdr_name 
 	[([nlConVarPat intDataCon_RDR [a_RDR]], 
-	   noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr) 
-			 (nlHsTyVar (getRdrName tycon))))]
+	   nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
+     L loc (TypeSig (L loc rdr_name) sig_ty))
   where
+    sig_ty = nlHsTyVar (getRdrName intPrimTyCon) 
+             `nlHsFunTy` (nlHsTyVar (getRdrName tycon))
+
     rdr_name = tag2con_RDR tycon
 
 genAuxBind loc (GenMaxTag tycon)
-  = mkHsVarBind loc rdr_name 
-		  (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
+  = (mkHsVarBind loc rdr_name rhs,
+     L loc (TypeSig (L loc rdr_name) sig_ty))
   where
     rdr_name = maxtag_RDR tycon
+    sig_ty = nlHsTyVar (getRdrName intPrimTyCon) 
+    rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
     max_tag =  case (tyConDataCons tycon) of
 		 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 
 genAuxBind loc (MkTyCon tycon)	--  $dT
-  = mkHsVarBind loc (mk_data_type_name tycon)
-		    ( nlHsVar mkDataType_RDR 
-                    `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
-                    `nlHsApp` nlList constrs )
+  = (mkHsVarBind loc rdr_name rhs,
+     L loc (TypeSig (L loc rdr_name) sig_ty))
   where
-    constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
+    rdr_name = mk_data_type_name tycon
+    sig_ty   = nlHsTyVar dataType_RDR
+    constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
+    rhs = nlHsVar mkDataType_RDR 
+          `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
+          `nlHsApp` nlList constrs
 
 genAuxBind loc (MkDataCon dc)	--  $cT1 etc
-  = mkHsVarBind loc (mk_constr_name dc) 
-	  	    (nlHsApps mkConstr_RDR constr_args)
+  = (mkHsVarBind loc rdr_name rhs,
+     L loc (TypeSig (L loc rdr_name) sig_ty))
   where
+    rdr_name = mk_constr_name dc
+    sig_ty   = nlHsTyVar constr_RDR
+    rhs      = nlHsApps mkConstr_RDR constr_args
+
     constr_args 
        = [ -- nlHsIntLit (toInteger (dataConTag dc)),	  -- Tag
 	   nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
@@ -1739,6 +1741,18 @@ mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
 
 mk_constr_name :: DataCon -> RdrName	-- "$cC"
 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
+
+genForAllTy :: SrcSpan -> TyCon
+            -> (LHsType RdrName -> LHsType RdrName)
+            -> LHsType RdrName
+-- Wrap a forall type for the variables of the TyCOn
+genForAllTy loc tc thing_inside
+  = L loc $ mkExplicitHsForAllTy (userHsTyVarBndrs (map (L loc) tvs)) (L loc []) $
+    thing_inside (nlHsTyConApp (getRdrName tc) (map nlHsTyVar tvs))
+  where
+    tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tc)
+	-- We can't use getRdrName because that makes an Exact RdrName
+	-- and we can't put them in the LocalRdrEnv
 \end{code}
 
 %************************************************************************