* included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.13 $
- * $Date: 1999/10/26 17:27:45 $
+ * $Revision: 1.17 $
+ * $Date: 1999/11/17 16:57:44 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Void local checkClassDefn Args((Class));
static Cell local depPredExp Args((Int,List,Cell));
static Void local checkMems Args((Class,List,Cell));
+static Void local checkMems2 Args((Class,Cell));
static Void local addMembers Args((Class));
static Name local newMember Args((Int,Int,Cell,Type,Class));
static Name local newDSel Args((Class,Int));
static Name local memberName Args((Class,Text));
static List local numInsert Args((Int,Cell,List));
- List local typeVarsIn Args((Cell,List,List,List));
static List local maybeAppendVar Args((Cell,List));
static Type local checkSigType Args((Int,String,Cell,Type));
con = ty;
}
- if (nr2>0) /* Add rank 2 annotation */
- type = ap(RANK2,pair(mkInt(nr2),type));
+ if (nr2>0) { /* Add rank 2 annotation */
+ type = ap(RANK2,pair(mkInt(nr2-length(lps)),type));
+ }
if (nonNull(evs)) { /* Add existential annotation */
if (nonNull(derivs)) {
cclass(nw).members = ms;
cclass(nw).level = 0;
cclass(nw).fds = fds;
+ cclass(nw).xfds = NIL;
classDefns = cons(nw,classDefns);
if (arity!=1)
h98DoesntSupport(line,"multiple parameter classes");
/* Check for trivial dependency
*/
- if (isNull(snd(fd))) {
+ if (isNull(vs)) {
ERRMSG(cclass(c).line) "Functional dependency is trivial"
EEND;
}
tcDeps = NIL;
}
+
+/* --------------------------------------------------------------------------
+ * Functional dependencies are inherited from superclasses.
+ * For example, if I've got the following classes:
+ *
+ * class C a b | a -> b
+ * class C [b] a => D a b
+ *
+ * then C will have the dependency ([a], [b]) as expected, and D will inherit
+ * the dependency ([b], [a]) from C.
+ * When doing pairwise improvement, we have to consider not just improving
+ * when we see a pair of Cs or a pair of Ds in the context, but when we've
+ * got a C and a D as well. In this case, we only improve when the
+ * predicate in question matches the type skeleton in the relevant superclass
+ * constraint. E.g., we improve the pair (C [Int] a, D b Int) (unifying
+ * a and b), but we don't improve the pair (C Int a, D b Int).
+ * To implement functional dependency inheritance, we calculate
+ * the closure of all functional dependencies, and store the result
+ * in an additional field `xfds' (extended functional dependencies).
+ * The `xfds' field is a list of functional dependency lists, annotated
+ * with a list of predicate skeletons constraining when improvement can
+ * happen against this dependency list. For example, the xfds field
+ * for C above would be:
+ * [([C a b], [([a], [b])])]
+ * and the xfds field for D would be:
+ * [([C [b] a, D a b], [([b], [a])])]
+ * Self-improvement (of a C with a C, or a D with a D) is treated as a
+ * special case of an inherited dependency.
+ * ------------------------------------------------------------------------*/
+static List local inheritFundeps(c,pi,o)
+Class c;
+Cell pi;
+Int o; {
+ Int alpha = newKindedVars(cclass(c).kinds);
+ List scs = cclass(c).supers;
+ List xfds = NIL;
+ Cell this = NIL;
+ /* better not fail ;-) */
+ if (!matchPred(pi,o,cclass(c).head,alpha))
+ internal("inheritFundeps - predicate failed to match it's own head!");
+ this = copyPred(pi,o);
+ for (; nonNull(scs); scs=tl(scs)) {
+ Class s = getHead(hd(scs));
+ if (isClass(s)) {
+ List sfds = inheritFundeps(s,hd(scs),alpha);
+ for (; nonNull(sfds); sfds=tl(sfds)) {
+ Cell h = hd(sfds);
+ xfds = cons(pair(cons(this,fst(h)),snd(h)),xfds);
+ }
+ }
+ }
+ if (nonNull(cclass(c).fds)) {
+ List fds = NIL, fs = cclass(c).fds;
+ for (; nonNull(fs); fs=tl(fs)) {
+ fds = cons(pair(otvars(this,fst(hd(fs))),
+ otvars(this,snd(hd(fs)))),fds);
+ }
+ xfds = cons(pair(cons(this,NIL),fds),xfds);
+ }
+ return xfds;
+}
+
+static Void local extendFundeps(c)
+Class c; {
+ Int alpha;
+ emptySubstitution();
+ alpha = newKindedVars(cclass(c).kinds);
+ cclass(c).xfds = inheritFundeps(c,cclass(c).head,alpha);
+
+ /* we can now check for ambiguity */
+ map1Proc(checkMems2,c,fst(cclass(c).members));
+}
+
+
static Cell local depPredExp(line,tyvars,pred)
Int line;
List tyvars;
h98CheckType(line,"member type",hd(vs),t);
}
+static Void local checkMems2(c,m) /* check member function details */
+Class c;
+Cell m; {
+ Int line = intOf(fst3(m));
+ List vs = snd3(m);
+ Type t = thd3(m);
+}
+
static Void local addMembers(c) /* Add definitions of member funs */
Class c; { /* and other parts of class struct.*/
List ms = fst(cclass(c).members);
name(m).arity = 1;
name(m).number = mfunNo(no);
name(m).type = t;
- name(m).inlineMe = TRUE;
return m;
}
else
return cons(t,vs);
- case OFFSET : internal("zonkTyvarsIn");
+ /* this case will lead to a type error --
+ much better than reporting an internal error ;-) */
+ /* case OFFSET : internal("zonkTyvarsIn"); */
default : return vs;
}
Cell pi;
List os; {
List us = NIL;
- List vs = NIL;
for (; nonNull(os); os=tl(os)) {
Type t = zonkType(nthArg(offsetOf(hd(os)),pi),o);
us = zonkTyvarsIn(t,us);
Cell pi = hd(ps);
Cell c = getHead(pi);
if (isClass(c)) {
- List fs = cclass(c).fds;
- for (; nonNull(fs); fs=tl(fs)) {
- fds = cons(pair(otvars(pi,fst(hd(fs))),
- otvars(pi,snd(hd(fs)))),fds);
- }
+ List xfs = cclass(c).xfds;
+ for (; nonNull(xfs); xfs=tl(xfs)) {
+ List fs = snd(hd(xfs));
+ for (; nonNull(fs); fs=tl(fs)) {
+ fds = cons(pair(otvars(pi,fst(hd(fs))),
+ otvars(pi,snd(hd(fs)))),fds);
+ }
+ }
}
#if IPARAM
else if (isIP(c)) {
Cell c = getHead(pi);
Int o = intOf(snd3(pi3));
if (isClass(c)) {
- List fs = cclass(c).fds;
- for (; nonNull(fs); fs=tl(fs)) {
- fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o),
- otvarsZonk(pi,snd(hd(fs)),o)),fds);
+ List xfs = cclass(c).xfds;
+ for (; nonNull(xfs); xfs=tl(xfs)) {
+ List fs = snd(hd(xfs));
+ for (; nonNull(fs); fs=tl(fs)) {
+ fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o),
+ otvarsZonk(pi,snd(hd(fs)),o)),fds);
+ }
}
}
#if IPARAM
ERRMSG(line) "Illegal predicate in instance declaration"
EEND;
}
+
+ if (nonNull(cclass(inst(in).c).fds)) {
+ List fds = cclass(inst(in).c).fds;
+ for (; nonNull(fds); fds=tl(fds)) {
+ List as = otvars(inst(in).head, fst(hd(fds)));
+ List bs = otvars(inst(in).head, snd(hd(fds)));
+ List fs = calcFunDeps(inst(in).specifics);
+ as = oclose(fs,as);
+ if (!osubset(bs,as)) {
+ ERRMSG(inst(in).line)
+ "Instance is more general than a dependency allows"
+ ETHEN
+ ERRTEXT "\n*** Instance : "
+ ETHEN ERRPRED(inst(in).head);
+ ERRTEXT "\n*** For class : "
+ ETHEN ERRPRED(cclass(inst(in).c).head);
+ ERRTEXT "\n*** Under dependency : "
+ ETHEN ERRFD(hd(fds));
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+ }
+
kindInst(in,length(tyvars));
insertInst(in);
List spcs = fst(snd(inst(in).specifics));
Int beta = inst(in).numSpecifics;
Int its = 1;
+ Int factor = 1+length(ps);
#ifdef DEBUG_DERIVING
Printf("calcInstPreds: ");
while (nonNull(ps)) {
Cell p = hd(ps);
ps = tl(ps);
- if (its++ >= cutoff) {
+ if (its++ >= factor*cutoff) {
Cell bpi = inst(in).head;
Cell pi = copyPred(fun(p),intOf(snd(p)));
ERRMSG(inst(in).line) "\n*** Cannot derive " ETHEN ERRPRED(bpi);
staticAnalysis(RESET);
}
-Void checkContext() { /* Top level static check on Expr */
+#if EXPLAIN_INSTANCE_RESOLUTION
+Void checkContext(void) { /* Top level static check on Expr */
List vs, qs;
staticAnalysis(RESET);
leaveScope();
staticAnalysis(RESET);
}
+#endif
Void checkDefns() { /* Top level static analysis */
Module thisModule = lastModule();
checkSynonyms(tyconDefns); /* check synonym definitions */
mapProc(checkClassDefn,classDefns); /* process class definitions */
mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds */
+ mapProc(extendFundeps,classDefns); /* finish class definitions */
mapProc(addMembers,classDefns); /* add definitions for member funs */
mapProc(visitClass,classDefns); /* check class hierarchy */
linkPreludeCM(); /* Get prelude cfuns and mfuns */
projects / ghc-hetmet.git / blobdiff