* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.54 $
- * $Date: 2000/03/24 12:36:43 $
+ * $Revision: 1.70 $
+ * $Date: 2000/04/12 09:37:19 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
#include "errors.h"
#include "object.h"
#include <setjmp.h>
+#include "Stg.h"
/*#define DEBUG_SHOWUSE*/
if (!isPair(v)) {
internal("identToStr");
}
- switch (fst(v)) {
+ switch (whatIs(v)) {
case VARIDCELL :
case VAROPCELL :
case CONIDCELL :
- case CONOPCELL : return text+textOf(v);
-
- case QUALIDENT : { Text pos = textHw;
- Text t = qmodOf(v);
- while (pos+1 < savedText && text[t]!=0) {
- text[pos++] = text[t++];
+ case CONOPCELL : return textToStr(textOf(v));
+
+ case QUALIDENT : { String qmod = textToStr(qmodOf(v));
+ String qtext = textToStr(qtextOf(v));
+ Text pos = textHw;
+
+ while (pos+1 < savedText && *qmod!=0) {
+ text[pos++] = *qmod++;
}
if (pos+1 < savedText) {
text[pos++] = '.';
}
- t = qtextOf(v);
- while (pos+1 < savedText && text[t]!=0) {
- text[pos++] = text[t++];
+ while (pos+1 < savedText && *qtext!=0) {
+ text[pos++] = *qtext++;
}
text[pos] = '\0';
return text+textHw;
* 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, \
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; \
- /*tab_name[n-TAB_BASE_ADDR].nextFree = free_list; */ \
- /*free_list = n;*/ \
+ 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 ) \
newTab[i].inUse = FALSE; \
newTab[i].nextFree = i-1+TAB_BASE_ADDR; \
} \
- /* fprintf(stderr, "Expanding " #type_name \
- "table to size %d\n", newSz );*/ \
+ 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; \
* ------------------------------------------------------------------------*/
#define TYCONHSZ 256 /* Size of Tycon hash table*/
- //#define tHash(x) (((x)-TEXT_BASE_ADDR)%TYCONHSZ)/* Tycon hash function */
+static Tycon tyconHash[TYCONHSZ]; /* Hash table storage */
+
static int tHash(Text x)
{
int r;
assert(r<TYCONHSZ);
return r;
}
-static Tycon tyconHash[TYCONHSZ]; /* Hash table storage */
-int RC_T ( int x )
+
+static int RC_T ( int x )
{
assert (x >= 0 && x < TYCONHSZ);
return x;
}
+
Tycon newTycon ( Text t ) /* add new tycon to tycon table */
{
Int h = tHash(t);
Tycon findTycon(t) /* locate Tycon in tycon table */
Text t; {
Tycon tc = tyconHash[RC_T(tHash(t))];
-assert(isTycon(tc) || isTuple(tc) || isNull(tc));
+ assert(isTycon(tc) || isTuple(tc) || isNull(tc));
while (nonNull(tc) && tycon(tc).text!=t)
tc = tycon(tc).nextTyconHash;
return tc;
* ------------------------------------------------------------------------*/
#define NAMEHSZ 256 /* Size of Name hash table */
-//#define nHash(x) (((x)-TEXT_BASE_ADDR)%NAMEHSZ) /* hash fn :: Text->Int */
+static Name nameHash[NAMEHSZ]; /* Hash table storage */
+
static int nHash(Text x)
{
assert(isText(x) || inventedText(x));
if (x < 0) x = -x;
return x%NAMEHSZ;
}
-static Name nameHash[NAMEHSZ]; /* Hash table storage */
+
int RC_N ( int x )
{
assert (x >= 0 && x < NAMEHSZ);
return x;
}
+
void hashSanity ( void )
{
Int i, j;
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 findName(t) /* Locate name in name table */
Text t; {
Name n = nameHash[RC_N(nHash(t))];
-assert(isText(t));
-assert(isName(n) || isNull(n));
+ 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;
if (combined)
m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
- m = findModule(findText("Prelude"));
+ m = findModule(findText("PrelPrim"));
setCurrModule(m);
k = STAR;
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 )
{
module(mod).completed = FALSE;
module(mod).lastStamp = 0; /* ???? */
- module(mod).fromSrc = TRUE;
+ module(mod).mode = NIL;
module(mod).srcExt = findText("");
module(mod).uses = NIL;
return mod;
}
+
+Bool nukeModule_needs_major_gc = TRUE;
+
void nukeModule ( Module m )
{
ObjectCode* oc;
ObjectCode* oc2;
Int i;
-assert(isModule(m));
-fprintf(stderr, "NUKEMODULE `%s'\n", textToStr(module(m).text));
+
+ if (!isModule(m)) internal("nukeModule");
+
+ /* 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;
Module m; {
Int i;
assert(isModule(m));
- /* fprintf(stderr, "SET CURR MODULE %s\n", textToStr(module(m).text));*/
+ /* fprintf(stderr, "SET CURR MODULE %s %d\n", textToStr(module(m).text),m); */
{List t;
for (t = module(m).names; nonNull(t); t=tl(t))
assert(isName(hd(t)));
}
+/* Only call this if in dire straits; searches every object symtab
+ in the system -- so is therefore slow.
+*/
+void* lookupOTabNameAbsolutelyEverywhere ( char* sym )
+{
+ ObjectCode* oc;
+ Module m;
+ void* ad;
+ for (m = MODULE_BASE_ADDR;
+ m < MODULE_BASE_ADDR+tabModuleSz; m++) {
+ if (tabModule[m-MODULE_BASE_ADDR].inUse) {
+ if (module(m).object) {
+ ad = ocLookupSym ( module(m).object, sym );
+ if (ad) return ad;
+ }
+ for (oc = module(m).objectExtras; oc; oc=oc->next) {
+ ad = ocLookupSym ( oc, sym );
+ if (ad) return ad;
+ }
+ }
+ }
+ return NULL;
+}
+
+
OSectionKind lookupSection ( void* ad )
{
int i;
Int heapSize = DEFAULTHEAP; /* number of cells in heap */
Heap heapFst; /* array of fst component of pairs */
Heap heapSnd; /* array of snd component of pairs */
-#ifndef GLOBALfst
Heap heapTopFst;
-#endif
-#ifndef GLOBALsnd
Heap heapTopSnd;
-#endif
Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
/* C stack; use with extreme care! */
Long numCells;
Cell pair(l,r) /* Allocate pair (l, r) from */
Cell l, r; { /* heap, garbage collecting first */
Cell c = freeList; /* if necessary ... */
-
if (isNull(c)) {
lsave = l;
rsave = r;
static Int *marks;
static Int marksSize;
-Cell markExpr(c) /* External interface to markCell */
-Cell c; {
- return isGenPair(c) ? markCell(c) : c;
-}
-
-static Cell local markCell(c) /* Traverse part of graph marking */
-Cell c; { /* cells reachable from given root */
- /* markCell(c) is only called if c */
- /* is a pair */
- { register int place = placeInSet(c);
- register int mask = maskInSet(c);
- if (marks[place]&mask)
- return c;
- else {
- 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)) || isTagPtr(fst(c))) {
- STACK_CHECK
- markSnd(c);
- }
-
- return c;
-}
-
-static Void local markSnd(c) /* Variant of markCell used to */
-Cell c; { /* update snd component of cell */
- Cell t; /* using tail recursion */
+void mark ( Cell root )
+{
+ Cell c;
+ Cell mstack[NUM_MSTACK];
+ Int msp = -1;
+ Int msp_max = -1;
-ma: t = c; /* Keep pointer to original pair */
- c = snd(c);
- if (!isPair(c))
- return;
+ mstack[++msp] = root;
- { register int place = placeInSet(c);
- register int mask = maskInSet(c);
- if (marks[place]&mask)
- return;
- else {
+ while (msp >= 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();
- }
- }
-
- if (isGenPair(fst(c))) {
- fst(c) = markCell(fst(c));
- goto ma;
- }
- else if (isNull(fst(c)) || isTagPtr(fst(c)))
- 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);
- }
+ 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);
}
+
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 */
-fprintf ( stderr, "wa-hey! garbage collection! too difficult! bye!\n" );
-exit(0);
+ HugsBreakAction oldBrk
+ = setBreakAction ( HugsIgnoreBreak );
+
setjmp(regs);
gcStarted();
+
for (i=0; i<marksSize; ++i) /* initialise mark set to empty */
marks[i] = 0;
}
gcRecovered(recovered);
- breakOn(breakStat); /* restore break trapping if nec. */
+ setBreakAction ( oldBrk );
everybody(GCDONE);
+#if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
+ /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
+#endif
+
/* can only return if freeList is nonempty on return. */
if (recovered<minRecovery || isNull(freeList)) {
ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
else if (isTagNonPtr(c)) {
Printf("TagNP(%d)", c);
}
- else if (isSpec(c)) {
+ else if (isSpec(c) && c != STAR) {
Printf("TagS(%d)", c);
}
else if (isText(c)) {
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);
* debugging support
* ------------------------------------------------------------------------*/
+/* 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;
+}
+
static String maybeModuleStr ( Module m )
{
if (isModule(m)) return textToStr(module(m).text); else return "??";
i < NAME_BASE_ADDR+tabNameSz; ++i) {
if (tabName[i-NAME_BASE_ADDR].inUse) {
mark(name(i).parent);
+ mark(name(i).type);
mark(name(i).defn);
mark(name(i).stgVar);
- mark(name(i).type);
}
}
end("Names", nameHw-NAMEMIN);
mark(module(i).classes);
mark(module(i).exports);
mark(module(i).qualImports);
+ mark(module(i).tree);
+ mark(module(i).uses);
mark(module(i).objectExtraNames);
}
}
for (i = TYCON_BASE_ADDR;
i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
if (tabTycon[i-TYCON_BASE_ADDR].inUse) {
- mark(tycon(i).defn);
mark(tycon(i).kind);
mark(tycon(i).what);
+ mark(tycon(i).defn);
}
}
end("Type constructors", tyconHw-TYCMIN);
start();
for (i = CCLASS_BASE_ADDR;
i < CCLASS_BASE_ADDR+tabClassSz; ++i) {
- if (tabModule[i-MODULE_BASE_ADDR].inUse) {
- mark(cclass(i).head);
+ if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
mark(cclass(i).kinds);
mark(cclass(i).fds);
mark(cclass(i).xfds);
- mark(cclass(i).dsels);
+ mark(cclass(i).head);
mark(cclass(i).supers);
+ mark(cclass(i).dsels);
mark(cclass(i).members);
mark(cclass(i).defaults);
mark(cclass(i).instances);
for (i = INST_BASE_ADDR;
i < INST_BASE_ADDR+tabInstSz; ++i) {
if (tabInst[i-INST_BASE_ADDR].inUse) {
- mark(inst(i).head);
mark(inst(i).kinds);
+ mark(inst(i).head);
mark(inst(i).specifics);
mark(inst(i).implements);
}
projects / ghc-hetmet.git / blobdiff