[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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