* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.28 $
- * $Date: 1999/12/20 16:55:27 $
+ * $Revision: 1.46 $
+ * $Date: 2000/02/25 10:53:54 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
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;
+ 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[n+1] = ')';
- buf[n+2] = 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);
}
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)");
Name addWiredInBoxingTycon
( String modNm, String typeNm, String constrNm,
- Int arity, Int no, Int rep )
+ Int rep, Kind kind )
{
- Name n;
- Tycon t;
- Text modT = findText(modNm);
- Text typeT = findText(typeNm);
- Text conT = findText(constrNm);
- Module m = findFakeModule(modT);
+ 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 = arity;
- name(n).number = cfunNo(no);
- name(n).type = 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;
+ Int i;
+ Kind k;
+ Tycon t;
Module m;
+ Name nm;
for (i = TYCMIN; i < tyconHw; i++)
if (tycon(i).tuple == n) return i;
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;
}
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;
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);
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 )
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:
*
int i;
Module m;
for (m=MODMIN; m<moduleHw; m++) {
- char* nm = ocLookupAddr ( module(m).object, p );
- if (nm) return nm;
+ if (module(m).object) {
+ char* nm = ocLookupAddr ( module(m).object, p );
+ if (nm) return nm;
+ }
}
return NULL;
}
void* lookupOTabName ( Module m, char* sym )
{
- return ocLookupSym ( module(m).object, sym );
+ if (module(m).object)
+ return ocLookupSym ( module(m).object, sym );
+ return NULL;
}
OSectionKind lookupSection ( void* ad )
{
- int i;
- Module m;
+ int i;
+ Module m;
+ ObjectCode* oc;
+ OSectionKind sect;
+
for (m=MODMIN; m<moduleHw; m++) {
- OSectionKind sect
- = ocLookupSection ( module(m).object, ad );
- if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
- return sect;
+ 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 */
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 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
projects / ghc-hetmet.git / blobdiff