[project @ 1998-05-04 13:24:42 by simonpj]

mkRhsTyLam now does not create redundant big lambdas

ghc/compiler/simplCore/SimplUtils.lhs

@@ -39,11 +39,13 @@ import PrelVals		( augmentId, buildId )
 import PrimOp		( primOpIsCheap )
 import SimplEnv
 import SimplMonad
-import Type		( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe,
+import Type		( tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys, getTyVar_maybe,
 			  splitAlgTyConApp_maybe, instantiateTy, Type
 			)
 import TyCon		( isDataTyCon )
-import TyVar		( elementOfTyVarSet, delFromTyVarEnv )
+import TyVar		( mkTyVarSet, intersectTyVarSets, elementOfTyVarSet, tyVarSetToList,
+			  delFromTyVarEnv
+			)
 import SrcLoc		( noSrcLoc )
 import Util		( isIn, zipWithEqual, panic, assertPanic )
 
@@ -182,31 +184,36 @@ mkRhsTyLam [] body = returnSmpl body
 mkRhsTyLam tyvars body
   = go (\x -> x) body
   where
-    tyvar_tys = mkTyVarTys tyvars
+    main_tyvar_set = mkTyVarSet tyvars
 
     go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
       = go (fn . Let bind) body
 
     go fn (Let bind@(NonRec var rhs) body)
-      = mk_poly var				`thenSmpl` \ (var', rhs') ->
+      = mk_poly tyvars_here var_ty			`thenSmpl` \ (var', rhs') ->
 	go (fn . Let (mk_silly_bind var rhs')) body	`thenSmpl` \ body' ->
-	returnSmpl (Let (NonRec var' (mkTyLam tyvars (fn rhs))) body')
+	returnSmpl (Let (NonRec var' (mkTyLam tyvars_here (fn rhs))) body')
+      where
+	tyvars_here = tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfType var_ty)
+	var_ty = idType var
 
     go fn (Let (Rec prs) body)
-       = mapAndUnzipSmpl mk_poly vars		`thenSmpl` \ (vars', rhss') ->
+       = mapAndUnzipSmpl (mk_poly tyvars_here) var_tys	`thenSmpl` \ (vars', rhss') ->
 	 let
 	    gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
 	 in
 	 go gn body				`thenSmpl` \ body' ->
-	 returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars (gn rhs) | rhs <- rhss])) body')
+	 returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars_here (gn rhs) | rhs <- rhss])) body')
        where
 	 (vars,rhss) = unzip prs
+	 tyvars_here = tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfTypes var_tys)
+	 var_tys     = map idType vars
 
     go fn body = returnSmpl (mkTyLam tyvars (fn body))
 
-    mk_poly var
-      = newId (mkForAllTys tyvars (idType var))	`thenSmpl` \ poly_id ->
-	returnSmpl (poly_id, mkTyApp (Var poly_id) tyvar_tys)
+    mk_poly tyvars_here var_ty
+      = newId (mkForAllTys tyvars_here var_ty)	`thenSmpl` \ poly_id ->
+	returnSmpl (poly_id, mkTyApp (Var poly_id) (mkTyVarTys tyvars_here))
 
     mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
 		-- The addInlinePragma is really important!  If we don't say 

ghc/compiler/typecheck/TcExpr.lhs

@@ -36,7 +36,7 @@ import TcEnv		( TcIdOcc(..), tcInstId,
 import TcMatches	( tcMatchesCase, tcMatchExpected )
 import TcGRHSs		( tcStmt )
 import TcMonoType	( tcHsType )
-import TcPat		( tcPat )
+import TcPat		( tcPat, badFieldsCon )
 import TcSimplify	( tcSimplifyAndCheck )
 import TcType		( TcType, TcTauType, TcMaybe(..),
 			  tcInstType, tcInstSigTcType, tcInstTyVars,
@@ -457,7 +457,7 @@ tcMonoExpr (RecordCon con_name _ rbinds) res_ty
     let
 	bad_fields = badFields rbinds con_id
     in
-    checkTc (null bad_fields) (badFieldsCon con_id bad_fields)	`thenTc_`
+    checkTc (null bad_fields) (badFieldsCon con_name bad_fields)	`thenTc_`
 
 	-- Typecheck the record bindings
 	-- (Do this after checkRecordFields in case there's a field that
@@ -1027,10 +1027,6 @@ badFieldsUpd rbinds
 
 recordUpdCtxt = ptext SLIT("In a record update construct")
 
-badFieldsCon con fields
-  = hsep [ptext SLIT("Constructor"), 		ppr con,
-	   ptext SLIT("does not have field(s):"), pprQuotedList fields]
-
 notSelector field
   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
 \end{code}