ghc/interpreter/preds.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Part of the type checker dealing with predicates and entailment
   4  *
   5  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   6  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
   7  * Technology, 1994-1999, All rights reserved.  It is distributed as
   8  * free software under the license in the file "License", which is
   9  * included in the distribution.
  10  *
  11  * $RCSfile: preds.c,v $
  12  * $Revision: 1.9 $
  13  * $Date: 1999/11/17 16:57:43 $
  14  * ------------------------------------------------------------------------*/
  15
  16 /* --------------------------------------------------------------------------
  17  * Local function prototypes:
  18  * ------------------------------------------------------------------------*/
  19
  20 static Cell   local assumeEvid        Args((Cell,Int));
  21 #if IPARAM
  22 static Cell   local findIPEvid        Args((Text));
  23 static Void   local removeIPEvid      Args((Text));
  24 #endif
  25 static List   local makePredAss       Args((List,Int));
  26 static List   local copyPreds         Args((List));
  27 static Void   local qualify           Args((List,Cell));
  28 static Void   local qualifyBinding    Args((List,Cell));
  29 static Cell   local qualifyExpr       Args((Int,List,Cell));
  30 static Void   local overEvid          Args((Cell,Cell));
  31
  32 static Void   local cutoffExceeded    Args((Cell,Int,List));
  33 static Cell   local scFind            Args((Cell,Cell,Int,Cell,Int,Int));
  34 static Cell   local scEntail          Args((List,Cell,Int,Int));
  35 static Cell   local entail            Args((List,Cell,Int,Int));
  36 static Cell   local inEntail          Args((List,Cell,Int,Int));
  37 #if MULTI_INST
  38 static Cell   local inEntails         Args((List,Cell,Int,Int));
  39 static Bool   local instCompare       Args((Inst, Inst));
  40 #endif
  41 #if TREX
  42 static Cell   local lacksNorm         Args((Type,Int,Cell));
  43 #endif
  44
  45 static List   local scSimplify        Args((List));
  46 static Void   local elimTauts         Args((Void));
  47 static Bool   local anyGenerics       Args((Type,Int));
  48 static List   local elimOuterPreds    Args((List));
  49 static List   local elimPredsUsing    Args((List,List));
  50 static Void   local reducePreds       Args((Void));
  51 static Void   local normPreds         Args((Int));
  52
  53 static Bool   local resolveDefs       Args((List));
  54 static Bool   local resolveVar        Args((Int));
  55 static Class  local classConstraining Args((Int,Cell,Int));
  56 static Bool   local instComp_         Args((Inst,Inst));
  57
  58 /* --------------------------------------------------------------------------
  59  * Predicate assignments:
  60  *
  61  * A predicate assignment is represented by a list of triples (pi,o,ev)
  62  * where o is the offset for types in pi, with evidence required at the
  63  * node pointed to by ev (which is taken as a dictionary parameter if
  64  * no other evidence is available).  Note that the ev node will be
  65  * overwritten at a later stage if evidence for that predicate is found
  66  * subsequently.
  67  * ------------------------------------------------------------------------*/
  68
  69 static List preds;                      /* Current predicate assignment    */
  70
  71 static Cell local assumeEvid(pi,o)      /* Add predicate pi (offset o) to  */
  72 Cell pi;                                /* preds with new dict var nd      */
  73 Int  o; {
  74     Cell nd = inventDictVar();
  75     preds   = cons(triple(pi,mkInt(o),nd),preds);
  76     return nd;
  77 }
  78
  79 #if IPARAM
  80 static Cell local findIPEvid(t)
  81 Text t; {
  82     List ps = preds;
  83     for (; nonNull(ps); ps=tl(ps)) {
  84         Cell p = hd(ps);
  85         if (ipMatch(fst3(p), t))
  86             return p;
  87     }
  88     return NIL;
  89 }
  90
  91 static Void local removeIPEvid(t)
  92 Text t; {
  93     List ps = preds;
  94     List *prev = &preds;
  95     for (; nonNull(ps); ps = tl(ps))
  96         if (ipMatch(fst3(hd(ps)), t)) {
  97             *prev = tl(ps);
  98             return;
  99         } else {
 100             prev = &tl(ps);
 101         }
 102 }
 103 #endif
 104
 105
 106 static List local makePredAss(qs,o)     /* Make list of predicate assumps. */
 107 List qs;                                /* from qs (offset o), w/ new dict */
 108 Int  o; {                               /* vars for each predicate         */
 109     List result = NIL;
 110     for (; nonNull(qs); qs=tl(qs))
 111         result = cons(triple(hd(qs),mkInt(o),inventDictVar()),result);
 112     return rev(result);
 113 }
 114
 115 static List local copyPreds(qs)         /* Copy list of predicates         */
 116 List qs; {
 117     List result = NIL;
 118     for (; nonNull(qs); qs=tl(qs)) {
 119         Cell pi = hd(qs);
 120         result  = cons(copyPred(fst3(pi),intOf(snd3(pi))),result);
 121     }
 122     return rev(result);
 123 }
 124
 125 static Void local qualify(qs,alt)       /* Add extra dictionary args to    */
 126 List qs;                                /* qualify alt by predicates in qs */
 127 Cell alt; {                             /* :: ([Pat],Rhs)                  */
 128     List ds;
 129     for (ds=NIL; nonNull(qs); qs=tl(qs))
 130         ds = cons(thd3(hd(qs)),ds);
 131     fst(alt) = revOnto(ds,fst(alt));
 132 }
 133
 134 static Void local qualifyBinding(qs,b)  /* Add extra dict args to each     */
 135 List qs;                                /* alternative in function binding */
 136 Cell b ; {
 137     if (!isVar(fst(b)))                 /* check for function binding      */
 138         internal("qualifyBinding");
 139     map1Proc(qualify,qs,snd(snd(b)));
 140 }
 141
 142 static Cell local qualifyExpr(l,ps,e)   /* Add dictionary params to expr   */
 143 Int  l;
 144 List ps;
 145 Cell e; {
 146     if (nonNull(ps)) {                  /* Qualify input expression with   */
 147         if (whatIs(e)!=LAMBDA)          /* additional dictionary params    */
 148             e = ap(LAMBDA,pair(NIL,pair(mkInt(l),e)));
 149         qualify(ps,snd(e));
 150     }
 151     return e;
 152 }
 153
 154 static Void local overEvid(dv,ev)       /* Overwrite dict var dv with      */
 155 Cell dv;                                /* evidence ev                     */
 156 Cell ev; {
 157     fst(dv) = nameInd;
 158     snd(dv) = ev;
 159 }
 160
 161 /* --------------------------------------------------------------------------
 162  * Predicate entailment:
 163  *
 164  * Entailment plays a prominent role in the theory of qualified types, and
 165  * so, unsurprisingly, in the implementation too.  For practical reasons,
 166  * we break down entailment into two pieces.  The first, scEntail, uses
 167  * only the information provided by class declarations, while the second,
 168  * entail, also uses the information in instance declarations.
 169  *
 170  * scEntail uses the following auxiliary function to do its work:
 171  *
 172  *   scFind (e : pi') pi : Find evidence for predicate pi using only
 173  *                           equality of predicates, superclass entailment,
 174  *                           and the evidence e for pi'.
 175  *
 176  *   scFind (e : pi') pi =
 177  *
 178  *      if pi = pi' then
 179  *          return e
 180  *
 181  *      if (pi.class.level < pi'.class.level)
 182  *          get superclass entailment pi' ||- P
 183  *          for each (sc, pi0) in P
 184  *              if (ev := scFind (sc e : pi0) pi) /= NIL
 185  *                  return ev
 186  *
 187  *      return NIL
 188  *
 189  * This code assumes that the class hierarchy is acyclic, and that
 190  * each class has been assigned a `level', which is its height in
 191  * the hierachy.  The first of the assumptions guarantees that the
 192  * algorithm will terminate.  The comparison of levels is an
 193  * optimization that cuts down the search space: given that superclass
 194  * entailments can only be used to descend the hierarchy, there is no
 195  * way we can reach a higher level than the one that we start with,
 196  * and hence there is no point in looking if we reach such a position.
 197  *
 198  * scEntail extends scFind to work on whole predicate assignments:
 199  *
 200  *   scEntail P pi : Find evidence for predicate pi using the evidence
 201  *                   provided by the predicate assignment P, and using
 202  *                   only superclass entailments.
 203  *
 204  *   scEntail P pi =
 205  *
 206  *       for each (v:pi') in P
 207  *           if (ev := scFind (v:pi') pi) /= NIL
 208  *               return ev;
 209  *       return NIL
 210  *
 211  * ------------------------------------------------------------------------*/
 212
 213 Int cutoff = 64;                        /* Used to limit depth of recursion*/
 214
 215 static Void local cutoffExceeded(pi,o,ps)
 216 Cell pi;                                /* Display error msg when cutoff   */
 217 Int  o;
 218 List ps; {
 219     clearMarks();
 220     ERRMSG(0)
 221         "\n*** The type checker has reached the cutoff limit while trying to\n"
 222     ETHEN ERRTEXT
 223         "*** determine whether:\n***     "     ETHEN ERRPRED(copyPred(pi,o));
 224     ps = copyPreds(ps);
 225     ERRTEXT
 226         "\n*** can be deduced from:\n***     " ETHEN ERRCONTEXT(ps);
 227     ERRTEXT
 228         "\n*** This may indicate that the problem is undecidable.  However,\n"
 229     ETHEN ERRTEXT
 230         "*** you may still try to increase the cutoff limit using the -c\n"
 231     ETHEN ERRTEXT
 232         "*** option and then try again.  (The current setting is -c%d)\n",
 233         cutoff
 234     EEND;
 235 }
 236
 237 static Cell local scFind(e,pi1,o1,pi,o,d)/* Use superclass entailment to   */
 238 Cell e;                                 /* find evidence for (pi,o) using  */
 239 Cell pi1;                               /* the evidence e for (pi1,o1).    */
 240 Int  o1;
 241 Cell pi;
 242 Int  o;
 243 Int  d; {
 244     Class h1 = getHead(pi1);
 245     Class h  = getHead(pi);
 246     Cell ev = NIL;
 247
 248     /* the h==h1 test is just an optimization, and I'm not
 249        sure it will work with IPs, so I'm being conservative
 250        and commenting it out */
 251     if (/* h==h1 && */ samePred(pi1,o1,pi,o))
 252         return e;
 253
 254     if (isClass(h1) && (!isClass(h) || cclass(h).level<cclass(h1).level)) {
 255         Int  beta  = newKindedVars(cclass(h1).kinds);
 256         List scs   = cclass(h1).supers;
 257         List dsels = cclass(h1).dsels;
 258         List ps = NIL;
 259         if (!matchPred(pi1,o1,cclass(h1).head,beta))
 260             internal("scFind");
 261
 262         for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels))
 263             ps = cons(triple(hd(scs),mkInt(beta),ap(hd(dsels),e)),ps);
 264         ps = rev(ps);
 265
 266 #if EXPLAIN_INSTANCE_RESOLUTION
 267         if (showInstRes) {
 268             int i;
 269             for (i = 0; i < d; i++)
 270               fputc(' ', stdout);
 271             fputs("scEntail(scFind): ", stdout);
 272             printContext(stdout,copyPreds(ps));
 273             fputs(" ||- ", stdout);
 274             printPred(stdout, copyPred(pi, o));
 275             fputc('\n', stdout);
 276         }
 277 #endif
 278         improve1(0,ps,pi,o);
 279         ev = scEntail(ps,pi,o,d);
 280 #if EXPLAIN_INSTANCE_RESOLUTION
 281         if (showInstRes && nonNull(ev)) {
 282             int i;
 283             for (i = 0; i < d; i++)
 284               fputc(' ', stdout);
 285             fputs("scSat.\n", stdout);
 286         }
 287 #endif
 288         return ev;
 289     }
 290     return NIL;
 291 }
 292
 293 static Cell local scEntail(ps,pi,o,d)   /* Calc evidence for (pi,o) from ps*/
 294 List ps;                                /* Using superclasses and equality.*/
 295 Cell pi;
 296 Int  o;
 297 Int  d; {
 298     if (d++ >= cutoff)
 299         cutoffExceeded(pi,o,ps);
 300
 301     for (; nonNull(ps); ps=tl(ps)) {
 302         Cell pi1 = hd(ps);
 303         Cell ev  = scFind(thd3(pi1),fst3(pi1),intOf(snd3(pi1)),pi,o,d);
 304         if (nonNull(ev))
 305             return ev;
 306     }
 307     return NIL;
 308 }
 309
 310
 311 /* --------------------------------------------------------------------------
 312  * Now we reach the main entailment routine:
 313  *
 314  *   entail P pi : Find evidence for predicate pi using the evidence
 315  *                 provided by the predicate assignment P.
 316  *
 317  *   entail P pi =
 318  *
 319  *       if (ev := scEntail P pi) /= NIL
 320  *           return ev;
 321  *
 322  *       if there is an instance entailment i : Q ||- pi
 323  *           for each pi' in Q
 324  *               if (ev := entail P pi') /= NIL
 325  *                   i := ap(i,ev)
 326  *               else
 327  *                   return NIL
 328  *           return i
 329  *
 330  *       return NIL;
 331  *
 332  * The form of evidence expressions produced by scEntail can be described
 333  * by the grammar:
 334  *
 335  *    e  =  v  |  sc e            (v = evidence var, sc = superclass sel)
 336  *
 337  * while entail extends this to include dictionary expressions given by:
 338  *
 339  *    d  =  e  |  mki d1 ... dn   (mki = dictionary constructor)
 340  *
 341  * A full grammar for evidence expressions is:
 342  *
 343  *    d   =   v   |   sc d   |   mki d1 ... dn
 344  *
 345  * and this includes evidence expressions of the form  sc (mki d1 ... dn)
 346  * that can never be produced by either of the entail functions described
 347  * above.  This is good, from a practical perspective, because t means
 348  * that we won't waste effort building a dictionary (mki d1 ... dn) only
 349  * to extract just one superclass component and throw the rest away.
 350  * Moreover, conditions on instance decls already guarantee that any
 351  * expression of this form can be rewritten in the form  mki' d1' ... dn'.
 352  * (Minor point: they don't guarantee that such rewritings will lead to
 353  * smaller terms, and hence to termination.  However, we have already
 354  * accepted the benefits of an undecidable entailment relation over
 355  * guarantees of termination, and this additional quirk is unlikely
 356  * to cause any further concern, except in pathological cases.)
 357  * ------------------------------------------------------------------------*/
 358
 359 static Cell local entail(ps,pi,o,d)     /* Calc evidence for (pi,o) from ps*/
 360 List ps;                                /* Uses superclasses, equality,    */
 361 Cell pi;                                /* tautology, and construction     */
 362 Int  o;
 363 Int  d; {
 364     Cell ev = NIL;
 365
 366 #if EXPLAIN_INSTANCE_RESOLUTION
 367     if (showInstRes) {
 368         int i;
 369         for (i = 0; i < d; i++)
 370           fputc(' ', stdout);
 371         fputs("entail: ", stdout);
 372         printContext(stdout,copyPreds(ps));
 373         fputs(" ||- ", stdout);
 374         printPred(stdout, copyPred(pi, o));
 375         fputc('\n', stdout);
 376     }
 377 #endif
 378
 379     ev = scEntail(ps,pi,o,d);
 380     if (nonNull(ev)) {
 381 #if EXPLAIN_INSTANCE_RESOLUTION
 382         if (showInstRes) {
 383             int i;
 384             for (i = 0; i < d; i++)
 385               fputc(' ', stdout);
 386             fputs("scSat.\n", stdout);
 387         }
 388 #endif
 389     } else {
 390         ev =
 391 #if MULTI_INST
 392              multiInstRes ? inEntails(ps,pi,o,d) :
 393                             inEntail(ps,pi,o,d);
 394 #else
 395              inEntail(ps,pi,o,d);
 396 #endif
 397 #if EXPLAIN_INSTANCE_RESOLUTION
 398         if (nonNull(ev) && showInstRes) {
 399             int i;
 400             for (i = 0; i < d; i++)
 401               fputc(' ', stdout);
 402             fputs("inSat.\n", stdout);
 403         }
 404 #endif
 405     }
 406     return ev;
 407 }
 408
 409 static Cell local inEntail(ps,pi,o,d)   /* Calc evidence for (pi,o) from ps*/
 410 List ps;                                /* using a top-level instance      */
 411 Cell pi;                                /* entailment                      */
 412 Int  o;
 413 Int  d; {
 414     int i;
 415     Inst in;
 416
 417     if (d++ >= cutoff)
 418         cutoffExceeded(pi,o,ps);
 419
 420 #if TREX
 421     if (isAp(pi) && isExt(fun(pi))) {   /* Lacks predicates                */
 422         Cell e  = fun(pi);
 423         Cell l;
 424         l  = lacksNorm(arg(pi),o,e);
 425         if (isNull(l) || isInt(l))
 426             return l;
 427         else {
 428             List qs = ps;
 429             for (; nonNull(qs); qs=tl(qs)) {
 430                 Cell qi = fst3(hd(qs));
 431                 if (isAp(qi) && fun(qi)==e) {
 432                     Cell lq = lacksNorm(arg(qi),intOf(snd3(hd(qs))),e);
 433                     if (isAp(lq) && intOf(fst(l))==intOf(fst(lq))) {
 434                         Int f = intOf(snd(l)) - intOf(snd(lq));
 435                         return (f==0) ? thd3(hd(qs)) : ap2(nameAddEv,
 436                                                            mkInt(f),
 437                                                            thd3(hd(qs)));
 438                     }
 439                 }
 440             }
 441             return NIL;
 442         }
 443     }
 444     else {
 445 #endif
 446
 447     in = findInstFor(pi,o);     /* Class predicates                */
 448     if (nonNull(in)) {
 449         Int  beta = typeOff;
 450         Cell e    = inst(in).builder;
 451         Cell es   = inst(in).specifics;
 452 #if EXPLAIN_INSTANCE_RESOLUTION
 453         if (showInstRes) {
 454             for (i = 0; i < d; i++)
 455               fputc(' ', stdout);
 456             fputs("try ", stdout);
 457             printContext(stdout, es);
 458             fputs(" => ", stdout);
 459             printPred(stdout, inst(in).head);
 460             fputc('\n', stdout);
 461         }
 462 #endif
 463         /* would need to lift es to triples, so be lazy, and just
 464            use improve1 in the loop */
 465         /* improve(0,ps,es); */
 466         for (; nonNull(es); es=tl(es)) {
 467             Cell ev;
 468             improve1(0,ps,hd(es),beta);
 469             ev = entail(ps,hd(es),beta,d);
 470             if (nonNull(ev))
 471                 e = ap(e,ev);
 472             else
 473                 return NIL;
 474         }
 475         return e;
 476     }
 477 #if EXPLAIN_INSTANCE_RESOLUTION
 478       else {
 479         if (showInstRes) {
 480             for (i = 0; i < d; i++)
 481               fputc(' ', stdout);
 482             fputs("No instance found for ", stdout);
 483             printPred(stdout, copyPred(pi, o));
 484             fputc('\n', stdout);
 485         }
 486     }
 487 #endif
 488     return NIL;
 489 #if TREX
 490     }
 491 #endif
 492 }
 493
 494 #if MULTI_INST
 495 static Cell local inEntails(ps,pi,o,d)  /* Calc evidence for (pi,o) from ps*/
 496 List ps;                                /* using a top-level instance      */
 497 Cell pi;                                /* entailment                      */
 498 Int  o;
 499 Int  d; {
 500     int i;
 501     int k = 0;
 502     Cell ins;                           /* Class predicates                */
 503     Inst in, in_;
 504     Cell e_;
 505
 506     if (d++ >= cutoff)
 507         cutoffExceeded(pi,o,ps);
 508
 509 #if TREX
 510     if (isAp(pi) && isExt(fun(pi))) {   /* Lacks predicates                */
 511         Cell e  = fun(pi);
 512         Cell l;
 513         l  = lacksNorm(arg(pi),o,e);
 514         if (isNull(l) || isInt(l))
 515             return l;
 516         else {
 517             List qs = ps;
 518             for (; nonNull(qs); qs=tl(qs)) {
 519                 Cell qi = fst3(hd(qs));
 520                 if (isAp(qi) && fun(qi)==e) {
 521                     Cell lq = lacksNorm(arg(qi),intOf(snd3(hd(qs))),e);
 522                     if (isAp(lq) && intOf(fst(l))==intOf(fst(lq))) {
 523                         Int f = intOf(snd(l)) - intOf(snd(lq));
 524                         return (f==0) ? thd3(hd(qs)) : ap2(nameAddEv,
 525                                                            mkInt(f),
 526                                                            thd3(hd(qs)));
 527                     }
 528                 }
 529             }
 530             return NIL;
 531         }
 532     }
 533     else {
 534 #endif
 535
 536 #if EXPLAIN_INSTANCE_RESOLUTION
 537     if (showInstRes) {
 538         for (i = 0; i < d; i++)
 539           fputc(' ', stdout);
 540         fputs("inEntails: ", stdout);
 541         printContext(stdout,copyPreds(ps));
 542         fputs(" ||- ", stdout);
 543         printPred(stdout, copyPred(pi, o));
 544         fputc('\n', stdout);
 545     }
 546 #endif
 547
 548     ins = findInstsFor(pi,o);
 549     for (; nonNull(ins); ins=tl(ins)) {
 550         in = snd(hd(ins));
 551         if (nonNull(in)) {
 552             Int  beta = fst(hd(ins));
 553             Cell e    = inst(in).builder;
 554             Cell es   = inst(in).specifics;
 555
 556 #if EXPLAIN_INSTANCE_RESOLUTION
 557             if (showInstRes) {
 558                 for (i = 0; i < d; i++)
 559                   fputc(' ', stdout);
 560                 fputs("try ", stdout);
 561                 printContext(stdout, es);
 562                 fputs(" => ", stdout);
 563                 printPred(stdout, inst(in).head);
 564                 fputc('\n', stdout);
 565             }
 566 #endif
 567
 568             for (; nonNull(es); es=tl(es)) {
 569                 Cell ev = entail(ps,hd(es),beta,d);
 570                 if (nonNull(ev))
 571                     e = ap(e,ev);
 572                 else {
 573                     e = NIL;
 574                     break;
 575                 }
 576             }
 577 #if EXPLAIN_INSTANCE_RESOLUTION
 578             if (showInstRes)
 579                 for (i = 0; i < d; i++)
 580                   fputc(' ', stdout);
 581 #endif
 582             if (nonNull(e)) {
 583 #if EXPLAIN_INSTANCE_RESOLUTION
 584                 if (showInstRes)
 585                     fprintf(stdout, "Sat\n");
 586 #endif
 587                 if (k > 0) {
 588                     if (instCompare (in_, in)) {
 589                         ERRMSG(0) "Multiple satisfiable instances for "
 590                         ETHEN
 591                         ERRPRED(copyPred(pi, o));
 592                         ERRTEXT "\nin_ " ETHEN ERRPRED(inst(in_).head);
 593                         ERRTEXT "\nin  " ETHEN ERRPRED(inst(in).head);
 594                         ERRTEXT "\n"
 595                         EEND;
 596                     }
 597                 }
 598                 if (k++ == 0) {
 599                     e_ = e;
 600                     in_ = in;
 601                 }
 602                 continue;
 603             } else {
 604 #if EXPLAIN_INSTANCE_RESOLUTION
 605                 if (showInstRes)
 606                     fprintf(stdout, "not Sat\n");
 607 #endif
 608                 continue;
 609             }
 610         }
 611 #if EXPLAIN_INSTANCE_RESOLUTION
 612         if (showInstRes) {
 613             for (i = 0; i < d; i++)
 614               fputc(' ', stdout);
 615             fprintf(stdout, "not Sat.\n");
 616         }
 617 #endif
 618     }
 619     if (k > 0)
 620         return e_;
 621 #if EXPLAIN_INSTANCE_RESOLUTION
 622     if (showInstRes) {
 623         for (i = 0; i < d; i++)
 624           fputc(' ', stdout);
 625         fprintf(stdout, "all not Sat.\n");
 626     }
 627 #endif
 628     return NIL;
 629 #if TREX
 630     }
 631 #endif
 632 }
 633
 634 static Bool local instComp_(ia,ib)      /* See if ia is an instance of ib  */
 635 Inst ia, ib;{
 636     Int alpha = newKindedVars(inst(ia).kinds);
 637     Int beta  = newKindedVars(inst(ib).kinds);
 638     return matchPred(inst(ia).head,alpha,inst(ib).head,beta);
 639 }
 640
 641 static Bool local instCompare (ia, ib)
 642 Inst ia, ib;
 643 {
 644     return instComp_(ia, ib) && instComp_(ib, ia);
 645 }
 646 #endif
 647
 648 Cell provePred(ks,ps,pi)                /* Find evidence for predicate pi  */
 649 Kinds ks;                               /* assuming ps.  If ps is null,    */
 650 List  ps;                               /* then we get to decide whether   */
 651 Cell  pi; {                             /* is tautological, and we can use */
 652     Int  beta;                          /* the evidence as a dictionary.   */
 653     Cell ev;
 654     emptySubstitution();
 655     beta = newKindedVars(ks);           /* (ks provides kinds for any      */
 656     ps   = makePredAss(ps,beta);        /*  vars that appear in pi.)       */
 657     ev   = entail(ps,pi,beta,0);
 658     emptySubstitution();
 659     return ev;
 660 }
 661
 662 #if TREX
 663 static Cell local lacksNorm(t,o,e)      /* Normalize lacks pred (t,o)\l    */
 664 Type t;                                 /* returning NIL (unsatisfiable),  */
 665 Int  o;                                 /* Int (tautological) or pair (v,a)*/
 666 Cell e; {                               /* such that, if e is evid for v\l,*/
 667     Text l = extText(e);                /* then (e+a) is evid for (t,o)\l. */
 668     Int  a = 0;
 669     for (;;) {
 670         Tyvar *tyv;
 671         deRef(tyv,t,o);
 672         if (tyv)
 673             return pair(mkInt(tyvNum(tyv)),mkInt(a));
 674         else {
 675             Cell h = getDerefHead(t,o);
 676             if (h==typeNoRow && argCount==0)
 677                 return mkInt(a);
 678             else if (isExt(h) && argCount==2) {
 679                 Text l1 = extText(h);
 680                 if (l1==l)
 681                     return NIL;
 682                 else if (strcmp(textToStr(l1),textToStr(l))<0)
 683                     a++;
 684                 t = arg(t);
 685             }
 686             else
 687                 return NIL;
 688         }
 689     }
 690 }
 691 #endif
 692
 693 /* --------------------------------------------------------------------------
 694  * Predicate set Simplification:
 695  *
 696  * Calculate a minimal equivalent subset of a given set of predicates.
 697  * ------------------------------------------------------------------------*/
 698
 699 static List local scSimplify(qs)        /* Simplify predicates in qs,      */
 700 List qs; {                              /* returning equiv minimal subset  */
 701     Int n = length(qs);
 702
 703     while (0<n--) {
 704         Cell pi = hd(qs);
 705         Cell ev = NIL;
 706 #if EXPLAIN_INSTANCE_RESOLUTION
 707         if (showInstRes) {
 708             fputs("scSimplify: ", stdout);
 709             printContext(stdout,copyPreds(tl(qs)));
 710             fputs(" ||- ", stdout);
 711             printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
 712             fputc('\n', stdout);
 713         }
 714 #endif
 715         ev = scEntail(tl(qs),fst3(pi),intOf(snd3(pi)),0);
 716         if (nonNull(ev)) {
 717             overEvid(thd3(pi),ev);      /* Overwrite dict var with evidence*/
 718             qs      = tl(qs);           /* ... and discard predicate       */
 719         }
 720         else {                          /* Otherwise, retain predicate     */
 721             Cell tmp = tl(qs);
 722             tl(qs)   = NIL;
 723             qs       = appendOnto(tmp,qs);
 724         }
 725     }
 726     return qs;
 727 }
 728
 729 List simpleContext(ps,o)                /* Simplify context of skeletons   */
 730 List ps;                                /* skeletons, offset o, using      */
 731 Int  o; {                               /* superclass hierarchy            */
 732     return copyPreds(scSimplify(makePredAss(ps,o)));
 733 }
 734
 735 /* --------------------------------------------------------------------------
 736  * Context splitting --- tautological and locally tautological predicates:
 737  * ------------------------------------------------------------------------*/
 738
 739 static Void local elimTauts() {         /* Remove tautological constraints */
 740     if (haskell98) {                    /* from preds                      */
 741         reducePreds();                  /* (or context reduce for Hask98)  */
 742     } else {
 743         List ps = preds;
 744         preds   = NIL;
 745         while (nonNull(ps)) {
 746             Cell pi = hd(ps);
 747             Cell ev = entail(NIL,fst3(pi),intOf(snd3(pi)),0);
 748             if (nonNull(ev)) {
 749                 overEvid(thd3(pi),ev);
 750                 ps = tl(ps);
 751             }
 752             else {
 753                 List tmp = tl(ps);
 754                 tl(ps)   = preds;
 755                 preds    = ps;
 756                 ps           = tmp;
 757             }
 758         }
 759     }
 760 }
 761
 762 static Int numFixedVars = 0;            /* Number of fixed vars found      */
 763
 764 static Bool local anyGenerics(t,o)      /* Test for generic vars, and count*/
 765 Type t;                                 /* fixed variables                 */
 766 Int  o; {
 767     Type h = getDerefHead(t,o);         /* This code is careful to expand  */
 768     Int  a = argCount;                  /* synonyms; mark* & copy* do not. */
 769     if (isSynonym(h) && a>=tycon(h).arity) {
 770         expandSyn(h,a,&t,&o);
 771         return anyGenerics(t,o);
 772     }
 773     else {
 774         Tyvar* tyv;
 775         for (; 0<a--; t=fun(t)) {       /* cycle through any arguments     */
 776             deRef(tyv,t,o);
 777             if (anyGenerics(arg(t),o))
 778                 return TRUE;
 779         }
 780         deRef(tyv,t,o);
 781         if (tyv) {
 782             if (tyv->offs == FIXED_TYVAR) {
 783                 numFixedVars++;
 784                 return FALSE;
 785             }
 786             else
 787                 return TRUE;
 788         }
 789         else
 790             return FALSE;
 791     }
 792 }
 793
 794 static List local elimOuterPreds(sps)   /* Simplify and defer any remaining*/
 795 List sps; {                             /* preds that contain no generics. */
 796     List qs = NIL;
 797     elimTauts();
 798     for (preds=scSimplify(preds); nonNull(preds); ) {
 799         Cell pi = hd(preds);
 800         Cell nx = tl(preds);
 801         if (anyGenerics(fst3(pi),intOf(snd3(pi)))
 802             || !isAp(fst3(pi))
 803             || isIP(fun(fst3(pi)))) {
 804             tl(preds) = qs;                             /* Retain predicate*/
 805             qs        = preds;
 806         }
 807         else {                                          /* Defer predicate */
 808             tl(preds) = sps;
 809             sps       = preds;
 810         }
 811         preds = nx;
 812     }
 813     preds = qs;
 814     return sps;
 815 }
 816
 817 static List local elimPredsUsing(ps,sps)/* Try to discharge or defer preds,*/
 818 List ps;                                /* splitting if necessary to match */
 819 List sps; {                             /* context ps.  sps = savePreds.   */
 820     List rems = NIL;
 821     while (nonNull(preds)) {            /* Pick a predicate from preds     */
 822         Cell p  = preds;
 823         Cell pi = fst3(hd(p));
 824         Int  o  = intOf(snd3(hd(p)));
 825         Cell ev = entail(ps,pi,o,0);
 826         preds   = tl(preds);
 827
 828         if (nonNull(ev)) {              /* Discharge if ps ||- (pi,o)      */
 829             overEvid(thd3(hd(p)),ev);
 830         } else if (!isAp(pi) || isIP(fun(pi)) || !anyGenerics(pi,o)) {
 831             tl(p) = sps;                /* Defer if no generics            */
 832             sps   = p;
 833         }
 834         else {                          /* Try to split generics and fixed */
 835             Inst in;
 836             if (numFixedVars>0 && nonNull(in=findInstFor(pi,o))) {
 837                 List qs = inst(in).specifics;
 838                 for (ev=inst(in).builder; nonNull(qs); qs=tl(qs))
 839                     ev = ap(ev,assumeEvid(hd(qs),typeOff));
 840                 overEvid(thd3(hd(p)),ev);
 841             }
 842             else {                      /* No worthwhile progress possible */
 843                 tl(p) = rems;
 844                 rems  = p;
 845             }
 846         }
 847     }
 848     preds = rems;                       /* Return any remaining predicates */
 849     return sps;
 850 }
 851
 852 static Void local reducePreds() {       /* Context reduce predicates: uggh!*/
 853     List rems = NIL;                    /* (A last resort for defaulting)  */
 854     while (nonNull(preds)) {            /* Pick a predicate from preds     */
 855         Cell p  = preds;
 856         Cell pi = fst3(hd(p));
 857         Int  o  = intOf(snd3(hd(p)));
 858         Inst in = NIL;
 859 #if MULTI_INST
 860         List ins = NIL;
 861         if (multiInstRes) {
 862             ins = findInstsFor(pi,o);
 863             in = nonNull(ins) && isNull(tl(ins)) ? snd(hd(ins)) : NIL;
 864         } else
 865 #endif
 866         in = findInstFor(pi,o);
 867         preds   = tl(preds);
 868         if (nonNull(in)) {
 869             List qs = inst(in).specifics;
 870             Cell ev = inst(in).builder;
 871             for (; nonNull(qs); qs=tl(qs))
 872                 ev = ap(ev,assumeEvid(hd(qs),typeOff));
 873             overEvid(thd3(hd(p)),ev);
 874         }
 875         else {                          /* No worthwhile progress possible */
 876             tl(p) = rems;
 877             rems  = p;
 878         }
 879     }
 880     preds = scSimplify(rems);           /* Return any remaining predicates */
 881 }
 882
 883 static Void local normPreds(line)       /* Normalize each element of preds */
 884 Int line; {                             /* in some appropriate manner      */
 885 #if TREX
 886     List ps = preds;
 887     List pr = NIL;
 888     while (nonNull(ps)) {
 889         Cell pi = fst3(hd(ps));
 890         Cell ev = thd3(hd(ps));
 891         if (isAp(pi) && isExt(fun(pi))) {
 892             Cell r = lacksNorm(arg(pi),intOf(snd3(hd(ps))),fun(pi));
 893             if (isNull(r)) {
 894                 ERRMSG(line) "Cannot satisfy constraint " ETHEN
 895                 ERRPRED(copyPred(pi,intOf(snd3(hd(ps)))));
 896                 ERRTEXT      "\n"
 897                 EEND;
 898             }
 899             else if (isInt(r)) {
 900                 overEvid(ev,r);
 901                 ps = tl(ps);
 902                 if (isNull(pr))
 903                     preds  = ps;
 904                 else
 905                     tl(pr) = ps;
 906             }
 907             else if (intOf(snd(r))!=0) {
 908                 Cell nd  = inventDictVar();
 909                 Cell ev1 = ap2(nameAddEv,snd(r),nd);
 910                 pi       = ap(fun(pi),aVar);
 911                 hd(ps)   = triple(pi,fst(r),nd);
 912                 overEvid(ev,ev1);
 913                 pr       = ps;
 914                 ps       = tl(ps);
 915             }
 916             else {
 917                 fst3(hd(ps)) = ap(fun(pi),fst(r));
 918                 pr = ps;
 919                 ps = tl(ps);
 920             }
 921         }
 922         else {
 923             pr = ps;
 924             ps = tl(ps);
 925         }
 926     }
 927 #endif
 928 }
 929
 930 /* --------------------------------------------------------------------------
 931  * Mechanisms for dealing with defaults:
 932  * ------------------------------------------------------------------------*/
 933
 934 static Bool local resolveDefs(vs)       /* Attempt to resolve defaults  */
 935 List vs; {                              /* for variables vs subject to  */
 936     List pvs       = NIL;               /* constraints in preds         */
 937     List qs        = preds;
 938     Bool defaulted = FALSE;
 939
 940 #ifdef DEBUG_DEFAULTS
 941     Printf("Attempt to resolve variables ");
 942     printExp(stdout,vs);
 943     Printf(" with context ");
 944     printContext(stdout,copyPreds(preds));
 945     Printf("\n");
 946 #endif
 947
 948     resetGenerics();                    /* find type variables in ps    */
 949     for (; nonNull(qs); qs=tl(qs)) {
 950         Cell pi = fst3(hd(qs));
 951         Int  o  = intOf(snd3(hd(qs)));
 952         for (; isAp(pi); pi=fun(pi))
 953             pvs = genvarType(arg(pi),o,pvs);
 954     }
 955
 956     for (; nonNull(pvs); pvs=tl(pvs)) { /* now try defaults             */
 957         Int vn = intOf(hd(pvs));
 958
 959 #ifdef DEBUG_DEFAULTS
 960         Printf("is var %d included in ",vn);
 961         printExp(stdout,vs);
 962         Printf("?\n");
 963 #endif
 964
 965         if (!intIsMember(vn,vs))
 966             defaulted |= resolveVar(vn);
 967 #ifdef DEBUG_DEFAULTS
 968         else
 969             Printf("Yes, so no ambiguity!\n");
 970 #endif
 971     }
 972
 973     return defaulted;
 974 }
 975
 976 static Bool local resolveVar(vn)        /* Determine whether an ambig.  */
 977 Int  vn; {                              /* variable vn can be resolved  */
 978     List ps        = preds;             /* by default in the context of */
 979     List cs        = NIL;               /* the predicates in ps         */
 980     Bool aNumClass = FALSE;
 981
 982     if (tyvar(vn)->bound == SKOLEM)
 983         return FALSE;
 984
 985     /* According to the Haskell definition, we can only default an ambiguous
 986      * variable if the set of classes that constrain it:
 987      *   (a) includes at least one numeric class.
 988      *   (b) includes only numeric or standard classes.
 989      * In addition, we will not allow a variable to be defaulted unless it
 990      * appears only in predicates of the form (Class var).
 991      */
 992
 993 #ifdef DEBUG_DEFAULTS
 994     Printf("Trying to default variable %d\n",vn);
 995 #endif
 996
 997     for (; nonNull(ps); ps=tl(ps)) {
 998         Cell  pi = hd(ps);
 999         Class c  = classConstraining(vn,fst3(pi),intOf(snd3(pi)));
1000         if (nonNull(c)) {
1001             if (c==classRealFrac   || c==classRealFloat ||
1002                 c==classFractional || c==classFloating  ||
1003                 c==classReal       || c==classIntegral  || c==classNum)
1004                 aNumClass = TRUE;
1005             else if (c!=classEq    && c!=classOrd  && c!=classShow &&
1006                      c!=classRead  && c!=classIx   && c!=classEnum &&
1007                      c!=classBounded)
1008                 return FALSE;
1009
1010             {   Type  t = arg(fst3(pi));/* Check for single var as arg     */
1011                 Int   o = intOf(snd3(pi));
1012                 Tyvar *tyv;
1013                 deRef(tyv,t,o);
1014                 if (!tyv || tyvNum(tyv)!=vn)
1015                     return FALSE;
1016             }
1017             if (!cellIsMember(c,cs))
1018                 cs = cons(c,cs);
1019         }
1020     }
1021
1022     /* Now find the first class (if any) in the list of defaults that
1023      * is an instance of all of the required classes.
1024      *
1025      * If we get this far, then cs only mentions classes from the list
1026      * above, all of which have only a single parameter of kind *.
1027      */
1028
1029     if (aNumClass) {
1030         List ds = defaultDefns;         /* N.B. guaranteed to be monotypes */
1031 #ifdef DEBUG_DEFAULTS
1032         Printf("Default conditions met, looking for type\n");
1033 #endif
1034         for (; nonNull(ds); ds=tl(ds)) {
1035             List cs1 = cs;
1036             while (nonNull(cs1) && nonNull(entail(NIL,ap(hd(cs1),hd(ds)),0,0)))
1037                 cs1 = tl(cs1);
1038             if (isNull(cs1)) {
1039                 bindTv(vn,hd(ds),0);
1040 #ifdef DEBUG_DEFAULTS
1041                 Printf("Default type for variable %d is ",vn);
1042                 printType(stdout,hd(ds));
1043                 Printf("\n");
1044 #endif
1045                 return TRUE;
1046             }
1047         }
1048     }
1049
1050 #ifdef DEBUG_DEFAULTS
1051     Printf("No default permitted/found\n");
1052 #endif
1053     return FALSE;
1054 }
1055
1056 static Class local classConstraining(vn,pi,o)
1057 Int  vn;                                /* Return class constraining var*/
1058 Cell pi;                                /* vn in predicate pi, or NIL if*/
1059 Int  o; {                               /* vn is not involved           */
1060     for (; isAp(pi); pi=fun(pi))
1061         if (!doesntOccurIn(tyvar(vn),arg(pi),o))
1062             return getHead(pi);
1063     return NIL;
1064 }
1065
1066 /*-------------------------------------------------------------------------*/