From: lewie Date: Fri, 3 Dec 1999 00:03:10 +0000 (+0000) Subject: [project @ 1999-12-03 00:03:06 by lewie] X-Git-Tag: Approximately_9120_patches~5442 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=297f714906efa8a76378c6fa6db3cd592f896749 [project @ 1999-12-03 00:03:06 by lewie] Basic functional dependency implementation. Most notable change to be aware of is that the datatype `Inst' now has a new constructor `FunDep' used to track functional dependencies. The FunDep predicates are filtered out in tcSimplify* so that they don't escape. --- diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 5968b1e..5d19d14 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, + tyVarsOfInst, instLoc, getDictClassTys, getFunDeps, lookupInst, lookupSimpleInst, LookupInstResult(..), - isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, + isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep, instBindingRequired, instCanBeGeneralised, - zonkInst, instToId, instToIdBndr, + zonkInst, zonkFunDeps, instToId, instToIdBndr, InstOrigin(..), InstLoc, pprInstLoc ) where @@ -44,8 +44,8 @@ import TcType ( TcThetaType, ) import Bag import Class ( classInstEnv, Class ) +import FunDeps ( instantiateFdClassTys ) import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) -import VarSet ( elemVarSet ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import Name ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName ) import PprType ( pprConstraint ) @@ -61,10 +61,11 @@ import Subst ( emptyInScopeSet, mkSubst, substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst ) import TyCon ( TyCon ) +import Var ( TyVar ) import VarEnv ( lookupVarEnv, TidyEnv, lookupSubstEnv, SubstResult(..) ) -import VarSet ( unionVarSet ) +import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy ) import TysWiredIn ( intDataCon, isIntTy, inIntRange, floatDataCon, isFloatTy, @@ -161,6 +162,11 @@ data Inst TcType -- The type at which the literal is used InstLoc + | FunDep + Class -- the class from which this arises + [([TcType], [TcType])] + InstLoc + data OverloadedLit = OverloadedIntegral Integer -- The number | OverloadedFractional Rational -- The number @@ -196,9 +202,16 @@ cmpInst (Method _ _ _ _ _ _) other cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) +cmpInst (LitInst _ _ _ _) (FunDep _ _ _) + = LT cmpInst (LitInst _ _ _ _) other = GT +cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) + = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) +cmpInst (FunDep _ _ _) other + = GT + cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2 cmpOverLit (OverloadedIntegral _) (OverloadedFractional _) = LT @@ -212,15 +225,23 @@ Selection instLoc (Dict u clas tys loc) = loc instLoc (Method u _ _ _ _ loc) = loc instLoc (LitInst u lit ty loc) = loc +instLoc (FunDep _ _ loc) = loc getDictClassTys (Dict u clas tys _) = (clas, tys) +getFunDeps (FunDep clas fds _) = Just (clas, fds) +getFunDeps _ = Nothing + tyVarsOfInst :: Inst -> TcTyVarSet tyVarsOfInst (Dict _ _ tys _) = tyVarsOfTypes tys tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id -- The id might have free type variables; in the case of -- locally-overloaded class methods, for example tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty +tyVarsOfInst (FunDep _ fds _) + = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds) + where tyVarsOfFd (ts1, ts2) = + tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts1 \end{code} Predicates @@ -242,6 +263,10 @@ isTyVarDict other = False isStdClassTyVarDict (Dict _ clas [ty] _) = isStandardClass clas && isTyVarTy ty isStdClassTyVarDict other = False + +notFunDep :: Inst -> Bool +notFunDep (FunDep _ _ _) = False +notFunDep other = True \end{code} Two predicates which deal with the case where class constraints don't @@ -307,7 +332,14 @@ newMethod orig id tys instOverloadedFun orig (HsVar v) arg_tys theta tau = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst -> - returnNF_Tc (HsVar (instToId inst), unitLIE inst) + instFunDeps orig theta `thenNF_Tc` \ fds -> + returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds)) + --returnNF_Tc (HsVar (instToId inst), unitLIE inst) + +instFunDeps orig theta + = tcGetInstLoc orig `thenNF_Tc` \ loc -> + let ifd (clas, tys) = FunDep clas (instantiateFdClassTys clas tys) loc in + returnNF_Tc (map ifd theta) newMethodWithGivenTy orig id tys theta tau = tcGetInstLoc orig `thenNF_Tc` \ loc -> @@ -379,6 +411,9 @@ instToIdBndr (Method u id tys theta tau (_,loc,_)) instToIdBndr (LitInst u list ty loc) = mkSysLocal SLIT("lit") u ty + +instToIdBndr (FunDep clas fds _) + = panic "FunDep escaped!!!" \end{code} @@ -408,6 +443,17 @@ zonkInst (Method u id tys theta tau loc) zonkInst (LitInst u lit ty loc) = zonkTcType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (LitInst u lit new_ty loc) + +zonkInst (FunDep clas fds loc) + = zonkFunDeps fds `thenNF_Tc` \ fds' -> + returnNF_Tc (FunDep clas fds' loc) + +zonkFunDeps fds = mapNF_Tc zonkFd fds + where + zonkFd (ts1, ts2) + = zonkTcTypes ts1 `thenNF_Tc` \ ts1' -> + zonkTcTypes ts2 `thenNF_Tc` \ ts2' -> + returnNF_Tc (ts1', ts2') \end{code} @@ -435,6 +481,9 @@ pprInst (Method u id tys _ _ loc) brackets (interppSP tys), show_uniq u] +pprInst (FunDep clas fds loc) + = ptext SLIT("fundep!") + tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst) tidyInst env (LitInst u lit ty loc) = (env', LitInst u lit ty' loc) @@ -451,7 +500,11 @@ tidyInst env (Method u id tys theta tau loc) -- Leave theta, tau alone cos we don't print them where (env', tys') = tidyOpenTypes env tys - + +-- this case shouldn't arise... (we never print fundeps) +tidyInst env fd@(FunDep clas fds loc) + = (env, fd) + tidyInsts env insts = mapAccumL tidyInst env insts show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") @@ -577,6 +630,10 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty loc) doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy double_lit = HsCon doubleDataCon [] [doubleprim_lit] +-- there are no `instances' of functional dependencies + +lookupInst (FunDep _ _ _) = returnNF_Tc NoInstance + \end{code} There is a second, simpler interface, when you want an instance of a diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 6a64ece..55c37dd 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -28,6 +28,7 @@ import TcEnv ( tcExtendLocalValEnv, tcGetGlobalTyVars, tcExtendGlobalTyVars ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) +import TcImprove ( tcImprove ) import TcMonoType ( tcHsType, checkSigTyVars, TcSigInfo(..), tcTySig, maybeSig, sigCtxt ) @@ -250,6 +251,14 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- (must do this before getTyVarsToGen) checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta -> + -- IMPROVE the LIE + -- Force any unifications dictated by functional dependencies. + -- Because unification may happen, it's important that this step + -- come before: + -- - computing vars over which to quantify + -- - zonking the generalized type vars + tcImprove lie_req `thenTc_` + -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen -- The tyvars_not_to_gen are free in the environment, and hence -- candidates for generalisation, but sometimes the monomorphism diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs new file mode 100644 index 0000000..a730a9a --- /dev/null +++ b/ghc/compiler/typecheck/TcImprove.lhs @@ -0,0 +1,154 @@ +\begin{code} +module TcImprove ( tcImprove ) where + +#include "HsVersions.h" + +import Type ( tyVarsOfTypes ) +import Class ( classInstEnv, classExtraBigSig ) +import Unify ( matchTys ) +import Subst ( mkSubst, substTy ) +import TcMonad +import TcType ( zonkTcType, zonkTcTypes ) +import TcUnify ( unifyTauTyLists ) +import Inst ( Inst, LookupInstResult(..), + lookupInst, isDict, getDictClassTys, getFunDeps, + zonkLIE {- for debugging -} ) +import VarSet ( emptyVarSet ) +import VarEnv ( emptyVarEnv ) +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 + +iterImprove cfdss + = instImprove cfdss `thenTc` \ change1 -> + selfImprove pairImprove cfdss `thenTc` \ change2 -> + if change1 || change2 then + iterImprove cfdss + else + returnTc () + +instImprove (cfds@(clas, fds) : cfdss) + = instImprove1 cfds ins + where ins = classInstEnv clas +instImprove [] = returnTc False + +instImprove1 cfds@(clas, fds1) ((free, ts, _) : ins) + = checkFds fds1 free fds2 `thenTc` \ changed -> + instImprove1 cfds ins `thenTc` \ rest_changed -> + returnTc (changed || rest_changed) + where fds2 = instantiateFdClassTys clas ts +instImprove1 _ _ = returnTc False + +selfImprove f [] = returnTc False +selfImprove f (cfds : cfdss) + = mapTc (f cfds) cfdss `thenTc` \ changes -> + orTc changes `thenTc` \ changed -> + selfImprove f cfdss `thenTc` \ rest_changed -> + returnTc (changed || rest_changed) + +pairImprove (clas1, fds1) (clas2, fds2) + = if clas1 == clas2 then + checkFds fds1 emptyVarSet fds2 + else + returnTc False + +checkFds [] free [] = returnTc False +checkFds (fd1 : fd1s) free (fd2 : fd2s) = + checkFd fd1 free fd2 `thenTc` \ change -> + checkFds fd1s free fd2s `thenTc` \ changes -> + returnTc (change || changes) +--checkFds _ _ = returnTc False + +checkFd (t_x, t_y) free (s_x, s_y) + -- we need to zonk each time because unification + -- may happen at any time + = zonkMatchTys t_x free s_x `thenTc` \ msubst -> + 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 + Nothing -> + returnTc False + +zonkMatchTys ts1 free ts2 + = mapTc zonkTcType ts1 `thenTc` \ ts1' -> + mapTc zonkTcType ts2 `thenTc` \ ts2' -> + --returnTc (ts1' == ts2') + case matchTys free ts2' ts1' of + Just (subst, []) -> 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 +\end{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 1b55034..7d253be 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -132,7 +132,7 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), tyVarsOfInst, - isDict, isStdClassTyVarDict, isMethodFor, + isDict, isStdClassTyVarDict, isMethodFor, notFunDep, instToId, instBindingRequired, instCanBeGeneralised, newDictFromOld, getDictClassTys, @@ -225,7 +225,17 @@ tcSimplify str top_lvl local_tvs wanted_lie -- Finished returnTc (mkLIE frees, binds, mkLIE irreds') where - wanteds = bagToList wanted_lie + -- the idea behind filtering out the dependencies here is that + -- they've already served their purpose, and can be reconstructed + -- at a later point from the retained class predicates. + -- however, there *is* the possibility that a dependency + -- out-lives the predicate from which it arose. + -- I don't have any examples of this, but if they show up, + -- we'd want to consider the possibility of saving the + -- dependencies as hidden constraints (i.e. they'd only + -- show up in interface files) -- or maybe they'd be useful + -- as first class predicates... + wanteds = filter notFunDep (bagToList wanted_lie) try_me inst -- Does not constrain a local tyvar @@ -272,7 +282,8 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie returnTc (mkLIE frees, binds) where givens = bagToList given_lie - wanteds = bagToList wanted_lie + -- see comment on wanteds in tcSimplify + wanteds = filter notFunDep (bagToList wanted_lie) given_dicts = filter isDict givens try_me inst @@ -1001,7 +1012,8 @@ tcSimplifyTop wanted_lie returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig) where - wanteds = bagToList wanted_lie + -- see comment on wanteds in tcSimplify + wanteds = filter notFunDep (bagToList wanted_lie) try_me inst = ReduceMe AddToIrreds d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index bcbe643..ca0de67 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -1,19 +1,14 @@ It's better to read it as: "if we know these, then we're going to know these" \begin{code} -module FunDeps(oclose, instantiateFundeps, instantiateFdTys, instantiateFdClassTys, pprFundeps) where +module FunDeps(oclose, instantiateFdClassTys, pprFundeps) where #include "HsVersions.h" -import Inst (getDictClassTys) import Class (classTvsFds) -import Type (getTyVar_maybe, tyVarsOfType) import Outputable (interppSP, ptext, empty, hsep, punctuate, comma) -import UniqSet (elementOfUniqSet, addOneToUniqSet, - uniqSetToList, unionManyUniqSets) +import UniqSet (elementOfUniqSet, addOneToUniqSet ) import List (elemIndex) -import Maybe (catMaybes) -import FastString oclose fds vs = case oclose1 fds vs of @@ -39,17 +34,6 @@ ounion (x:xs) ys = where (ys', b) = ounion xs ys --- instantiate fundeps to type variables -instantiateFundeps dict = - map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys - where - fdtys = instantiateFdTys dict - getTyVars ty = tyVarsOfType ty - unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs)) - --- instantiate fundeps to types -instantiateFdTys dict = instantiateFdClassTys clas ts - where (clas, ts) = getDictClassTys dict instantiateFdClassTys clas ts = map (lookupInstFundep tyvars ts) fundeps where