X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Finterpreter%2Fstorage.c;h=9d743bf8d175dfab100fbad427c1686b85ae1f5e;hb=0b445d919bc1f6e8014956d67a1154d8d2af3521;hp=3fb6502ca3970975c650bcf783b5456c8a2e1e1e;hpb=e3bb5d64a61847a306ef38f14b39768adb721cf6;p=ghc-hetmet.git diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 3fb6502..9d743bf 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.53 $ - * $Date: 2000/03/23 14:54:21 $ + * $Revision: 1.78 $ + * $Date: 2000/06/23 13:13:10 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -19,6 +19,14 @@ #include "errors.h" #include "object.h" #include +#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*/ @@ -101,23 +109,24 @@ Cell v; { 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; @@ -468,6 +477,13 @@ Text t; { * 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, \ @@ -483,9 +499,11 @@ Text t; { 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 ) \ @@ -513,8 +531,9 @@ Text t; { 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; \ @@ -612,7 +631,8 @@ struct strModule* generate_module_ref ( Cell mo ) * ------------------------------------------------------------------------*/ #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; @@ -624,12 +644,13 @@ static int tHash(Text x) assert(r= 0 && x < TYCONHSZ); return x; } + Tycon newTycon ( Text t ) /* add new tycon to tycon table */ { Int h = tHash(t); @@ -646,6 +667,7 @@ Tycon newTycon ( Text t ) /* add new tycon to tycon table */ 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; @@ -655,7 +677,7 @@ Tycon newTycon ( Text t ) /* add new tycon to tycon table */ 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; @@ -813,7 +835,8 @@ Tycon mkTuple ( Int n ) * ------------------------------------------------------------------------*/ #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)); @@ -821,12 +844,13 @@ static int nHash(Text 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; @@ -859,22 +883,23 @@ Name newName ( Text t, Cell parent ) /* Add new name to name table */ name(nm).arity = 0; name(nm).number = EXECNAME; name(nm).defn = NIL; - name(nm).stgVar = NIL; + name(nm).hasStrict = FALSE; 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 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; @@ -947,33 +972,21 @@ Cell id; { /* in name table */ } -Name nameFromStgVar ( StgVar v ) -{ - 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 ) +void* /* StgClosure* */ getHugs_BCO_cptr_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); } /* -------------------------------------------------------------------------- @@ -1033,7 +1046,7 @@ Tycon addTupleTycon ( Int n ) if (combined) m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else - m = findModule(findText("Prelude")); + m = findModule(findText("PrelPrim")); setCurrModule(m); k = STAR; @@ -1314,6 +1327,7 @@ Inst newInst() { /* Add new instance to table */ 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; @@ -1516,6 +1530,15 @@ List getAllKnownTyconsAndClasses ( void ) 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 ) { @@ -1584,13 +1607,14 @@ Module newModule ( Text t ) /* add new module to module table */ module(mod).classes = NIL; module(mod).exports = NIL; module(mod).qualImports = NIL; + module(mod).codeList = NIL; module(mod).fake = FALSE; module(mod).tree = NIL; module(mod).completed = FALSE; module(mod).lastStamp = 0; /* ???? */ - module(mod).fromSrc = TRUE; + module(mod).mode = NIL; module(mod).srcExt = findText(""); module(mod).uses = NIL; @@ -1603,13 +1627,27 @@ Module newModule ( Text t ) /* add new module to module table */ 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; @@ -1625,14 +1663,21 @@ fprintf(stderr, "NUKEMODULE `%s'\n", textToStr(module(m).text)); 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); } @@ -1717,7 +1762,7 @@ Void setCurrModule(m) /* set lookup tables for current module */ 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))); @@ -1738,6 +1783,47 @@ fprintf(stderr, "SET CURR MODULE %s\n", textToStr(module(m).text)); 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; @@ -1803,6 +1889,31 @@ void* lookupOExtraTabName ( char* sym ) } +/* 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; @@ -1810,15 +1921,18 @@ OSectionKind lookupSection ( void* ad ) ObjectCode* oc; OSectionKind sect; + /* speedup hack */ + if (!combined) return HUGS_SECTIONKIND_OTHER; + for (m = MODULE_BASE_ADDR; m < MODULE_BASE_ADDR+tabModuleSz; m++) { if (tabModule[m-MODULE_BASE_ADDR].inUse) { - if (module(m).object) { - sect = ocLookupSection ( module(m).object, ad ); + if (tabModule[m-MODULE_BASE_ADDR].object) { + sect = ocLookupSection ( tabModule[m-MODULE_BASE_ADDR].object, ad ); if (sect != HUGS_SECTIONKIND_NOINFOAVAIL) return sect; } - for (oc = module(m).objectExtras; oc; oc=oc->next) { + for (oc = tabModule[m-MODULE_BASE_ADDR].objectExtras; oc; oc=oc->next) { sect = ocLookupSection ( oc, ad ); if (sect != HUGS_SECTIONKIND_NOINFOAVAIL) return sect; @@ -1829,6 +1943,38 @@ OSectionKind lookupSection ( void* ad ) } +/* 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 = tabName[nm-NAME_BASE_ADDR].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 = tabTycon[tc-TYCON_BASE_ADDR].closure; + if (nonNull(cl)) { + assert(isCPtr(cl)); + snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) ); + } + } + } +} + + /* -------------------------------------------------------------------------- * Heap storage: * @@ -1842,15 +1988,12 @@ OSectionKind lookupSection ( void* ad ) 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; +int numEnters; Int numGcs; /* number of garbage collections */ Int cellsRecovered; /* number of cells recovered */ @@ -1900,7 +2043,6 @@ static Int markCount, stackRoots; 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; @@ -1921,89 +2063,54 @@ Cell l, r; { /* heap, garbage collecting first */ 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=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 @@ -2211,7 +2275,7 @@ Void print ( Cell c, Int depth ) 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)) { @@ -2245,8 +2309,17 @@ Void print ( Cell c, Int depth ) 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); @@ -2531,19 +2604,36 @@ Int n; { 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; } @@ -2697,6 +2787,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); @@ -2974,6 +3065,27 @@ List args; { * 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 "??"; @@ -3048,10 +3160,10 @@ void dumpName ( Int n ) 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" ); } @@ -3140,9 +3252,9 @@ Int what; { i < NAME_BASE_ADDR+tabNameSz; ++i) { if (tabName[i-NAME_BASE_ADDR].inUse) { mark(name(i).parent); - mark(name(i).defn); - mark(name(i).stgVar); mark(name(i).type); + mark(name(i).defn); + mark(name(i).closure); } } end("Names", nameHw-NAMEMIN); @@ -3156,6 +3268,9 @@ Int what; { 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); } } @@ -3168,9 +3283,10 @@ Int what; { 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); + mark(tycon(i).closure); } } end("Type constructors", tyconHw-TYCMIN); @@ -3178,13 +3294,13 @@ Int what; { 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); @@ -3197,8 +3313,8 @@ Int what; { 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); }