[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.

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

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

ghc/compiler/typecheck/TcImprove.lhs

+\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}

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

ghc/compiler/types/FunDeps.lhs

 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