X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fstorage.c;h=cf50bf464b79b260a615e0bd8cb397d1a97e4c6f;hb=564f5f6203ea431c7b50d3dad348e2a846589485;hp=ec0bbc9535d62917937f530bb30fefddeddb1008;hpb=51c33894862dfd591d71018a70f4ca3914b17f7b;p=ghc-hetmet.git

diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index ec0bbc9..cf50bf4 100644
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: storage.c,v $
- * $Revision: 1.25 $
- * $Date: 1999/12/10 15:59:53 $
+ * $Revision: 1.46 $
+ * $Date: 2000/02/25 10:53:54 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -18,6 +18,7 @@
 #include "backend.h"
 #include "connect.h"
 #include "errors.h"
+#include "object.h"
 #include <setjmp.h>
 
 /*#define DEBUG_SHOWUSE*/
@@ -352,6 +353,19 @@ Text enZcodeThenFindText ( String s )
          p[n] = *s; n++; s++;
          continue;
       }
+      if (*s == '(') {
+         int tup = 0;
+         char num[12];
+         s++;
+         while (*s && *s==',') { s++; tup++; };
+         if (*s != ')') internal("enZcodeThenFindText: invalid tuple type");
+         s++;
+         p[n++] = 'Z';
+         sprintf(num,"%d",tup);
+         p[n] = 0; strcat ( &(p[n]), num ); n += strlen(num);
+         p[n++] = 'T';
+         continue;         
+      }
       switch (*s++) {
          case '(': p[n++] = 'Z'; p[n++] = 'L'; break;
          case ')': p[n++] = 'Z'; p[n++] = 'R'; break;
@@ -487,7 +501,9 @@ Text t; {
 
 Tycon addTycon(tc)  /* Insert Tycon in tycon table - if no clash is caused */
 Tycon tc; {
-    Tycon oldtc = findTycon(tycon(tc).text);
+    Tycon oldtc; 
+    assert(whatIs(tc)==TYCON || whatIs(tc)==TUPLE);
+    oldtc = findTycon(tycon(tc).text);
     if (isNull(oldtc)) {
         hashTycon(tc);
         module(currentModule).tycons=cons(tc,module(currentModule).tycons);
@@ -498,7 +514,10 @@ Tycon tc; {
 
 static Void local hashTycon(tc)         /* Insert Tycon into hash table    */
 Tycon tc; {
-   assert(isTycon(tc) || isTuple(tc));
+  if (!(isTycon(tc) || isTuple(tc))) {
+    printf("\nbad stuff: " ); print(tc,10); printf("\n");
+      assert(isTycon(tc) || isTuple(tc));
+  }
    if (1) {
      Text  t = tycon(tc).text;
      Int   h = tHash(t);
@@ -580,19 +599,23 @@ List   ts; {                            /* Null pattern matches every tycon*/
 
 Text ghcTupleText_n ( Int n )
 {
-    Int  i;
-    char buf[103];
+    Int i;
+    Int x = 0; 
+    char buf[104];
     if (n < 0 || n >= 100) internal("ghcTupleText_n");
-    buf[0] = '(';
-    for (i = 1; i <= n; i++) buf[i] = ',';
-    buf[i] = ')';
-    buf[i+1] = 0;
+    if (n == 1) internal("ghcTupleText_n==1");
+    buf[x++] = '(';
+    for (i = 1; i <= n-1; i++) buf[x++] = ',';
+    buf[x++] = ')';
+    buf[x++] = 0;
     return findText(buf);
 }
 
 Text ghcTupleText(tup)
 Tycon tup; {
-    assert(isTuple(tup));
+    if (!isTuple(tup)) {
+       assert(isTuple(tup));
+    }
     return ghcTupleText_n ( tupleOf(tup) );
 }
 
@@ -607,23 +630,6 @@ Tycon mkTuple ( Int n )
    internal("mkTuple: request for non-existent tuple");
 }
 
-Void allocTupleTycon ( Int n )
-{
-   Int   i;
-   Kind  k;
-   Tycon t;
-   for (i = TYCMIN; i < tyconHw; i++)
-      if (tycon(i).tuple == n) return;
-
-   //t = addPrimTycon(findText(buf),simpleKind(n),n, DATATYPE,NIL);
-
-   k = STAR;
-   for (i = 0; i < n; i++) k = ap(STAR,k);
-   t = newTycon(ghcTupleText_n(n));
-   tycon(t).kind = k;
-   tycon(t).tuple = n;
-   tycon(t).what = DATATYPE;
-}
 
 /* --------------------------------------------------------------------------
  * Name storage:
@@ -682,7 +688,9 @@ Text t; {
 
 Name addName(nm)                        /* Insert Name in name table - if  */
 Name nm; {                              /* no clash is caused              */
-    Name oldnm = findName(name(nm).text);
+    Name oldnm; 
+    assert(whatIs(nm)==NAME);
+    oldnm = findName(name(nm).text);
     if (isNull(oldnm)) {
         hashName(nm);
         module(currentModule).names=cons(nm,module(currentModule).names);
@@ -760,7 +768,10 @@ void* getHugs_AsmObject_for ( char* s )
    Name   n = NIL;
    for (n = NAMEMIN; n < nameHw; n++)
       if (name(n).text == t) break;
-   if (n == nameHw) internal("getHugs_AsmObject_for(1)");
+   if (n == nameHw) {
+      fprintf ( stderr, "can't find `%s' in ...\n", s );
+      internal("getHugs_AsmObject_for(1)");
+   }
    v = name(n).stgVar;
    if (!isStgVar(v) || !isPtr(stgVarInfo(v)))
       internal("getHugs_AsmObject_for(2)");
@@ -771,6 +782,105 @@ void* getHugs_AsmObject_for ( char* s )
  * Primitive functions:
  * ------------------------------------------------------------------------*/
 
+Module findFakeModule ( Text t )
+{
+   Module m = findModule(t);
+   if (nonNull(m)) {
+      if (!module(m).fake) internal("findFakeModule");
+   } else {
+      m = newModule(t);
+      module(m).fake = TRUE;
+   }
+   return m;
+}
+
+
+Name addWiredInBoxingTycon
+        ( String modNm, String typeNm, String constrNm,
+          Int rep, Kind kind )
+{
+   Name   n;
+   Tycon  t;
+   Text   modT  = findText(modNm);
+   Text   typeT = findText(typeNm);
+   Text   conT  = findText(constrNm);
+   Module m     = findFakeModule(modT);
+   setCurrModule(m);
+   
+   n = newName(conT,NIL);
+   name(n).arity  = 1;
+   name(n).number = cfunNo(0);
+   name(n).type   = NIL;
+   name(n).primop = (void*)rep;
+
+   t = newTycon(typeT);
+   tycon(t).what = DATATYPE;
+   tycon(t).kind = kind;
+   return n;
+}
+
+
+Tycon addTupleTycon ( Int n )
+{
+   Int    i;
+   Kind   k;
+   Tycon  t;
+   Module m;
+   Name   nm;
+
+   for (i = TYCMIN; i < tyconHw; i++)
+      if (tycon(i).tuple == n) return i;
+
+   if (combined)
+      m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
+      m = findModule(findText("Prelude"));
+
+   setCurrModule(m);
+   k = STAR;
+   for (i = 0; i < n; i++) k = ap(STAR,k);
+   t = newTycon(ghcTupleText_n(n));
+   tycon(t).kind  = k;
+   tycon(t).tuple = n;
+   tycon(t).what  = DATATYPE;
+
+   if (n == 0) {
+      /* maybe we want to do this for all n ? */
+      nm = newName(ghcTupleText_n(n), t);
+      name(nm).type = t;   /* ummm ... for n > 0 */
+   }
+
+   return t;
+}
+
+
+Tycon addWiredInEnumTycon ( String modNm, String typeNm, 
+                            List /*of Text*/ constrs )
+{
+   Int    i;
+   Tycon  t;
+   Text   modT  = findText(modNm);
+   Text   typeT = findText(typeNm);
+   Module m     = findFakeModule(modT);
+   setCurrModule(m);
+
+   t             = newTycon(typeT);
+   tycon(t).kind = STAR;
+   tycon(t).what = DATATYPE;
+   
+   constrs = reverse(constrs);
+   i       = length(constrs);
+   for (; nonNull(constrs); constrs=tl(constrs),i--) {
+      Text conT        = hd(constrs);
+      Name con         = newName(conT,t);
+      name(con).number = cfunNo(i);
+      name(con).type   = t;
+      name(con).parent = t;
+      tycon(t).defn    = cons(con, tycon(t).defn);      
+   }
+   return t;
+}
+
+
 Name addPrimCfunREP(t,arity,no,rep)     /* add primitive constructor func  */
 Text t;                                 /* sets rep, not type              */
 Int  arity;
@@ -972,7 +1082,9 @@ Text t; {
 
 Class addClass(c)                       /* Insert Class in class list      */
 Class c; {                              /*  - if no clash caused           */
-    Class oldc = findClass(cclass(c).text);
+    Class oldc; 
+    assert(whatIs(c)==CLASS);
+    oldc = findClass(cclass(c).text);
     if (isNull(oldc)) {
         classes=cons(c,classes);
         module(currentModule).classes=cons(c,module(currentModule).classes);
@@ -1052,20 +1164,161 @@ Type tc; {
                          || typeInvolves(arg(ty),tc)));
 }
 
-Inst findSimpleInstance ( ConId klass, ConId dataty )
+
+/* Needed by finishGHCInstance to find classes, before the
+   export list has been built -- so we can't use 
+   findQualClass.
+*/
+Class findQualClassWithoutConsultingExportList ( QualId q )
 {
-   Inst in;
-   for (in = INSTMIN; in < instHw; in++) {
-      Cell head = inst(in).head;
-      if (isClass(fun(head)) 
-          && cclass(fun(head)).text==textOf(klass)
-          && typeInvolves(arg(head), findTycon(textOf(dataty)) )
-         )
-         return in;
+   Class cl;
+   Text t_mod;
+   Text t_class;
+
+   assert(isQCon(q));
+
+   if (isCon(q)) {
+      t_mod   = NIL;
+      t_class = textOf(q);
+   } else {
+      t_mod   = qmodOf(q);
+      t_class = qtextOf(q);
+   }
+
+   for (cl = CLASSMIN; cl < classHw; cl++) {
+      if (cclass(cl).text == t_class) {
+         /* Class name is ok, but is this the right module? */
+         if (isNull(t_mod)   /* no module name specified */
+             || (nonNull(t_mod) 
+                 && t_mod == module(cclass(cl).mod).text)
+            )
+            return cl;
+      }
    }
    return NIL;
 }
 
+
+/* Same deal, except for Tycons. */
+Tycon findQualTyconWithoutConsultingExportList ( QualId q )
+{
+   Tycon tc;
+   Text t_mod;
+   Text t_tycon;
+
+   assert(isQCon(q));
+
+   if (isCon(q)) {
+      t_mod   = NIL;
+      t_tycon = textOf(q);
+   } else {
+      t_mod   = qmodOf(q);
+      t_tycon = qtextOf(q);
+   }
+
+   for (tc = TYCMIN; tc < tyconHw; tc++) {
+      if (tycon(tc).text == t_tycon) {
+         /* Tycon name is ok, but is this the right module? */
+         if (isNull(t_mod)   /* no module name specified */
+             || (nonNull(t_mod) 
+                 && t_mod == module(tycon(tc).mod).text)
+            )
+            return tc;
+      }
+   }
+   return NIL;
+}
+
+Tycon findTyconInAnyModule ( Text t )
+{
+   Tycon tc;
+   for (tc = TYCMIN; tc < tyconHw; tc++)
+      if (tycon(tc).text == t) return tc;
+   return NIL;
+}
+
+Class findClassInAnyModule ( Text t )
+{
+   Class cc;
+   for (cc = CLASSMIN; cc < classHw; cc++)
+      if (cclass(cc).text == t) return cc;
+   return NIL;
+}
+
+Name findNameInAnyModule ( Text t )
+{
+   Name nm;
+   for (nm = NAMEMIN; nm < nameHw; nm++)
+      if (name(nm).text == t) return nm;
+   return NIL;
+}
+
+/* Same deal, except for Names. */
+Name findQualNameWithoutConsultingExportList ( QualId q )
+{
+   Name nm;
+   Text t_mod;
+   Text t_name;
+
+   assert(isQVar(q) || isQCon(q));
+
+   if (isCon(q) || isVar(q)) {
+      t_mod  = NIL;
+      t_name = textOf(q);
+   } else {
+      t_mod  = qmodOf(q);
+      t_name = qtextOf(q);
+   }
+
+   for (nm = NAMEMIN; nm < nameHw; nm++) {
+      if (name(nm).text == t_name) {
+         /* Name is ok, but is this the right module? */
+         if (isNull(t_mod)   /* no module name specified */
+             || (nonNull(t_mod) 
+                 && t_mod == module(name(nm).mod).text)
+            )
+            return nm;
+      }
+   }
+   return NIL;
+}
+
+
+/* returns List of QualId */
+List getAllKnownTyconsAndClasses ( void )
+{
+   Tycon tc;
+   Class nw;
+   List  xs = NIL;
+   for (tc = TYCMIN; tc < tyconHw; tc++) {
+      /* almost certainly undue paranoia about duplicate avoidance, but .. */
+      QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text );
+      if (!qualidIsMember(q,xs))
+         xs = cons ( q, xs );
+   }
+   for (nw = CLASSMIN; nw < classHw; nw++) {
+      QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text );
+      if (!qualidIsMember(q,xs))
+         xs = cons ( q, xs );
+   }
+   return xs;
+}
+
+/* Purely for debugging. */
+void locateSymbolByName ( Text t )
+{
+   Int i;
+   for (i = NAMEMIN; i < nameHw; i++)
+      if (name(i).text == t)
+         fprintf ( stderr, "name(%d)\n", i-NAMEMIN);
+   for (i = TYCMIN; i < tyconHw; i++)
+      if (tycon(i).text == t)
+         fprintf ( stderr, "tycon(%d)\n", i-TYCMIN);
+   for (i = CLASSMIN; i < classHw; i++)
+      if (cclass(i).text == t)
+         fprintf ( stderr, "class(%d)\n", i-CLASSMIN);
+}
+
 /* --------------------------------------------------------------------------
  * Control stack:
  *
@@ -1151,19 +1404,16 @@ Text t; {
         ERRMSG(0) "Module storage space exhausted"
         EEND;
     }
-    module(moduleHw).text          = t; /* clear new module record         */
-    module(moduleHw).qualImports   = NIL;
-    module(moduleHw).exports       = NIL;
-    module(moduleHw).tycons        = NIL;
-    module(moduleHw).names         = NIL;
-    module(moduleHw).classes       = NIL;
-    module(moduleHw).oImage        = NULL;
-    module(moduleHw).oTab          = NULL;
-    module(moduleHw).sizeoTab      = 0;
-    module(moduleHw).usedoTab      = 0;
-    module(moduleHw).dlTab         = NULL;
-    module(moduleHw).sizedlTab     = 0;
-    module(moduleHw).useddlTab     = 0;
+    module(moduleHw).text             = t; /* clear new module record      */
+    module(moduleHw).qualImports      = NIL;
+    module(moduleHw).fake             = FALSE;
+    module(moduleHw).exports          = NIL;
+    module(moduleHw).tycons           = NIL;
+    module(moduleHw).names            = NIL;
+    module(moduleHw).classes          = NIL;
+    module(moduleHw).object           = NULL;
+    module(moduleHw).objectExtras     = NULL;
+    module(moduleHw).objectExtraNames = NIL;
     return moduleHw++;
 }
 
@@ -1249,96 +1499,62 @@ Name jrsFindQualName ( Text mn, Text sn )
 }
 
 
-/* A bit tricky.  Assumes that if tab==NULL, then 
-   currUsed and *currSize must be zero.
-*/
-static
-void* genericExpand ( void* tab, 
-                      int*  currSize, int  currUsed,
-                      int   initSize, int  elemSize )
+char* nameFromOPtr ( void* p )
 {
-   int   size2;
-   void* tab2;
-   if (currUsed < *currSize)
-      return tab;
-   size2 = (*currSize == 0) ? initSize : (2 * *currSize);
-   tab2 = malloc ( size2 * elemSize );
-   if (!tab2) {
-      ERRMSG(0) "Can't allocate enough memory to resize a table"
-      EEND;
+   int i;
+   Module m;
+   for (m=MODMIN; m<moduleHw; m++) {
+      if (module(m).object) {
+         char* nm = ocLookupAddr ( module(m).object, p );
+         if (nm) return nm;
+      }
    }
-   if (*currSize > 0)
-      memcpy ( tab2, tab, elemSize * *currSize );
-   *currSize = size2;
-   if (tab) free ( tab );
-   return tab2;
-}
-
-void addOTabName ( Module m, char* nm, void* ad )
-{
-   module(m).oTab
-      = genericExpand ( module(m).oTab, 
-                        &module(m).sizeoTab,
-                        module(m).usedoTab,
-                        8, sizeof(OSym) );
-
-   module(m).oTab[ module(m).usedoTab ].nm = nm;
-   module(m).oTab[ module(m).usedoTab ].ad = ad;
-   module(m).usedoTab++;
-}
-
-
-void addDLSect ( Module m, void* start, void* end, DLSect sect )
-{
-   module(m).dlTab
-      = genericExpand ( module(m).dlTab,
-                        &module(m).sizedlTab,
-                        module(m).useddlTab,
-                        4, sizeof(DLTabEnt) );
-   module(m).dlTab[ module(m).useddlTab ].start = start;
-   module(m).dlTab[ module(m).useddlTab ].end   = end;
-   module(m).dlTab[ module(m).useddlTab ].sect  = sect;
-   module(m).useddlTab++;
+   return NULL;
 }
 
 
-void* lookupOTabName ( Module m, char* nm )
+void* lookupOTabName ( Module m, char* sym )
 {
-   int i;
-   for (i = 0; i < module(m).usedoTab; i++) {
-      if (1)
-         fprintf ( stderr, 
-                   "lookupOTabName: request %s, table has %s\n",
-                   nm, module(m).oTab[i].nm );
-      if (0==strcmp(nm,module(m).oTab[i].nm))
-         return module(m).oTab[i].ad;
-   }
+   if (module(m).object)
+      return ocLookupSym ( module(m).object, sym );
    return NULL;
 }
 
 
-char* nameFromOPtr ( void* p )
+void* lookupOExtraTabName ( char* sym )
 {
-   int i;
-   Module m;
-   for (m=MODMIN; m<moduleHw; m++)
-      for (i = 0; i < module(m).usedoTab; i++)
-         if (p == module(m).oTab[i].ad)
-            return module(m).oTab[i].nm;
+   ObjectCode* oc;
+   Module      m;
+   for (m = MODMIN; m < moduleHw; m++) {
+      for (oc = module(m).objectExtras; oc; oc=oc->next) {
+         void* ad = ocLookupSym ( oc, sym );
+         if (ad) return ad;
+      }
+   }
    return NULL;
 }
 
 
-DLSect lookupDLSect ( void* ad )
+OSectionKind lookupSection ( void* ad )
 {
-   int i;
-   Module m;
-   for (m=MODMIN; m<moduleHw; m++)
-      for (i = 0; i < module(m).useddlTab; i++)
-         if (module(m).dlTab[i].start <= ad &&
-             ad <= module(m).dlTab[i].end)
-            return module(m).dlTab[i].sect;
-   return HUGS_DL_SECTION_OTHER;
+   int          i;
+   Module       m;
+   ObjectCode*  oc;
+   OSectionKind sect;
+
+   for (m=MODMIN; m<moduleHw; m++) {
+      if (module(m).object) {
+         sect = ocLookupSection ( module(m).object, ad );
+         if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
+            return sect;
+      }
+      for (oc = module(m).objectExtras; oc; oc=oc->next) {
+         sect = ocLookupSection ( oc, ad );
+         if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
+            return sect;
+      }
+   }
+   return HUGS_SECTIONKIND_OTHER;
 }
 
 
@@ -1430,12 +1646,13 @@ String f; {                             /* of status for later restoration  */
 }
 
 Bool isPreludeScript() {                /* Test whether this is the Prelude*/
-    return (scriptHw==0);
+    return (scriptHw < N_PRELUDE_SCRIPTS /*==0*/ );
 }
 
 Bool moduleThisScript(m)                /* Test if given module is defined */
 Module m; {                             /* in current script file          */
-    return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw;
+    return scriptHw < 1
+           || m>=scripts[scriptHw-1].moduleHw;
 }
 
 Module lastModule() {              /* Return module in current script file */
@@ -1969,7 +2186,7 @@ Int  depth; {
                 Printf("Offset %d", offsetOf(c));
                 break;
         case TUPLE:
-                Printf("%s", textToStr(ghcTupleText(tupleOf(c))));
+                Printf("%s", textToStr(ghcTupleText(c)));
                 break;
         case POLYTYPE:
                 Printf("Polytype");
@@ -2103,8 +2320,20 @@ Int  depth; {
                 break;
         case ZTUP2:
                 Printf("<ZPair ");
-                print(snd(c),depth-1);
+                print(zfst(c),depth-1);
+                Putchar(' ');
+                print(zsnd(c),depth-1);
+                Putchar('>');
+                break;
+        case ZTUP3:
+                Printf("<ZTriple ");
+                print(zfst3(c),depth-1);
+                Putchar(' ');
+                print(zsnd3(c),depth-1);
+                Putchar(' ');
+                print(zthd3(c),depth-1);
                 Putchar('>');
+                break;
         case BANG:
                 Printf("(BANG,");
                 print(snd(c),depth-1);
@@ -2172,6 +2401,16 @@ Cell c; {
     return isPair(c) && (fst(c)==QUALIDENT);
 }
 
+Bool eqQualIdent ( QualId c1, QualId c2 )
+{
+   assert(isQualIdent(c1));
+   if (!isQualIdent(c2)) {
+   assert(isQualIdent(c2));
+   }
+   return qmodOf(c1)==qmodOf(c2) &&
+          qtextOf(c1)==qtextOf(c2);
+}
+
 Bool isIdent(c)                        /* is cell an identifier?           */
 Cell c; {
     if (!isPair(c)) return FALSE;
@@ -2194,8 +2433,7 @@ Cell c; {
 
 Int intOf(c)                           /* find integer value of cell?      */
 Cell c; {
-  if (!isInt(c)) {
-    assert(isInt(c)); }
+    assert(isInt(c));
     return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO);
 }
 
@@ -2206,8 +2444,10 @@ Int n; {
            : pair(INTCELL,n);
 }
 
-#if SIZEOF_INTP == SIZEOF_INT
+#if SIZEOF_VOID_P == SIZEOF_INT
+
 typedef union {Int i; Ptr p;} IntOrPtr;
+
 Cell mkPtr(p)
 Ptr p;
 {
@@ -2224,6 +2464,7 @@ Cell c;
     x.i = snd(c);
     return x.p;
 }
+
 Cell mkCPtr(p)
 Ptr p;
 {
@@ -2240,8 +2481,11 @@ Cell c;
     x.i = snd(c);
     return x.p;
 }
-#elif SIZEOF_INTP == 2*SIZEOF_INT
+
+#elif SIZEOF_VOID_P == 2*SIZEOF_INT
+
 typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
+
 Cell mkPtr(p)
 Ptr p;
 {
@@ -2259,23 +2503,32 @@ Cell c;
     x.i.i2 = intOf(snd(snd(c)));
     return x.p;
 }
-#else
-#warning "type Addr not supported on this architecture - don't use it"
-Cell mkPtr(p)
+
+Cell mkCPtr(p)
 Ptr p;
 {
-    ERRMSG(0) "mkPtr: type Addr not supported on this architecture"
-    EEND;
+    IntOrPtr x;
+    x.p = p;
+    return pair(CPTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
 }
 
-Ptr ptrOf(c)
+Ptr cptrOf(c)
 Cell c;
 {
-    ERRMSG(0) "ptrOf: type Addr not supported on this architecture"
-    EEND;
+    IntOrPtr x;
+    assert(fst(c) == CPTRCELL);
+    x.i.i1 = intOf(fst(snd(c)));
+    x.i.i2 = intOf(snd(snd(c)));
+    return x.p;
 }
+
+#else
+
+#error "Can't implement mkPtr/ptrOf on this architecture."
+
 #endif
 
+
 String stringNegate( s )
 String s;
 {
@@ -2349,6 +2602,15 @@ List xs, ys; {                         /* list xs onto list ys...          */
     return ys;
 }
 
+QualId qualidIsMember ( QualId q, List xs )
+{
+   for (; nonNull(xs); xs=tl(xs)) {
+      if (eqQualIdent(q, hd(xs)))
+         return hd(xs);
+   }
+   return NIL;
+}  
+
 Cell varIsMember(t,xs)                 /* Test if variable is a member of  */
 Text t;                                /* given list of variables          */
 List xs; {
@@ -2680,6 +2942,142 @@ List args; {
     return f;
 }
 
+/* --------------------------------------------------------------------------
+ * debugging support
+ * ------------------------------------------------------------------------*/
+
+static String maybeModuleStr ( Module m )
+{
+   if (isModule(m)) return textToStr(module(m).text); else return "??";
+}
+
+static String maybeNameStr ( Name n )
+{
+   if (isName(n)) return textToStr(name(n).text); else return "??";
+}
+
+static String maybeTyconStr ( Tycon t )
+{
+   if (isTycon(t)) return textToStr(tycon(t).text); else return "??";
+}
+
+static String maybeClassStr ( Class c )
+{
+   if (isClass(c)) return textToStr(cclass(c).text); else return "??";
+}
+
+static String maybeText ( Text t )
+{
+   if (isNull(t)) return "(nil)";
+   return textToStr(t);
+}
+
+static void print100 ( Int x )
+{
+   print ( x, 100); printf("\n");
+}
+
+void dumpTycon ( Int t )
+{
+   if (isTycon(TYCMIN+t) && !isTycon(t)) t += TYCMIN;
+   if (!isTycon(t)) {
+      printf ( "dumpTycon %d: not a tycon\n", t);
+      return;
+   }
+   printf ( "{\n" );
+   printf ( "    text: %s\n",     textToStr(tycon(t).text) );
+   printf ( "    line: %d\n",     tycon(t).line );
+   printf ( "     mod: %s\n",     maybeModuleStr(tycon(t).mod));
+   printf ( "   tuple: %d\n",     tycon(t).tuple);
+   printf ( "   arity: %d\n",     tycon(t).arity);
+   printf ( "    kind: ");        print100(tycon(t).kind);
+   printf ( "    what: %d\n",     tycon(t).what);
+   printf ( "    defn: ");        print100(tycon(t).defn);
+   printf ( "    cToT: %d %s\n",  tycon(t).conToTag, 
+                                  maybeNameStr(tycon(t).conToTag));
+   printf ( "    tToC: %d %s\n",  tycon(t).tagToCon, 
+                                  maybeNameStr(tycon(t).tagToCon));
+   printf ( "    itbl: %p\n",     tycon(t).itbl);
+   printf ( "  nextTH: %d %s\n",  tycon(t).nextTyconHash,
+                                  maybeTyconStr(tycon(t).nextTyconHash));
+   printf ( "}\n" );
+}
+
+void dumpName ( Int n )
+{
+   if (isName(NAMEMIN+n) && !isName(n)) n += NAMEMIN;
+   if (!isName(n)) {
+      printf ( "dumpName %d: not a name\n", n);
+      return;
+   }
+   printf ( "{\n" );
+   printf ( "    text: %s\n",     textToStr(name(n).text) );
+   printf ( "    line: %d\n",     name(n).line );
+   printf ( "     mod: %s\n",     maybeModuleStr(name(n).mod));
+   printf ( "  syntax: %d\n",     name(n).syntax );
+   printf ( "  parent: %d\n",     name(n).parent );
+   printf ( "   arity: %d\n",     name(n).arity );
+   printf ( "  number: %d\n",     name(n).number );
+   printf ( "    type: ");        print100(name(n).type);
+   printf ( "    defn: %d\n",     name(n).defn );
+   printf ( "  stgVar: ");        print100(name(n).stgVar);
+   printf ( "   cconv: %d\n",     name(n).callconv );
+   printf ( "  primop: %p\n",     name(n).primop );
+   printf ( "    itbl: %p\n",     name(n).itbl );
+   printf ( "  nextNH: %d\n",     name(n).nextNameHash );
+   printf ( "}\n" );
+}
+
+
+void dumpClass ( Int c )
+{
+   if (isClass(CLASSMIN+c) && !isClass(c)) c += CLASSMIN;
+   if (!isClass(c)) {
+      printf ( "dumpClass %d: not a class\n", c);
+      return;
+   }
+   printf ( "{\n" );
+   printf ( "    text: %s\n",     textToStr(cclass(c).text) );
+   printf ( "    line: %d\n",     cclass(c).line );
+   printf ( "     mod: %s\n",     maybeModuleStr(cclass(c).mod));
+   printf ( "   arity: %d\n",     cclass(c).arity );
+   printf ( "   level: %d\n",     cclass(c).level );
+   printf ( "   kinds: ");        print100( cclass(c).kinds );
+   printf ( "     fds: %d\n",     cclass(c).fds );
+   printf ( "    xfds: %d\n",     cclass(c).xfds );
+   printf ( "    head: ");        print100( cclass(c).head );
+   printf ( "    dcon: ");        print100( cclass(c).dcon );
+   printf ( "  supers: ");        print100( cclass(c).supers );
+   printf ( " #supers: %d\n",     cclass(c).numSupers );
+   printf ( "   dsels: ");        print100( cclass(c).dsels );
+   printf ( " members: ");        print100( cclass(c).members );
+   printf ( "#members: %d\n",     cclass(c).numMembers );
+   printf ( "defaults: ");        print100( cclass(c).defaults );
+   printf ( "   insts: ");        print100( cclass(c).instances );
+   printf ( "}\n" );
+}
+
+
+void dumpInst ( Int i )
+{
+   if (isInst(INSTMIN+i) && !isInst(i)) i += INSTMIN;
+   if (!isInst(i)) {
+      printf ( "dumpInst %d: not an instance\n", i);
+      return;
+   }
+   printf ( "{\n" );
+   printf ( "   class: %s\n",     maybeClassStr(inst(i).c) );
+   printf ( "    line: %d\n",     inst(i).line );
+   printf ( "     mod: %s\n",     maybeModuleStr(inst(i).mod));
+   printf ( "   kinds: ");        print100( inst(i).kinds );
+   printf ( "    head: ");        print100( inst(i).head );
+   printf ( "   specs: ");        print100( inst(i).specifics );
+   printf ( "  #specs: %d\n",     inst(i).numSpecifics );
+   printf ( "   impls: ");        print100( inst(i).implements );
+   printf ( " builder: %s\n",     maybeNameStr( inst(i).builder ) );
+   printf ( "}\n" );
+}
+
 
 /* --------------------------------------------------------------------------
  * plugin support
@@ -2822,6 +3220,7 @@ Int what; {
                            mark(module(i).classes);
                            mark(module(i).exports);
                            mark(module(i).qualImports);
+                           mark(module(i).objectExtraNames);
                        }
                        end("Modules", moduleHw-MODMIN);