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

mkRhsTyLam now does not create redundant big lambdas

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 4bd662b..8856a64 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/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 

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 0e719a9..b449863 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/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}