[project @ 2000-05-12 16:03:04 by sewardj]

[ghc-hetmet.git] / ghc / interpreter / preds.c

diff --git a/ghc/interpreter/preds.c b/ghc/interpreter/preds.c
index c41ed5c..7c5a7a8 100644 (file)
--- a/ghc/interpreter/preds.c
+++ b/ghc/interpreter/preds.c
@@ -9,51 +9,51 @@
  * included in the distribution.
  *
  * $RCSfile: preds.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/11/17 16:57:43 $
+ * $Revision: 1.11 $
+ * $Date: 2000/03/13 11:37:16 $
  * ------------------------------------------------------------------------*/
 
 /* --------------------------------------------------------------------------
  * Local function prototypes:
  * ------------------------------------------------------------------------*/
 
-static Cell   local assumeEvid        Args((Cell,Int));
+static Cell   local assumeEvid        ( Cell,Int );
 #if IPARAM
-static Cell   local findIPEvid       Args((Text));
-static Void   local removeIPEvid      Args((Text));
+static Cell   local findIPEvid       ( Text );
+static Void   local removeIPEvid      ( Text );
 #endif
-static List   local makePredAss       Args((List,Int));
-static List   local copyPreds         Args((List));
-static Void   local qualify           Args((List,Cell));
-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,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));
-static Cell   local inEntail          Args((List,Cell,Int,Int));
+static List   local makePredAss       ( List,Int );
+static List   local copyPreds         ( List );
+static Void   local qualify           ( List,Cell );
+static Void   local qualifyBinding    ( List,Cell );
+static Cell   local qualifyExpr       ( Int,List,Cell );
+static Void   local overEvid          ( Cell,Cell );
+
+static Void   local cutoffExceeded    ( Cell,Int,List );
+static Cell   local scFind            ( Cell,Cell,Int,Cell,Int,Int );
+static Cell   local scEntail          ( List,Cell,Int,Int );
+static Cell   local entail            ( List,Cell,Int,Int );
+static Cell   local inEntail          ( List,Cell,Int,Int );
 #if MULTI_INST
-static Cell   local inEntails        Args((List,Cell,Int,Int));
-static Bool   local instCompare              Args((Inst, Inst));
+static Cell   local inEntails        ( List,Cell,Int,Int );
+static Bool   local instCompare              ( Inst, Inst );
 #endif
 #if TREX
-static Cell   local lacksNorm         Args((Type,Int,Cell));
+static Cell   local lacksNorm         ( Type,Int,Cell );
 #endif
 
-static List   local scSimplify        Args((List));
-static Void   local elimTauts         Args((Void));
-static Bool   local anyGenerics       Args((Type,Int));
-static List   local elimOuterPreds    Args((List));
-static List   local elimPredsUsing    Args((List,List));
-static Void   local reducePreds       Args((Void));
-static Void   local normPreds         Args((Int));
+static List   local scSimplify        ( List );
+static Void   local elimTauts         ( Void );
+static Bool   local anyGenerics       ( Type,Int );
+static List   local elimOuterPreds    ( List );
+static List   local elimPredsUsing    ( List,List );
+static Void   local reducePreds       ( Void );
+static Void   local normPreds         ( Int );
 
-static Bool   local resolveDefs       Args((List));
-static Bool   local resolveVar        Args((Int));
-static Class  local classConstraining Args((Int,Cell,Int));
-static Bool   local instComp_         Args((Inst,Inst));
+static Bool   local resolveDefs       ( List );
+static Bool   local resolveVar        ( Int );
+static Class  local classConstraining ( Int,Cell,Int );
+static Bool   local instComp_         ( Inst,Inst );
 
 /* --------------------------------------------------------------------------
  * Predicate assignments:
@@ -448,24 +448,25 @@ Int  d; {
     if (nonNull(in)) {
         Int  beta = typeOff;
         Cell e    = inst(in).builder;
-        Cell es   = inst(in).specifics;
+       List es   = inst(in).specifics;
+       List fs   = NIL;
+       for (; nonNull(es); es=tl(es))
+           fs = cons(triple(hd(es),mkInt(beta),NIL),fs);
+       fs = rev(fs);
+       improve(0,ps,fs);
 #if EXPLAIN_INSTANCE_RESOLUTION
        if (showInstRes) {
            for (i = 0; i < d; i++)
              fputc(' ', stdout);
            fputs("try ", stdout);
-           printContext(stdout, es);
+           printContext(stdout, copyPreds(fs));
            fputs(" => ", stdout);
-           printPred(stdout, inst(in).head);
+           printPred(stdout, copyPred(inst(in).head,beta));
            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)) {
+       for (es=inst(in).specifics; 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);
@@ -827,7 +828,10 @@ List sps; {                             /* context ps.  sps = savePreds.   */
 
        if (nonNull(ev)) {              /* Discharge if ps ||- (pi,o)      */
             overEvid(thd3(hd(p)),ev);
-       } else if (!isAp(pi) || isIP(fun(pi)) || !anyGenerics(pi,o)) {
+       } else if (isIP(fun(pi))) {
+           tl(p) = rems;
+           rems  = p;
+       } else if (!isAp(pi) || !anyGenerics(pi,o)) {
            tl(p) = sps;                /* Defer if no generics            */
             sps   = p;
         }