[project @ 1999-12-03 18:17:29 by lewie]

Extend getTyVarsToGen to take the closure of the set of tyvars
with respect to functional dependencies.  Really simple programs
using functional dependencies work now.  Also fixed a small glitch
where trivial (empty) FunDeps were being tossed into the context willy nilly.

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 5d19d14..12f1743 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -16,14 +16,14 @@ module Inst (
        newDictFromOld, newDicts, newDictsAtLoc, 
        newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun,
 
-       tyVarsOfInst, instLoc, getDictClassTys, getFunDeps,
+       tyVarsOfInst, instLoc, getDictClassTys, getFunDeps, getFunDepsOfLIE,
 
        lookupInst, lookupSimpleInst, LookupInstResult(..),
 
        isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
        instBindingRequired, instCanBeGeneralised,
 
-       zonkInst, zonkFunDeps, instToId, instToIdBndr,
+       zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
 
        InstOrigin(..), InstLoc, pprInstLoc
     ) where
@@ -39,7 +39,7 @@ import TcMonad
 import TcEnv   ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
 import TcType  ( TcThetaType,
                  TcType, TcTauType, TcTyVarSet,
-                 zonkTcType, zonkTcTypes, 
+                 zonkTcTyVars, zonkTcType, zonkTcTypes, 
                  zonkTcThetaType
                )
 import Bag
@@ -76,6 +76,7 @@ import Unique ( fromRationalClassOpKey, rationalTyConKey,
                  fromIntClassOpKey, fromIntegerClassOpKey, Unique
                )
 import Maybes  ( expectJust )
+import Maybe   ( catMaybes )
 import Util    ( thenCmp, zipWithEqual, mapAccumL )
 import Outputable
 \end{code}
@@ -232,6 +233,8 @@ getDictClassTys (Dict u clas tys _) = (clas, tys)
 getFunDeps (FunDep clas fds _) = Just (clas, fds)
 getFunDeps _ = Nothing
 
+getFunDepsOfLIE lie = catMaybes (map getFunDeps (bagToList lie))
+
 tyVarsOfInst :: Inst -> TcTyVarSet
 tyVarsOfInst (Dict _ _ tys _)        = tyVarsOfTypes  tys
 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
@@ -338,8 +341,10 @@ instOverloadedFun orig (HsVar v) arg_tys theta tau
 
 instFunDeps orig theta
   = tcGetInstLoc orig  `thenNF_Tc` \ loc ->
-    let ifd (clas, tys) = FunDep clas (instantiateFdClassTys clas tys) loc in
-    returnNF_Tc (map ifd theta)
+    let ifd (clas, tys) =
+           let fds = instantiateFdClassTys clas tys in
+           if null fds then Nothing else Just (FunDep clas fds loc)
+    in returnNF_Tc (catMaybes (map ifd theta))
 
 newMethodWithGivenTy orig id tys theta tau
   = tcGetInstLoc orig  `thenNF_Tc` \ loc ->
@@ -454,6 +459,13 @@ zonkFunDeps fds = mapNF_Tc zonkFd fds
     = zonkTcTypes ts1                  `thenNF_Tc` \ ts1' ->
       zonkTcTypes ts2                  `thenNF_Tc` \ ts2' ->
       returnNF_Tc (ts1', ts2')
+
+zonkTvFunDeps fds = mapNF_Tc zonkFd fds
+  where
+  zonkFd (tvs1, tvs2)
+    = zonkTcTyVars tvs1                        `thenNF_Tc` \ tvs1' ->
+      zonkTcTyVars tvs2                        `thenNF_Tc` \ tvs2' ->
+      returnNF_Tc (tvs1', tvs2')
 \end{code}
 
 
@@ -482,7 +494,7 @@ pprInst (Method u id tys _ _ loc)
          show_uniq u]
 
 pprInst (FunDep clas fds loc)
-  = ptext SLIT("fundep!")
+  = hsep [ppr clas, ppr fds]
 
 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 tidyInst env (LitInst u lit ty loc)

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 55c37dd..f0679f3 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -20,7 +20,8 @@ import TcHsSyn                ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
 
 import TcMonad
 import Inst            ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
-                         newDicts, tyVarsOfInst, instToId,
+                         newDicts, tyVarsOfInst, instToId, getFunDepsOfLIE,
+                         zonkFunDeps
                        )
 import TcEnv           ( tcExtendLocalValEnv,
                          newSpecPragmaId, newLocalId,
@@ -53,6 +54,7 @@ import Type           ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
                          mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
                          isUnboxedType, unboxedTypeKind, boxedTypeKind
                        )
+import FunDeps         ( tyVarFunDep, oclose )
 import Var             ( TyVar, tyVarKind )
 import VarSet
 import Bag
@@ -533,22 +535,27 @@ getTyVarsToGen is_unrestricted mono_id_tys lie
   = tcGetGlobalTyVars                  `thenNF_Tc` \ free_tyvars ->
     zonkTcTypes mono_id_tys            `thenNF_Tc` \ zonked_mono_id_tys ->
     let
-       tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
+       body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
     in
     if is_unrestricted
     then
-       returnNF_Tc (emptyVarSet, tyvars_to_gen)
+       let fds = concatMap snd (getFunDepsOfLIE lie) in
+       zonkFunDeps fds         `thenNF_Tc` \ fds' ->
+       let tvFundep = tyVarFunDep fds'
+           extended_tyvars = oclose tvFundep body_tyvars in
+       -- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $
+       returnNF_Tc (emptyVarSet, extended_tyvars)
     else
        -- This recover and discard-errs is to avoid duplicate error
        -- messages; this, after all, is an "extra" call to tcSimplify
-       recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen))         $
+       recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars))           $
        discardErrsTc                                                   $
 
-       tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie    `thenTc` \ (_, _, constrained_dicts) ->
+       tcSimplify (text "getTVG") NotTopLevel body_tyvars lie    `thenTc` \ (_, _, constrained_dicts) ->
        let
          -- ASSERT: dicts_sig is already zonked!
            constrained_tyvars    = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
-           reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
+           reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars
         in
         returnTc (constrained_tyvars, reduced_tyvars_to_gen)
 \end{code}

diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs
index a730a9a..0250a30 100644 (file)
--- a/ghc/compiler/typecheck/TcImprove.lhs
+++ b/ghc/compiler/typecheck/TcImprove.lhs
@@ -11,7 +11,7 @@ import TcMonad
 import TcType          ( zonkTcType, zonkTcTypes )
 import TcUnify         ( unifyTauTyLists )
 import Inst            ( Inst, LookupInstResult(..),
-                         lookupInst, isDict, getDictClassTys, getFunDeps,
+                         lookupInst, isDict, getDictClassTys, getFunDepsOfLIE,
                          zonkLIE {- for debugging -} )
 import VarSet          ( emptyVarSet )
 import VarEnv          ( emptyVarEnv )
@@ -19,15 +19,12 @@ import FunDeps              ( instantiateFdClassTys )
 import Bag             ( bagToList )
 import Outputable
 import List            ( elemIndex )
-import Maybe           ( catMaybes )
 \end{code}
 
 Improvement goes here.
 
 \begin{code}
-tcImprove lie
-  = let cfdss = catMaybes (map getFunDeps (bagToList lie)) in
-    iterImprove cfdss
+tcImprove lie = iterImprove (getFunDepsOfLIE lie)
 
 iterImprove cfdss
   = instImprove cfdss                  `thenTc` \ change1 ->

diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs
index ca0de67..d99b53b 100644 (file)
--- a/ghc/compiler/types/FunDeps.lhs
+++ b/ghc/compiler/types/FunDeps.lhs
@@ -1,13 +1,15 @@
 It's better to read it as: "if we know these, then we're going to know these"
 
 \begin{code}
-module FunDeps(oclose, instantiateFdClassTys, pprFundeps) where
+module FunDeps(oclose, instantiateFdClassTys, tyVarFunDep, pprFundeps) where
 
 #include "HsVersions.h"
 
 import Class           (classTvsFds)
+import Type            (tyVarsOfType)
 import Outputable      (interppSP, ptext, empty, hsep, punctuate, comma)
-import UniqSet         (elementOfUniqSet, addOneToUniqSet )
+import UniqSet         (elementOfUniqSet, addOneToUniqSet,
+                        uniqSetToList, unionManyUniqSets)
 import List            (elemIndex)
 
 oclose fds vs =
@@ -44,6 +46,12 @@ lookupInstTys tyvars ts = map (lookupInstTy tyvars ts)
 lookupInstTy tyvars ts u = ts !! i
     where Just i = elemIndex u tyvars
 
+tyVarFunDep fdtys =
+    map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys
+    where
+       getTyVars ty = tyVarsOfType ty
+       unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs))
+
 pprFundeps [] = empty
 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
 

diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index 81d4bee..fbea784 100644 (file)
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -209,6 +209,9 @@ instance Outputable (UniqFM a) where
        ppr (LeafUFM x a) = text "LeafUFM " <+> int IBOX(x)
        ppr (EmptyUFM)    = empty
 -}
+-- and when not debugging the package itself...
+instance Outputable a => Outputable (UniqFM a) where
+    ppr ufm = ppr (ufmToList ufm)
 \end{code}
 
 %************************************************************************