* included in the distribution.
*
* $RCSfile: subst.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/10/15 21:40:59 $
+ * $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 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 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 ( 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 */
typeFree++;
}
- if (whatIs(typeIs)==QUAL) { /* Qualified type? */
+ if (isQualType(typeIs)) { /* Qualified type? */
predsAre = fst(snd(typeIs));
typeIs = snd(snd(typeIs));
}
Void markType(t,o) /* mark fixed vars in type (t,o) */
Type t;
Int o; {
+ STACK_CHECK
switch (whatIs(t)) {
case POLYTYPE :
case QUAL :
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;
Type copyType(t,o) /* calculate most general form of */
Type t; /* type expression (t,o) */
Int o; {
+ STACK_CHECK
switch (whatIs(t)) {
case AP : { Type l = copyType(fst(t),o);/* ensure correct */
Type r = copyType(snd(t),o);/* eval. order */
return pi;
}
+Type zonkTyvar(vn) /* flatten type by chasing all references */
+Int vn; { /* and collapsing OFFSETS to absolute indexes */
+ Tyvar *tyv = tyvar(vn);
+
+ if (tyv->bound)
+ return zonkType(tyv->bound,tyv->offs);
+ else
+ return mkInt(vn);
+}
+
+Type zonkType(t,o) /* flatten type by chasing all references */
+Type t; /* and collapsing OFFSETS to absolute indexes */
+Int o; {
+ STACK_CHECK
+ switch (whatIs(t)) {
+ case AP : { Type l = zonkType(fst(t),o);/* ensure correct */
+ Type r = zonkType(snd(t),o);/* eval. order */
+ return ap(l,r);
+ }
+ case OFFSET : return zonkTyvar(o+offsetOf(t));
+ case INTCELL : return zonkTyvar(intOf(t));
+ }
+
+ return t;
+}
+
#ifdef DEBUG_TYPES
Type debugTyvar(vn) /* expand type structure in full */
Int vn; { /* detail */
Type debugType(t,o)
Type t;
Int o; {
+ STACK_CHECK
switch (whatIs(t)) {
case AP : { Type l = debugType(fst(t),o);
Type r = debugType(snd(t),o);
return t;
}
+List debugContext(ps)
+List ps; {
+ Cell p;
+ List qs = NIL;
+ for (; nonNull(ps); ps=tl(ps)) {
+ p = debugPred(fst3(hd(ps)),intOf(snd3(hd(ps))));
+ qs = cons(p,qs);
+ }
+ return rev(qs);
+}
+
+Cell debugPred(pi,o)
+Cell pi;
+Int o; {
+ if (isAp(pi)) {
+ return pair(debugPred(fun(pi),o),debugType(arg(pi),o));
+ }
+ return pi;
+}
#endif /*DEBUG_TYPES*/
Kind copyKindvar(vn) /* build kind attatched to variable*/
}
/* --------------------------------------------------------------------------
+ * Copy type expression from substitution without marking:
+ * ------------------------------------------------------------------------*/
+
+static List local listTyvar(vn,ns)
+Int vn;
+List ns; {
+ Tyvar *tyv = tyvar(vn);
+
+ if (isBound(tyv)) {
+ return listTyvars(tyv->bound,tyv->offs,ns);
+ } else if (!intIsMember(vn,ns)) {
+ ns = cons(mkInt(vn),ns);
+ }
+ return ns;
+}
+
+static List local listTyvars(t,o,ns)
+Cell t;
+Int o;
+List ns; {
+ switch (whatIs(t)) {
+ case AP : return listTyvars(fst(t),o,
+ listTyvars(snd(t),o,
+ ns));
+ case OFFSET : return listTyvar(o+offsetOf(t),ns);
+ case INTCELL : return listTyvar(intOf(t),ns);
+ default : break;
+ }
+ return ns;
+}
+
+static Cell local dupTyvar(vn,ns)
+Int vn;
+List ns; {
+ Tyvar *tyv = tyvar(vn);
+
+ if (isBound(tyv)) {
+ return dupTyvars(tyv->bound,tyv->offs,ns);
+ } else {
+ Int i = 0;
+ for (; nonNull(ns) && vn!=intOf(hd(ns)); ns=tl(ns)) {
+ i++;
+ }
+ return mkOffset(i);
+ }
+}
+
+static Cell local dupTyvars(t,o,ns)
+Cell t;
+Int o;
+List ns; {
+ switch (whatIs(t)) {
+ case AP : { Type l = dupTyvars(fst(t),o,ns);
+ Type r = dupTyvars(snd(t),o,ns);
+ return ap(l,r);
+ }
+ case OFFSET : return dupTyvar(o+offsetOf(t),ns);
+ case INTCELL : return dupTyvar(intOf(t),ns);
+ }
+ return t;
+}
+
+static Cell local copyNoMark(t,o) /* Copy a type or predicate without*/
+Cell t; /* changing marks */
+Int o; {
+ List ns = listTyvars(t,o,NIL);
+ Cell result = pair(ns,dupTyvars(t,o,ns));
+ for (; nonNull(ns); ns=tl(ns)) {
+ hd(ns) = tyvar(intOf(hd(ns)))->kind;
+ }
+ return result;
+}
+
+/* --------------------------------------------------------------------------
* Droping and lifting of type schemes that appear in rank 2 position:
* ------------------------------------------------------------------------*/
Int o; {
Tyvar *tyv;
+ STACK_CHECK
for (;;) {
deRef(tyv,t,o);
if (tyv) /* type variable */
Int o1,o2; {
Tyvar *tyv1, *tyv2;
+ STACK_CHECK
deRef(tyv1,t1,o1);
deRef(tyv2,t2,o2);
Bool typeMatches(type,mt) /* test if type matches monotype mt*/
Type type, mt; { /* imported from STG Hugs */
Bool result;
- if (isPolyType(type) || whatIs(type)==QUAL)
+ if (isPolyOrQualType(type))
return FALSE;
emptySubstitution();
noBind();
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);
+ else
+#endif
return pi1==pi;
}
Int o; { /* match is found, then tyvars from*/
Class c = getHead(pi); /* typeOff have been initialized to*/
List ins; /* allow direct use of specifics. */
+ Cell kspi = NIL;
if (!isClass(c))
return NIL;
typeOff = beta;
return in;
}
- else
- numTyvars = beta;
+ else {
+ numTyvars = beta;
+ if (allowOverlap) {
+ Int alpha = newKindedVars(inst(in).kinds);
+ if (isNull(kspi)) {
+ kspi = copyNoMark(pi,o);
+ }
+ beta = newKindedVars(fst(kspi));
+ if (matchPred(inst(in).head,alpha,snd(kspi),beta)) {
+ numTyvars = alpha;
+ return NIL;
+ }
+ numTyvars = alpha;
+ }
+ }
}
unrestrictBind();
return NIL;
}
+#if MULTI_INST
+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*/
+ List ins; /* allow direct use of specifics. */
+ List res = NIL;
+
+ if (!isClass(c))
+ return NIL;
+
+ for (ins=cclass(c).instances; nonNull(ins); ins=tl(ins)) {
+ Inst in = hd(ins);
+ Int beta = newKindedVars(inst(in).kinds);
+ if (matchPred(pi,o,inst(in).head,beta)) {
+ res = cons (pair (beta, in), res);
+ continue;
+ }
+ else
+ numTyvars = beta;
+ }
+ if (res == NIL) {
+ unrestrictBind();
+ }
+
+ return rev(res);
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Improvement:
+ * ------------------------------------------------------------------------*/
+
+Void improve(line,sps,ps) /* Improve a list of predicates */
+Int line;
+List sps;
+List ps; {
+ Bool improved;
+ List ps1;
+ do {
+ improved = FALSE;
+ for (ps1=ps; nonNull(ps1); ps1=tl(ps1)) {
+ Cell pi = fst3(hd(ps1));
+ Int o = intOf(snd3(hd(ps1)));
+ Cell c = getHead(pi);
+ if ((isClass(c) && nonNull(cclass(c).xfds)) || isIP(c)) {
+ improved |= improveAgainst(line,sps,pi,o);
+ if (!isIP(c))
+ 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 pi;
+Int o; {
+ Bool improved = FALSE;
+ Cell h = getHead(pi);
+ for (; nonNull(ps); ps=tl(ps)) {
+ Cell pr = hd(ps);
+ Cell pi1 = fst3(pr);
+ Int o1 = intOf(snd3(pr));
+ Cell h1 = getHead(pi1);
+ /* 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);
+#endif
+ }
+ 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)
+Int line;
+Cell pi;
+Int o;
+Cell pi1;
+Int o1; {
+ Type t = arg(pi);
+ Type t1 = arg(pi1);
+ if (!sameType(t,o,t1,o1)) {
+ if (!unify(t,o,t1,o1)) {
+ ERRMSG(line) "Mismatching uses of implicit parameter\n"
+ ETHEN
+ ERRTEXT "\n*** "
+ ETHEN ERRPRED(copyPred(pi1,o1));
+ ERRTEXT "\n*** "
+ ETHEN ERRPRED(copyPred(pi,o));
+ ERRTEXT "\n"
+ EEND;
+ }
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+
+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 pi2;
+Int o2;
+Int above; {
+ Bool improved = FALSE;
+ 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 (nonNull(hs)) {
+ List fds = snd(xfd);
+ 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 &= 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 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)
+ "Constraints are not consistent with functional dependency"
+ ETHEN
+ ERRTEXT "\n*** Constraint : "
+ 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*** Break dependency : "
+ ETHEN ERRFD(hd(fds));
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+ }
+ numTyvars = alpha;
+ }
+ }
+ return improved;
+}
+
/* --------------------------------------------------------------------------
* Compare type schemes:
* ------------------------------------------------------------------------*/
for (; nr2>0; nr2--) { /* Deal with rank 2 arguments */
Type t = arg(fun(s));
Type t1 = arg(fun(s1));
- b = isPolyType(t);
- b1 = isPolyType(t1);
+ b = isPolyOrQualType(t);
+ b1 = isPolyOrQualType(t1);
if (b || b1) {
if (b && b1) {
t = dropRank1(t,o,m);
return FALSE;
}
else {
- noBind();
- b = unify(t,o,t1,o);
- unrestrictBind();
- if (!b)
+ if (!sameType(t,o,t1,o)) {
return FALSE;
+ }
}
+
s = arg(s);
s1 = arg(s1);
}
- noBind(); /* Ensure body types are the same */
- b = unify(s,o,s1,o);
+ return sameType(s,o,s1,o); /* Ensure body types are the same */
+}
+
+Bool sameType(t1,o1,t,o) /* Test to see if types are */
+Type t1; /* the same, with no binding of */
+Int o1; /* the variables in either one. */
+Cell t; /* Assumes types are kind correct */
+Int o; { /* with the same kind. */
+ Bool result;
+ noBind();
+ result = unify(t1,o1,t,o);
unrestrictBind();
- return b;
+ return result;
+}
+
+Bool matchType(t1,o1,t,o) /* One way match type (t1,o1) */
+Type t1; /* against (t,o), allowing only */
+Int o1; /* vars in 2nd type to be bound. */
+Type t; /* Assumes types are kind correct */
+Int o; { /* and that no vars have been */
+ Bool result; /* alloc'd since o. */
+ bindOnlyAbove(o);
+ result = unify(t1,o1,t,o);
+ unrestrictBind();
+ 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;
}
/* --------------------------------------------------------------------------
#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