* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.37 $
- * $Date: 2000/01/11 14:51:43 $
+ * $Revision: 1.48 $
+ * $Date: 2000/03/10 14:53:00 $
* ------------------------------------------------------------------------*/
#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;
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 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;
}
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;
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:
*
if (nm) return nm;
}
}
+# if 0
+ /* A kludge to assist Win32 debugging; not actually necessary. */
+ { char* nm = nameFromStaticOPtr(p);
+ if (nm) return nm;
+ }
+# endif
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;
}
}
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 */
return c;*/
}
-#if DEBUG_PRINTER
/* A very, very simple printer.
* Output is uglier than from printExp - but the printer is more
* robust and can be used on any data structure irrespective of
Int depth; {
if (0 == depth) {
Printf("...");
-#if 0 /* Not in this version of Hugs */
- } else if (isPair(c) && !isGenPair(c)) {
- extern Void printEvalCell Args((Cell, Int));
- printEvalCell(c,depth);
-#endif
} else {
Int tag = whatIs(c);
switch (tag) {
}
FlushStdout();
}
-#endif
+
Bool isVar(c) /* is cell a VARIDCELL/VAROPCELL ? */
Cell c; { /* also recognises DICTVAR cells */
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