X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftype.c;h=05501a6233b72391adcf6940939f56cff290c4d3;hb=891e78b3ac7f865055203fd6d14f26809f749ec9;hp=ff794f734939f79fb867ff04de49fb710d8f3d99;hpb=820f09b2c2550f88aa0192442c1c62bb00d62d38;p=ghc-hetmet.git

diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c
index ff794f7..05501a6 100644
--- a/ghc/interpreter/type.c
+++ b/ghc/interpreter/type.c
@@ -2,23 +2,23 @@
 /* --------------------------------------------------------------------------
  * This is the Hugs type checker
  *
- * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
- * Haskell Group 1994-99, and is distributed as Open Source software
- * under the Artistic License; see the file "Artistic" that is included
- * in the distribution for details.
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved.  It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
  *
  * $RCSfile: type.c,v $
- * $Revision: 1.7 $
- * $Date: 1999/06/07 17:22:31 $
+ * $Revision: 1.35 $
+ * $Date: 2000/04/27 16:35:30 $
  * ------------------------------------------------------------------------*/
 
-#include "prelude.h"
+#include "hugsbasictypes.h"
 #include "storage.h"
-#include "backend.h"
 #include "connect.h"
-#include "link.h"
 #include "errors.h"
-#include "subst.h"
+
+#include "Rts.h"       /* to make StgPtr visible in Assembler.h */
 #include "Assembler.h" /* for AsmCTypes */
 
 /*#define DEBUG_TYPES*/
@@ -27,84 +27,82 @@
 /*#define DEBUG_SELS*/
 /*#define DEBUG_DEPENDS*/
 /*#define DEBUG_DERIVING*/
-/*#define DEBUG_CODE*/
-
-Bool catchAmbigs       = FALSE;         /* TRUE => functions with ambig.   */
-                                        /*         types produce error     */
-
 
 /* --------------------------------------------------------------------------
  * Local function prototypes:
  * ------------------------------------------------------------------------*/
 
-static Void   local emptyAssumption   Args((Void));
-static Void   local enterBindings     Args((Void));
-static Void   local leaveBindings     Args((Void));
-static Int    local defType           Args((Cell));
-static Type   local useType           Args((Cell));
-static Void   local markAssumList     Args((List));
-static Cell   local findAssum         Args((Text));
-static Pair   local findInAssumList   Args((Text,List));
-static List   local intsIntersect     Args((List,List));
-static List   local genvarAllAss      Args((List));
-static List   local genvarAnyAss      Args((List));
-static Int    local newVarsBind       Args((Cell));
-static Void   local newDefnBind       Args((Cell,Type));
-
-static Void   local enterPendingBtyvs Args((Void));
-static Void   local leavePendingBtyvs Args((Void));
-static Cell   local patBtyvs          Args((Cell));
-static Void   local doneBtyvs         Args((Int));
-static Void   local enterSkolVars     Args((Void));
-static Void   local leaveSkolVars     Args((Int,Type,Int,Int));
-
-static Void   local typeError         Args((Int,Cell,Cell,String,Type,Int));
-static Void   local reportTypeError   Args((Int,Cell,Cell,String,Type,Type));
-static Void   local cantEstablish     Args((Int,String,Cell,Type,List));
-static Void   local tooGeneral        Args((Int,Cell,Type,Type));
-
-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 Void   local typeAlt           Args((String,Cell,Cell,Type,Int,Int));
-static Int    local funcType          Args((Int));
-static Void   local typeCase          Args((Int,Int,Cell));
-static Void   local typeComp          Args((Int,Type,Cell,List));
-static Cell   local typeMonadComp     Args((Int,Cell));
-static Void   local typeDo            Args((Int,Cell));
-static Void   local typeConFlds       Args((Int,Cell));
-static Void   local typeUpdFlds       Args((Int,Cell));
-static Cell   local typeFreshPat      Args((Int,Cell));
-
-static Void   local typeBindings      Args((List));
-static Void   local removeTypeSigs    Args((Cell));
-
-static Void   local monorestrict      Args((List));
-static Void   local restrictedBindAss Args((Cell));
-static Void   local restrictedAss     Args((Int,Cell,Type));
-
-static Void   local unrestricted      Args((List));
-static List   local itbscc            Args((List));
-static Void   local addEvidParams     Args((List,Cell));
-
-static Void   local typeClassDefn     Args((Class));
-static Void   local typeInstDefn      Args((Inst));
-static Void   local typeMember        Args((String,Name,Cell,List,Cell,Int));
-
-static Void   local typeBind          Args((Cell));
-static Void   local typeDefAlt        Args((Int,Cell,Pair));
-static Cell   local typeRhs           Args((Cell));
-static Void   local guardedType       Args((Int,Cell));
-
-static Void   local genBind           Args((List,Cell));
-static Void   local genAss            Args((Int,List,Cell,Type));
-static Type   local genTest           Args((Int,Cell,List,Type,Type,Int));
-static Type   local generalize        Args((List,Type));
-static Bool   local equalTypes        Args((Type,Type));
-
-static Void   local typeDefnGroup     Args((List));
-static Pair   local typeSel           Args((Name));
+static Void   local emptyAssumption   ( Void );
+static Void   local enterBindings     ( Void );
+static Void   local leaveBindings     ( Void );
+static Int    local defType           ( Cell );
+static Type   local useType           ( Cell );
+static Void   local markAssumList     ( List );
+static Cell   local findAssum         ( Text );
+static Pair   local findInAssumList   ( Text,List );
+static List   local intsIntersect     ( List,List );
+static List   local genvarAllAss      ( List );
+static List   local genvarAnyAss      ( List );
+static Int    local newVarsBind       ( Cell );
+static Void   local newDefnBind       ( Cell,Type );
+
+static Void   local enterPendingBtyvs ( Void );
+static Void   local leavePendingBtyvs ( Void );
+static Cell   local patBtyvs          ( Cell );
+static Void   local doneBtyvs         ( Int );
+static Void   local enterSkolVars     ( Void );
+static Void   local leaveSkolVars     ( Int,Type,Int,Int );
+
+static Void   local typeError         ( Int,Cell,Cell,String,Type,Int );
+static Void   local reportTypeError   ( Int,Cell,Cell,String,Type,Type );
+static Void   local cantEstablish     ( Int,String,Cell,Type,List );
+static Void   local tooGeneral        ( Int,Cell,Type,Type );
+
+static Cell   local typeExpr          ( Int,Cell );
+
+static Cell   local typeAp            ( Int,Cell );
+static Type   local typeExpected      ( Int,String,Cell,Type,Int,Int,Bool );
+static Void   local typeAlt           ( String,Cell,Cell,Type,Int,Int );
+static Int    local funcType          ( Int );
+static Void   local typeCase          ( Int,Int,Cell );
+static Void   local typeComp          ( Int,Type,Cell,List );
+static Cell   local typeMonadComp     ( Int,Cell );
+static Void   local typeDo            ( Int,Cell );
+static Void   local typeConFlds       ( Int,Cell );
+static Void   local typeUpdFlds       ( Int,Cell );
+#if IPARAM
+static Cell   local typeWith	      ( Int,Cell );
+#endif
+static Cell   local typeFreshPat      ( Int,Cell );
+
+static Void   local typeBindings      ( List );
+static Void   local removeTypeSigs    ( Cell );
+
+static Void   local monorestrict      ( List );
+static Void   local restrictedBindAss ( Cell );
+static Void   local restrictedAss     ( Int,Cell,Type );
+
+static Void   local unrestricted      ( List );
+static List   local itbscc            ( List );
+static Void   local addEvidParams     ( List,Cell );
+
+static Void   local typeClassDefn     ( Class );
+static Void   local typeInstDefn      ( Inst );
+static Void   local typeMember        ( String,Name,Cell,List,Cell,Int );
+
+static Void   local typeBind          ( Cell );
+static Void   local typeDefAlt        ( Int,Cell,Pair );
+static Cell   local typeRhs           ( Cell );
+static Void   local guardedType       ( Int,Cell );
+
+static Void   local genBind           ( List,Cell );
+static Void   local genAss            ( Int,List,Cell,Type );
+static Type   local genTest           ( Int,Cell,List,Type,Type,Int );
+static Type   local generalize        ( List,Type );
+static Bool   local equalTypes        ( Type,Type );
+
+static Void   local typeDefnGroup     ( List );
+static Pair   local typeSel           ( Name );
 
 
 
@@ -147,6 +145,10 @@ static List localEvs;                   /*::[[(Pred,offset,ev)]]           */
 static List savedPs;                    /*::[[(Pred,offset,ev)]]           */
 static Cell dummyVar;                   /* Used to put extra tvars into ass*/
 
+Bool catchAmbigs       = FALSE;         /* TRUE => functions with ambig.   */
+                                        /*         types produce error     */
+
+
 #define saveVarsAss()     List saveAssump = hd(varsBounds)
 #define restoreVarsAss()  hd(varsBounds)  = saveAssump
 #define addVarAssump(v,t) hd(varsBounds)  = cons(pair(v,t),hd(varsBounds))
@@ -394,6 +396,7 @@ Int  m; {
             tyvar(intOf(fst(hd(sks))))->offs = UNUSED_GENERIC;
             sks = tl(sks);
         } while (nonNull(sks));
+ 	normPreds(l);
         sps   = elimPredsUsing(hd(localEvs),sps);
         preds = revOnto(preds,sps);
     }
@@ -494,6 +497,13 @@ Type   inft, expt; {
                                        typeError(l,e,in,where,t,o);
 #define check(l,e,in,where,t,o)    e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
 #define inferType(t,o)             typeIs=t; typeOff=o
+#if IPARAM
+#define spTypeExpr(l,e)			svPreds = preds; preds = NIL; e = typeExpr(l,e); preds = revOnto(preds,svPreds);
+#define spCheck(l,e,in,where,t,o)	svPreds = preds; preds = NIL; check(l,e,in,where,t,o); preds = revOnto(preds,svPreds);
+#else
+#define spTypeExpr(l,e)			e = typeExpr(l,e);
+#define spCheck(l,e,in,where,t,o)	check(l,e,in,where,t,o);
+#endif
 
 static Void local cantEstablish(line,wh,e,t,ps)
 Int    line;                            /* Complain when declared preds    */
@@ -532,19 +542,23 @@ Type dt, it; {
 static int tcMode = EXPRESSION;
 
 #ifdef DEBUG_TYPES
-static Cell local mytypeExpr    Args((Int,Cell));
+static Cell local mytypeExpr    ( Int,Cell));
 static Cell local typeExpr(l,e)
 Int l;
 Cell e; {
     static int number = 0;
     Cell retv;
     int  mynumber = number++;
+    List ps;
+    STACK_CHECK
     Printf("%d) to check: ",mynumber);
     printExp(stdout,e);
     Putchar('\n');
     retv = mytypeExpr(l,e);
     Printf("%d) result: ",mynumber);
     printType(stdout,debugType(typeIs,typeOff));
+    Printf("\n%d) preds: ",mynumber);
+    printContext(stdout,debugContext(preds));
     Putchar('\n');
     return retv;
 }
@@ -560,6 +574,9 @@ Cell e; {
     static String aspat   = "as (@) pattern";
     static String typeSig = "type annotation";
     static String lambda  = "lambda expression";
+#if IPARAM
+    List svPreds;
+#endif
 
     switch (whatIs(e)) {
 
@@ -568,7 +585,11 @@ Cell e; {
         case AP         :
         case NAME       :
         case VAROPCELL  :
-        case VARIDCELL  : return typeAp(l,e);
+	case VARIDCELL	:
+#if IPARAM
+	case IPVAR	:
+#endif
+	  		  return typeAp(l,e);
 
         case TUPLE      : typeTuple(e);
                           break;
@@ -625,10 +646,14 @@ Cell e; {
         case UPDFLDS    : typeUpdFlds(l,e);
                           break;
 
+#if IPARAM
+	case WITHEXP	: return typeWith(l,e);
+#endif
+
         case COND       : {   Int beta = newTyvars(1);
                               check(l,fst3(snd(e)),e,cond,typeBool,0);
-                              check(l,snd3(snd(e)),e,cond,aVar,beta);
-                              check(l,thd3(snd(e)),e,cond,aVar,beta);
+ 			      spCheck(l,snd3(snd(e)),e,cond,aVar,beta);
+ 			      spCheck(l,thd3(snd(e)),e,cond,aVar,beta);
                               tyvarType(beta);
                           }
                           break;
@@ -636,7 +661,7 @@ Cell e; {
         case LETREC     : enterBindings();
                           enterSkolVars();
                           mapProc(typeBindings,fst(snd(e)));
-                          snd(snd(e)) = typeExpr(l,snd(snd(e)));
+ 			  spTypeExpr(l,snd(snd(e)));
                           leaveBindings();
                           leaveSkolVars(l,typeIs,typeOff,0);
                           break;
@@ -644,7 +669,7 @@ Cell e; {
         case FINLIST    : {   Int  beta = newTyvars(1);
                               List xs;
                               for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
-                                 check(l,hd(xs),e,list,aVar,beta);
+				 spCheck(l,hd(xs),e,list,aVar,beta);
                               }
                               inferType(listof,beta);
                           }
@@ -698,12 +723,10 @@ Cell e; {
         case LAZYPAT    : snd(e) = typeExpr(l,snd(e));
                           break;
 
-#if NPLUSK
         case ADDPAT     : {   Int alpha = newTyvars(1);
                               inferType(typeVarToVar,alpha);
                               return ap(e,assumeEvid(predIntegral,alpha));
                           }
-#endif
 
         default         : internal("typeExpr");
    }
@@ -724,6 +747,9 @@ Cell e; {                               /* requires polymorphism, qualified*/
     Cell p = NIL;
     Cell a = e;
     Int  i;
+#if IPARAM
+    List svPreds;
+#endif
 
     switch (whatIs(h)) {
         case NAME      : typeIs = name(h).type;
@@ -750,6 +776,17 @@ Cell e; {                               /* requires polymorphism, qualified*/
                          }
                          break;
 
+#if IPARAM
+	case IPVAR    :	{   Text t    = textOf(h);
+			    Int alpha = newTyvars(1);
+			    Cell ip   = pair(ap(IPCELL,t),aVar);
+			    Cell ev   = assumeEvid(ip,alpha);
+			    typeIs    = mkInt(alpha);
+			    h	      = ap(h,ev);
+			}
+			break;
+#endif
+
         default        : h = typeExpr(l,h);
                          break;
     }
@@ -764,7 +801,7 @@ Cell e; {                               /* requires polymorphism, qualified*/
         for (; nonNull(predsAre); predsAre=tl(predsAre)) {
             evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
         }
-        if (!isName(h) || !isCfun(h)) {
+        /* we now _always_ do this: if (!isName(h) || !isCfun(h)) */ {
             h = applyToArgs(h,rev(evs));
         }
     }
@@ -820,7 +857,7 @@ Cell e; {                               /* requires polymorphism, qualified*/
 
         for (as=getArgs(as); nonNull(as); as=tl(as), body=arg(body)) {
             Type expect = dropRank1(arg(fun(body)),alpha,m);
-            if (isPolyType(expect)) {
+ 	    if (isPolyOrQualType(expect)) {
                 if (tcMode==EXPRESSION)         /* poly/qual type in expr  */
                     hd(as) = typeExpected(l,app,hd(as),expect,alpha,m,TRUE);
                 else if (hd(as)!=WILDCARD) {    /* Pattern binding/match   */
@@ -855,7 +892,7 @@ Cell e; {                               /* requires polymorphism, qualified*/
                 }
             }
             else {                              /* Not a poly/qual type    */
-                check(l,hd(as),e,app,expect,alpha);
+		spCheck(l,hd(as),e,app,expect,alpha);
             }
             h = ap(h,hd(as));                   /* Save checked argument   */
         }
@@ -867,7 +904,7 @@ Cell e; {                               /* requires polymorphism, qualified*/
         Int beta = funcType(n);         /* check h::t1->t2->...->tn->rn+1  */
         shouldBe(l,h,e,app,aVar,beta);
         for (i=n; i>0; --i) {           /* check e_i::t_i for each i       */
-            check(l,arg(a),e,app,aVar,beta+2*i-1);
+ 	    spCheck(l,arg(a),e,app,aVar,beta+2*i-1);
             p = a;
             a = fun(a);
         }
@@ -905,6 +942,7 @@ Bool   addEvid; {                       /* TRUE => add \ev -> ...          */
 
     preds = NIL;
     check(l,e,NIL,wh,t,o);
+    improve(l,ps,preds);
 
     clearMarks();
     mapProc(markAssumList,defnBounds);
@@ -912,9 +950,20 @@ Bool   addEvid; {                       /* TRUE => add \ev -> ...          */
     mapProc(markPred,savePreds);
     markBtyvs();
 
-    for (i=0; i<n; i++)
-        markTyvar(alpha+i);
+    if (n > 0) {		  /* mark alpha thru alpha+n-1, plus any   */
+				  /* type vars that are functionally	   */
+	List us = NIL, vs = NIL;  /* dependent on them			   */
+	List fds = calcFunDepsPreds(preds);
+	for (i=0; i<n; i++) {
+	    Type t1 = zonkTyvar(alpha+i);
+	    us = zonkTyvarsIn(t1,us);
+	}
+	vs = oclose(fds,us);
+	for (; nonNull(vs); vs=tl(vs))
+	    markTyvar(intOf(hd(vs)));
+    }
 
+    normPreds(l);
     savePreds = elimPredsUsing(ps,savePreds);
     if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
         savePreds = elimPredsUsing(ps,savePreds);
@@ -971,7 +1020,7 @@ Int    m; {
 
     while (getHead(t)==typeArrow && argCount==2 && nonNull(ps)) {
         Type ta = arg(fun(t));
-        if (isPolyType(ta)) {
+	if (isPolyOrQualType(ta)) {
             if (hd(ps)!=WILDCARD) {
                 if (!isVar(hd(ps))) {
                    ERRMSG(l) "Argument " ETHEN ERREXPR(hd(ps));
@@ -1061,14 +1110,18 @@ Cell e;
 List qs; {
     static String boolQual = "boolean qualifier";
     static String genQual  = "generator";
+#if IPARAM
+    List svPreds;
+#endif
 
-    if (isNull(qs))                     /* no qualifiers left              */
-        fst(e) = typeExpr(l,fst(e));
-    else {
+    STACK_CHECK
+    if (isNull(qs)) {			/* no qualifiers left		   */
+	spTypeExpr(l,fst(e));
+    } else {
         Cell q   = hd(qs);
         List qs1 = tl(qs);
         switch (whatIs(q)) {
-            case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0);
+	    case BOOLQUAL : spCheck(l,snd(q),NIL,boolQual,typeBool,0);
                             typeComp(l,m,e,qs1);
                             break;
 
@@ -1082,7 +1135,7 @@ List qs; {
 
             case FROMQUAL : {   Int beta = newTyvars(1);
                                 saveVarsAss();
-                                check(l,snd(snd(q)),NIL,genQual,m,beta);
+				spCheck(l,snd(snd(q)),NIL,genQual,m,beta);
                                 enterSkolVars();
                                 fst(snd(q))
                                     = typeFreshPat(l,patBtyvs(fst(snd(q))));
@@ -1094,7 +1147,7 @@ List qs; {
                             }
                             break;
 
-            case DOQUAL   : check(l,snd(q),NIL,genQual,m,newTyvars(1));
+	    case DOQUAL   : spCheck(l,snd(q),NIL,genQual,m,newTyvars(1));
                             typeComp(l,m,e,qs1);
                             break;
         }
@@ -1111,6 +1164,7 @@ Cell e; {
     tyvar(beta)->kind = starToStar;
 #if !MONAD_COMPS
     bindTv(beta,typeList,0);
+     m = nameListMonad;
 #endif
 
     typeComp(l,mon,snd(e),snd(snd(e)));
@@ -1144,6 +1198,9 @@ Cell e; {
     Int  to;
     Int  tf;
     Int  i;
+#if IPARAM
+    List svPreds;
+#endif
 
     instantiate(name(c).type);
     for (; nonNull(predsAre); predsAre=tl(predsAre))
@@ -1159,10 +1216,10 @@ Cell e; {
         for (i=sfunPos(fst(hd(fs)),c); --i>0; t=arg(t))
             ;
         t = dropRank1(arg(fun(t)),to,tf);
-        if (isPolyType(t))
+	if (isPolyOrQualType(t))
             snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE);
         else {
-            check(l,snd(hd(fs)),e,conExpr,t,to);
+	    spCheck(l,snd(hd(fs)),e,conExpr,t,to);
         }
     }
     for (i=name(c).arity; i>0; i--)
@@ -1181,10 +1238,13 @@ Cell e; {                               /* bizarre manner for the benefit  */
     Int  alpha = newTyvars(2+n);
     Int  i;
     List fs1;
+#if IPARAM
+    List svPreds;
+#endif
 
     /* Calculate type and translation for each expr in the field list      */
     for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
-        snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
+ 	spTypeExpr(line,snd(hd(fs1)));
         bindTv(i,typeIs,typeOff);
     }
 
@@ -1201,7 +1261,7 @@ Cell e; {                               /* bizarre manner for the benefit  */
     ts = rev(ts);
 
     /* Type check expression to be updated                                 */
-    fst3(snd(e)) = typeExpr(line,fst3(snd(e)));
+    spTypeExpr(line,fst3(snd(e)));
     bindTv(alpha,typeIs,typeOff);
 
     for (; nonNull(cs); cs=tl(cs)) {    /* Loop through constrs            */
@@ -1265,6 +1325,57 @@ Cell e; {                               /* bizarre manner for the benefit  */
     /* (typeIs,typeOff) still carry the result type when we exit the loop  */
 }
 
+#if IPARAM
+static Cell local typeWith(line,e)	/* Type check a with		   */
+Int  line;
+Cell e; {
+    List fs    = snd(snd(e));		/* List of field specifications	   */
+    Int  n     = length(fs);
+    Int  alpha = newTyvars(2+n);
+    Int  i;
+    List fs1;
+    Cell tIs;
+    Cell tOff;
+    List dpreds = NIL, dp;
+    Cell bs = NIL;
+
+    /* Type check expression to be updated				   */
+    fst(snd(e)) = typeExpr(line,fst(snd(e)));
+    bindTv(alpha,typeIs,typeOff);
+    tIs = typeIs;
+    tOff = typeOff;
+    /* elim duplicate uses of imp params */
+    preds = scSimplify(preds);
+    /* extract preds that we're going to bind */
+    for (fs1=fs; nonNull(fs1); fs1=tl(fs1)) {
+        Text t = textOf(fst(hd(fs1)));
+	Cell p = findIPEvid(t);
+	dpreds = cons(p, dpreds);
+	if (nonNull(p)) {
+	    removeIPEvid(t);
+	} else {
+	    /* maybe give a warning message here... */
+	}
+    }
+    dpreds = rev(dpreds);
+
+    /* Calculate type and translation for each expr in the field list	   */
+    for (fs1=fs, dp=dpreds, i=alpha+2; nonNull(fs1); fs1=tl(fs1), dp=tl(dp), i++) {
+	static String with = "with";
+        Cell ev = hd(dp);
+	snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
+	bindTv(i,typeIs,typeOff);
+	if (nonNull(ev)) {
+	    shouldBe(line,fst(hd(fs1)),e,with,snd(fst3(ev)),intOf(snd3(ev)));
+	    bs = cons(cons(pair(thd3(ev), cons(triple(NIL, mkInt(line), snd(hd(fs1))), NIL)), NIL), bs);
+	}
+    }
+    typeIs = tIs;
+    typeOff = tOff;
+    return (ap(LETREC,pair(bs,fst(snd(e)))));
+}
+#endif
+
 static Cell local typeFreshPat(l,p)    /* find type of pattern, assigning  */
 Int  l;                                /* fresh type variables to each var */
 Cell p; {                              /* bound in the pattern             */
@@ -1329,6 +1440,7 @@ List bs; {
     preds = NIL;                        /* Type check the bindings         */
     mapProc(restrictedBindAss,bs);
     mapProc(typeBind,bs);
+    improve(line,NIL,preds);
     normPreds(line);
     elimTauts();
     preds = revOnto(preds,savePreds);
@@ -1495,6 +1607,7 @@ List bs; {
 
         preds = NIL;
         mapProc(typeBind,hd(imps));
+	improve(line,NIL,preds);
 
         clearMarks();
         mapProc(markAssumList,tl(defnBounds));
@@ -1547,6 +1660,7 @@ List bs; {
         enterPendingBtyvs();
         for (; nonNull(alts); alts=tl(alts))
             typeAlt(extbind,fst(b),hd(alts),t,o,m);
+	improve(line,ps,preds);
         leavePendingBtyvs();
 
         if (nonNull(ps))                /* Add dict params, if necessary   */
@@ -1558,14 +1672,16 @@ List bs; {
         mapProc(markPred,savePreds);
         markBtyvs();
 
+	normPreds(line);
         savePreds = elimPredsUsing(ps,savePreds);
         if (nonNull(preds)) {
             List vs = NIL;
             Int  i  = 0;
             for (; i<m; ++i)
                 vs = cons(mkInt(o+i),vs);
-            if (resolveDefs(vs))
+ 	    if (resolveDefs(vs)) {
                 savePreds = elimPredsUsing(ps,savePreds);
+	    }
             if (nonNull(preds)) {
                 clearMarks();
                 reducePreds();
@@ -1621,111 +1737,104 @@ Cell v; {                              /* parameters given by qs           */
  * ------------------------------------------------------------------------*/
 
 static Void local typeClassDefn(c)      /* Type check implementations of   */
-Class c; {                              /* defaults for class c            */
+Class c; {				/* defaults for class c		   */
 
     /* ----------------------------------------------------------------------
-     * Generate code for default dictionary builder function:
-     *
-     *   class.C sc1 ... scn d = let v1 ... = ...
-     *                               vm ... = ...
-     *                           in Make.C sc1 ... scn v1 ... vm
-     *
-     * where sci are superclass dictionary parameters, vj are implementations
-     * for member functions, either taken from defaults, or using "error" to
-     * produce a suitable error message.  (Additional line number values must
-     * be added at appropriate places but, for clarity, these are not shown
-     * above.)
+     * Generate code for default dictionary builder functions:
      * --------------------------------------------------------------------*/
 
     Int  beta   = newKindedVars(cclass(c).kinds);
-    List params = makePredAss(cclass(c).supers,beta);
-    Cell body   = cclass(c).dcon;
-    Cell pat    = body;
+    Cell d      = inventDictVar();
+    List dparam = singleton(triple(cclass(c).head,mkInt(beta),d));
     List mems   = cclass(c).members;
     List defs   = cclass(c).defaults;
     List dsels  = cclass(c).dsels;
-    Cell d      = inventDictVar();
-    List args   = NIL;
-    List locs   = NIL;
-    Cell l      = mkInt(cclass(c).line);
-    List ps;
+    Cell pat    = cclass(c).dcon;
+    Int  width  = cclass(c).numSupers + cclass(c).numMembers;
+    char buf[FILENAME_MAX+1];
+    Int  i      = 0;
+    Int  j      = 0;
 
-    for (ps=params; nonNull(ps); ps=tl(ps)) {
-        Cell v = thd3(hd(ps));
-        body   = ap(body,v);
-        pat    = ap(pat,inventVar());
-        args   = cons(v,args);
+    if (isNull(defs) && nonNull(mems)) {
+        defs = cclass(c).defaults = cons(NIL,NIL);
     }
-    args   = revOnto(args,singleton(d));
-    params = appendOnto(params,
-                        singleton(triple(cclass(c).head,mkInt(beta),d)));
 
     for (; nonNull(mems); mems=tl(mems)) {
-        Cell v   = inventVar();         /* Pick a name for component       */
-        Cell imp = NIL;
-
-        if (nonNull(defs)) {            /* Look for default implementation */
-            imp  = hd(defs);
-            defs = tl(defs);
-        }
-
-        if (isNull(imp)) {              /* Generate undefined member msg   */
-            static String header = "Undefined member: ";
-            String name = textToStr(name(hd(mems)).text);
-            char   msg[FILENAME_MAX+1];
-            Int    i;
-            Int    j;
-
-            for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
-                msg[i] = header[i];
-            for (j=0; (i+j)<FILENAME_MAX && name[j]!='\0'; j++)
-                msg[i+j] = name[j];
-            msg[i+j] = '\0';
-
-            imp = pair(v,singleton(pair(NIL,ap(l,ap(nameError,
-                                                    mkStr(findText(msg)))))));
-        }
-        else {                          /* Use default implementation      */
-            fst(imp) = v;
-            typeMember("default member binding",
-                       hd(mems),
-                       snd(imp),
-                       params,
-                       cclass(c).head,
-                       beta);
-        }
-
-        locs = cons(imp,locs);
-        body = ap(body,v);
-        pat  = ap(pat,v);
+        /* static String deftext = "default_"; */
+	static String deftext = "$dm";
+	String s	      = textToStr(name(hd(mems)).text);
+	Name   n;
+        i = j = 0;
+	for (; i<FILENAME_MAX && deftext[i]!='\0'; i++) {
+	    buf[i] = deftext[i];
+	}
+	for(; (i+j)<FILENAME_MAX && s[j]!='\0'; j++) {
+	    buf[i+j] = s[j];
+	}
+	buf[i+j] = '\0';
+	n = newName(findText(buf),c);
+
+	if (isNull(hd(defs))) {		/* No default definition	   */
+	    static String header = "Undefined member: ";
+	    for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
+		buf[i] = header[i];
+	    for (j=0; (i+j)<FILENAME_MAX && s[j]!='\0'; j++)
+		buf[i+j] = s[j];
+	    buf[i+j] = '\0';
+	    name(n).line  = cclass(c).line;
+	    name(n).arity = 1;
+	    name(n).defn  = singleton(pair(singleton(d),
+					   ap(mkInt(cclass(c).line),
+					      ap(nameError,
+						 mkStr(fixLitText(
+							findText(buf)))))));
+	} else {			/* User supplied default defn	   */
+	    List alts = snd(hd(defs));
+	    Int  line = rhsLine(snd(hd(alts)));
+
+	    typeMember("default member binding",
+		       hd(mems),
+		       alts,
+		       dparam,
+		       cclass(c).head,
+		       beta);
+
+	    name(n).line  = line;
+	    name(n).arity = 1+length(fst(hd(alts)));
+	    name(n).defn  = alts;
+
+	    for (; nonNull(alts); alts=tl(alts)) {
+		fst(hd(alts)) = cons(d,fst(hd(alts)));
+	    }
+	}
+
+        hd(defs) = n;
+	genDefns = cons(n,genDefns);
+	if (isNull(tl(defs)) && nonNull(tl(mems))) {
+	    tl(defs) = cons(NIL,NIL);
+	}
+	defs     = tl(defs);
     }
-    body     = ap(l,body);
-    if (nonNull(locs))
-        body = ap(LETREC,pair(singleton(locs),body));
-    name(cclass(c).dbuild).defn
-             = singleton(pair(args,body));
-
-    name(cclass(c).dbuild).inlineMe = TRUE;
-    genDefns = cons(cclass(c).dbuild,genDefns);
-    cclass(c).defaults = NIL;
 
     /* ----------------------------------------------------------------------
      * Generate code for superclass and member function selectors:
      * --------------------------------------------------------------------*/
 
-    args = getArgs(pat);
-    pat  = singleton(pat);
-    for (; nonNull(dsels); dsels=tl(dsels)) {
-        name(hd(dsels)).defn = singleton(pair(pat,ap(l,hd(args))));
-        name(hd(dsels)).inlineMe = TRUE;
-        args                 = tl(args);
-        genDefns             = cons(hd(dsels),genDefns);
+    for (i=0; i<width; i++) {
+	pat = ap(pat,inventVar());
+    }
+    pat = singleton(pat);
+    for (i=0; nonNull(dsels); dsels=tl(dsels)) {
+	name(hd(dsels)).defn = singleton(pair(pat,
+					      ap(mkInt(cclass(c).line),
+						 nthArg(i++,hd(pat)))));
+	genDefns	     = cons(hd(dsels),genDefns);
     }
     for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
-        name(hd(mems)).defn = singleton(pair(pat,ap(mkInt(name(hd(mems)).line),
-                                                    hd(args))));
-        args                = tl(args);
-        genDefns            = cons(hd(mems),genDefns);
+	name(hd(mems)).defn  = singleton(pair(pat,
+					      ap(mkInt(name(hd(mems)).line),
+						 nthArg(i++,hd(pat)))));
+	genDefns	     = cons(hd(mems),genDefns);
     }
 }
 
@@ -1740,16 +1849,16 @@ Inst in; {                              /* member functions for instance in*/
      *                                  .
      *                                  .
      *                              scm = ...
-     *                              d   = f (class.C sc1 ... scm d)
-     *           omit if the   /    f (Make.C sc1' ... scm' v1' ... vk')
-     *          instance decl {         = let vj ... = ...
-     *           has no imps   \          in Make.C sc1' ... scm' ... vj ...
+     *				    vj ... = ...
+     *				    d      = Make.C sc1 ... scm v1 ... vk
      *                          in d
      *
-     * where sci are superclass dictionaries, d and f are new names, vj
+     * where sci are superclass dictionaries, d is a new name, vj
      * is a newly generated name corresponding to the implementation of a
      * member function.  (Additional line number values must be added at
      * appropriate places but, for clarity, these are not shown above.)
+     * If no implementation of a particular vj is available, then we use
+     * the default implementation, partially applied to d.
      * --------------------------------------------------------------------*/
 
     Int  alpha   = newKindedVars(cclass(inst(in).c).kinds);
@@ -1757,12 +1866,17 @@ Inst in; {                              /* member functions for instance in*/
     Int  beta    = newKindedVars(inst(in).kinds);
     List params  = makePredAss(inst(in).specifics,beta);
     Cell d       = inventDictVar();
+    /*
     List evids   = cons(triple(inst(in).head,mkInt(beta),d),
                         appendOnto(dupList(params),supers));
+    */
+    List evids   = dupList(params);
 
     List imps    = inst(in).implements;
     Cell l       = mkInt(inst(in).line);
-    Cell dictDef = cclass(inst(in).c).dbuild;
+    Cell dictDef = cclass(inst(in).c).dcon;
+    List mems    = cclass(inst(in).c).members;
+    List defs    = cclass(inst(in).c).defaults;
     List args    = NIL;
     List locs    = NIL;
     List ps;
@@ -1776,9 +1890,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
@@ -1794,64 +1928,79 @@ Inst in; {                              /* member functions for instance in*/
         locs    = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
         dictDef = ap(dictDef,thd3(pi));
     }
-    dictDef = ap(dictDef,d);
-
-    if (isNull(imps))                           /* No implementations      */
-        locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
-    else {                                      /* Implementations supplied*/
-        List mems  = cclass(inst(in).c).members;
-        Cell f     = inventVar();
-        Cell pat   = cclass(inst(in).c).dcon;
-        Cell res   = pat;
-        List locs1 = NIL;
 
-        locs       = cons(pair(d,singleton(pair(NIL,ap(l,ap(f,dictDef))))),
-                          locs);
-
-        for (ps=supers; nonNull(ps); ps=tl(ps)){/* Add param for each sc   */
-            Cell v = inventVar();
-            pat    = ap(pat,v);
-            res    = ap(res,v);
-        }
-
-        for (; nonNull(mems); mems=tl(mems)) {  /* For each member:        */
-            Cell v   = inventVar();
-            Cell imp = NIL;
-
-            if (nonNull(imps)) {                /* Look for implementation */
-                imp  = hd(imps);
-                imps = tl(imps);
-            }
+    for (; nonNull(defs); defs=tl(defs)) {
+	Cell imp = NIL;
+	if (nonNull(imps)) {
+	    imp  = hd(imps);
+	    imps = tl(imps);
+	}
+	if (isNull(imp)) {
+	    dictDef = ap(dictDef,ap(hd(defs),d));
+	} else {
+	    Cell v  = inventVar();
+	    dictDef = ap(dictDef,v);
+	    typeMember("instance member binding",
+		       hd(mems),
+		       snd(imp),
+		       evids,
+		       inst(in).head,
+		       beta);
+	    locs     = cons(pair(v,snd(imp)),locs);
+	}
+	mems = tl(mems);
+    }
+    locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
+
+    name(inst(in).builder).defn			/* Register builder imp	   */
+       = singleton(pair(args,ap(LETREC,pair(singleton(locs),
+	                                    ap(l,d)))));
+
+    /* Invent a GHC-compatible name for the instance decl */
+    {
+       char buf[FILENAME_MAX+1];
+       char buf2[10];
+       Int           i, j;
+       String        str;
+       Cell          qq      = inst(in).head;
+       Cell          pp      = NIL;
+       static String zdftext = "$f";
+
+       while (isAp(qq)) {
+          pp = cons(arg(qq),pp);
+          qq = fun(qq);
+       }
+       // pp is now the fwd list of args(?) to this pred
+
+       i = 0;
+       for (j = 0; i<FILENAME_MAX && zdftext[j]!='\0'; i++, j++) {
+          buf[i] = zdftext[j];
+       }
+       str = textToStr(cclass(inst(in).c).text);
+       for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+          buf[i] = str[j];
+       }
+       if (nonNull(pp)) {
+          qq = hd(pp);
+          while (isAp(qq)) qq = fun(qq);
+          switch (whatIs(qq)) {
+             case TYCON:  str = textToStr(tycon(qq).text); break;
+             case TUPLE:  str = textToStr(ghcTupleText(qq)); break;
+             case OFFSET: sprintf(buf2,"%d",offsetOf(qq)); 
+                          str = buf2;
+                          break;
+             default: internal("typeInstDefn: making GHC name"); break;
+          }
+          for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+             buf[i] = str[j];
+          }
+       }
 
-            if (isNull(imp)) {                  /* If none, f will copy    */
-                pat = ap(pat,v);                /* its argument unchanged  */
-                res = ap(res,v);
-            }
-            else {                              /* Otherwise, add the impl */
-                pat      = ap(pat,WILDCARD);    /* to f as a local defn    */
-                res      = ap(res,v);
-                typeMember("instance member binding",
-                           hd(mems),
-                           snd(imp),
-                           evids,
-                           inst(in).head,
-                           beta);
-                locs1    = cons(pair(v,snd(imp)),locs1);
-            }
-        }
-        res = ap(l,res);
-        if (nonNull(locs1))                     /* Build the body of f     */
-            res = ap(LETREC,pair(singleton(locs1),res));
-        pat  = singleton(pat);                  /* And the arglist for f   */
-        locs = cons(pair(f,singleton(pair(pat,res))),locs);
+       buf[i++] = '\0';
+       name(inst(in).builder).text = findText(buf);
+       //fprintf ( stderr, "result = %s\n", buf );
     }
-    d = ap(l,d);
 
-    name(inst(in).builder).defn                 /* Register builder imp    */
-             = singleton(pair(args,ap(LETREC,pair(singleton(locs),d))));
-
-    name(inst(in).builder).inlineMe   = TRUE;
-    name(inst(in).builder).isDBuilder = TRUE;
     genDefns = cons(inst(in).builder,genDefns);
 }
 
@@ -1904,11 +2053,13 @@ Int    beta; {
         typeAlt(wh,mem,hd(alts),t,o,m);
         qualify(tl(ps),hd(alts));       /* Add any extra dict params       */
     }
+    improve(line,evids,preds);
     leavePendingBtyvs();
 
     evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts  */
                        evids);
     clearMarks();
+    normPreds(line);
     qs = elimPredsUsing(evids,NIL);
     if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
         qs = elimPredsUsing(evids,qs);
@@ -1932,8 +2083,10 @@ Int    beta; {
 #endif
     if (!sameSchemes(t,rt))
         tooGeneral(line,mem,rt,t);
-    if (nonNull(preds))
-        cantEstablish(line,wh,mem,t,ps);
+    if (nonNull(preds)) {
+	preds = scSimplify(preds);
+	cantEstablish(line,wh,mem,t,ps);
+    }
 }
 
 /* --------------------------------------------------------------------------
@@ -2017,14 +2170,18 @@ Cell gded; {                           /*             ex :: (var,beta)     */
     static String guarded = "guarded expression";
     static String guard   = "guard";
     Int line = intOf(fst(gded));
+#if IPARAM
+    List svPreds;
+#endif
 
     gded     = snd(gded);
-    check(line,fst(gded),NIL,guard,typeBool,0);
-    check(line,snd(gded),NIL,guarded,aVar,beta);
+    spCheck(line,fst(gded),NIL,guard,typeBool,0);
+    spCheck(line,snd(gded),NIL,guarded,aVar,beta);
 }
 
 Cell rhsExpr(rhs)                      /* find first expression on a rhs   */
 Cell rhs; {
+    STACK_CHECK
     switch (whatIs(rhs)) {
         case GUARDED : return snd(snd(hd(snd(rhs))));
         case LETREC  : return rhsExpr(snd(snd(rhs)));
@@ -2035,6 +2192,7 @@ Cell rhs; {
 
 Int rhsLine(rhs)                       /* find line number associated with */
 Cell rhs; {                            /* a right hand side                */
+    STACK_CHECK
     switch (whatIs(rhs)) {
         case GUARDED : return intOf(fst(hd(snd(rhs))));
         case LETREC  : return rhsLine(snd(snd(rhs)));
@@ -2142,7 +2300,7 @@ Type t; {                               /* with qualifying preds qs        */
 
 static Bool local equalTypes(t1,t2)    /* Compare simple types for equality*/
 Type t1, t2; {
-
+    STACK_CHECK
 et: if (whatIs(t1)!=whatIs(t2))
         return FALSE;
 
@@ -2186,6 +2344,7 @@ Bool useDefs; {                         /* using defaults if reqd          */
     type      = typeIs;
     beta      = typeOff;
     clearMarks();
+    improve(0,NIL,preds);
     normPreds(0);
     elimTauts();
     preds     = scSimplify(preds);
@@ -2291,8 +2450,8 @@ Name s; {                               /* particular selector, s.         */
     Type rng  = NIL;                    /* Inferred range                  */
     Cell nv   = inventVar();
     List alts = NIL;
-    Int  o;
-    Int  m;
+    Int  o    = 0;                      /* bogus init to keep gcc -O happy */
+    Int  m    = 0;                      /* bogus init to keep gcc -O happy */
 
 #ifdef DEBUG_SELS
     Printf("Selector %s, cns=",textToStr(name(s).text));
@@ -2397,13 +2556,14 @@ Name s; {                               /* particular selector, s.         */
  * Local function prototypes:
  * ------------------------------------------------------------------------*/
 
-static Type local basicType Args((Char));
+static Type local basicType ( Char );
 
 
 static Type stateVar = NIL;
 static Type alphaVar = NIL;
 static Type betaVar  = NIL;
 static Type gammaVar = NIL;
+static Type deltaVar = NIL;
 static Int  nextVar  = 0;
 
 static Void clearTyVars( void )
@@ -2412,6 +2572,7 @@ static Void clearTyVars( void )
     alphaVar = NIL;
     betaVar  = NIL;
     gammaVar = NIL;
+    deltaVar = NIL;
     nextVar  = 0;
 }
 
@@ -2447,6 +2608,14 @@ static Type mkGammaVar( void )
     return gammaVar;
 }
 
+static Type mkDeltaVar( void )
+{
+    if (isNull(deltaVar)) {
+        deltaVar = mkOffset(nextVar++);
+    }
+    return deltaVar;
+}
+
 static Type local basicType(k)
 Char k; {
     switch (k) {
@@ -2464,15 +2633,18 @@ Char k; {
             return typeFloat;
     case DOUBLE_REP:
             return typeDouble;
-    case ARR_REP:     return ap(typePrimArray,mkAlphaVar());            
-    case BARR_REP:    return typePrimByteArray;
-    case REF_REP:     return ap2(typeRef,mkStateVar(),mkAlphaVar());                  
-    case MUTARR_REP:  return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());     
-    case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar()); 
-#ifdef PROVIDE_STABLE
+    case ARR_REP:
+            return ap(typePrimArray,mkAlphaVar());            
+    case BARR_REP:
+            return typePrimByteArray;
+    case REF_REP:
+            return ap2(typeRef,mkStateVar(),mkAlphaVar());
+    case MUTARR_REP:
+            return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());     
+    case MUTBARR_REP:
+            return ap(typePrimMutableByteArray,mkStateVar()); 
     case STABLE_REP:
             return ap(typeStable,mkAlphaVar());
-#endif
 #ifdef PROVIDE_WEAK
     case WEAK_REP:
             return ap(typeWeak,mkAlphaVar());
@@ -2483,12 +2655,10 @@ Char k; {
     case FOREIGN_REP:
             return typeForeign;
 #endif
-#ifdef PROVIDE_CONCURRENT
     case THREADID_REP:
             return typeThreadId;
     case MVAR_REP:
             return ap(typeMVar,mkAlphaVar());
-#endif
     case BOOL_REP:
             return typeBool;
     case HANDLER_REP:
@@ -2501,6 +2671,8 @@ Char k; {
             return mkBetaVar();   /* polymorphic */
     case GAMMA_REP:
             return mkGammaVar();  /* polymorphic */
+    case DELTA_REP:
+            return mkDeltaVar();  /* polymorphic */
     default:
             printf("Kind: '%c'\n",k);
             internal("basicType");
@@ -2556,11 +2728,6 @@ Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds )
         assert(length(tvars) == nextVar);
         r = mkPolyType(simpleKind(length(tvars)),r);
     }
-#if DEBUG_CODE
-    if (debugCode) {
-        printType(stdout,r); printf("\n");
-    }
-#endif
     return r;
 }    
 
@@ -2608,14 +2775,14 @@ Void typeChecker(what)
 Int what; {
     switch (what) {
         case RESET   : tcMode       = EXPRESSION;
+ 		       daSccs	    = NIL;
                        preds        = NIL;
                        pendingBtyvs = NIL;
                        daSccs       = NIL;
                        emptyAssumption();
                        break;
 
-        case MARK    : mark(daSccs);
-                       mark(defnBounds);
+        case MARK    : mark(defnBounds);
                        mark(varsBounds);
                        mark(depends);
                        mark(pendingBtyvs);
@@ -2623,6 +2790,7 @@ Int what; {
                        mark(localEvs);
                        mark(savedPs);
                        mark(dummyVar);
+		       mark(daSccs);
                        mark(preds);
                        mark(stdDefaults);
                        mark(arrow);
@@ -2634,65 +2802,115 @@ Int what; {
                        mark(predIntegral);
                        mark(starToStar);
                        mark(predMonad);
+		       mark(typeProgIO);
                        break;
 
-        case INSTALL : typeChecker(RESET);
-                       dummyVar     = inventVar();
-
-                       setCurrModule(modulePrelude);
-
-                       starToStar   = simpleKind(1);
-
-                       typeUnit     = addPrimTycon(findText("()"),
-                                                   STAR,0,DATATYPE,NIL);
-                       typeArrow    = addPrimTycon(findText("(->)"),
-                                                   simpleKind(2),2,
-                                                   DATATYPE,NIL);
-                       typeList     = addPrimTycon(findText("[]"),
-                                                   starToStar,1,
-                                                   DATATYPE,NIL);
-
-                       arrow        = fn(aVar,bVar);
-                       listof       = ap(typeList,aVar);
-                       boundPair    = ap(ap(mkTuple(2),aVar),aVar);
-
-                       nameUnit     = addPrimCfun(findText("()"),0,0,typeUnit);
-                       tycon(typeUnit).defn
-                                    = singleton(nameUnit);
-
-                       nameNil      = addPrimCfun(findText("[]"),0,1,
-                                                   mkPolyType(starToStar,
-                                                              listof));
-                       nameCons     = addPrimCfun(findText(":"),2,2,
-                                                   mkPolyType(starToStar,
-                                                              fn(aVar,
-                                                              fn(listof,
-                                                                 listof))));
-                       name(nameNil).parent =
-                       name(nameCons).parent = typeList;
-
-                       name(nameCons).syntax
-                                    = mkSyntax(RIGHT_ASS,5);
-
-                       tycon(typeList).defn
-                                    = cons(nameNil,cons(nameCons,NIL));
-
-                       typeVarToVar = fn(aVar,aVar);
+        case POSTPREL:
+
+           if (combined) {
+               setCurrModule(modulePrelude);
+               dummyVar     = inventVar();
+               typeUnit     = mkTuple(0);
+               arrow        = fn(aVar,bVar);
+               listof       = ap(typeList,aVar);
+               boundPair    = ap(ap(mkTuple(2),aVar),aVar);
+               nameUnit     = findQualNameWithoutConsultingExportList
+                                 (mkQVar(findText("PrelBase"),
+                                         findText("()")));
+               typeVarToVar = fn(aVar,aVar);
+           }
+           break;
+
+        case PREPREL : 
+           typeChecker(RESET);
+
+           if (combined) {
+               Module m = findFakeModule(findText("PrelBase"));
+               setCurrModule(m);
+
+               starToStar   = simpleKind(1);
+               typeList     = addPrimTycon(findText("[]"),
+                                           starToStar,1,
+                                           DATATYPE,NIL);
+
+               listof       = ap(typeList,aVar);
+               nameNil      = addPrimCfun(findText("[]"),0,1,
+                                           mkPolyType(starToStar,
+                                                      listof));
+               nameCons     = addPrimCfun(findText(":"),2,2,
+                                           mkPolyType(starToStar,
+                                                      fn(aVar,
+                                                      fn(listof,
+                                                         listof))));
+               name(nameNil).parent =
+               name(nameCons).parent = typeList;
+
+               name(nameCons).syntax
+                            = mkSyntax(RIGHT_ASS,5);
+
+               tycon(typeList).defn
+                            = cons(nameNil,cons(nameCons,NIL));
+
+           } else {
+               dummyVar     = inventVar();
+
+               setCurrModule(modulePrelPrim);
+
+               starToStar   = simpleKind(1);
+
+               typeUnit     = findTycon(findText("()"));
+                              assert(nonNull(typeUnit));
+
+               typeArrow    = addPrimTycon(findText("(->)"),
+                                           simpleKind(2),2,
+                                           DATATYPE,NIL);
+               typeList     = addPrimTycon(findText("[]"),
+                                           starToStar,1,
+                                           DATATYPE,NIL);
+
+               arrow        = fn(aVar,bVar);
+               listof       = ap(typeList,aVar);
+               boundPair    = ap(ap(mkTuple(2),aVar),aVar);
+
+               nameUnit     = addPrimCfun(findText("()"),0,0,typeUnit);
+               tycon(typeUnit).defn
+                            = singleton(nameUnit);
+
+               nameNil      = addPrimCfun(findText("[]"),0,1,
+                                           mkPolyType(starToStar,
+                                                      listof));
+               nameCons     = addPrimCfun(findText(":"),2,2,
+                                           mkPolyType(starToStar,
+                                                      fn(aVar,
+                                                      fn(listof,
+                                                         listof))));
+               name(nameNil).parent =
+               name(nameCons).parent = typeList;
+
+               name(nameCons).syntax
+                            = mkSyntax(RIGHT_ASS,5);
+
+               tycon(typeList).defn
+                            = cons(nameNil,cons(nameCons,NIL));
+
+               typeVarToVar = fn(aVar,aVar);
 #if TREX
-                       typeNoRow    = addPrimTycon(findText("EmptyRow"),
-                                                   ROW,0,DATATYPE,NIL);
-                       typeRec      = addPrimTycon(findText("Rec"),
-                                                   pair(ROW,STAR),1,
-                                                   DATATYPE,NIL);
-                       nameNoRec    = addPrimCfun(findText("EmptyRec"),0,0,
-                                                        ap(typeRec,typeNoRow));
+               typeNoRow    = addPrimTycon(findText("EmptyRow"),
+                                           ROW,0,DATATYPE,NIL);
+               typeRec      = addPrimTycon(findText("Rec"),
+                                           pair(ROW,STAR),1,
+                                           DATATYPE,NIL);
+               nameNoRec    = addPrimCfun(findText("EmptyRec"),0,0,
+                                                ap(typeRec,typeNoRow));
 #else
-                       /* bogus definitions to avoid changing the prelude */
-                       addPrimCfun(findText("Rec"),      0,0,typeUnit);
-                       addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
-                       addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
+               /* bogus definitions to avoid changing the prelude */
+               addPrimCfun(findText("Rec"),      0,0,typeUnit);
+               addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
+               addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
 #endif
-                       break;
+	   }
+           break;
+
     }
 }