* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.72 $
- * $Date: 2000/04/25 17:43:50 $
+ * $Revision: 1.73 $
+ * $Date: 2000/04/27 16:35:29 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
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;
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(name(i).mod).mode == FM_SOURCE) {
free(name(i).itbl);
}
- name(i).itbl = NULL;
+ name(i).itbl = NULL;
+ name(i).closure = NIL;
freeName(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;
}
+/* 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) = MarkRoot ( 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) = MarkRoot ( snd(cl) );
+ }
+ }
+ }
+
+}
+
+
/* --------------------------------------------------------------------------
* Heap storage:
*
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;
}
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