* 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"
#include "backend.h"
#include "connect.h"
#include "errors.h"
+#include "object.h"
#include <setjmp.h>
/*#define DEBUG_SHOWUSE*/
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;
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);
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);
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) );
}
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:
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);
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)");
* 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;
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);
|| 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:
*
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++;
}
}
-/* 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;
}
}
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 */
Printf("Offset %d", offsetOf(c));
break;
case TUPLE:
- Printf("%s", textToStr(ghcTupleText(tupleOf(c))));
+ Printf("%s", textToStr(ghcTupleText(c)));
break;
case POLYTYPE:
Printf("Polytype");
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);
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;
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);
}
: 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;
{
x.i = snd(c);
return x.p;
}
+
Cell mkCPtr(p)
Ptr p;
{
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;
{
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;
{
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; {
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
mark(module(i).classes);
mark(module(i).exports);
mark(module(i).qualImports);
+ mark(module(i).objectExtraNames);
}
end("Modules", moduleHw-MODMIN);
projects / ghc-hetmet.git / blobdiff