/* --------------------------------------------------------------------------
* Primitives for manipulating global data structures
*
- * 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: storage.c,v $
- * $Revision: 1.7 $
- * $Date: 1999/06/07 17:22:49 $
+ * $Revision: 1.21 $
+ * $Date: 1999/12/03 17:01:23 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
return (t<0 || t>=NUM_TEXT);
}
+#define MAX_FIXLIT 100
+Text fixLitText(t) /* fix literal text that might include \ */
+Text t; {
+ String s = textToStr(t);
+ char p[MAX_FIXLIT];
+ Int i;
+ for(i = 0;i < MAX_FIXLIT-2 && *s;s++) {
+ p[i++] = *s;
+ if (*s == '\\') {
+ p[i++] = '\\';
+ }
+ }
+ if (i < MAX_FIXLIT-2) {
+ p[i] = 0;
+ } else {
+ ERRMSG(0) "storage space exhausted for internal literal string"
+ EEND;
+ }
+ return (findText(p));
+}
+#undef MAX_FIXLIT
+
static Int local hash(s) /* Simple hash function on strings */
String s; {
int v, j = 3;
}
+static int fromHexDigit ( char c )
+{
+ switch (c) {
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ return c - '0';
+ case 'a': case 'A': return 10;
+ case 'b': case 'B': return 11;
+ case 'c': case 'C': return 12;
+ case 'd': case 'D': return 13;
+ case 'e': case 'E': return 14;
+ case 'f': case 'F': return 15;
+ default: return -1;
+ }
+}
+
+
+/* returns findText (unZencode s) */
+Text unZcodeThenFindText ( String s )
+{
+ unsigned char* p;
+ Int n, nn, i;
+ Text t;
+
+ assert(s);
+ nn = 100 + 10 * strlen(s);
+ p = malloc ( nn );
+ if (!p) internal ("unZcodeThenFindText: malloc failed");
+ n = 0;
+
+ while (1) {
+ if (!(*s)) break;
+ if (n > nn-90) internal ("unZcodeThenFindText: result is too big");
+ if (*s != 'z' && *s != 'Z') {
+ p[n] = *s; n++; s++;
+ continue;
+ }
+ s++;
+ if (!(*s)) goto parse_error;
+ switch (*s++) {
+ case 'Z': p[n++] = 'Z'; break;
+ case 'C': p[n++] = ':'; break;
+ case 'L': p[n++] = '('; break;
+ case 'R': p[n++] = ')'; break;
+ case 'M': p[n++] = '['; break;
+ case 'N': p[n++] = ']'; break;
+ case 'z': p[n++] = 'z'; break;
+ case 'a': p[n++] = '&'; break;
+ case 'b': p[n++] = '|'; break;
+ case 'd': p[n++] = '$'; break;
+ case 'e': p[n++] = '='; break;
+ case 'g': p[n++] = '>'; break;
+ case 'h': p[n++] = '#'; break;
+ case 'i': p[n++] = '.'; break;
+ case 'l': p[n++] = '<'; break;
+ case 'm': p[n++] = '-'; break;
+ case 'n': p[n++] = '!'; break;
+ case 'p': p[n++] = '+'; break;
+ case 'q': p[n++] = '\\'; break;
+ case 'r': p[n++] = '\''; break;
+ case 's': p[n++] = '/'; break;
+ case 't': p[n++] = '*'; break;
+ case 'u': p[n++] = '^'; break;
+ case 'v': p[n++] = '%'; break;
+ case 'x':
+ if (!s[0] || !s[1]) goto parse_error;
+ if (fromHexDigit(s[0]) < 0 || fromHexDigit(s[1]) < 0) goto parse_error;
+ p[n++] = 16 * fromHexDigit(s[0]) + fromHexDigit(s[1]);
+ p += 2; s += 2;
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ i = 0;
+ s--;
+ while (*s && isdigit((int)(*s))) {
+ i = 10 * i + (*s - '0');
+ s++;
+ }
+ if (*s != 'T') goto parse_error;
+ s++;
+ p[n++] = '(';
+ while (i > 0) { p[n++] = ','; i--; };
+ p[n++] = ')';
+ break;
+ default:
+ goto parse_error;
+ }
+ }
+ p[n] = 0;
+ t = findText(p);
+ free(p);
+ return t;
+
+ parse_error:
+ free(p);
+ fprintf ( stderr, "\nstring = `%s'\n", s );
+ internal ( "unZcodeThenFindText: parse error on above string");
+ return NIL; /*notreached*/
+}
+
+
+Text enZcodeThenFindText ( String s )
+{
+ unsigned char* p;
+ Int n, nn;
+ Text t;
+ char toHex[16] = "0123456789ABCDEF";
+
+ assert(s);
+ nn = 100 + 10 * strlen(s);
+ p = malloc ( nn );
+ if (!p) internal ("enZcodeThenFindText: malloc failed");
+ n = 0;
+ while (1) {
+ if (!(*s)) break;
+ if (n > nn-90) internal ("enZcodeThenFindText: result is too big");
+ if (*s != 'z'
+ && *s != 'Z'
+ && (isalnum((int)(*s)) || *s == '_')) {
+ p[n] = *s; n++; s++;
+ continue;
+ }
+ switch (*s++) {
+ case '(': p[n++] = 'Z'; p[n++] = 'L'; break;
+ case ')': p[n++] = 'Z'; p[n++] = 'R'; break;
+ case '[': p[n++] = 'Z'; p[n++] = 'M'; break;
+ case ']': p[n++] = 'Z'; p[n++] = 'N'; break;
+ case ':': p[n++] = 'Z'; p[n++] = 'C'; break;
+ case 'Z': p[n++] = 'Z'; p[n++] = 'Z'; break;
+ case 'z': p[n++] = 'z'; p[n++] = 'z'; break;
+ case '&': p[n++] = 'z'; p[n++] = 'a'; break;
+ case '|': p[n++] = 'z'; p[n++] = 'b'; break;
+ case '$': p[n++] = 'z'; p[n++] = 'd'; break;
+ case '=': p[n++] = 'z'; p[n++] = 'e'; break;
+ case '>': p[n++] = 'z'; p[n++] = 'g'; break;
+ case '#': p[n++] = 'z'; p[n++] = 'h'; break;
+ case '.': p[n++] = 'z'; p[n++] = 'i'; break;
+ case '<': p[n++] = 'z'; p[n++] = 'l'; break;
+ case '-': p[n++] = 'z'; p[n++] = 'm'; break;
+ case '!': p[n++] = 'z'; p[n++] = 'n'; break;
+ case '+': p[n++] = 'z'; p[n++] = 'p'; break;
+ case '\'': p[n++] = 'z'; p[n++] = 'q'; break;
+ case '\\': p[n++] = 'z'; p[n++] = 'r'; break;
+ case '/': p[n++] = 'z'; p[n++] = 's'; break;
+ case '*': p[n++] = 'z'; p[n++] = 't'; break;
+ case '^': p[n++] = 'z'; p[n++] = 'u'; break;
+ case '%': p[n++] = 'z'; p[n++] = 'v'; break;
+ default: s--; p[n++] = 'z'; p[n++] = 'x';
+ p[n++] = toHex[(int)(*s)/16];
+ p[n++] = toHex[(int)(*s)%16];
+ s++; break;
+ }
+ }
+ p[n] = 0;
+ t = findText(p);
+ free(p);
+ return t;
+}
+
+
+Text textOf ( Cell c )
+{
+ Bool ok =
+ (whatIs(c)==VARIDCELL
+ || whatIs(c)==CONIDCELL
+ || whatIs(c)==VAROPCELL
+ || whatIs(c)==CONOPCELL
+ || whatIs(c)==STRCELL
+ || whatIs(c)==DICTVAR
+ );
+ if (!ok) {
+ fprintf(stderr, "\ntextOf: bad tag %d\n",whatIs(c) );
+ internal("textOf: bad tag");
+ }
+ return snd(c);
+}
+
/* --------------------------------------------------------------------------
* Ext storage:
*
static Void local hashTycon(tc) /* Insert Tycon into hash table */
Tycon tc; {
- Text t = tycon(tc).text;
- Int h = tHash(t);
- tycon(tc).nextTyconHash = tyconHash[h];
- tyconHash[h] = tc;
+ assert(isTycon(tc));
+ if (1) {
+ Text t = tycon(tc).text;
+ Int h = tHash(t);
+ tycon(tc).nextTyconHash = tyconHash[h];
+ tyconHash[h] = tc;
+ }
}
Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
}
default : internal("findQualTycon2");
}
- return 0; /* NOTREACHED */
+ return NIL; /* NOTREACHED */
}
Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
return ts;
}
+Text ghcTupleText(tup)
+Tycon tup; {
+ Int i;
+ char buf[103];
+ assert(isTuple(tup));
+ tup = tupleOf(tup);
+ if (tup >= 100) internal("ghcTupleText");
+ buf[0] = '(';
+ for (i = 1; i <= tup; i++) buf[i] = ',';
+ buf[i] = ')';
+ buf[i+1] = 0;
+ return findText(buf);
+}
+
/* --------------------------------------------------------------------------
* Name storage:
*
name(nameHw).number = EXECNAME;
name(nameHw).defn = NIL;
name(nameHw).stgVar = NIL;
- name(nameHw).stgSize = 0;
- name(nameHw).inlineMe = FALSE;
- name(nameHw).simplified = FALSE;
- name(nameHw).isDBuilder = FALSE;
+ name(nameHw).callconv = NIL;
name(nameHw).type = NIL;
name(nameHw).primop = 0;
name(nameHw).mod = currentModule;
- name(nameHw).ghc_names = NIL;
module(currentModule).names=cons(nameHw,module(currentModule).names);
name(nameHw).nextNameHash = nameHash[h];
nameHash[h] = nameHw;
return NIL;
}
+void* getHugs_AsmObject_for ( char* s )
+{
+ StgVar v;
+ Text t = findText(s);
+ Name n = NIL;
+ for (n = NAMEMIN; n < nameHw; n++)
+ if (name(n).text == t) break;
+ if (n == nameHw) internal("getHugs_AsmObject_for(1)");
+ v = name(n).stgVar;
+ if (!isStgVar(v) || !isPtr(stgVarInfo(v)))
+ internal("getHugs_AsmObject_for(2)");
+ return ptrOf(stgVarInfo(v));
+}
/* --------------------------------------------------------------------------
* Primitive functions:
cclass(classHw).arity = 0;
cclass(classHw).kinds = NIL;
cclass(classHw).head = NIL;
+ cclass(classHw).fds = NIL;
+ cclass(classHw).xfds = NIL;
cclass(classHw).dcon = NIL;
cclass(classHw).supers = NIL;
cclass(classHw).dsels = NIL;
cclass(classHw).members = NIL;
- cclass(classHw).dbuild = NIL;
cclass(classHw).defaults = NIL;
cclass(classHw).instances = NIL;
classes=cons(classHw,classes);
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;
return moduleHw++;
}
case CONIDCELL : return findModule(textOf(c));
default : internal("findModid");
}
- assert(0); return 0; /* NOTREACHED */
+ return NIL;/*NOTUSED*/
}
static local Module findQualifier(t) /* locate Module in import list */
Text t; {
Module ms;
-printf ( "findQualifier %s\n", textToStr(t));
for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
if (textOf(fst(hd(ms)))==t)
return snd(hd(ms));
Void setCurrModule(m) /* set lookup tables for current module */
Module m; {
Int i;
+ assert(isModule(m));
if (m!=currentModule) {
currentModule = m; /* This is the only assignment to currentModule */
for (i=0; i<TYCONHSZ; ++i)
return NIL;
}
+
+/* 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 )
+{
+ 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;
+ }
+ 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++;
+}
+
+
+void* lookupOTabName ( Module m, char* nm )
+{
+ 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;
+ }
+ return NULL;
+}
+
+
+char* nameFromOPtr ( void* p )
+{
+ 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;
+ return NULL;
+}
+
+
+DLSect lookupDLSect ( 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;
+}
+
+
/* --------------------------------------------------------------------------
* Script file storage:
*
}
}
+ /* STACK_CHECK: Avoid stack overflows during recursive marking. */
if (isGenPair(fst(c))) {
+ STACK_CHECK
fst(c) = markCell(fst(c));
markSnd(c);
}
else if (isNull(fst(c)) || fst(c)>=BCSTAG) {
+ STACK_CHECK
markSnd(c);
}
case CONOPCELL:
Printf("{id %s}",textToStr(textOf(c)));
break;
+#if IPARAM
+ case IPCELL :
+ Printf("{ip %s}",textToStr(textOf(c)));
+ break;
+ case IPVAR :
+ Printf("?%s",textToStr(textOf(c)));
+ break;
+#endif
case QUALIDENT:
Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
break;
print(snd(snd(c)),depth-1);
Putchar(')');
break;
+ case DICTAP:
+ Printf("(DICTAP,");
+ print(snd(c),depth-1);
+ Putchar(')');
+ break;
+ case UNBOXEDTUP:
+ Printf("(UNBOXEDTUP,");
+ print(snd(c),depth-1);
+ Putchar(')');
+ break;
+ case BANG:
+ Printf("(BANG,");
+ print(snd(c),depth-1);
+ Putchar(')');
+ break;
default:
if (isBoxTag(tag)) {
Printf("Tag(%d)=%d", c, tag);
mark(name(i).defn);
mark(name(i).stgVar);
mark(name(i).type);
- mark(name(i).ghc_names);
- }
+ }
end("Names", nameHw-NAMEMIN);
start();
for (i=CLASSMIN; i<classHw; ++i) {
mark(cclass(i).head);
mark(cclass(i).kinds);
+ mark(cclass(i).fds);
+ mark(cclass(i).xfds);
mark(cclass(i).dsels);
mark(cclass(i).supers);
mark(cclass(i).members);
projects / ghc-hetmet.git / blobdiff