* included in the distribution.
*
* $RCSfile: subst.c,v $
- * $Revision: 1.7 $
- * $Date: 1999/10/16 02:17:27 $
+ * $Revision: 1.17 $
+ * $Date: 2000/03/23 14:54:21 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
-#include "link.h"
-#include "subst.h"
+
/*#define DEBUG_TYPES*/
static Int maxTyvars = 0;
static Int nextGeneric; /* number of generics found so far */
-#if FIXED_SUBST
-Tyvar tyvars[NUM_TYVARS]; /* storage for type variables */
-#else
Tyvar *tyvars = 0; /* storage for type variables */
-#endif
Int typeOff; /* offset of result type */
Type typeIs; /* skeleton of result type */
Int typeFree; /* freedom in instantiated type */
* local function prototypes:
* ------------------------------------------------------------------------*/
-static Void local expandSubst Args((Int));
-static Int local findBtyvsInt Args((Text));
-static Type local makeTupleType Args((Int));
-static Kind local makeSimpleKind Args((Int));
-static Kind local makeVarKind Args((Int));
-static Void local expandSyn1 Args((Tycon, Type *, Int *));
-static List local listTyvar Args((Int,List));
-static List local listTyvars Args((Type,Int,List));
-static Cell local dupTyvar Args((Int,List));
-static Cell local dupTyvars Args((Cell,Int,List));
-static Pair local copyNoMark Args((Cell,Int));
-static Type local dropRank1Body Args((Type,Int,Int));
-static Type local liftRank1Body Args((Type,Int));
-
-static Bool local varToVarBind Args((Tyvar *,Tyvar *));
-static Bool local varToTypeBind Args((Tyvar *,Type,Int));
+static Void local expandSubst ( Int );
+static Int local findBtyvsInt ( Text );
+static Type local makeTupleType ( Int );
+static Kind local makeSimpleKind ( Int );
+static Kind local makeVarKind ( Int );
+static Void local expandSyn1 ( Tycon, Type *, Int * );
+static List local listTyvar ( Int,List );
+static List local listTyvars ( Type,Int,List );
+static Cell local dupTyvar ( Int,List );
+static Cell local dupTyvars ( Cell,Int,List );
+static Pair local copyNoMark ( Cell,Int );
+static Type local dropRank1Body ( Type,Int,Int );
+static Type local liftRank1Body ( Type,Int );
+static Bool local matchTypeAbove ( Type,Int,Type,Int,Int );
+
+static Bool local varToVarBind ( Tyvar *,Tyvar * );
+static Bool local varToTypeBind ( Tyvar *,Type,Int );
#if TREX
-static Bool local inserter Args((Type,Int,Type,Int));
-static Int local remover Args((Text,Type,Int));
-static Int local tailVar Args((Type,Int));
+static Bool local inserter ( Type,Int,Type,Int );
+static Int local remover ( Text,Type,Int );
+static Int local tailVar ( Type,Int );
#endif
-static Bool local pairImprove Args((Int,Class,Cell,Int,Cell,Int));
-static Bool local instImprove Args((Int,Cell,Int));
-static Bool local improveAgainst Args((Int,List,Cell,Int));
+static Bool local improveAgainst ( Int,List,Cell,Int );
+static Bool local instImprove ( Int,Class,Cell,Int );
+static Bool local pairImprove ( Int,Class,Cell,Int,Cell,Int,Int );
#if IPARAM
-static Bool local ipImprove Args((Int,Cell,Int,Cell,Int));
+static Bool local ipImprove ( Int,Cell,Int,Cell,Int );
#endif
-static Bool local kvarToVarBind Args((Tyvar *,Tyvar *));
-static Bool local kvarToTypeBind Args((Tyvar *,Type,Int));
+static Bool local kvarToVarBind ( Tyvar *,Tyvar * );
+static Bool local kvarToTypeBind ( Tyvar *,Type,Int );
/* --------------------------------------------------------------------------
* The substitution, types, and kinds:
Void emptySubstitution() { /* clear current substitution */
numTyvars = 0;
-#if !FIXED_SUBST
if (maxTyvars!=NUM_TYVARS) {
maxTyvars = 0;
if (tyvars) {
tyvars = 0;
}
}
-#endif
nextGeneric = 0;
genericVars = NIL;
typeIs = NIL;
static Void local expandSubst(n) /* add further n type variables to */
Int n; { /* current substituion */
-#if FIXED_SUBST
- if (numTyvars+n>NUM_TYVARS) {
- ERRMSG(0) "Too many type variables in type checker"
- EEND;
- }
-#else
if (numTyvars+n>maxTyvars) { /* need to expand substitution */
Int newMax = maxTyvars+NUM_TYVARS;
Tyvar *newTvs;
tyvars = newTvs;
maxTyvars = newMax;
}
-#endif
}
Int newTyvars(n) /* allocate new type variables */
case FIXED_TYVAR : return mkInt(vn);
case UNUSED_GENERIC : (tyv->offs) = GENERIC + nextGeneric++;
- if (nextGeneric>=NUM_OFFSETS) {
+ if (nextGeneric>=(OFF_MAX-OFF_MIN+1)) {
ERRMSG(0)
"Too many quantified type variables"
EEND;
return result;
}
-
+Bool isProgType(ks,type) /* Test if type is of the form */
+List ks; /* IO t for some t. */
+Type type; {
+ Bool result;
+ Int alpha;
+ Int beta;
+ emptySubstitution();
+ alpha = newKindedVars(ks);
+ beta = newTyvars(1);
+ bindOnlyAbove(beta);
+ result = unify(type,alpha,typeProgIO,beta);
+ unrestrictBind();
+ emptySubstitution();
+ return result;
+}
/* --------------------------------------------------------------------------
* Matching predicates:
Int o1; /* with the same class. */
Cell pi;
Int o; {
- for (; isAp(pi1); pi1=fun(pi1), pi=fun(pi))
- if (!unify(arg(pi1),o1,arg(pi),o))
- return FALSE;
+ for (; isAp(pi1); pi1=fun(pi1), pi=fun(pi)) {
+ if (!isAp(pi) || !unify(arg(pi1),o1,arg(pi),o))
+ return FALSE;
+ }
+ /* pi1 has exhausted its argument chain, we also need to check that
+ pi has no remaining arguments. However, under this condition,
+ the pi1 == pi will always return FALSE, giving the desired
+ result. */
+
#if IPARAM
if (isIP(pi1) && isIP(pi))
return textOf(pi1)==textOf(pi);
}
#if MULTI_INST
-Cell findInstsFor(pi,o) /* Find matching instance for pred */
+List findInstsFor(pi,o) /* Find matching instance for pred */
Cell pi; /* (pi,o), or otherwise NIL. If a */
Int o; { /* match is found, then tyvars from*/
Class c = getHead(pi); /* typeOff have been initialized to*/
Cell pi = fst3(hd(ps1));
Int o = intOf(snd3(hd(ps1)));
Cell c = getHead(pi);
- if ((isClass(c) && nonNull(cclass(c).fds)) || isIP(c)) {
+ if ((isClass(c) && nonNull(cclass(c).xfds)) || isIP(c)) {
improved |= improveAgainst(line,sps,pi,o);
if (!isIP(c))
- improved |= instImprove(line,pi,o);
+ improved |= instImprove(line,c,pi,o);
improved |= improveAgainst(line,tl(ps1),pi,o);
}
}
} while (improved);
}
+Void improve1(line,sps,pi,o) /* Improve a single predicate */
+Int line;
+List sps;
+Cell pi;
+Int o; {
+ Bool improved;
+ Cell c = getHead(pi);
+ do {
+ improved = FALSE;
+ if ((isClass(c) && nonNull(cclass(c).xfds)) || isIP(c)) {
+ improved |= improveAgainst(line,sps,pi,o);
+ if (!isIP(c))
+ improved |= instImprove(line,c,pi,o);
+ }
+ } while (improved);
+}
+
Bool improveAgainst(line,ps,pi,o)
Int line;
List ps;
Cell pi1 = fst3(pr);
Int o1 = intOf(snd3(pr));
Cell h1 = getHead(pi1);
- if (isClass(h1) && h==h1)
- improved |= pairImprove(line,h,pi,o,pi1,o1);
+ /* it would be nice to optimize for the common case
+ where h == h1 */
+ if (isClass(h) && isClass(h1)) {
+ improved |= pairImprove(line,h,pi,o,pi1,o1,numTyvars);
+ if (h != h1)
+ improved |= pairImprove(line,h1,pi1,o1,pi,o,numTyvars);
+ }
#if IPARAM
else if (isIP(h1) && textOf(h1) == textOf(h))
improved |= ipImprove(line,pi,o,pi1,o1);
}
return improved;
}
+/* should emulate findInsts behavior of shorting out if the
+ predicate would match a more general signature... */
+
+Bool instImprove(line,c,pi,o)
+Int line;
+Class c;
+Cell pi;
+Int o; {
+ Bool improved = FALSE;
+ List ins = cclass(c).instances;
+ for (; nonNull(ins); ins=tl(ins)) {
+ Cell in = hd(ins);
+ Int alpha = newKindedVars(inst(in).kinds);
+ improved |= pairImprove(line,c,pi,o,inst(in).head,alpha,alpha);
+ }
+ return improved;
+}
#if IPARAM
Bool ipImprove(line,pi,o,pi1,o1)
}
#endif
-Bool pairImprove(line,c,pi1,o1,pi,o) /* Look for improvement of (pi1,o1)*/
-Int line; /* against (pi,o), assuming that */
-Class c; /* both pi and pi1 are for class c */
+Bool pairImprove(line,c,pi1,o1,pi2,o2,above) /* Look for improvement of (pi1,o1)*/
+Int line; /* against (pi2,o2) */
+Class c;
Cell pi1;
Int o1;
-Cell pi;
-Int o; {
+Cell pi2;
+Int o2;
+Int above; {
Bool improved = FALSE;
- List fds = cclass(c).fds;
- for (; nonNull(fds); fds=tl(fds)) {
- List as = fst(hd(fds));
- Bool same = TRUE;
- for (; same && nonNull(as); as=tl(as)) {
- Int n = offsetOf(hd(as));
- same &= sameType(nthArg(n,pi1),o1,nthArg(n,pi),o);
+ List xfds = cclass(c).xfds;
+ for (; nonNull(xfds); xfds=tl(xfds)) {
+ Cell xfd = hd(xfds);
+ Cell hs = fst(xfd);
+ Int alpha;
+ for (; nonNull(hs); hs=tl(hs)) {
+ Cell h = hd(hs);
+ Class d = getHead(h);
+ alpha = newKindedVars(cclass(d).kinds);
+ if (matchPred(pi2,o2,h,alpha))
+ break;
+ numTyvars = alpha;
}
- if (isNull(as) && same) {
- for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
- Int n = offsetOf(hd(as));
- Type t1 = nthArg(n,pi1);
- Type t = nthArg(n,pi);
- if (!sameType(t1,o1,t,o)) {
- same &= unify(t1,o1,t,o);
- improved = TRUE;
- }
- }
- if (!same) {
- ERRMSG(line)
- "Constraints are not consistent with functional dependency"
- ETHEN
- ERRTEXT "\n*** Constraint : "
- ETHEN ERRPRED(copyPred(pi1,o1));
- ERRTEXT "\n*** And constraint : "
- ETHEN ERRPRED(copyPred(pi,o));
- ERRTEXT "\n*** For class : "
- ETHEN ERRPRED(cclass(c).head);
- ERRTEXT "\n*** Break dependency : "
- ETHEN ERRFD(hd(fds));
- ERRTEXT "\n"
- EEND;
- }
- }
- }
- return improved;
-}
-
-Bool instImprove(line,pi,o) /* Look for improvement of (pi,o) */
-Int line; /* returning TRUE if an improvement*/
-Cell pi; /* was made, and FALSE otherwise */
-Int o; {
- Bool improved = FALSE;
- Cell c = getHead(pi);
- if (isClass(c) && nonNull(cclass(c).fds)) {
- List ins = cclass(c).instances;
- for (; nonNull(ins); ins=tl(ins)) {
- Cell in = hd(ins);
- List fds = cclass(c).fds;
+ if (nonNull(hs)) {
+ List fds = snd(xfd);
for (; nonNull(fds); fds=tl(fds)) {
- Int beta = newKindedVars(inst(in).kinds);
- Bool same = TRUE;
List as = fst(hd(fds));
+ Bool same = TRUE;
for (; same && nonNull(as); as=tl(as)) {
Int n = offsetOf(hd(as));
- same &= matchType(nthArg(n,pi),o,
- nthArg(n,inst(in).head),beta);
+ same &= matchTypeAbove(nthArg(n,pi1),o1,
+ mkOffset(n),alpha,above);
}
if (isNull(as) && same) {
for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
- Int n = offsetOf(hd(as));
- Type tp = nthArg(n,pi);
- Type ti = nthArg(n,inst(in).head);
- if (!matchType(tp,o,ti,beta)) {
- same &= unify(tp,o,ti,beta);
+ Int n = offsetOf(hd(as));
+ Type t1 = nthArg(n,pi1);
+ Type t2 = mkOffset(n);
+ if (!matchTypeAbove(t1,o1,t2,alpha,above)) {
+ same &= unify(t1,o1,t2,alpha);
improved = TRUE;
}
}
if (!same) {
ERRMSG(line)
- "Constraint is not consistent with declared instance"
+ "Constraints are not consistent with functional dependency"
ETHEN
ERRTEXT "\n*** Constraint : "
- ETHEN ERRPRED(copyPred(pi,o));
- ERRTEXT "\n*** Instance : "
- ETHEN ERRPRED(inst(in).head);
+ ETHEN ERRPRED(copyPred(pi1,o1));
+ ERRTEXT "\n*** And constraint : "
+ ETHEN ERRPRED(copyPred(pi2,o2));
ERRTEXT "\n*** For class : "
ETHEN ERRPRED(cclass(c).head);
- ERRTEXT "\n*** Under dependency : "
+ ERRTEXT "\n*** Break dependency : "
ETHEN ERRFD(hd(fds));
ERRTEXT "\n"
EEND;
}
- } else {
- numTyvars = beta;
}
}
+ numTyvars = alpha;
}
}
return improved;
return result;
}
+static Bool local matchTypeAbove(t1,o1,t,o,a) /* match, allowing only vars */
+Type t1; /* allocated since `a' to be bound */
+Int o1; /* this is deeply hacky, since it */
+Type t; /* relies on careful use of the */
+Int o; /* substitution stack */
+Int a; {
+ Bool result;
+ bindOnlyAbove(a);
+ result = unify(t1,o1,t,o);
+ unrestrictBind();
+ return result;
+}
+
/* --------------------------------------------------------------------------
* Unify kind expressions:
* ------------------------------------------------------------------------*/
#endif
break;
- case INSTALL : substitution(RESET);
+ case POSTPREL: break;
+
+ case PREPREL : substitution(RESET);
for (i=0; i<MAXTUPCON; ++i)
tupleConTypes[i] = NIL;
for (i=0; i<MAXKINDFUN; ++i) {
projects / ghc-hetmet.git / blobdiff