X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fstorage.c;h=637c15bc6ca4b9f06eed3f66f2fa55c83a73a17b;hb=9ff75d089614cce1cfa8c88344ace47698258bfa;hp=a302cb7bc659cfba0ce5619fcea3009eaca9187a;hpb=9df21476c4963a6ec4de6401a6e7275ba632f4bd;p=ghc-hetmet.git diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index a302cb7..637c15b 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,17 +9,17 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.34 $ - * $Date: 2000/01/10 16:23:33 $ + * $Revision: 1.71 $ + * $Date: 2000/04/14 15:18:06 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "backend.h" #include "connect.h" #include "errors.h" #include "object.h" #include +#include "Stg.h" /*#define DEBUG_SHOWUSE*/ @@ -27,22 +27,21 @@ * local function prototypes: * ------------------------------------------------------------------------*/ -static Int local hash Args((String)); -static Int local saveText Args((Text)); -static Module local findQualifier Args((Text)); -static Void local hashTycon Args((Tycon)); -static List local insertTycon Args((Tycon,List)); -static Void local hashName Args((Name)); -static List local insertName Args((Name,List)); -static Void local patternError Args((String)); -static Bool local stringMatch Args((String,String)); -static Bool local typeInvolves Args((Type,Type)); -static Cell local markCell Args((Cell)); -static Void local markSnd Args((Cell)); -static Cell local lowLevelLastIn Args((Cell)); -static Cell local lowLevelLastOut Args((Cell)); - Module local moduleOfScript Args((Script)); - Script local scriptThisFile Args((Text)); +static Int local hash ( String ); +static Int local saveText ( Text ); +static Module local findQualifier ( Text ); +static Void local hashTycon ( Tycon ); +static List local insertTycon ( Tycon,List ); +static Void local hashName ( Name ); +static List local insertName ( Name,List ); +static Void local patternError ( String ); +static Bool local stringMatch ( String,String ); +static Bool local typeInvolves ( Type,Type ); +static Cell local markCell ( Cell ); +static Void local markSnd ( Cell ); +static Cell local lowLevelLastIn ( Cell ); +static Cell local lowLevelLastOut ( Cell ); + /* -------------------------------------------------------------------------- * Text storage: @@ -73,23 +72,29 @@ static Cell local lowLevelLastOut Args((Cell)); #define TEXTHSZ 512 /* Size of Text hash table */ #define NOTEXT ((Text)(~0)) /* Empty bucket in Text hash table */ static Text textHw; /* Next unused position */ -static Text savedText = NUM_TEXT; /* Start of saved portion of text */ +static Text savedText = TEXT_SIZE; /* Start of saved portion of text */ static Text nextNewText; /* Next new text value */ static Text nextNewDText; /* Next new dict text value */ -static char DEFTABLE(text,NUM_TEXT);/* Storage of character strings */ +static char text[TEXT_SIZE]; /* Storage of character strings */ static Text textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage */ String textToStr(t) /* find string corresp to given Text*/ Text t; { static char newVar[16]; - if (0<=t && t= INVAR_BASE_ADDR+INVAR_MAX_AVAIL) + internal("inventText: too many invented variables"); + return nextNewText++; } Text inventDictText() { /* return new unused dictvar name */ - return nextNewDText--; + if (nextNewDText >= INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL) + internal("inventDictText: too many invented variables"); + return nextNewDText++; } Bool inventedText(t) /* Signal TRUE if text has been */ Text t; { /* generated internally */ - return (t<0 || t>=NUM_TEXT); + return isInventedVar(t) || isInventedDictVar(t); } #define MAX_FIXLIT 100 @@ -175,13 +185,13 @@ String s; { int hashno = 0; Text textPos = textHash[h][hashno]; -#define TryMatch { Text originalTextPos = textPos; \ +# define TryMatch { Text originalTextPos = textPos; \ String t; \ for (t=s; *t==text[textPos]; textPos++,t++) \ if (*t=='\0') \ - return originalTextPos; \ + return originalTextPos+TEXT_BASE_ADDR; \ } -#define Skip while (text[textPos++]) ; +# define Skip while (text[textPos++]) ; while (textPos!=NOTEXT) { TryMatch @@ -213,14 +223,13 @@ String s; { textHash[h][hashno+1] = NOTEXT; } - return textPos; + return textPos+TEXT_BASE_ADDR; } static Int local saveText(t) /* Save text value in buffer */ Text t; { /* at top of text table */ String s = textToStr(t); Int l = strlen(s); - if (textHw + l + 1 > savedText) { ERRMSG(0) "Character string storage space exhausted" EEND; @@ -353,6 +362,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; @@ -393,16 +415,19 @@ Text enZcodeThenFindText ( String s ) Text textOf ( Cell c ) { + Int wot = whatIs(c); Bool ok = - (whatIs(c)==VARIDCELL - || whatIs(c)==CONIDCELL - || whatIs(c)==VAROPCELL - || whatIs(c)==CONOPCELL - || whatIs(c)==STRCELL - || whatIs(c)==DICTVAR + (wot==VARIDCELL + || wot==CONIDCELL + || wot==VAROPCELL + || wot==CONOPCELL + || wot==STRCELL + || wot==DICTVAR + || wot==IPCELL + || wot==IPVAR ); if (!ok) { - fprintf(stderr, "\ntextOf: bad tag %d\n",whatIs(c) ); + fprintf(stderr, "\ntextOf: bad tag %d\n",wot ); internal("textOf: bad tag"); } return snd(c); @@ -439,6 +464,156 @@ Text t; { } #endif + +/* -------------------------------------------------------------------------- + * Expandable symbol tables. A template, which is instantiated for the name, + * tycon, class, instance and module tables. Also, potentially, TREX Exts. + * ------------------------------------------------------------------------*/ + +#ifdef DEBUG_STORAGE_EXTRA +static Bool debugStorageExtra = TRUE; +#else +static Bool debugStorageExtra = FALSE; +#endif + + +#define EXPANDABLE_SYMBOL_TABLE(type_name,struct_name, \ + proc_name,free_proc_name, \ + free_list,tab_name,tab_size,err_msg, \ + TAB_INIT_SIZE,TAB_MAX_SIZE, \ + TAB_BASE_ADDR) \ + \ + struct struct_name* tab_name = NULL; \ + int tab_size = 0; \ + static type_name free_list = TAB_BASE_ADDR-1; \ + \ + void free_proc_name ( type_name n ) \ + { \ + assert(TAB_BASE_ADDR <= n); \ + assert(n < TAB_BASE_ADDR+tab_size); \ + assert(tab_name[n-TAB_BASE_ADDR].inUse); \ + tab_name[n-TAB_BASE_ADDR].inUse = FALSE; \ + if (!debugStorageExtra) { \ + tab_name[n-TAB_BASE_ADDR].nextFree = free_list; \ + free_list = n; \ + } \ + } \ + \ + type_name proc_name ( void ) \ + { \ + Int i; \ + Int newSz; \ + struct struct_name* newTab; \ + struct struct_name* temp; \ + try_again: \ + if (free_list != TAB_BASE_ADDR-1) { \ + type_name t = free_list; \ + free_list = tab_name[free_list-TAB_BASE_ADDR].nextFree; \ + assert (!(tab_name[t-TAB_BASE_ADDR].inUse)); \ + tab_name[t-TAB_BASE_ADDR].inUse = TRUE; \ + return t; \ + } \ + \ + newSz = (tab_size == 0 ? TAB_INIT_SIZE : 2 * tab_size); \ + if (newSz > TAB_MAX_SIZE) goto cant_allocate; \ + newTab = malloc(newSz * sizeof(struct struct_name)); \ + if (!newTab) goto cant_allocate; \ + for (i = 0; i < tab_size; i++) \ + newTab[i] = tab_name[i]; \ + for (i = tab_size; i < newSz; i++) { \ + newTab[i].inUse = FALSE; \ + newTab[i].nextFree = i-1+TAB_BASE_ADDR; \ + } \ + if (0 && debugStorageExtra) \ + fprintf(stderr, "Expanding " #type_name \ + "table to size %d\n", newSz ); \ + newTab[tab_size].nextFree = TAB_BASE_ADDR-1; \ + free_list = newSz-1+TAB_BASE_ADDR; \ + tab_size = newSz; \ + temp = tab_name; \ + tab_name = newTab; \ + if (temp) free(temp); \ + goto try_again; \ + \ + cant_allocate: \ + ERRMSG(0) err_msg \ + EEND; \ + } \ + + + +EXPANDABLE_SYMBOL_TABLE(Name,strName,allocNewName,freeName, + nameFL,tabName,tabNameSz, + "Name storage space exhausted", + NAME_INIT_SIZE,NAME_MAX_SIZE,NAME_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Tycon,strTycon,allocNewTycon,freeTycon, + tyconFL,tabTycon,tabTyconSz, + "Type constructor storage space exhausted", + TYCON_INIT_SIZE,TYCON_MAX_SIZE,TYCON_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Class,strClass,allocNewClass,freeClass, + classFL,tabClass,tabClassSz, + "Class storage space exhausted", + CCLASS_INIT_SIZE,CCLASS_MAX_SIZE,CCLASS_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Inst,strInst,allocNewInst,freeInst, + instFL,tabInst,tabInstSz, + "Instance storage space exhausted", + INST_INIT_SIZE,INST_MAX_SIZE,INST_BASE_ADDR) + + +EXPANDABLE_SYMBOL_TABLE(Module,strModule,allocNewModule,freeModule, + moduleFL,tabModule,tabModuleSz, + "Module storage space exhausted", + MODULE_INIT_SIZE,MODULE_MAX_SIZE,MODULE_BASE_ADDR) + +#ifdef DEBUG_STORAGE +struct strName* generate_name_ref ( Cell nm ) +{ + assert(isName(nm)); + nm -= NAME_BASE_ADDR; + assert(tabName[nm].inUse); + assert(isModule(tabName[nm].mod)); + return & tabName[nm]; +} +struct strTycon* generate_tycon_ref ( Cell tc ) +{ + assert(isTycon(tc) || isTuple(tc)); + tc -= TYCON_BASE_ADDR; + assert(tabTycon[tc].inUse); + assert(isModule(tabTycon[tc].mod)); + return & tabTycon[tc]; +} +struct strClass* generate_cclass_ref ( Cell cl ) +{ + assert(isClass(cl)); + cl -= CCLASS_BASE_ADDR; + assert(tabClass[cl].inUse); + assert(isModule(tabClass[cl].mod)); + return & tabClass[cl]; +} +struct strInst* generate_inst_ref ( Cell in ) +{ + assert(isInst(in)); + in -= INST_BASE_ADDR; + assert(tabInst[in].inUse); + assert(isModule(tabInst[in].mod)); + return & tabInst[in]; +} +struct strModule* generate_module_ref ( Cell mo ) +{ + assert(isModule(mo)); + mo -= MODULE_BASE_ADDR; + assert(tabModule[mo].inUse); + return & tabModule[mo]; +} +#endif + + /* -------------------------------------------------------------------------- * Tycon storage: * @@ -449,38 +624,52 @@ Text t; { * ------------------------------------------------------------------------*/ #define TYCONHSZ 256 /* Size of Tycon hash table*/ -#define tHash(x) ((x)%TYCONHSZ) /* Tycon hash function */ -static Tycon tyconHw; /* next unused Tycon */ -static Tycon DEFTABLE(tyconHash,TYCONHSZ); /* Hash table storage */ -struct strTycon DEFTABLE(tabTycon,NUM_TYCON); /* Tycon storage */ +static Tycon tyconHash[TYCONHSZ]; /* Hash table storage */ -Tycon newTycon(t) /* add new tycon to tycon table */ -Text t; { - Int h = tHash(t); - if (tyconHw-TYCMIN >= NUM_TYCON) { - ERRMSG(0) "Type constructor storage space exhausted" - EEND; - } - tycon(tyconHw).text = t; /* clear new tycon record */ - tycon(tyconHw).kind = NIL; - tycon(tyconHw).defn = NIL; - tycon(tyconHw).what = NIL; - tycon(tyconHw).conToTag = NIL; - tycon(tyconHw).tagToCon = NIL; - tycon(tyconHw).tuple = -1; - tycon(tyconHw).mod = currentModule; - tycon(tyconHw).itbl = NULL; - module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons); - tycon(tyconHw).nextTyconHash = tyconHash[h]; - tyconHash[h] = tyconHw; - - return tyconHw++; +static int tHash(Text x) +{ + int r; + assert(isText(x) || inventedText(x)); + x -= TEXT_BASE_ADDR; + if (x < 0) x = -x; + r= x%TYCONHSZ; + assert(r>=0); + assert(r= 0 && x < TYCONHSZ); + return x; +} + +Tycon newTycon ( Text t ) /* add new tycon to tycon table */ +{ + Int h = tHash(t); + Tycon tc = allocNewTycon(); + tabTycon + [tc-TYCON_BASE_ADDR].tuple = -1; + tabTycon + [tc-TYCON_BASE_ADDR].mod = currentModule; + tycon(tc).text = t; /* clear new tycon record */ + tycon(tc).kind = NIL; + tycon(tc).defn = NIL; + tycon(tc).what = NIL; + tycon(tc).conToTag = NIL; + tycon(tc).tagToCon = NIL; + tycon(tc).itbl = NULL; + tycon(tc).arity = 0; + module(currentModule).tycons = cons(tc,module(currentModule).tycons); + tycon(tc).nextTyconHash = tyconHash[RC_T(h)]; + tyconHash[RC_T(h)] = tc; + return tc; } Tycon findTycon(t) /* locate Tycon in tycon table */ Text t; { - Tycon tc = tyconHash[tHash(t)]; - + Tycon tc = tyconHash[RC_T(tHash(t))]; + assert(isTycon(tc) || isTuple(tc) || isNull(tc)); while (nonNull(tc) && tycon(tc).text!=t) tc = tycon(tc).nextTyconHash; return tc; @@ -489,7 +678,7 @@ Text t; { Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */ Tycon tc; { Tycon oldtc; - assert(whatIs(tc)==TYCON || whatIs(tc)==TUPLE); + assert(isTycon(tc) || isTuple(tc)); oldtc = findTycon(tycon(tc).text); if (isNull(oldtc)) { hashTycon(tc); @@ -501,16 +690,18 @@ Tycon tc; { static Void local hashTycon(tc) /* Insert Tycon into hash table */ Tycon 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); - tycon(tc).nextTyconHash = tyconHash[h]; - tyconHash[h] = tc; + Text t; + Int h; + assert(isTycon(tc) || isTuple(tc)); + {int i; for (i = 0; i < TYCONHSZ; i++) + assert (tyconHash[i] == 0 + || isTycon(tyconHash[i]) + || isTuple(tyconHash[i])); } + t = tycon(tc).text; + h = tHash(t); + tycon(tc).nextTyconHash = tyconHash[RC_T(h)]; + tyconHash[RC_T(h)] = tc; } Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */ @@ -577,22 +768,26 @@ List addTyconsMatching(pat,ts) /* Add tycons matching pattern pat */ String pat; /* to list of Tycons ts */ List ts; { /* Null pattern matches every tycon*/ Tycon tc; /* (Tycons with NIL kind excluded) */ - for (tc=TYCMIN; tc= 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); } @@ -610,8 +805,10 @@ Tycon mkTuple ( Int n ) Int i; if (n >= NUM_TUPLES) internal("mkTuple: request for tuple of unsupported size"); - for (i = TYCMIN; i < tyconHw; i++) - if (tycon(i).tuple == n) return i; + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse) + if (tycon(i).tuple == n) return i; internal("mkTuple: request for non-existent tuple"); } @@ -630,42 +827,71 @@ Tycon mkTuple ( Int n ) * ------------------------------------------------------------------------*/ #define NAMEHSZ 256 /* Size of Name hash table */ -#define nHash(x) ((x)%NAMEHSZ) /* hash fn :: Text->Int */ - Name nameHw; /* next unused name */ -static Name DEFTABLE(nameHash,NAMEHSZ); /* Hash table storage */ -struct strName DEFTABLE(tabName,NUM_NAME); /* Name table storage */ - -Name newName(t,parent) /* Add new name to name table */ -Text t; -Cell parent; { +static Name nameHash[NAMEHSZ]; /* Hash table storage */ + +static int nHash(Text x) +{ + assert(isText(x) || inventedText(x)); + x -= TEXT_BASE_ADDR; + if (x < 0) x = -x; + return x%NAMEHSZ; +} + +int RC_N ( int x ) +{ + assert (x >= 0 && x < NAMEHSZ); + return x; +} + +void hashSanity ( void ) +{ + Int i, j; + for (i = 0; i < TYCONHSZ; i++) { + j = tyconHash[i]; + while (nonNull(j)) { + assert(isTycon(j) || isTuple(j)); + j = tycon(j).nextTyconHash; + } + } + for (i = 0; i < NAMEHSZ; i++) { + j = nameHash[i]; + while (nonNull(j)) { + assert(isName(j)); + j = name(j).nextNameHash; + } + } +} + +Name newName ( Text t, Cell parent ) /* Add new name to name table */ +{ Int h = nHash(t); - if (nameHw-NAMEMIN >= NUM_NAME) { - ERRMSG(0) "Name storage space exhausted" - EEND; - } - name(nameHw).text = t; /* clear new name record */ - name(nameHw).line = 0; - name(nameHw).syntax = NO_SYNTAX; - name(nameHw).parent = parent; - name(nameHw).arity = 0; - name(nameHw).number = EXECNAME; - name(nameHw).defn = NIL; - name(nameHw).stgVar = NIL; - name(nameHw).callconv = NIL; - name(nameHw).type = NIL; - name(nameHw).primop = 0; - name(nameHw).mod = currentModule; - name(nameHw).itbl = NULL; - module(currentModule).names=cons(nameHw,module(currentModule).names); - name(nameHw).nextNameHash = nameHash[h]; - nameHash[h] = nameHw; - return nameHw++; + Name nm = allocNewName(); + tabName + [nm-NAME_BASE_ADDR].mod = currentModule; + name(nm).text = t; /* clear new name record */ + name(nm).line = 0; + name(nm).syntax = NO_SYNTAX; + name(nm).parent = parent; + name(nm).arity = 0; + name(nm).number = EXECNAME; + name(nm).defn = NIL; + name(nm).hasStrict = FALSE; + name(nm).stgVar = NIL; + name(nm).callconv = NIL; + name(nm).type = NIL; + name(nm).primop = NULL; + name(nm).itbl = NULL; + module(currentModule).names = cons(nm,module(currentModule).names); + name(nm).nextNameHash = nameHash[RC_N(h)]; + nameHash[RC_N(h)] = nm; + return nm; } Name findName(t) /* Locate name in name table */ Text t; { - Name n = nameHash[nHash(t)]; - + Name n = nameHash[RC_N(nHash(t))]; + assert(isText(t) || isInventedVar(t) || isInventedDictVar(t)); + assert(isName(n) || isNull(n)); while (nonNull(n) && name(n).text!=t) n = name(n).nextNameHash; return n; @@ -674,7 +900,7 @@ Text t; { Name addName(nm) /* Insert Name in name table - if */ Name nm; { /* no clash is caused */ Name oldnm; - assert(whatIs(nm)==NAME); + assert(isName(nm)); oldnm = findName(name(nm).text); if (isNull(oldnm)) { hashName(nm); @@ -691,8 +917,8 @@ Name nm; { assert(isName(nm)); t = name(nm).text; h = nHash(t); - name(nm).nextNameHash = nameHash[h]; - nameHash[h] = nm; + name(nm).nextNameHash = nameHash[RC_N(h)]; + nameHash[RC_N(h)] = nm; } Name findQualName(id) /* Locate (possibly qualified) name*/ @@ -741,8 +967,10 @@ Cell id; { /* in name table */ Name nameFromStgVar ( StgVar v ) { Int n; - for (n = NAMEMIN; n < nameHw; n++) - if (name(n).stgVar == v) return n; + for (n = NAME_BASE_ADDR; + n < NAME_BASE_ADDR+tabNameSz; n++) + if (tabName[n-NAME_BASE_ADDR].inUse) + if (name(n).stgVar == v) return n; return NIL; } @@ -751,9 +979,14 @@ 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)"); + for (n = NAME_BASE_ADDR; + n < NAME_BASE_ADDR+tabNameSz; n++) + if (tabName[n-NAME_BASE_ADDR].inUse) + if (name(n).text == t) break; + if (n == NAME_BASE_ADDR+tabNameSz) { + 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)"); @@ -779,24 +1012,25 @@ Module findFakeModule ( Text t ) Name addWiredInBoxingTycon ( String modNm, String typeNm, String constrNm, - Int arity, Int no, Int rep ) -{ - Name n; - Tycon t; - Text modT = findText(modNm); - Text typeT = findText(typeNm); - Text conT = findText(constrNm); - Module m = findFakeModule(modT); + 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 = 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; } @@ -809,12 +1043,14 @@ Tycon addTupleTycon ( Int n ) Module m; Name nm; - for (i = TYCMIN; i < tyconHw; i++) - if (tycon(i).tuple == n) return i; + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse) + if (tycon(i).tuple == n) return i; if (combined) m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else - m = findModule(findText("Prelude")); + m = findModule(findText("PrelPrim")); setCurrModule(m); k = STAR; @@ -855,6 +1091,7 @@ Tycon addWiredInEnumTycon ( String modNm, String typeNm, 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; @@ -925,13 +1162,17 @@ List addNamesMatching(pat,ns) /* Add names matching pattern pat */ String pat; /* to list of names ns */ List ns; { /* Null pattern matches every name */ Name nm; /* (Names with NIL type, or hidden */ + /* or invented names are excluded) */ #if 1 - for (nm=NAMEMIN; nm= NUM_CLASSES) { - ERRMSG(0) "Class storage space exhausted" - EEND; - } - cclass(classHw).text = t; - 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).defaults = NIL; - cclass(classHw).instances = NIL; - classes=cons(classHw,classes); - cclass(classHw).mod = currentModule; - module(currentModule).classes=cons(classHw,module(currentModule).classes); - return classHw++; -} - -Class classMax() { /* Return max Class in use ... */ - return classHw; /* This is a bit ugly, but it's not*/ -} /* worth a lot of effort right now */ +Class newClass ( Text t ) /* add new class to class table */ +{ + Class cl = allocNewClass(); + tabClass + [cl-CCLASS_BASE_ADDR].mod = currentModule; + cclass(cl).text = t; + cclass(cl).arity = 0; + cclass(cl).kinds = NIL; + cclass(cl).head = NIL; + cclass(cl).fds = NIL; + cclass(cl).xfds = NIL; + cclass(cl).dcon = NIL; + cclass(cl).supers = NIL; + cclass(cl).dsels = NIL; + cclass(cl).members = NIL; + cclass(cl).defaults = NIL; + cclass(cl).instances = NIL; + classes = cons(cl,classes); + module(currentModule).classes + = cons(cl,module(currentModule).classes); + return cl; +} Class findClass(t) /* look for named class in table */ Text t; { @@ -1094,22 +1325,19 @@ Cell c; { /* class in class list */ } Inst newInst() { /* Add new instance to table */ - if (instHw-INSTMIN >= NUM_INSTS) { - ERRMSG(0) "Instance storage space exhausted" - EEND; - } - inst(instHw).kinds = NIL; - inst(instHw).head = NIL; - inst(instHw).specifics = NIL; - inst(instHw).implements = NIL; - inst(instHw).builder = NIL; - inst(instHw).mod = currentModule; - - return instHw++; + Inst in = allocNewInst(); + tabInst + [in-INST_BASE_ADDR].mod = currentModule; + inst(in).kinds = NIL; + inst(in).head = NIL; + inst(in).specifics = NIL; + inst(in).implements = NIL; + inst(in).builder = NIL; + return in; } #ifdef DEBUG_DICTS -extern Void printInst Args((Inst)); +extern Void printInst ( Inst)); Void printInst(in) Inst in; { @@ -1121,14 +1349,17 @@ Inst in; { Inst findFirstInst(tc) /* look for 1st instance involving */ Tycon tc; { /* the type constructor tc */ - return findNextInst(tc,INSTMIN-1); + return findNextInst(tc,INST_BASE_ADDR-1); } Inst findNextInst(tc,in) /* look for next instance involving*/ Tycon tc; /* the type constructor tc */ Inst in; { /* starting after instance in */ - while (++in < instHw) { - Cell pi = inst(in).head; + Cell pi; + while (++in < INST_BASE_ADDR+tabInstSz) { + if (!tabInst[in-INST_BASE_ADDR].inUse) continue; + assert(isModule(inst(in).mod)); + pi = inst(in).head; for (; isAp(pi); pi=fun(pi)) if (typeInvolves(arg(pi),tc)) return in; @@ -1165,20 +1396,21 @@ Class findQualClassWithoutConsultingExportList ( QualId 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; - } + for (cl = CCLASS_BASE_ADDR; + cl < CCLASS_BASE_ADDR+tabClassSz; cl++) { + if (tabClass[cl-CCLASS_BASE_ADDR].inUse) + 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 ) { @@ -1196,43 +1428,21 @@ Tycon findQualTyconWithoutConsultingExportList ( QualId 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; - } + for (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) { + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) + 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 ) { @@ -1250,40 +1460,106 @@ Name findQualNameWithoutConsultingExportList ( QualId 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; - } + for (nm = NAME_BASE_ADDR; + nm < NAME_BASE_ADDR+tabNameSz; nm++) { + if (tabName[nm-NAME_BASE_ADDR].inUse) + 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; } +Tycon findTyconInAnyModule ( Text t ) +{ + Tycon tc; + for (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) + if (tycon(tc).text == t) return tc; + return NIL; +} + +Class findClassInAnyModule ( Text t ) +{ + Class cc; + for (cc = CCLASS_BASE_ADDR; + cc < CCLASS_BASE_ADDR+tabClassSz; cc++) + if (tabClass[cc-CCLASS_BASE_ADDR].inUse) + if (cclass(cc).text == t) return cc; + return NIL; +} + +Name findNameInAnyModule ( Text t ) +{ + Name nm; + for (nm = NAME_BASE_ADDR; + nm < NAME_BASE_ADDR+tabNameSz; nm++) + if (tabName[nm-NAME_BASE_ADDR].inUse) + if (name(nm).text == t) 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 (tc = TYCON_BASE_ADDR; + tc < TYCON_BASE_ADDR+tabTyconSz; tc++) { + if (tabTycon[tc-TYCON_BASE_ADDR].inUse) { + /* almost certainly undue paranoia about duplicate avoidance */ + 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 ); + for (nw = CCLASS_BASE_ADDR; + nw < CCLASS_BASE_ADDR+tabClassSz; nw++) { + if (tabClass[nw-CCLASS_BASE_ADDR].inUse) { + QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text ); + if (!qualidIsMember(q,xs)) + xs = cons ( q, xs ); + } } return xs; } +Int numQualifiers ( Type t ) +{ + if (isPolyType(t)) t = monotypeOf(t); + if (isQualType(t)) + return length ( fst(snd(t)) ); else + return 0; +} + + +/* Purely for debugging. */ +void locateSymbolByName ( Text t ) +{ + Int i; + for (i = NAME_BASE_ADDR; + i < NAME_BASE_ADDR+tabNameSz; i++) + if (tabName[i-NAME_BASE_ADDR].inUse && name(i).text == t) + fprintf ( stderr, "name(%d)\n", i-NAME_BASE_ADDR); + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).text == t) + fprintf ( stderr, "tycon(%d)\n", i-TYCON_BASE_ADDR); + for (i = CCLASS_BASE_ADDR; + i < CCLASS_BASE_ADDR+tabClassSz; i++) + if (tabClass[i-CCLASS_BASE_ADDR].inUse && cclass(i).text == t) + fprintf ( stderr, "class(%d)\n", i-CCLASS_BASE_ADDR); +} + /* -------------------------------------------------------------------------- * Control stack: * @@ -1291,51 +1567,14 @@ List getAllKnownTyconsAndClasses ( void ) * operations are defined as macros, expanded inline. * ------------------------------------------------------------------------*/ -Cell DEFTABLE(cellStack,NUM_STACK); /* Storage for cells on stack */ +Cell cellStack[NUM_STACK]; /* Storage for cells on stack */ StackPtr sp; /* stack pointer */ -#if GIMME_STACK_DUMPS - -#define UPPER_DISP 5 /* # display entries on top of stack */ -#define LOWER_DISP 5 /* # display entries on bottom of stack*/ - -Void hugsStackOverflow() { /* Report stack overflow */ - extern Int rootsp; - extern Cell evalRoots[]; - - ERRMSG(0) "Control stack overflow" ETHEN - if (rootsp>=0) { - Int i; - if (rootsp>=UPPER_DISP+LOWER_DISP) { - for (i=0; i=0; i--) { - ERRTEXT "\nwhile evaluating: " ETHEN - ERREXPR(evalRoots[i]); - } - } - else { - for (i=rootsp; i>=0; i--) { - ERRTEXT "\nwhile evaluating: " ETHEN - ERREXPR(evalRoots[i]); - } - } - } - ERRTEXT "\n" - EEND; -} - -#else /* !GIMME_STACK_DUMPS */ - Void hugsStackOverflow() { /* Report stack overflow */ ERRMSG(0) "Control stack overflow" EEND; } -#endif /* !GIMME_STACK_DUMPS */ /* -------------------------------------------------------------------------- * Module storage: @@ -1354,32 +1593,120 @@ Void hugsStackOverflow() { /* Report stack overflow */ * * ------------------------------------------------------------------------*/ -static Module moduleHw; /* next unused Module */ -struct Module DEFTABLE(tabModule,NUM_MODULE); /* Module storage */ Module currentModule; /* Module currently being processed*/ -Bool isValidModule(m) /* is m a legitimate module id? */ +Bool isValidModule(m) /* is m a legitimate module id? */ Module m; { - return (MODMIN <= m && m < moduleHw); + return isModule(m); } -Module newModule(t) /* add new module to module table */ -Text t; { - if (moduleHw-MODMIN >= NUM_MODULE) { - ERRMSG(0) "Module storage space exhausted" - EEND; - } - 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++; +Module newModule ( Text t ) /* add new module to module table */ +{ + Module mod = allocNewModule(); + module(mod).text = t; /* clear new module record */ + + module(mod).tycons = NIL; + module(mod).names = NIL; + module(mod).classes = NIL; + module(mod).exports = NIL; + module(mod).qualImports = NIL; + module(mod).fake = FALSE; + + module(mod).tree = NIL; + module(mod).completed = FALSE; + module(mod).lastStamp = 0; /* ???? */ + + module(mod).mode = NIL; + module(mod).srcExt = findText(""); + module(mod).uses = NIL; + + module(mod).objName = findText(""); + module(mod).objSize = 0; + + module(mod).object = NULL; + module(mod).objectExtras = NULL; + module(mod).objectExtraNames = NIL; + return mod; +} + + +Bool nukeModule_needs_major_gc = TRUE; + +void nukeModule ( Module m ) +{ + ObjectCode* oc; + ObjectCode* oc2; + Int i; + + if (!isModule(m)) internal("nukeModule"); + + /* fprintf ( stderr, "NUKE MODULE %s\n", textToStr(module(m).text) ); */ + + /* see comment in compiler.c about this, + and interaction with info tables */ + if (nukeModule_needs_major_gc) { + /* fprintf ( stderr, "doing major GC in nukeModule\n"); */ + /* performMajorGC(); */ + nukeModule_needs_major_gc = FALSE; + } + + oc = module(m).object; + while (oc) { + oc2 = oc->next; + ocFree(oc); + oc = oc2; + } + oc = module(m).objectExtras; + while (oc) { + oc2 = oc->next; + ocFree(oc); + oc = oc2; + } + + for (i = NAME_BASE_ADDR; i < NAME_BASE_ADDR+tabNameSz; i++) + if (tabName[i-NAME_BASE_ADDR].inUse && name(i).mod == m) { + if (name(i).itbl && + module(name(i).mod).mode == FM_SOURCE) { + free(name(i).itbl); + } + name(i).itbl = NULL; + freeName(i); + } + + for (i = TYCON_BASE_ADDR; i < TYCON_BASE_ADDR+tabTyconSz; i++) + if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).mod == m) { + if (tycon(i).itbl && + module(tycon(i).mod).mode == FM_SOURCE) { + free(tycon(i).itbl); + } + tycon(i).itbl = NULL; + freeTycon(i); + } + + for (i = CCLASS_BASE_ADDR; i < CCLASS_BASE_ADDR+tabClassSz; i++) + if (tabClass[i-CCLASS_BASE_ADDR].inUse) { + if (cclass(i).mod == m) { + freeClass(i); + } else { + List /* Inst */ ins; + List /* Inst */ ins2 = NIL; + for (ins = cclass(i).instances; nonNull(ins); ins=tl(ins)) + if (inst(hd(ins)).mod != m) + ins2 = cons(hd(ins),ins2); + cclass(i).instances = ins2; + } + } + + + for (i = INST_BASE_ADDR; i < INST_BASE_ADDR+tabInstSz; i++) + if (tabInst[i-INST_BASE_ADDR].inUse && inst(i).mod == m) + freeInst(i); + + freeModule(m); + //for (i = 0; i < TYCONHSZ; i++) tyconHash[i] = 0; + //for (i = 0; i < NAMEHSZ; i++) nameHash[i] = 0; + //classes = NIL; + //hashSanity(); } void ppModules ( void ) @@ -1387,10 +1714,12 @@ void ppModules ( void ) Int i; fflush(stderr); fflush(stdout); printf ( "begin MODULES\n" ); - for (i = moduleHw-1; i >= MODMIN; i--) - printf ( " %2d: %16s\n", - i-MODMIN, textToStr(module(i).text) - ); + for (i = MODULE_BASE_ADDR+tabModuleSz-1; + i >= MODULE_BASE_ADDR; i--) + if (tabModule[i-MODULE_BASE_ADDR].inUse) + printf ( " %2d: %16s\n", + i-MODULE_BASE_ADDR, textToStr(module(i).text) + ); printf ( "end MODULES\n" ); fflush(stderr); fflush(stdout); } @@ -1399,9 +1728,11 @@ void ppModules ( void ) Module findModule(t) /* locate Module in module table */ Text t; { Module m; - for(m=MODMIN; mnext) { - void* ad = ocLookupSym ( oc, sym ); - if (ad) return ad; - } + for (m = MODULE_BASE_ADDR; + m < MODULE_BASE_ADDR+tabModuleSz; m++) { + if (tabModule[m-MODULE_BASE_ADDR].inUse) + for (oc = module(m).objectExtras; oc; oc=oc->next) { + void* ad = ocLookupSym ( oc, sym ); + if (ad) return ad; + } } return NULL; } -OSectionKind lookupSection ( void* ad ) +/* Only call this if in dire straits; searches every object symtab + in the system -- so is therefore slow. +*/ +void* lookupOTabNameAbsolutelyEverywhere ( char* sym ) { - int i; - Module m; - for (m=MODMIN; mnext) { + ad = ocLookupSym ( oc, sym ); + if (ad) return ad; + } + } } - return HUGS_SECTIONKIND_OTHER; -} - - -/* -------------------------------------------------------------------------- - * Script file storage: - * - * script files are read into the system one after another. The state of - * the stored data structures (except the garbage-collected heap) is recorded - * before reading a new script. In the event of being unable to read the - * script, or if otherwise requested, the system can be restored to its - * original state immediately before the file was read. - * ------------------------------------------------------------------------*/ - -typedef struct { /* record of storage state prior to */ - Text file; /* reading script/module */ - Text textHw; - Text nextNewText; - Text nextNewDText; - Module moduleHw; - Tycon tyconHw; - Name nameHw; - Class classHw; - Inst instHw; -#if TREX - Ext extHw; -#endif -} script; - -#ifdef DEBUG_SHOWUSE -static Void local showUse(msg,val,mx) -String msg; -Int val, mx; { - Printf("%6s : %5d of %5d (%2d%%)\n",msg,val,mx,(100*val)/mx); + return NULL; } -#endif - -static Script scriptHw; /* next unused script number */ -static script scripts[NUM_SCRIPTS]; /* storage for script records */ -void ppScripts ( void ) +OSectionKind lookupSection ( void* ad ) { - Int i; - fflush(stderr); fflush(stdout); - printf ( "begin SCRIPTS\n" ); - for (i = scriptHw-1; i >= 0; i--) - printf ( " %2d: %16s tH=%d mH=%d yH=%d " - "nH=%d cH=%d iH=%d nnS=%d,%d\n", - i, textToStr(scripts[i].file), - scripts[i].textHw, scripts[i].moduleHw, - scripts[i].tyconHw, scripts[i].nameHw, - scripts[i].classHw, scripts[i].instHw, - scripts[i].nextNewText, scripts[i].nextNewDText - ); - printf ( "end SCRIPTS\n" ); - fflush(stderr); fflush(stdout); -} - -Script startNewScript(f) /* start new script, keeping record */ -String f; { /* of status for later restoration */ - if (scriptHw >= NUM_SCRIPTS) { - ERRMSG(0) "Too many script files in use" - EEND; - } -#ifdef DEBUG_SHOWUSE - showUse("Text", textHw, NUM_TEXT); - showUse("Module", moduleHw-MODMIN, NUM_MODULE); - showUse("Tycon", tyconHw-TYCMIN, NUM_TYCON); - showUse("Name", nameHw-NAMEMIN, NUM_NAME); - showUse("Class", classHw-CLASSMIN, NUM_CLASSES); - showUse("Inst", instHw-INSTMIN, NUM_INSTS); -#if TREX - showUse("Ext", extHw-EXTMIN, NUM_EXT); -#endif -#endif - scripts[scriptHw].file = findText( f ? f : "" ); - scripts[scriptHw].textHw = textHw; - scripts[scriptHw].nextNewText = nextNewText; - scripts[scriptHw].nextNewDText = nextNewDText; - scripts[scriptHw].moduleHw = moduleHw; - scripts[scriptHw].tyconHw = tyconHw; - scripts[scriptHw].nameHw = nameHw; - scripts[scriptHw].classHw = classHw; - scripts[scriptHw].instHw = instHw; -#if TREX - scripts[scriptHw].extHw = extHw; -#endif - return scriptHw++; -} - -Bool isPreludeScript() { /* Test whether this is the Prelude*/ - return (scriptHw==0); -} - -Bool moduleThisScript(m) /* Test if given module is defined */ -Module m; { /* in current script file */ - return scriptHw<1 || m>=scripts[scriptHw-1].moduleHw; -} - -Module lastModule() { /* Return module in current script file */ - return (moduleHw>MODMIN ? moduleHw-1 : modulePrelude); -} - -#define scriptThis(nm,t,tag) Script nm(x) \ - t x; { \ - Script s=0; \ - while (s=scripts[s].tag) \ - s++; \ - return s; \ - } -scriptThis(scriptThisName,Name,nameHw) -scriptThis(scriptThisTycon,Tycon,tyconHw) -scriptThis(scriptThisInst,Inst,instHw) -scriptThis(scriptThisClass,Class,classHw) -#undef scriptThis - -Module moduleOfScript(s) -Script s; { - return (s==0) ? modulePrelude : scripts[s-1].moduleHw; -} - -String fileOfModule(m) -Module m; { - Script s; - if (m == modulePrelude) { - return STD_PRELUDE; - } - for(s=0; snext) { + sect = ocLookupSection ( oc, ad ); + if (sect != HUGS_SECTIONKIND_NOINFOAVAIL) + return sect; + } + } + } + return HUGS_SECTIONKIND_OTHER; } -Script scriptThisFile(f) -Text f; { - Script s; - for (s=0; s < scriptHw; ++s) { - if (scripts[s].file == f) { - return s+1; - } - } - if (f == findText(STD_PRELUDE)) { - return 0; - } - return (-1); -} - -Void dropScriptsFrom(sno) /* Restore storage to state prior */ -Script sno; { /* to reading script sno */ - if (sno= scripts[sno].moduleHw; --i) { - if (module(i).objectFile) { - printf("[bogus] closing objectFile for module %d\n",i); - /*dlclose(module(i).objectFile);*/ - } - } - moduleHw = scripts[sno].moduleHw; -#endif - for (i=0; i= 0) { + if (msp > msp_max) msp_max = msp; + c = mstack[msp--]; + if (!isGenPair(c)) continue; + if (fst(c)==FREECELL) continue; + { + register int place = placeInSet(c); + register int mask = maskInSet(c); + if (!(marks[place]&mask)) { marks[place] |= mask; - recordMark(); - } - } - - /* 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); - } - - return c; + if (msp >= NUM_MSTACK-5) { + fprintf ( stderr, + "hugs: fatal stack overflow during GC. " + "Increase NUM_MSTACK.\n" ); + exit(9); + } + mstack[++msp] = fst(c); + mstack[++msp] = snd(c); + } + } + } + // fprintf(stderr, "%d ",msp_max); } -static Void local markSnd(c) /* Variant of markCell used to */ -Cell c; { /* update snd component of cell */ - Cell t; /* using tail recursion */ - -ma: t = c; /* Keep pointer to original pair */ - c = snd(c); - if (!isPair(c)) - return; - - { register int place = placeInSet(c); - register int mask = maskInSet(c); - if (marks[place]&mask) - return; - else { - marks[place] |= mask; - recordMark(); - } - } - - if (isGenPair(fst(c))) { - fst(c) = markCell(fst(c)); - goto ma; - } - else if (isNull(fst(c)) || fst(c)>=BCSTAG) - goto ma; - return; -} - -Void markWithoutMove(n) /* Garbage collect cell at n, as if*/ -Cell n; { /* it was a cell ref, but don't */ - /* move cell so we don't have */ - /* to modify the stored value of n */ - if (isGenPair(n)) { - recordStackRoot(); - markCell(n); - } -} Void garbageCollect() { /* Run garbage collector ... */ - Bool breakStat = breakOn(FALSE); /* disable break checking */ + /* disable break checking */ Int i,j; register Int mask; register Int place; Int recovered; - jmp_buf regs; /* save registers on stack */ + HugsBreakAction oldBrk + = setBreakAction ( HugsIgnoreBreak ); + setjmp(regs); gcStarted(); + for (i=0; i=TUPMIN) return TUPLE; return c;*/ } +#endif + -#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 * its type. */ -Void print Args((Cell, Int)); -Void print(c, depth) -Cell c; -Int depth; { +Void print ( Cell c, 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 { + } + else if (isNull(c)) { + Printf("NIL"); + } + else if (isTagPtr(c)) { + Printf("TagP(%d)", c); + } + else if (isTagNonPtr(c)) { + Printf("TagNP(%d)", c); + } + else if (isSpec(c) && c != STAR) { + Printf("TagS(%d)", c); + } + else if (isText(c)) { + Printf("text(%d)=\"%s\"",c-TEXT_BASE_ADDR,textToStr(c)); + } + else if (isInventedVar(c)) { + Printf("invented(%d)", c-INVAR_BASE_ADDR); + } + else if (isInventedDictVar(c)) { + Printf("inventedDict(%d)",c-INDVAR_BASE_ADDR); + } + else { Int tag = whatIs(c); switch (tag) { case AP: @@ -2111,27 +2284,23 @@ Int depth; { Printf("ptr(%p)",ptrOf(c)); break; case CLASS: - Printf("class(%d)", c-CLASSMIN); - if (CLASSMIN <= c && c < classHw) { - Printf("=\"%s\"", textToStr(cclass(c).text)); - } + Printf("class(%d)", c-CCLASS_BASE_ADDR); + Printf("=\"%s\"", textToStr(cclass(c).text)); break; case INSTANCE: - Printf("instance(%d)", c - INSTMIN); + Printf("instance(%d)", c - INST_BASE_ADDR); break; case NAME: - Printf("name(%d)", c-NAMEMIN); - if (NAMEMIN <= c && c < nameHw) { - Printf("=\"%s\"", textToStr(name(c).text)); - } + Printf("name(%d)", c-NAME_BASE_ADDR); + Printf("=\"%s\"", textToStr(name(c).text)); break; case TYCON: - Printf("tycon(%d)", c-TYCMIN); - if (TYCMIN <= c && c < tyconHw) - Printf("=\"%s\"", textToStr(tycon(c).text)); + Printf("tycon(%d)", c-TYCON_BASE_ADDR); + Printf("=\"%s\"", textToStr(tycon(c).text)); break; case MODULE: - Printf("module(%d)", c - MODMIN); + Printf("module(%d)", c - MODULE_BASE_ADDR); + Printf("=\"%s\"", textToStr(module(c).text)); break; case OFFSET: Printf("Offset %d", offsetOf(c)); @@ -2157,9 +2326,6 @@ Int depth; { } Printf(")"); break; - case NIL: - Printf("NIL"); - break; case WILDCARD: Printf("_"); break; @@ -2291,10 +2457,10 @@ Int depth; { Putchar(')'); break; default: - if (isBoxTag(tag)) { - Printf("Tag(%d)=%d", c, tag); - } else if (isConTag(tag)) { - Printf("%d@(%d,",c,tag); + if (isTagNonPtr(tag)) { + Printf("(TagNP=%d,%d)", c, tag); + } else if (isTagPtr(tag)) { + Printf("(TagP=%d,",tag); print(snd(c), depth-1); Putchar(')'); break; @@ -2308,7 +2474,7 @@ Int depth; { } FlushStdout(); } -#endif + Bool isVar(c) /* is cell a VARIDCELL/VAROPCELL ? */ Cell c; { /* also recognises DICTVAR cells */ @@ -2384,20 +2550,22 @@ Cell c; { Int intOf(c) /* find integer value of cell? */ Cell c; { - if (!isInt(c)) { - assert(isInt(c)); } - return isPair(c) ? (Int)(snd(c)) : (Int)(c-INTZERO); + assert(isInt(c)); + return isPair(c) ? (Int)(snd(c)) : (Int)(c-SMALL_INT_ZERO); } Cell mkInt(n) /* make cell representing integer */ Int n; { - return (MINSMALLINT <= n && n <= MAXSMALLINT) - ? INTZERO+n + return (SMALL_INT_MIN <= SMALL_INT_ZERO+n && + SMALL_INT_ZERO+n <= SMALL_INT_MAX) + ? SMALL_INT_ZERO+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; { @@ -2414,6 +2582,7 @@ Cell c; x.i = snd(c); return x.p; } + Cell mkCPtr(p) Ptr p; { @@ -2430,8 +2599,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; { @@ -2449,23 +2621,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; { @@ -2551,6 +2732,7 @@ QualId qualidIsMember ( QualId q, List xs ) Cell varIsMember(t,xs) /* Test if variable is a member of */ Text t; /* given list of variables */ List xs; { + assert(isText(t) || isInventedVar(t) || isInventedDictVar(t)); for (; nonNull(xs); xs=tl(xs)) if (t==textOf(hd(xs))) return hd(xs); @@ -2703,7 +2885,7 @@ List xs; { /* non destructive */ /* -------------------------------------------------------------------------- - * Strongly-typed lists (z-lists) and tuples (experimental) + * Tagged tuples (experimental) * ------------------------------------------------------------------------*/ static void z_tag_check ( Cell x, int tag, char* caller ) @@ -2721,61 +2903,6 @@ static void z_tag_check ( Cell x, int tag, char* caller ) } } -#if 0 -Cell zcons ( Cell x, Cell xs ) -{ - if (!(isNull(xs) || whatIs(xs)==ZCONS)) - internal("zcons: ill typed tail"); - return ap(ZCONS,ap(x,xs)); -} - -Cell zhd ( Cell xs ) -{ - if (isNull(xs)) internal("zhd: empty list"); - z_tag_check(xs,ZCONS,"zhd"); - return fst( snd(xs) ); -} - -Cell ztl ( Cell xs ) -{ - if (isNull(xs)) internal("ztl: empty list"); - z_tag_check(xs,ZCONS,"zhd"); - return snd( snd(xs) ); -} - -Int zlength ( ZList xs ) -{ - Int n = 0; - while (nonNull(xs)) { - z_tag_check(xs,ZCONS,"zlength"); - n++; - xs = snd( snd(xs) ); - } - return n; -} - -ZList zreverse ( ZList xs ) -{ - ZList rev = NIL; - while (nonNull(xs)) { - z_tag_check(xs,ZCONS,"zreverse"); - rev = zcons(zhd(xs),rev); - xs = ztl(xs); - } - return rev; -} - -Cell zsingleton ( Cell x ) -{ - return zcons (x,NIL); -} - -Cell zdoubleton ( Cell x, Cell y ) -{ - return zcons(x,zcons(y,NIL)); -} -#endif - Cell zpair ( Cell x1, Cell x2 ) { return ap(ZTUP2,ap(x1,x2)); } Cell zfst ( Cell zpair ) @@ -2879,108 +3006,168 @@ List args; { return f; } - /* -------------------------------------------------------------------------- - * plugin support + * debugging support * ------------------------------------------------------------------------*/ -/*--------------------------------------------------------------------------- - * GreenCard entry points - * - * GreenCard generated code accesses Hugs data structures and functions - * (only) via these functions (which are stored in the virtual function - * table hugsAPI1. - *-------------------------------------------------------------------------*/ - -#if GREENCARD - -static Cell makeTuple Args((Int)); -static Cell makeInt Args((Int)); -static Cell makeChar Args((Char)); -static Char CharOf Args((Cell)); -static Cell makeFloat Args((FloatPro)); -static Void* derefMallocPtr Args((Cell)); -static Cell* Fst Args((Cell)); -static Cell* Snd Args((Cell)); - -static Cell makeTuple(n) Int n; { return mkTuple(n); } -static Cell makeInt(n) Int n; { return mkInt(n); } -static Cell makeChar(n) Char n; { return mkChar(n); } -static Char CharOf(n) Cell n; { return charOf(n); } -static Cell makeFloat(n) FloatPro n; { return mkFloat(n); } -static Void* derefMallocPtr(n) Cell n; { return derefMP(n); } -static Cell* Fst(n) Cell n; { return (Cell*)&fst(n); } -static Cell* Snd(n) Cell n; { return (Cell*)&snd(n); } - -HugsAPI1* hugsAPI1() { - static HugsAPI1 api; - static Bool initialised = FALSE; - if (!initialised) { - api.nameTrue = nameTrue; - api.nameFalse = nameFalse; - api.nameNil = nameNil; - api.nameCons = nameCons; - api.nameJust = nameJust; - api.nameNothing = nameNothing; - api.nameLeft = nameLeft; - api.nameRight = nameRight; - api.nameUnit = nameUnit; - api.nameIORun = nameIORun; - api.makeInt = makeInt; - api.makeChar = makeChar; - api.CharOf = CharOf; - api.makeFloat = makeFloat; - api.makeTuple = makeTuple; - api.pair = pair; - api.mkMallocPtr = mkMallocPtr; - api.derefMallocPtr = derefMallocPtr; - api.mkStablePtr = mkStablePtr; - api.derefStablePtr = derefStablePtr; - api.freeStablePtr = freeStablePtr; - api.eval = eval; - api.evalWithNoError = evalWithNoError; - api.evalFails = evalFails; - api.whnfArgs = &whnfArgs; - api.whnfHead = &whnfHead; - api.whnfInt = &whnfInt; - api.whnfFloat = &whnfFloat; - api.garbageCollect = garbageCollect; - api.stackOverflow = hugsStackOverflow; - api.internal = internal; - api.registerPrims = registerPrims; - api.addPrimCfun = addPrimCfun; - api.inventText = inventText; - api.Fst = Fst; - api.Snd = Snd; - api.cellStack = cellStack; - api.sp = &sp; - } - return &api; +/* Given the address of an info table, find the constructor/tuple + that it belongs to, and return the name. Only needed for debugging. +*/ +char* lookupHugsItblName ( void* v ) +{ + int i; + for (i = TYCON_BASE_ADDR; + i < TYCON_BASE_ADDR+tabTyconSz; ++i) { + if (tabTycon[i-TYCON_BASE_ADDR].inUse + && tycon(i).itbl == v) + return textToStr(tycon(i).text); + } + for (i = NAME_BASE_ADDR; + i < NAME_BASE_ADDR+tabNameSz; ++i) { + if (tabName[i-NAME_BASE_ADDR].inUse + && name(i).itbl == v) + return textToStr(name(i).text); + } + return NULL; } -#endif /* GREENCARD */ +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(TYCON_BASE_ADDR+t) && !isTycon(t)) t += TYCON_BASE_ADDR; + 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(NAME_BASE_ADDR+n) && !isName(n)) n += NAME_BASE_ADDR; + 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(CCLASS_BASE_ADDR+c) && !isClass(c)) c += CCLASS_BASE_ADDR; + 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(INST_BASE_ADDR+i) && !isInst(i)) i += INST_BASE_ADDR; + 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" ); +} /* -------------------------------------------------------------------------- * storage control: * ------------------------------------------------------------------------*/ -#if DYN_TABLES -static void far* safeFarCalloc Args((Int,Int)); -static void far* safeFarCalloc(n,s) /* allocate table storage and check*/ -Int n, s; { /* for non-null return */ - void far* tab = farCalloc(n,s); - if (tab==0) { - ERRMSG(0) "Cannot allocate run-time tables" - EEND; - } - return tab; -} -#define TABALLOC(v,t,n) v=(t far*)safeFarCalloc(n,sizeof(t)); -#else -#define TABALLOC(v,t,n) -#endif - Void storage(what) Int what; { Int i; @@ -3001,59 +3188,79 @@ Int what; { lsave = NIL; rsave = NIL; if (isNull(lastExprSaved)) - savedText = NUM_TEXT; + savedText = TEXT_SIZE; break; case MARK : start(); - for (i=NAMEMIN; i