From c2b053f3228a8e32cf4d4909c2e97b338e3ac3c1 Mon Sep 17 00:00:00 2001 From: lewie Date: Fri, 3 Dec 1999 18:17:33 +0000 Subject: [PATCH] [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. --- ghc/compiler/typecheck/Inst.lhs | 24 ++++++++++++++++++------ ghc/compiler/typecheck/TcBinds.lhs | 19 +++++++++++++------ ghc/compiler/typecheck/TcImprove.lhs | 7 ++----- ghc/compiler/types/FunDeps.lhs | 12 ++++++++++-- ghc/compiler/utils/UniqFM.lhs | 3 +++ 5 files changed, 46 insertions(+), 19 deletions(-) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 5d19d14..12f1743 100644 --- 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 --- 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 --- 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 --- 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 --- 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} %************************************************************************ -- 1.7.10.4