From: lewie <unknown>
Date: Mon, 6 Dec 1999 22:52:28 +0000 (+0000)
Subject: [project @ 1999-12-06 22:52:26 by lewie]
X-Git-Tag: Approximately_9120_patches~5421
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e03c0dd3bf272e00ea0fc70559b861b37177efa4

[project @ 1999-12-06 22:52:26 by lewie]
Fixed a FunDep leak in tcSimplifyToDicts (they weren't being filtered out),
and fixed bug in instance improvement (matching wasn't being done correctly
for polymorphic instances).
---

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 5f6096c..7e5f033 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -22,7 +22,7 @@ import BasicTypes	( RecFlag(..) )
 
 import Inst		( Inst, InstOrigin(..), OverloadedLit(..),
 			  LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
-			  newMethod, instOverloadedFun, newDicts, instToId )
+			  newMethod, instOverloadedFun, newDicts )
 import TcBinds		( tcBindsAndThen )
 import TcEnv		( tcInstId,
 			  tcLookupValue, tcLookupClassByKey,
diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs
index a81e874..b9e543e 100644
--- a/ghc/compiler/typecheck/TcImprove.lhs
+++ b/ghc/compiler/typecheck/TcImprove.lhs
@@ -3,9 +3,6 @@ module TcImprove ( tcImprove ) where
 
 #include "HsVersions.h"
 
-import InstEnv		( InstEnv )		-- Reqd for 4.02; InstEnv is a synonym, and
-						-- 4.02 doesn't "see" it soon enough
-
 import Type		( tyVarsOfTypes )
 import Class		( classInstEnv, classExtraBigSig )
 import Unify		( matchTys )
@@ -15,7 +12,9 @@ import TcType		( zonkTcType, zonkTcTypes )
 import TcUnify		( unifyTauTyLists )
 import Inst		( Inst, LookupInstResult(..),
 			  lookupInst, isDict, getDictClassTys, getFunDepsOfLIE,
-			  zonkLIE {- for debugging -} )
+			  zonkLIE, zonkFunDeps {- for debugging -} )
+import InstEnv		( InstEnv )		-- Reqd for 4.02; InstEnv is a synonym, and
+						-- 4.02 doesn't "see" it soon enough
 import VarSet		( emptyVarSet )
 import VarEnv		( emptyVarEnv )
 import FunDeps		( instantiateFdClassTys )
@@ -27,23 +26,43 @@ import List		( elemIndex )
 Improvement goes here.
 
 \begin{code}
-tcImprove lie = iterImprove (getFunDepsOfLIE lie)
+tcImprove lie =
+    if null cfdss then
+	returnTc ()
+    else
+	-- zonkCfdss cfdss `thenTc` \ cfdss' ->
+	-- pprTrace "tcI" (ppr cfdss') $
+	iterImprove cfdss
+    where cfdss = getFunDepsOfLIE lie
 
+iterImprove [] = returnTc ()
 iterImprove cfdss
-  = instImprove cfdss			`thenTc` \ change1 ->
+  = -- zonkCfdss cfdss `thenTc` \ cfdss' ->
+    -- pprTrace "iterI" (ppr cfdss') $
+    instImprove cfdss			`thenTc` \ change1 ->
     selfImprove pairImprove cfdss	`thenTc` \ change2 ->
     if change1 || change2 then
 	iterImprove cfdss
     else
 	returnTc ()
 
+-- ZZ debugging...
+zonkCfdss ((c, fds) : cfdss)
+  = zonkFunDeps fds `thenTc` \ fds' ->
+    zonkCfdss cfdss `thenTc` \ cfdss' ->
+    returnTc ((c, fds') : cfdss')
+zonkCfdss [] = returnTc []
+
 instImprove (cfds@(clas, fds) : cfdss)
-  = instImprove1 cfds ins
+  = instImprove1 cfds ins	`thenTc` \ changed ->
+    instImprove cfdss		`thenTc` \ rest_changed ->
+    returnTc (changed || rest_changed)
   where ins = classInstEnv clas
 instImprove [] = returnTc False
 
-instImprove1 cfds@(clas, fds1) ((free, ts, _) : ins)
-  = checkFds fds1 free fds2	`thenTc` \ changed ->
+instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins)
+  = -- pprTrace "iI1" (ppr (free, ts, i)) $
+    checkFds fds1 free fds2	`thenTc` \ changed ->
     instImprove1 cfds ins	`thenTc` \ rest_changed ->
     returnTc (changed || rest_changed)
   where fds2 = instantiateFdClassTys clas ts
@@ -52,7 +71,7 @@ instImprove1 _ _ = returnTc False
 selfImprove f [] = returnTc False
 selfImprove f (cfds : cfdss)
   = mapTc (f cfds) cfdss	`thenTc` \ changes ->
-    orTc changes		`thenTc` \ changed ->
+    anyTc changes		`thenTc` \ changed ->
     selfImprove f cfdss		`thenTc` \ rest_changed ->
     returnTc (changed || rest_changed)
 
@@ -76,79 +95,35 @@ checkFd (t_x, t_y) free (s_x, s_y)
     case msubst of
       Just subst ->
 	let s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y in
-	    zonkMatchTys t_y free s_y `thenTc` \ msubst2 ->
-		case msubst2 of
-		  Just _ ->
-		    -- they're the same, nothing changes
-		    returnTc False
-		  Nothing ->
-		    unifyTauTyLists t_y s_y' `thenTc_`
-		    -- if we get here, something must have unified
-		    returnTc True
+	    zonkEqTys t_y s_y' `thenTc` \ eq ->
+	    if eq then
+		-- they're the same, nothing changes...
+		returnTc False
+	    else
+		unifyTauTyLists t_y s_y' `thenTc_`
+		-- if we get here, something must have unified
+		returnTc True
       Nothing ->
 	returnTc False
 
+zonkEqTys ts1 ts2
+  = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
+    mapTc zonkTcType ts2 `thenTc` \ ts2' ->
+    returnTc (ts1' == ts2')
+
 zonkMatchTys ts1 free ts2
   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
-    --returnTc (ts1' == ts2')
+    -- pprTrace "zMT" (ppr (ts1', free, ts2')) $
     case matchTys free ts2' ts1' of
-      Just (subst, []) -> returnTc (Just subst)
+      Just (subst, []) -> -- pprTrace "zMT match!" empty $
+			  returnTc (Just subst)
       Nothing -> returnTc Nothing
-
-{-
-instImprove clas fds =
-    pprTrace "class inst env" (ppr (clas, classInstEnv clas)) $
-    zonkFunDeps fds `thenTc` \ fds' ->
-    pprTrace "lIEFDs" (ppr (clas, fds')) $
-    case lookupInstEnvFDs clas fds' of
-      Nothing -> returnTc ()
-      Just (t_y, s_y) ->
-	pprTrace "lIEFDs result" (ppr (t_y, s_y)) $
-	unifyTauTyLists t_y s_y
-
-lookupInstEnvFDs clas fds
-  = find env
-  where
-    env = classInstEnv clas
-    (ctvs, fds, _, _, _, _) = classExtraBigSig clas
-    find [] = Nothing
-    find ((tpl_tyvars, tpl, val) : rest)
-      = let tplx = concatMap (\us -> thingy tpl us ctvs) (map fst fds)
-	    tply = concatMap (\vs -> thingy tpl vs ctvs) (map snd fds)
-        in
-	    case matchTys tpl_tyvars tplx tysx of
-	      Nothing -> find rest
-	      Just (tenv, leftovers) ->
-		let subst = mkSubst (tyVarsOfTypes tys) tenv
-		in
-		    -- this is the list of things that
-		    -- need to be unified
-		    Just (map (substTy subst) tply, tysy)
-    tysx = concatMap (\us -> thingy tys us ctvs) (map fst fds)
-    tysy = concatMap (\vs -> thingy tys vs ctvs) (map snd fds)
-    thingy f us ctvs
-      = map (f !!) is
-	where is = map (\u -> let Just i = elemIndex u ctvs in i) us
--}
-
-{-
-  = let (clas, tys) = getDictClassTys dict
-    in
-	-- first, do instance-based improvement
-	instImprove clas tys `thenTc_`
-	-- OK, now do pairwise stuff
-	mapTc (f clas tys) dicts `thenTc` \ changes ->
-	foldrTc (\a b -> returnTc (a || b)) False changes `thenTc` \ changed ->
-	allDictPairs f dicts `thenTc` \ rest_changed ->
-	returnTc (changed || rest_changed)
--}
-
 \end{code}
 
 Utilities:
 
 A monadic version of the standard Prelude `or' function.
 \begin{code}
-orTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
+anyTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
 \end{code}
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index a708509..1ece1c8 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -17,8 +17,7 @@ import TcHsSyn		( TcPat, TcId )
 import TcMonad
 import Inst		( Inst, OverloadedLit(..), InstOrigin(..),
 			  emptyLIE, plusLIE, LIE,
-			  newMethod, newOverloadedLit, 
-			  newDicts, instToIdBndr
+			  newMethod, newOverloadedLit, newDicts
 			)
 import Name		( Name, getOccName, getSrcLoc )
 import FieldLabel	( fieldLabelName )
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 7d253be..d80e609 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -328,7 +328,8 @@ tcSimplifyToDicts wanted_lie
     ASSERT( null frees )
     returnTc (mkLIE irreds, binds)
   where
-    wanteds	= bagToList wanted_lie
+    -- see comment on wanteds in tcSimplify
+    wanteds = filter notFunDep (bagToList wanted_lie)
 
 	-- Reduce methods and lits only; stop as soon as we get a dictionary
     try_me inst	| isDict inst = DontReduce