From: andy Date: Wed, 17 Nov 1999 16:57:51 +0000 (+0000) Subject: [project @ 1999-11-17 16:57:38 by andy] X-Git-Tag: Approximately_9120_patches~5547 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=333e9b497dd063a37af367abd937d2f6454ae84c;p=ghc-hetmet.git [project @ 1999-11-17 16:57:38 by andy] Merging in the various changes between Sep99 Hugs and Nov99 Hugs. --- diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 93be39b..bf79c88 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -8,8 +8,8 @@ * included in the distribution. * * $RCSfile: connect.h,v $ - * $Revision: 1.15 $ - * $Date: 1999/11/12 17:32:38 $ + * $Revision: 1.16 $ + * $Date: 1999/11/17 16:57:38 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -206,7 +206,9 @@ extern Void projInput Args((String)); extern Void stringInput Args((String)); extern Void parseScript Args((String,Long)); extern Void parseExp Args((Void)); +#if EXPLAIN_INSTANCE_RESOLUTION extern Void parseContext Args((Void)); +#endif extern String readFilename Args((Void)); extern String readLine Args((Void)); extern Syntax defaultSyntax Args((Text)); @@ -245,6 +247,9 @@ extern Type zonkType Args((Type,Int)); extern Void primDefn Args((Cell,List,Cell)); extern Void defaultDefn Args((Int,List)); extern Void checkExp Args((Void)); +#if EXPLAIN_INSTANCE_RESOLUTION +extern Void checkContext Args((Void)); +#endif extern Void checkDefns Args((Void)); extern Bool h98Pred Args((Bool,Cell)); extern Cell h98Context Args((Bool,List)); @@ -304,6 +309,9 @@ extern Void gcCStack Args((Void)); extern Void needPrims Args((Int)); extern List calcFunDepsPreds Args((List)); extern Inst findInstFor Args((Cell,Int)); +#if MULTI_INST +extern List findInstsFor Args((Cell,Int)); +#endif extern Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds ); #define aVar mkOffset(0) /* Simple skeleton for type var */ diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 9610ed2..8887b79 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.20 $ - * $Date: 1999/11/12 17:50:01 $ + * $Revision: 1.21 $ + * $Date: 1999/11/17 16:57:38 $ * ------------------------------------------------------------------------*/ #include @@ -90,7 +90,7 @@ static Void local forgetScriptsFrom Args((Script)); static Void local setLastEdit Args((String,Int)); static Void local failed Args((Void)); static String local strCopy Args((String)); -static Void local browseit Args((Module,String)); +static Void local browseit Args((Module,String,Bool)); static Void local browse Args((Void)); /* -------------------------------------------------------------------------- @@ -1417,16 +1417,19 @@ static Void local showtype() { /* print type of expression (if any)*/ } -static Void local browseit(mod,t) +static Void local browseit(mod,t,all) Module mod; -String t; { +String t; +Bool all; { if (nonNull(mod)) { Cell cs; - Printf("module %s where\n",textToStr(module(mod).text)); + if (nonNull(t)) + Printf("module %s where\n",textToStr(module(mod).text)); for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) { Name nm = hd(cs); - /* only look at things defined in this module */ - if (name(nm).mod == mod) { + /* only look at things defined in this module, + unless `all' flag is set */ + if (all || name(nm).mod == mod) { /* unwanted artifacts, like lambda lifted values, are in the list of names, but have no types */ if (nonNull(name(nm).type)) { @@ -1454,20 +1457,23 @@ String t; { static Void local browse() { /* browse modules */ Int count = 0; /* or give menu of commands */ String s; + Bool all = FALSE; setCurrModule(findEvalModule()); startNewScript(0); /* for recovery of storage */ - for (; (s=readFilename())!=0; count++) { - browseit(findModule(findText(s)),s); - } + for (; (s=readFilename())!=0; count++) + if (strcmp(s,"all") == 0) { + all = TRUE; + --count; + } else + browseit(findModule(findText(s)),s,all); if (count == 0) { - whatScripts(); + browseit(findEvalModule(),NULL,all); } } #if EXPLAIN_INSTANCE_RESOLUTION static Void local xplain() { /* print type of expression (if any)*/ - Cell type; Cell d; Bool sir = showInstRes; @@ -1997,7 +2003,12 @@ static Int charCount; Void setGoal(what, t) /* Set goal for what to be t */ String what; Target t; { - if (quiet) return; + if (quiet) + return; +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + return; +#endif currTarget = (t?t:1); aiming = TRUE; if (useDots) { @@ -2013,7 +2024,12 @@ Target t; { Void soFar(t) /* Indicate progress towards goal */ Target t; { /* has now reached t */ - if (quiet) return; + if (quiet) + return; +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + return; +#endif if (useDots) { Int newPos = (Int)((maxPos * ((long)t))/currTarget); @@ -2031,7 +2047,12 @@ Target t; { /* has now reached t */ } Void done() { /* Goal has now been achieved */ - if (quiet) return; + if (quiet) + return; +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) + return; +#endif if (useDots) { while (maxPos>currPos++) Putchar('.'); diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index 19f9f14..ecc489d 100644 --- a/ghc/interpreter/input.c +++ b/ghc/interpreter/input.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: input.c,v $ - * $Revision: 1.11 $ - * $Date: 1999/11/12 16:38:31 $ + * $Revision: 1.12 $ + * $Date: 1999/11/17 16:57:40 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1657,9 +1657,12 @@ Void parseExp() { /* Read an expression to evaluate */ setLastExpr(inputExpr); } + +#if EXPLAIN_INSTANCE_RESOLUTION Void parseContext() { /* Read a context to prove */ parseInput(CONTEXT); } +#endif Void parseInterface(nm,len) /* Read a GHC interface file */ String nm; diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c index 9b5579e..cc69112 100644 --- a/ghc/interpreter/machdep.c +++ b/ghc/interpreter/machdep.c @@ -13,8 +13,8 @@ * included in the distribution. * * $RCSfile: machdep.c,v $ - * $Revision: 1.9 $ - * $Date: 1999/10/20 02:16:01 $ + * $Revision: 1.10 $ + * $Date: 1999/11/17 16:57:41 $ * ------------------------------------------------------------------------*/ #ifdef HAVE_SIGNAL_H @@ -282,7 +282,7 @@ static String local hugsdir() { /* directory containing lib/Prelude.hs */ } } return dir; -#elif HAVE_GETMODULEFILENAME && !DOS +#elif HAVE_GETMODULEFILENAME && !DOS && !__CYGWIN32__ /* On Windows, we can find the binary we're running and it's * conventional to put the libraries in the same place. */ @@ -293,7 +293,8 @@ static String local hugsdir() { /* directory containing lib/Prelude.hs */ if (dir[0] == '\0') { /* GetModuleFileName must have failed */ return HUGSDIR; } - if (slash = strrchr(dir,SLASH)) { /* truncate after directory name */ + slash = strrchr(dir,SLASH); + if (slash) { /* truncate after directory name */ *slash = '\0'; } } @@ -1107,7 +1108,14 @@ Int readTerminalChar() { /* read character from terminal */ hIn = GetStdHandle(STD_INPUT_HANDLE); GetConsoleMode(hIn, &mo); SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT)); - c = getc(stdin); + /* + * On Win9x, the first time you change the mode (as above) a + * raw '\n' is inserted. Since enter maps to a raw '\r', and we + * map this (below) to '\n', we can just ignore all *raw* '\n's. + */ + do { + c = getc(stdin); + } while (c == '\n'); /* Same as it ever was - revert back state of stdin. */ SetConsoleMode(hIn, mo); @@ -1491,6 +1499,20 @@ Int val; { #endif /* USE_REGISTRY */ /* -------------------------------------------------------------------------- + * Things to do with the argv/argc and the env + * ------------------------------------------------------------------------*/ + +int nh_argc ( void ) +{ + return prog_argc; +} + +int nh_argvb ( int argno, int offset ) +{ + return (int)(prog_argv[argno][offset]); +} + +/* -------------------------------------------------------------------------- * Machine dependent control: * ------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index a836cd6..b91d7d5 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -12,8 +12,8 @@ * included in the distribution. * * $RCSfile: parser.y,v $ - * $Revision: 1.12 $ - * $Date: 1999/10/26 17:27:37 $ + * $Revision: 1.13 $ + * $Date: 1999/11/17 16:57:42 $ * ------------------------------------------------------------------------*/ %{ @@ -40,7 +40,7 @@ static String local unexpected Args((Void)); static Cell local checkPrec Args((Cell)); static Void local fixDefn Args((Syntax,Cell,Cell,List)); static Cell local buildTuple Args((List)); -static List local checkContext Args((List)); +static List local checkCtxt Args((List)); static Cell local checkPred Args((Cell)); static Pair local checkDo Args((List)); static Cell local checkTyLhs Args((Cell)); @@ -715,10 +715,10 @@ sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));} context : '(' ')' {$$ = gc2(NIL);} | btype2 {$$ = gc1(singleton(checkPred($1)));} | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));} - | '(' btypes2 ')' {$$ = gc3(checkContext(rev($2)));} + | '(' btypes2 ')' {$$ = gc3(checkCtxt(rev($2)));} /*#if TREX*/ | lacks {$$ = gc1(singleton($1));} - | '(' lacks1 ')' {$$ = gc3(checkContext(rev($2)));} + | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));} ; lacks : varid '\\' varid { #if TREX @@ -1409,7 +1409,7 @@ List tup; { /* list [xn,...,x1] */ return tup; } -static List local checkContext(con) /* validate context */ +static List local checkCtxt(con) /* validate context */ Type con; { mapOver(checkPred, con); return con; diff --git a/ghc/interpreter/preds.c b/ghc/interpreter/preds.c index 1c95a58..c41ed5c 100644 --- a/ghc/interpreter/preds.c +++ b/ghc/interpreter/preds.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: preds.c,v $ - * $Revision: 1.8 $ - * $Date: 1999/10/20 02:16:04 $ + * $Revision: 1.9 $ + * $Date: 1999/11/17 16:57:43 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -21,7 +21,6 @@ static Cell local assumeEvid Args((Cell,Int)); #if IPARAM static Cell local findIPEvid Args((Text)); static Void local removeIPEvid Args((Text)); -static Void local matchupIPs Args((List,List)); #endif static List local makePredAss Args((List,Int)); static List local copyPreds Args((List)); @@ -30,7 +29,7 @@ static Void local qualifyBinding Args((List,Cell)); static Cell local qualifyExpr Args((Int,List,Cell)); static Void local overEvid Args((Cell,Cell)); -static Void local cutoffExceeded Args((Cell,Int,Cell,Int,List)); +static Void local cutoffExceeded Args((Cell,Int,List)); static Cell local scFind Args((Cell,Cell,Int,Cell,Int,Int)); static Cell local scEntail Args((List,Cell,Int,Int)); static Cell local entail Args((List,Cell,Int,Int)); @@ -213,16 +212,16 @@ Cell ev; { Int cutoff = 64; /* Used to limit depth of recursion*/ -static Void local cutoffExceeded(pi,o,pi1,o1,ps) -Cell pi, pi1; /* Display error msg when cutoff */ -Int o, o1; +static Void local cutoffExceeded(pi,o,ps) +Cell pi; /* Display error msg when cutoff */ +Int o; List ps; { clearMarks(); ERRMSG(0) "\n*** The type checker has reached the cutoff limit while trying to\n" ETHEN ERRTEXT "*** determine whether:\n*** " ETHEN ERRPRED(copyPred(pi,o)); - ps = (isNull(pi1)) ? copyPreds(ps) : singleton(copyPred(pi1,o1)); + ps = copyPreds(ps); ERRTEXT "\n*** can be deduced from:\n*** " ETHEN ERRCONTEXT(ps); ERRTEXT @@ -244,6 +243,7 @@ Int o; Int d; { Class h1 = getHead(pi1); Class h = getHead(pi); + Cell ev = NIL; /* the h==h1 test is just an optimization, and I'm not sure it will work with IPs, so I'm being conservative @@ -251,24 +251,42 @@ Int d; { if (/* h==h1 && */ samePred(pi1,o1,pi,o)) return e; - /* the cclass.level test is also an optimization */ if (isClass(h1) && (!isClass(h) || cclass(h).level= cutoff) - cutoffExceeded(pi,o,pi1,o1,NIL); + for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels)) + ps = cons(triple(hd(scs),mkInt(beta),ap(hd(dsels),e)),ps); + ps = rev(ps); - for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels)) { - Cell ev = scFind(ap(hd(dsels),e),hd(scs),beta,pi,o,d); - if (nonNull(ev)) - return ev; - } +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + int i; + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("scEntail(scFind): ", stdout); + printContext(stdout,copyPreds(ps)); + fputs(" ||- ", stdout); + printPred(stdout, copyPred(pi, o)); + fputc('\n', stdout); + } +#endif + improve1(0,ps,pi,o); + ev = scEntail(ps,pi,o,d); +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes && nonNull(ev)) { + int i; + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("scSat.\n", stdout); + } +#endif + return ev; } - return NIL; } @@ -277,6 +295,9 @@ List ps; /* Using superclasses and equality.*/ Cell pi; Int o; Int d; { + if (d++ >= cutoff) + cutoffExceeded(pi,o,ps); + for (; nonNull(ps); ps=tl(ps)) { Cell pi1 = hd(ps); Cell ev = scFind(thd3(pi1),fst3(pi1),intOf(snd3(pi1)),pi,o,d); @@ -286,36 +307,6 @@ Int d; { return NIL; } -#if IPARAM -static Cell local ipEntail(ps,ip,o) /* Find evidence for (ip,o) from ps*/ -List ps; -Cell ip; -Int o; { - Class h = getHead(ip); - int i; - for (; nonNull(ps); ps=tl(ps)) { - Cell pr1 = hd(ps); - Cell pi1 = fst3(pr1); - Int o1 = intOf(snd3(pr1)); - Class h1 = getHead(pi1); - if (isIP(h1)) { - if (textOf(h1) == textOf(h)) { - if (unify(arg(pi1),o1,arg(ip),o)) { - return thd3(pr1); - } else { - ERRMSG(0) "Mismatching uses of implicit parameter\n" ETHEN - ERRPRED(copyPred(pi1,o1)); - ERRTEXT "\n" ETHEN - ERRPRED(copyPred(ip,o)); - ERRTEXT "\n" - EEND; - } - } - } - } - return NIL; -} -#endif /* -------------------------------------------------------------------------- * Now we reach the main entailment routine: @@ -370,14 +361,49 @@ List ps; /* Uses superclasses, equality, */ Cell pi; /* tautology, and construction */ Int o; Int d; { - Cell ev = scEntail(ps,pi,o,d); - return nonNull(ev) ? ev : + Cell ev = NIL; + +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + int i; + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("entail: ", stdout); + printContext(stdout,copyPreds(ps)); + fputs(" ||- ", stdout); + printPred(stdout, copyPred(pi, o)); + fputc('\n', stdout); + } +#endif + + ev = scEntail(ps,pi,o,d); + if (nonNull(ev)) { +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + int i; + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("scSat.\n", stdout); + } +#endif + } else { + ev = #if MULTI_INST - multiInstRes ? inEntails(ps,pi,o,d) : - inEntail(ps,pi,o,d); + multiInstRes ? inEntails(ps,pi,o,d) : + inEntail(ps,pi,o,d); #else - inEntail(ps,pi,o,d); + inEntail(ps,pi,o,d); #endif +#if EXPLAIN_INSTANCE_RESOLUTION + if (nonNull(ev) && showInstRes) { + int i; + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("inSat.\n", stdout); + } +#endif + } + return ev; } static Cell local inEntail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/ @@ -385,6 +411,12 @@ List ps; /* using a top-level instance */ Cell pi; /* entailment */ Int o; Int d; { + int i; + Inst in; + + if (d++ >= cutoff) + cutoffExceeded(pi,o,ps); + #if TREX if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */ Cell e = fun(pi); @@ -411,16 +443,30 @@ Int d; { } else { #endif - Inst in = findInstFor(pi,o); /* Class predicates */ + in = findInstFor(pi,o); /* Class predicates */ if (nonNull(in)) { Int beta = typeOff; Cell e = inst(in).builder; Cell es = inst(in).specifics; - if (d++ >= cutoff) - cutoffExceeded(pi,o,NIL,0,ps); - for (; nonNull(es); es=tl(es)) { - Cell ev = entail(ps,hd(es),beta,d); +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("try ", stdout); + printContext(stdout, es); + fputs(" => ", stdout); + printPred(stdout, inst(in).head); + fputc('\n', stdout); + } +#endif + /* would need to lift es to triples, so be lazy, and just + use improve1 in the loop */ + /* improve(0,ps,es); */ + for (; nonNull(es); es=tl(es)) { + Cell ev; + improve1(0,ps,hd(es),beta); + ev = entail(ps,hd(es),beta,d); if (nonNull(ev)) e = ap(e,ev); else @@ -428,6 +474,17 @@ Int d; { } return e; } +#if EXPLAIN_INSTANCE_RESOLUTION + else { + if (showInstRes) { + for (i = 0; i < d; i++) + fputc(' ', stdout); + fputs("No instance found for ", stdout); + printPred(stdout, copyPred(pi, o)); + fputc('\n', stdout); + } + } +#endif return NIL; #if TREX } @@ -444,9 +501,11 @@ Int d; { int k = 0; Cell ins; /* Class predicates */ Inst in, in_; - Cell pi_; Cell e_; + if (d++ >= cutoff) + cutoffExceeded(pi,o,ps); + #if TREX if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */ Cell e = fun(pi); @@ -473,16 +532,15 @@ Int d; { } else { #endif - if (d++ >= cutoff) - cutoffExceeded(pi,o,NIL,0,ps); #if EXPLAIN_INSTANCE_RESOLUTION if (showInstRes) { - pi_ = copyPred(pi, o); for (i = 0; i < d; i++) fputc(' ', stdout); fputs("inEntails: ", stdout); - printPred(stdout, pi_); + printContext(stdout,copyPreds(ps)); + fputs(" ||- ", stdout); + printPred(stdout, copyPred(pi, o)); fputc('\n', stdout); } #endif @@ -494,7 +552,6 @@ Int d; { Int beta = fst(hd(ins)); Cell e = inst(in).builder; Cell es = inst(in).specifics; - Cell es_ = es; #if EXPLAIN_INSTANCE_RESOLUTION if (showInstRes) { @@ -645,7 +702,17 @@ List qs; { /* returning equiv minimal subset */ while (0 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; @@ -1460,6 +1536,14 @@ Cell m; { 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); @@ -2004,7 +2088,9 @@ List vs; { 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; } @@ -2024,7 +2110,6 @@ static List local otvarsZonk(pi,os,o) /* same as above, but zonks */ 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); @@ -2101,11 +2186,14 @@ List ps; { 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)) { @@ -2125,10 +2213,13 @@ List ps; { 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 @@ -2550,6 +2641,8 @@ Inst in; { 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" @@ -4887,6 +4980,7 @@ Void checkExp() { /* Top level static check on Expr */ staticAnalysis(RESET); } +#if EXPLAIN_INSTANCE_RESOLUTION Void checkContext(void) { /* Top level static check on Expr */ List vs, qs; @@ -4901,6 +4995,7 @@ Void checkContext(void) { /* Top level static check on Expr */ leaveScope(); staticAnalysis(RESET); } +#endif Void checkDefns() { /* Top level static analysis */ Module thisModule = lastModule(); @@ -4930,6 +5025,7 @@ Void checkDefns() { /* Top level static analysis */ 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 */ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 87f0775..903296e 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.16 $ - * $Date: 1999/11/16 17:38:56 $ + * $Revision: 1.17 $ + * $Date: 1999/11/17 16:57:46 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -714,6 +714,7 @@ Text t; { cclass(classHw).kinds = NIL; cclass(classHw).head = NIL; cclass(classHw).fds = NIL; + cclass(classHw).xfds = NIL; cclass(classHw).dcon = NIL; cclass(classHw).supers = NIL; cclass(classHw).dsels = NIL; @@ -2441,6 +2442,7 @@ Int what; { mark(cclass(i).head); mark(cclass(i).kinds); mark(cclass(i).fds); + mark(cclass(i).xfds); mark(cclass(i).dsels); mark(cclass(i).supers); mark(cclass(i).members); diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index c0560b3..33829fa 100644 --- a/ghc/interpreter/storage.h +++ b/ghc/interpreter/storage.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: storage.h,v $ - * $Revision: 1.12 $ - * $Date: 1999/11/12 17:32:47 $ + * $Revision: 1.13 $ + * $Date: 1999/11/17 16:57:48 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -638,6 +638,7 @@ struct strClass { Int arity; /* Number of arguments */ Kinds kinds; /* Kinds of constructors in class */ List fds; /* Functional Dependencies */ + List xfds; /* Xpanded Functional Dependencies */ Cell head; /* Head of class */ Name dcon; /* Dictionary constructor function */ List supers; /* :: [Pred] */ diff --git a/ghc/interpreter/subst.c b/ghc/interpreter/subst.c index ead1c97..41c32a7 100644 --- a/ghc/interpreter/subst.c +++ b/ghc/interpreter/subst.c @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: subst.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/10/16 02:17:27 $ + * $Revision: 1.8 $ + * $Date: 1999/11/17 16:57:49 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -56,6 +56,7 @@ 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 matchTypeAbove Args((Type,Int,Type,Int,Int)); static Bool local varToVarBind Args((Tyvar *,Tyvar *)); static Bool local varToTypeBind Args((Tyvar *,Type,Int)); @@ -65,9 +66,9 @@ static Int local remover Args((Text,Type,Int)); static Int local tailVar Args((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 instImprove Args((Int,Class,Cell,Int)); +static Bool local pairImprove Args((Int,Class,Cell,Int,Cell,Int,Int)); #if IPARAM static Bool local ipImprove Args((Int,Cell,Int,Cell,Int)); #endif @@ -1418,7 +1419,7 @@ Int o; { /* match is found, then tyvars from*/ } #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*/ @@ -1462,16 +1463,33 @@ List ps; { 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; @@ -1484,8 +1502,13 @@ Int o; { 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); @@ -1494,6 +1517,21 @@ Int o; { return improved; } +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; @@ -1520,101 +1558,66 @@ Int 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); - } - 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; - } + 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; } - } - 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; @@ -1735,6 +1738,19 @@ Int o; { /* and that no vars have been */ 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: * ------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/subst.h b/ghc/interpreter/subst.h index f2de3ae..ffad34f 100644 --- a/ghc/interpreter/subst.h +++ b/ghc/interpreter/subst.h @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: subst.h,v $ - * $Revision: 1.5 $ - * $Date: 1999/10/16 02:17:27 $ + * $Revision: 1.6 $ + * $Date: 1999/11/17 16:57:50 $ * ------------------------------------------------------------------------*/ typedef struct { /* Each type variable contains: */ @@ -109,6 +109,7 @@ extern Bool unifyPred Args((Cell,Int,Cell,Int)); extern Inst findInstFor Args((Cell,Int)); extern Void improve Args((Int,List,List)); +extern Void improve1 Args((Int,List,Cell,Int)); extern Bool sameSchemes Args((Type,Type)); extern Bool sameType Args((Type,Int,Type,Int)); diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index 8f12154..d273849 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: type.c,v $ - * $Revision: 1.12 $ - * $Date: 1999/11/16 17:39:00 $ + * $Revision: 1.13 $ + * $Date: 1999/11/17 16:57:50 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -68,7 +68,6 @@ static Cell local typeExpr Args((Int,Cell)); static Cell local typeAp Args((Int,Cell)); static Type local typeExpected Args((Int,String,Cell,Type,Int,Int,Bool)); -static Type local typeExpected2 Args((Int,String,Cell,Type,Int,Int)); static Void local typeAlt Args((String,Cell,Cell,Type,Int,Int)); static Int local funcType Args((Int)); static Void local typeCase Args((Int,Int,Cell)); @@ -1325,9 +1324,7 @@ Cell e; { /* bizarre manner for the benefit */ static Cell local typeWith(line,e) /* Type check a with */ Int line; Cell e; { - static String update = "with"; List fs = snd(snd(e)); /* List of field specifications */ - List ts = NIL; /* List of types for fields */ Int n = length(fs); Int alpha = newTyvars(2+n); Int i; @@ -1748,7 +1745,6 @@ Class c; { /* defaults for class c */ List defs = cclass(c).defaults; List dsels = cclass(c).dsels; Cell pat = cclass(c).dcon; - Cell args = NIL; Int width = cclass(c).numSupers + cclass(c).numMembers; char buf[FILENAME_MAX+1]; Int i = 0; @@ -1884,9 +1880,29 @@ Inst in; { /* member functions for instance in*/ for (ps=supers; nonNull(ps); ps=tl(ps)) { /* Superclass dictionaries */ Cell pi = hd(ps); - Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0); - if (isNull(ev)) + Cell ev = NIL; +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + fputs("scEntail: ", stdout); + printContext(stdout,copyPreds(params)); + fputs(" ||- ", stdout); + printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi)))); + fputc('\n', stdout); + } +#endif + ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0); + if (isNull(ev)) { +#if EXPLAIN_INSTANCE_RESOLUTION + if (showInstRes) { + fputs("inEntail: ", stdout); + printContext(stdout,copyPreds(evids)); + fputs(" ||- ", stdout); + printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi)))); + fputc('\n', stdout); + } +#endif ev = inEntail(evids,fst3(pi),intOf(snd3(pi)),0); + } if (isNull(ev)) { clearMarks(); ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN diff --git a/ghc/interpreter/version.h b/ghc/interpreter/version.h index b41c05c..8fc3755 100644 --- a/ghc/interpreter/version.h +++ b/ghc/interpreter/version.h @@ -11,8 +11,8 @@ #define MAJOR_RELEASE 0 #if MAJOR_RELEASE -#define HUGS_VERSION "October 1999 " +#define HUGS_VERSION "November 1999 " #else -#define HUGS_VERSION "STGHugs-991115" +#define HUGS_VERSION "STGHugs-991117" #endif