X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fstorage.c;h=9d743bf8d175dfab100fbad427c1686b85ae1f5e;hb=89cefac83e7e468ddc0fdc62b3f4e076e97a7d51;hp=637c15bc6ca4b9f06eed3f66f2fa55c83a73a17b;hpb=9ff75d089614cce1cfa8c88344ace47698258bfa;p=ghc-hetmet.git diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 637c15b..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.71 $ - * $Date: 2000/04/14 15:18:06 $ + * $Revision: 1.78 $ + * $Date: 2000/06/23 13:13:10 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -21,6 +21,13 @@ #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*/ /* -------------------------------------------------------------------------- @@ -660,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; @@ -876,14 +884,14 @@ Name newName ( Text t, Cell parent ) /* Add new name to name table */ 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; } @@ -964,33 +972,21 @@ Cell id; { /* in name table */ } -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); } /* -------------------------------------------------------------------------- @@ -1331,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; @@ -1610,6 +1607,7 @@ 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; @@ -1669,7 +1667,8 @@ void nukeModule ( Module m ) module(name(i).mod).mode == FM_SOURCE) { free(name(i).itbl); } - name(i).itbl = NULL; + name(i).itbl = NULL; + name(i).closure = NIL; freeName(i); } @@ -1784,6 +1783,47 @@ Module m; { 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; @@ -1881,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; @@ -1900,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: * @@ -1918,6 +1993,7 @@ Heap heapTopSnd; 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 */ @@ -2153,79 +2229,32 @@ Cell c; { /* except that Cells refering to */ * 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=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 @@ -2280,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); @@ -2566,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; } @@ -3105,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" ); } @@ -3199,7 +3254,7 @@ Int what; { mark(name(i).parent); mark(name(i).type); mark(name(i).defn); - mark(name(i).stgVar); + mark(name(i).closure); } } end("Names", nameHw-NAMEMIN); @@ -3213,6 +3268,7 @@ 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); @@ -3230,6 +3286,7 @@ Int what; { mark(tycon(i).kind); mark(tycon(i).what); mark(tycon(i).defn); + mark(tycon(i).closure); } } end("Type constructors", tyconHw-TYCMIN);