* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.64 $
- * $Date: 2000/04/06 00:01:27 $
+ * $Revision: 1.77 $
+ * $Date: 2000/05/12 13:34:07 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
#include "errors.h"
#include "object.h"
#include <setjmp.h>
+#include "Stg.h"
+
+/* #include "Storage.h"
+ We'd like to, but Storage.h and storage.h look the same under
+ Cygwin, alas, causing compilation chaos. So just copy what
+ we need to know, which is ...
+*/
+extern StgClosure* MarkRoot ( StgClosure* );
/*#define DEBUG_SHOWUSE*/
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) { \
+ if (1 || (!debugStorageExtra)) { \
tab_name[n-TAB_BASE_ADDR].nextFree = free_list; \
free_list = n; \
} \
newTab[i].inUse = FALSE; \
newTab[i].nextFree = i-1+TAB_BASE_ADDR; \
} \
- if (debugStorageExtra) \
+ if (0 && debugStorageExtra) \
fprintf(stderr, "Expanding " #type_name \
"table to size %d\n", newSz ); \
newTab[tab_size].nextFree = TAB_BASE_ADDR-1; \
tycon(tc).tagToCon = NIL;
tycon(tc).itbl = NULL;
tycon(tc).arity = 0;
+ tycon(tc).closure = NIL;
module(currentModule).tycons = cons(tc,module(currentModule).tycons);
tycon(tc).nextTyconHash = tyconHash[RC_T(h)];
tyconHash[RC_T(h)] = tc;
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;
+ name(nm).closure = NIL;
module(currentModule).names = cons(nm,module(currentModule).names);
name(nm).nextNameHash = nameHash[RC_N(h)];
- nameHash[RC_N(h)] = nm;
+ nameHash[RC_N(h)] = nm;
return nm;
}
}
-Name nameFromStgVar ( StgVar v )
+void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s )
{
- Int 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;
-}
-
-void* getHugs_AsmObject_for ( char* s )
-{
- StgVar v;
Text t = findText(s);
Name n = NIL;
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 (tabName[n-NAME_BASE_ADDR].inUse && 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)");
+ internal("getHugs_BCO_cptr_for(1)");
}
- v = name(n).stgVar;
- if (!isStgVar(v) || !isPtr(stgVarInfo(v)))
- internal("getHugs_AsmObject_for(2)");
- return ptrOf(stgVarInfo(v));
+ if (!isCPtr(name(n).closure))
+ internal("getHugs_BCO_cptr_for(2)");
+ return cptrOf(name(n).closure);
}
/* --------------------------------------------------------------------------
inst(in).kinds = NIL;
inst(in).head = NIL;
inst(in).specifics = NIL;
+ inst(in).numSpecifics = 0;
inst(in).implements = NIL;
inst(in).builder = NIL;
return in;
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).classes = NIL;
module(mod).exports = NIL;
module(mod).qualImports = NIL;
+ module(mod).codeList = NIL;
module(mod).fake = FALSE;
module(mod).tree = 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");
+
+ /* 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;
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) free(name(i).itbl);
- name(i).itbl = NULL;
+ if (name(i).itbl &&
+ module(name(i).mod).mode == FM_SOURCE) {
+ free(name(i).itbl);
+ }
+ name(i).itbl = NULL;
+ name(i).closure = NIL;
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) free(tycon(i).itbl);
+ if (tycon(i).itbl &&
+ module(tycon(i).mod).mode == FM_SOURCE) {
+ free(tycon(i).itbl);
+ }
tycon(i).itbl = NULL;
freeTycon(i);
}
hashSanity();
}
+void addToCodeList ( Module m, Cell c )
+{
+ assert(isName(c) || isTuple(c));
+ if (nonNull(getNameOrTupleClosure(c)))
+ module(m).codeList = cons ( c, module(m).codeList );
+ /* fprintf ( stderr, "addToCodeList %s %s\n",
+ textToStr(module(m).text),
+ textToStr( isTuple(c) ? tycon(c).text : name(c).text ) );
+ */
+}
+
+Cell getNameOrTupleClosure ( Cell c )
+{
+ if (isName(c)) return name(c).closure;
+ else if (isTuple(c)) return tycon(c).closure;
+ else internal("getNameOrTupleClosure");
+}
+
+void setNameOrTupleClosure ( Cell c, Cell closure )
+{
+ if (isName(c)) name(c).closure = closure;
+ else if (isTuple(c)) tycon(c).closure = closure;
+ else internal("setNameOrTupleClosure");
+}
+
+/* This function is used in ghc/rts/Assembler.c. */
+void* /* StgClosure* */ getNameOrTupleClosureCPtr ( Cell c )
+{
+ return cptrOf(getNameOrTupleClosure(c));
+}
+
+/* used in codegen.c */
+void setNameOrTupleClosureCPtr ( Cell c, void* /* StgClosure* */ cptr )
+{
+ if (isName(c)) name(c).closure = mkCPtr(cptr);
+ else if (isTuple(c)) tycon(c).closure = mkCPtr(cptr);
+ else internal("setNameOrTupleClosureCPtr");
+}
+
+
+
Name jrsFindQualName ( Text mn, Text sn )
{
Module m;
}
+/* 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;
}
+/* Called by the evaluator's GC to tell Hugs to mark stuff in the
+ run-time heap.
+*/
+void markHugsObjects( void )
+{
+ Name nm;
+ Tycon tc;
+
+ for ( nm = NAME_BASE_ADDR;
+ nm < NAME_BASE_ADDR+tabNameSz; ++nm ) {
+ if (tabName[nm-NAME_BASE_ADDR].inUse) {
+ Cell cl = name(nm).closure;
+ if (nonNull(cl)) {
+ assert(isCPtr(cl));
+ snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
+ }
+ }
+ }
+
+ for ( tc = TYCON_BASE_ADDR;
+ tc < TYCON_BASE_ADDR+tabTyconSz; ++tc ) {
+ if (tabTycon[tc-TYCON_BASE_ADDR].inUse) {
+ Cell cl = tycon(tc).closure;
+ if (nonNull(cl)) {
+ assert(isCPtr(cl));
+ snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
+ }
+ }
+ }
+
+}
+
+
/* --------------------------------------------------------------------------
* Heap storage:
*
Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
/* C stack; use with extreme care! */
Long numCells;
+int numEnters;
Int numGcs; /* number of garbage collections */
Int cellsRecovered; /* number of cells recovered */
everybody(GCDONE);
#if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
- fprintf(stderr, "\n--- GC recovered %d\n",recovered );
+ /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
#endif
/* can only return if freeList is nonempty on return. */
* Miscellaneous operations on heap cells:
* ------------------------------------------------------------------------*/
+/* Reordered 2 May 00 to have most common options first. */
Cell whatIs ( register Cell c )
{
if (isPair(c)) {
register Cell fstc = fst(c);
return isTag(fstc) ? fstc : AP;
}
+ if (isTycon(c)) return TYCON;
if (isOffset(c)) return OFFSET;
- if (isChar(c)) return CHARCELL;
- if (isInt(c)) return INTCELL;
if (isName(c)) return NAME;
- if (isTycon(c)) return TYCON;
+ if (isInt(c)) return INTCELL;
if (isTuple(c)) return TUPLE;
+ if (isSpec(c)) return c;
if (isClass(c)) return CLASS;
+ if (isChar(c)) return CHARCELL;
+ if (isNull(c)) return c;
if (isInst(c)) return INSTANCE;
if (isModule(c)) return MODULE;
if (isText(c)) return TEXTCELL;
if (isInventedVar(c)) return INVAR;
if (isInventedDictVar(c)) return INDVAR;
- if (isSpec(c)) return c;
- if (isNull(c)) return c;
fprintf ( stderr, "whatIs: unknown %d\n", c );
internal("whatIs");
}
-#if 0
-Cell whatIs(c) /* identify type of cell */
-register Cell c; {
- if (isPair(c)) {
- register Cell fstc = fst(c);
- return isTag(fstc) ? fstc : AP;
- }
- if (c<OFFMIN) return c;
-#if TREX
- if (isExt(c)) return EXT;
-#endif
- if (c>=INTMIN) return INTCELL;
-
- if (c>=NAMEMIN){if (c>=CLASSMIN) {if (c>=CHARMIN) return CHARCELL;
- else return CLASS;}
- else if (c>=INSTMIN) return INSTANCE;
- else return NAME;}
- else if (c>=MODMIN) {if (c>=TYCMIN) return isTuple(c) ? TUPLE : TYCON;
- else return MODULE;}
- else if (c>=OFFMIN) return OFFSET;
-#if TREX
- else return (c>=EXTMIN) ?
- EXT : TUPLE;
-#else
- else return TUPLE;
-#endif
-
-
-/* if (isPair(c)) {
- register Cell fstc = fst(c);
- return isTag(fstc) ? fstc : AP;
- }
- if (c>=INTMIN) return INTCELL;
- if (c>=CHARMIN) return CHARCELL;
- if (c>=CLASSMIN) return CLASS;
- if (c>=INSTMIN) return INSTANCE;
- if (c>=NAMEMIN) return NAME;
- if (c>=TYCMIN) return TYCON;
- if (c>=MODMIN) return MODULE;
- if (c>=OFFMIN) return OFFSET;
-#if TREX
- if (c>=EXTMIN) return EXT;
-#endif
- if (c>=TUPMIN) return TUPLE;
- return c;*/
-}
-#endif
-
/* A very, very simple printer.
* Output is uglier than from printExp - but the printer is more
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)) {
case CHARCELL:
Printf("char('%c')", charOf(c));
break;
- case PTRCELL:
- Printf("ptr(%p)",ptrOf(c));
+ case STRCELL:
+ Printf("strcell(\"%s\")",textToStr(snd(c)));
+ break;
+ case MPTRCELL:
+ Printf("mptr(%p)",mptrOf(c));
+ break;
+ case CPTRCELL:
+ Printf("cptr(%p)",cptrOf(c));
+ break;
+ case ADDRCELL:
+ Printf("addr(%p)",addrOf(c));
break;
case CLASS:
Printf("class(%d)", c-CCLASS_BASE_ADDR);
typedef union {Int i; Ptr p;} IntOrPtr;
-Cell mkPtr(p)
+Cell mkAddr(p)
Ptr p;
{
IntOrPtr x;
x.p = p;
- return pair(PTRCELL,x.i);
+ return pair(ADDRCELL,x.i);
}
-Ptr ptrOf(c)
+Ptr addrOf(c)
Cell c;
{
IntOrPtr x;
- assert(fst(c) == PTRCELL);
+ assert(fst(c) == ADDRCELL);
+ x.i = snd(c);
+ return x.p;
+}
+
+Cell mkMPtr(p)
+Ptr p;
+{
+ IntOrPtr x;
+ x.p = p;
+ return pair(MPTRCELL,x.i);
+}
+
+Ptr mptrOf(c)
+Cell c;
+{
+ IntOrPtr x;
+ assert(fst(c) == MPTRCELL);
x.i = snd(c);
return x.p;
}
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 "??";
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 ( " closure: %d\n", name(n).closure );
printf ( " nextNH: %d\n", name(n).nextNameHash );
printf ( "}\n" );
}
mark(name(i).parent);
mark(name(i).type);
mark(name(i).defn);
- mark(name(i).stgVar);
+ mark(name(i).closure);
}
}
end("Names", nameHw-NAMEMIN);
mark(module(i).classes);
mark(module(i).exports);
mark(module(i).qualImports);
+ mark(module(i).codeList);
mark(module(i).tree);
mark(module(i).uses);
mark(module(i).objectExtraNames);
mark(tycon(i).kind);
mark(tycon(i).what);
mark(tycon(i).defn);
+ mark(tycon(i).closure);
}
}
end("Type constructors", tyconHw-TYCMIN);
projects / ghc-hetmet.git / blobdiff