int internal_eqvp(CELL obj1, CELL obj2)
{
if (AS_LITERAL(obj1) == AS_LITERAL(obj2)) {
return 1;
}
if (! (IS_POINTER(obj1) && IS_POINTER(obj2)) ) {
return 0;
}
TYPEID t = GET_POINTER_TYPE(obj1);
if (t != GET_POINTER_TYPE(obj2)) {
return 0;
}
switch(t) {
case T_FLOAT:
return GET_FLOAT(obj1) == GET_FLOAT(obj2);
case T_BIGINT:
return GET_BIGINT(obj1) == GET_BIGINT(obj2);
default:
return 0;
}
//FIXME - does not implement equality correctly for LAMBDAs
//principally because LAMBDAs are not implemented correctly
//yet either (i.e. as closures).
}
static void check_ro_ptrpair_sib (Sib* ap) {
// ====================
//
Val* p;
Val* stop;
Val w;
int gen = GET_AGE_FROM_SIBID(ap->id);
if (*sib_is_active(ap)) return; // sib_is_active def in src/c/h/heap.h
debug_say (" pairs [%d]: [%#x..%#x:%#x)\n",
gen, ap->tospace, ap->tospace.first_free, ap->tospace.limit);
p = ap->tospace + 2;
stop = ap->tospace.first_free;
while (p < stop) {
w = *p++;
if (IS_TAGWORD(w)) {
ERROR;
debug_say (
"** @%#x: unexpected tagword %#x in pair sib\n",
p-1, w);
return;
}
else if (IS_POINTER(w)) {
check_pointer(p, w, gen, RO_CONSCELL_KIND, CHUNKC_any);
}
}
}
int internal_eqp(CELL obj1, CELL obj2)
{
if (AS_LITERAL(obj1) == AS_LITERAL(obj2)) {
return 1;
}
if (! (IS_POINTER(obj1) && IS_POINTER(obj2)) ) {
return 0;
}
TYPEID t = GET_POINTER_TYPE(obj1);
if (t != GET_POINTER_TYPE(obj2)) {
return 0;
}
return 0;
}
static inline void forward_to_agegroup1_if_in_agegroup0 (Sibid* book2sibid, Agegroup* g1, Val *p, Task* task) { // 'task' arg is only for debugging, can be dropped in production code.
// ====================================
//
// Forward *p if it is in agegroup0:
Val w = *p;
//
if (IS_POINTER(w)) {
//
Sibid sibid = SIBID_FOR_POINTER( book2sibid, w );
//
if (sibid == AGEGROUP0_SIBID) *p = forward_agegroup0_chunk_to_agegroup1( g1, w, task, 0 );
}
}
static int
tclOutputFormatGen(char **buf, char *name, DCL_NOM_STR *nom)
{
int i;
if (IS_POINTER(nom)) {
fprintf(stderr, "Pointer %s does not make sense here.\n", name);
return -1;
}
/* List of dimensions */
bufcat(buf, "{ ");
for(i=0;i<nom->ndimensions-IS_STRING(nom)?1:0;i++) {
bufcat(buf, "%d ", nom->dimensions[i]);
}
bufcat(buf, "} ");
if (nom->type->type != STRUCT && nom->type->type != UNION) {
bufcat(buf, "%s ", name);
} else {
/* recurse */
DCL_NOM_LIST *m;
bufcat(buf, "{ %s ", name);
for (m = nom->type->members; m != NULL; m = m->next) {
if (m->dcl_nom->name == NULL) {
fprintf(stderr, "Warning: null member name in %s.\n", name);
continue;
}
if (tclOutputFormatGen(buf, m->dcl_nom->name, m->dcl_nom))
fprintf(stderr,
"Warning: struct member %s was problematic.\n",
m->dcl_nom->name);
}
bufcat(buf, "} ");
}
return 0;
}
int get_chunk_age (Val chunk) {
//=============
//
// Get the agegroup of a chunk.
// Return -1 for external/unboxed chunks.
//
// We are called (only) from
// src/c/heapcleaner/datastructure-pickler.c
if (! IS_POINTER( chunk )) {
return -1;
} else {
//
Sibid aid = SIBID_FOR_POINTER( book_to_sibid__global, chunk );
//
if (SIBID_KIND_IS_CODE( aid )) {
//
int i;
for (i = GET_BOOK_CONTAINING_POINTEE(chunk); !SIBID_ID_IS_BIGCHUNK_RECORD(aid); aid = book_to_sibid__global[--i]) {
continue;
}
Hugechunk_Quire*
//
hq = (Hugechunk_Quire*) ADDRESS_OF_BOOK( i );
Hugechunk*
//
dp = get_hugechunk_holding_pointee( hq, chunk );
return dp->age;
} else if (aid == AGEGROUP0_SIBID) { return 0;
} else if (BOOK_IS_UNMAPPED(aid)) { return -1;
} else { return GET_AGE_FROM_SIBID( aid );
}
}
}
int internal_equalp(CELL obj1, CELL obj2)
{
while(1) {
if (AS_LITERAL(obj1) == AS_LITERAL(obj2)) {
return 1;
}
if (! (IS_POINTER(obj1) && IS_POINTER(obj2)) ) {
return 0;
}
if (GET_POINTER_TYPE(obj1) != GET_POINTER_TYPE(obj2)) {
return 0;
}
switch(GET_POINTER_TYPE(obj1)) {
case T_CONS:
// FIXME - unbounded recursion!
if (!internal_equalp(CAR(obj1), CAR(obj2))) {
return 0;
}
obj1 = CDR(obj1);
obj2 = CDR(obj2);
break;
case T_VECTOR:
case T_RECORD:
{
VECTOR * const vec1 = GET_VECTOR(obj1);
VECTOR * const vec2 = GET_VECTOR(obj2);
if (vec1->len != vec2->len) {
return 0;
}
int i;
for(i = 0; i < vec1->len; ++i) {
// FIXME - unbounded recursion!
if (!internal_equalp(vec1->data[i], vec2->data[i])) {
return 0;
}
}
return 1;
}
case T_STRING:
{
STRING * const p1 = GET_STRING(obj1);
STRING * const p2 = GET_STRING(obj2);
return p1->len == p2->len && 0 == memcmp(p1->data, p2->data, p1->len);
}
case T_FLOAT:
return GET_FLOAT(obj1) == GET_FLOAT(obj2);
case T_BIGINT:
return GET_BIGINT(obj1) == GET_BIGINT(obj2);
default:
return 0;
}
}
}
static void _dump_node_basic(QSP_ARG_DECL Vec_Expr_Node *enp)
{
Tree_Code code;
int i;
const char *s;
if( enp==NULL ) return;
/* print the node "name", and a code that tells about shape knowledge */
// Temporarily print to stderr instead of stdout for debugging...
prt_node(enp,msg_str);
prt_msg_frag(msg_str);
if( SHOWING_LHS_REFS ){
sprintf(msg_str,"\t%d",VN_LHS_REFS(enp));
prt_msg_frag(msg_str);
}
if( SHOWING_COST ){
if( VN_SHAPE(enp) != NULL ){
sprintf(msg_str,"\t%d", SHP_N_MACH_ELTS(VN_SHAPE(enp)));
}
prt_msg_frag(msg_str);
sprintf(msg_str,"\t%d\t%d", VN_FLOPS(enp),VN_N_MATH(enp));
prt_msg_frag(msg_str);
}
if( IS_CURDLED(enp) ){
sprintf(msg_str,"\t%s (curdled!?)", NNAME(enp));
prt_msg(msg_str);
return;
}
sprintf(msg_str,"\t%s", NNAME(enp));
prt_msg_frag(msg_str);
/* print the special op-dependent args in human-readable form */
code = VN_CODE(enp);
if( code==T_DYN_OBJ || code == T_UNDEF || code == T_PROTO || code==T_POINTER || code==T_FUNCPTR || code==T_STR_PTR ){
sprintf(msg_str,"\t%s",VN_STRING(enp));
prt_msg_frag(msg_str);
if( code == T_POINTER ){
Identifier *idp;
/* We don't use get_set_ptr() here because we don't want an error msg... */
idp = id_of(VN_STRING(enp));
if( idp != NULL && IS_POINTER(idp) && POINTER_IS_SET(idp) ){
if( PTR_REF(ID_PTR(idp)) == NULL ){
/* how could this ever happen??? */
prt_msg_frag("->???");
} else {
Data_Obj *dp;
dp = REF_OBJ(PTR_REF(ID_PTR(idp)));
sprintf(msg_str,"->%s",OBJ_NAME(dp));
prt_msg_frag(msg_str);
}
}
}
} else if( code == T_STATIC_OBJ ){
sprintf(msg_str,"\t%s",OBJ_NAME(VN_OBJ(enp)));
prt_msg_frag(msg_str);
#ifdef SCALARS_NOT_OBJECTS
} else if( code == T_SCALAR_VAR ){
sprintf(msg_str,"\t%s",VN_STRING(enp));
prt_msg_frag(msg_str);
#endif // SCALARS_NOT_OBJECTS
} else if ( code == T_FUNCREF ){
Subrt *srp;
srp=VN_SUBRT(enp);
sprintf(msg_str,"\t%s",SR_NAME(srp));
prt_msg_frag(msg_str);
} else if( code == T_SIZE_FN ){
sprintf(msg_str,"\t%s",FUNC_NAME(VN_FUNC_PTR(enp)));
prt_msg_frag(msg_str);
}
#ifdef NOT_YET
else if(code == T_CALL_NATIVE ){
// was kw_token???
// curr_native_func_tbl...
sprintf(msg_str,"\t%s",FUNC_NAME(VN_FUNC_PTR(enp)));
prt_msg_frag(msg_str);
}
#endif /* NOT_YET */
else if(code == T_TYPECAST ){
// BUG not how we do precision any more!!!
//sprintf(msg_str," %s",NAME_FOR_PREC_CODE(VN_INTVAL(enp)));
if( VN_SHAPE(enp) == NULL ) error1("CAUTIOUS: null node shape for typecast node!?");
else {
sprintf(msg_str," %s",PREC_NAME(VN_PREC_PTR(enp)));
prt_msg_frag(msg_str);
}
} else if( code == T_SUBRT_DECL || code == T_SCRIPT ){
Subrt *srp;
srp=VN_SUBRT(enp);
sprintf(msg_str,"\t%s",SR_NAME(srp));
prt_msg_frag(msg_str);
} else if( code==T_DECL_STAT ){
//sprintf(msg_str," %s",NAME_FOR_PREC_CODE(VN_INTVAL(enp)));
sprintf(msg_str," %s",PREC_NAME(VN_DECL_PREC(enp)));
prt_msg_frag(msg_str);
} else if( IS_DECL(code) ){
sprintf(msg_str," %s",VN_STRING(enp));
prt_msg_frag(msg_str);
} else if( code==T_ADVISE ){
/* BUG need to elim yylex_qsp */
s=eval_string(VN_CHILD(enp,0));
sprintf(msg_str,"\t\"%s\"",s);
prt_msg_frag(msg_str);
} else if( code==T_WARN ){
/* BUG need to elim yylex_qsp */
s=eval_string(VN_CHILD(enp,0));
sprintf(msg_str,"\t\"%s\"",s);
prt_msg_frag(msg_str);
} else if( code==T_STRING ){
sprintf(msg_str,"\t\"%s\"",VN_STRING(enp));
prt_msg_frag(msg_str);
} else if( code == T_LABEL || code ==T_GO_BACK || code == T_GO_FWD ){
sprintf(msg_str," %s",VN_STRING(enp));
prt_msg_frag(msg_str);
} else if( code==T_LIT_DBL ){
sprintf(msg_str," %g",VN_DBLVAL(enp));
prt_msg_frag(msg_str);
} else if( code == T_MATH0_FN ){
sprintf(msg_str," %s",FUNC_NAME(VN_FUNC_PTR(enp)));
prt_msg_frag(msg_str);
} else if( code == T_MATH1_FN ){
sprintf(msg_str," %s",FUNC_NAME(VN_FUNC_PTR(enp)));
prt_msg_frag(msg_str);
} else if( code == T_MATH2_FN ){
sprintf(msg_str," %s",FUNC_NAME(VN_FUNC_PTR(enp)));
prt_msg_frag(msg_str);
} else if (
code == T_MATH0_VFN
|| code == T_MATH1_VFN
|| code == T_MATH2_VFN
|| code == T_MATH2_VSFN
|| code == T_CHAR_VFN
/* BUG? shouldn't there bre a VSFN2 ??? */
|| code == T_VS_FUNC
|| code == T_VV_FUNC
){
sprintf(msg_str," %s",VF_NAME(FIND_VEC_FUNC(VN_VFUNC_CODE(enp))));
prt_msg_frag(msg_str);
} else if( code==T_CALLFUNC ){
assert(VN_SUBRT(enp)!=NULL);
sprintf(msg_str," %s", SR_NAME(VN_SUBRT(enp)));
prt_msg_frag(msg_str);
} else if( code==T_LIT_INT ){
sprintf(msg_str," %"PRId64, VN_INTVAL(enp) );
prt_msg_frag(msg_str);
} else if( code==T_ASSIGN ){
prt_msg_frag("\t");
} else if( code==T_MAXVAL ){
prt_msg_frag("\t");
} else if( code==T_MINVAL ){
prt_msg_frag("\t");
} else if( code==T_RAMP ){
prt_msg_frag("\t");
}
/* Now print the addresses of the child nodes */
if( VN_CHILD(enp,0)!=NULL){
sprintf(msg_str,"\t\tn%d",VN_SERIAL(VN_CHILD(enp,0)));
prt_msg_frag(msg_str);
}
for(i=1;i<MAX_CHILDREN(enp);i++){
if( VN_CHILD(enp,i)!=NULL){
sprintf(msg_str,", n%d",VN_SERIAL(VN_CHILD(enp,i)));
prt_msg_frag(msg_str);
}
}
prt_msg("");
if( SHOWING_SHAPES && VN_SHAPE(enp) != NULL ){
prt_msg_frag("\t");
if( OWNS_SHAPE(enp) ){
sprintf(msg_str,"* 0x%lx ",(u_long)VN_SHAPE(enp));
prt_msg_frag(msg_str);
}
else {
sprintf(msg_str,"@ 0x%lx ",(u_long)VN_SHAPE(enp));
prt_msg_frag(msg_str);
}
prt_msg_frag("\t");
describe_shape(VN_SHAPE(enp));
}
if( SHOWING_RESOLVERS && VN_RESOLVERS(enp)!=NULL ){
Node *np; Vec_Expr_Node *enp2;
prt_msg("\tResolvers:");
np=QLIST_HEAD(VN_RESOLVERS(enp));
while(np!=NULL){
enp2=(Vec_Expr_Node *)NODE_DATA(np);
sprintf(msg_str,"\t\t%s",node_desc(enp2));
prt_msg(msg_str);
np=NODE_NEXT(np);
}
}
}
static void check_ro_pointer_sib (Sib* ap) {
// ====================
Val* p;
Val* stop;
Val tagword;
Val w;
int i;
int len;
int gen = GET_AGE_FROM_SIBID( ap->id );
if (*sib_is_active(ap)) return; // sib_is_active def in src/c/h/heap.h
debug_say (" records [%d]: [%#x..%#x:%#x)\n",
//
gen,
ap->tospace,
ap->tospace.first_free,
ap->tospace.limit
);
p = ap->tospace;
stop = ap->tospace.first_free;
while (p < stop) {
//
tagword = *p++;
if (*IS_TAGWORD(tagword)) {
ERROR;
debug_say (
"** @%#x: expected tagword, but found %#x in record sib\n",
p-1, tagword);
return;
}
switch (GET_BTAG_FROM_TAGWORD tagword) {
//
case PAIRS_AND_RECORDS_BTAG:
#
len = GET_LENGTH_IN_WORDS_FROM_TAGWORD( tagword ); // Length excludes tagword.
#
for (i = 0; i < len; i++, p++) {
w = *p;
if (IS_TAGWORD(w)) {
ERROR;
debug_say (
"** @%#x: unexpected tagword %#x in slot %d of %d\n",
p, w, i, GET_LENGTH_IN_WORDS_FROM_TAGWORD(tagword));
return;
}
else if (IS_POINTER(w)) {
check_pointer(p, w, gen, RO_POINTERS_KIND, CHUNKC_any);
}
}
break;
case RW_VECTOR_HEADER_BTAG:
case RO_VECTOR_HEADER_BTAG:
//
switch (GET_LENGTH_IN_WORDS_FROM_TAGWORD(tagword)) {
//
case TYPEAGNOSTIC_VECTOR_CTAG:
if (GET_BTAG_FROM_TAGWORD(tagword) == RW_VECTOR_HEADER_BTAG) check_pointer (p, *p, gen, RO_POINTERS_KIND, CHUNKC__IS_RW_POINTERS);
else check_pointer (p, *p, gen, RO_POINTERS_KIND, CHUNKC__IS_RO_POINTERS|CHUNKC__IS_RO_CONSCELL);
break;
case VECTOR_OF_ONE_BYTE_UNTS_CTAG:
case UNT16_VECTOR_CTAG:
case TAGGED_INT_VECTOR_CTAG:
case INT1_VECTOR_CTAG:
case VECTOR_OF_FOUR_BYTE_FLOATS_CTAG:
case VECTOR_OF_EIGHT_BYTE_FLOATS_CTAG:
check_pointer (p, *p, gen, RO_POINTERS_KIND, CHUNKC__IS_NONPTR_DATA);
break;
default:
ERROR;
debug_say ("** @%#x: strange sequence kind %d in record sib\n",
p-1, GET_LENGTH_IN_WORDS_FROM_TAGWORD(tagword));
return;
}
if (*IS_TAGGED_INT(p[1])) {
ERROR;
debug_say ("** @%#x: sequence header length field not an in (%#x)\n",
p+1, p[1]);
}
p += 2;
break;
default:
ERROR;
debug_say ("** @%#x: strange tag (%#x) in record sib\n",
p-1, GET_BTAG_FROM_TAGWORD(tagword));
return;
}
}
} // fun check_ro_pointer_sib
static void check_rw_pointer_sib (Sib* ap, Coarse_Inter_Agegroup_Pointers_Map* map) { // 'map' is nowhere used in the code?! Should be deleted or used. XXX BUGGO FIXME
// ====================
//
Val* p;
Val* stop;
Val tagword;
Val w;
int i, j;
int len;
int gen = GET_AGE_FROM_SIBID(ap->id);
if (*sib_is_active(ap)) return; // sib_is_active def in src/c/h/heap.h
debug_say (" arrays [%d]: [%#x..%#x:%#x)\n",
//
gen,
ap->tospace,
ap->tospace.first_free,
ap->tospace.limit
);
p = ap->tospace;
stop = ap->tospace.first_free;
while (p < stop) {
tagword = *p++;
if (*IS_TAGWORD(tagword)) {
ERROR;
debug_say (
"** @%#x: expected tagword, but found %#x in vector sib\n",
p-1, tagword);
return;
}
switch (GET_BTAG_FROM_TAGWORD(tagword)) {
//
case RW_VECTOR_DATA_BTAG:
len = GET_LENGTH_IN_WORDS_FROM_TAGWORD(tagword);
break;
case WEAK_POINTER_OR_SUSPENSION_BTAG:
len = 1;
break;
default:
ERROR;
debug_say ("** @%#x: strange tag (%#x) in vector sib\n",
p-1, GET_BTAG_FROM_TAGWORD(tagword));
return;
}
for (int i = 0; i < len; i++, p++) {
//
w = *p;
if (IS_TAGWORD(w)) {
ERROR;
debug_say (
"** @%#x: Unexpected tagword %#x in rw_vector slot %d of %d\n",
p, w, i, GET_LENGTH_IN_WORDS_FROM_TAGWORD(tagword));
for (p -= (i+1), j = 0; j <= len; j++, p++) {
debug_say (" %#x: %#10x\n", p, *p);
}
return;
} else if (IS_POINTER(w)) {
check_pointer(p, w, gen, RW_POINTERS_KIND, CHUNKC_any);
}
}
}
} // fun check_rw_pointer_sib
static Val pickle_heap_datastructure (Task *task, Val root_chunk, Pickler_Result* result) {
// =========================
//
Heap* heap = task->heap;
int max_age = result->oldest_agegroup_included_in_pickle;
Vunt total_sib_buffer_bytesize[ MAX_PLAIN_SIBS ];
Vunt total_bytesize;
struct {
Vunt base; // Base address of the sib buffer in the heap.
Vunt offset; // Relative position in the merged sib buffer.
//
} adjust[ MAX_AGEGROUPS ][ MAX_PLAIN_SIBS ];
Sib_Header* p; // Sib_Header def in src/c/heapcleaner/runtime-heap-image.h
Sib_Header* sib_headers[ TOTAL_SIBS ];
Sib_Header* sib_header_buffer;
int sib_header_bytesize;
int smallchunk_sibs_count;
Val pickle;
Writer* wr;
// Compute the sib offsets in the heap image:
//
for (int ilk = 0; ilk < MAX_PLAIN_SIBS; ilk++) {
//
total_sib_buffer_bytesize[ ilk ] = 0;
}
// The embedded literals go first:
//
total_sib_buffer_bytesize[ NONPTR_DATA_SIB ] // pickler__relocate_embedded_literals def in src/c/heapcleaner/datastructure-pickler-cleaner.c
=
pickler__relocate_embedded_literals( result, NONPTR_DATA_SIB, 0 );
// DEBUG debug_say("%d bytes of string literals\n", total_sib_buffer_bytesize[NONPTR_DATA_SIB]);
for (int age = 0; age < max_age; age++) {
for (int ilk = 0; ilk < MAX_PLAIN_SIBS; ilk++) {
//
Sib* sib = heap->agegroup[ age ]->sib[ ilk ];
adjust[ age ][ ilk ].offset
=
total_sib_buffer_bytesize[ ilk ];
if (!sib_is_active(sib)) { // sib_is_active def in src/c/h/heap.h
//
adjust[ age ][ ilk ].base = 0;
//
} else {
//
total_sib_buffer_bytesize[ ilk ]
+=
(Vunt) sib->tospace.first_free
-
(Vunt) sib->tospace.start;
adjust[ age ][ ilk ].base = (Vunt) sib->tospace.start;
}
}
}
// DEBUG for (ilk = 0; ilk < MAX_PLAIN_SIBS; ilk++) debug_say ("sib %d: %d bytes\n", ilk+1, total_sib_buffer_bytesize[ilk]);
// WHAT ABOUT THE BIG CHUNKS??? XXX BUGGO FIXME
// Compute the total size of the pickled datastructure:
//
smallchunk_sibs_count = 0;
total_bytesize = 0;
//
for (int ilk = 0; ilk < MAX_PLAIN_SIBS; ilk++) {
//
if (total_sib_buffer_bytesize[ilk] > 0) {
smallchunk_sibs_count++;
total_bytesize += total_sib_buffer_bytesize[ilk];
}
}
total_bytesize
+=
sizeof( Heapfile_Header )
+
sizeof( Pickle_Header )
+
(smallchunk_sibs_count * sizeof( Sib_Header ));
// COUNT SPACE FOR BIG CHUNKS
total_bytesize
+=
sizeof(Externs_Header)
+
heapfile_cfun_table_bytesize( result->cfun_table ); // Include the space for the external symbols (i.e., runtime C functions referenced within the heapgraph).
// Allocate the heap bytevector for the pickled
// datastructure representation and initialize
// the bytevector-writer.
//
pickle
=
allocate_heap_ram_for_pickle( task, total_bytesize );
//
wr = WR_OpenMem( PTR_CAST(Unt8*, pickle), total_bytesize ); // WR_OpenMem def in src/c/heapcleaner/mem-writer.c
// Initialize the sib headers:
//
sib_header_bytesize = smallchunk_sibs_count * sizeof(Sib_Header);
//
sib_header_buffer = (Sib_Header*) MALLOC (sib_header_bytesize);
//
p = sib_header_buffer;
//
for (int ilk = 0; ilk < MAX_PLAIN_SIBS; ilk++) {
//
if (total_sib_buffer_bytesize[ ilk ] <= 0) {
//
sib_headers[ilk] = NULL;
//
} else {
//
p->age = 0;
p->chunk_ilk = ilk;
//
p->info.o.base_address = 0; // Not used.
p->info.o.bytesize = total_sib_buffer_bytesize[ ilk ];
p->info.o.rounded_bytesize = -1; // Not used.
//
p->offset = -1; // Not used.
sib_headers[ ilk ] = p;
p++;
}
}
// What about big chunks? XXX BUGGO FIXME
// Write the pickle image header:
//
if (heapio__write_image_header (wr, NORMAL_DATASTRUCTURE_PICKLE) == FALSE) { // heapio__write_image_header def in src/c/heapcleaner/export-heap-stuff.c
//
FREE( sib_header_buffer );
return PICKLER_ERROR;
}
// Write the pickle header:
//
{ Pickle_Header header;
header.smallchunk_sibs_count = smallchunk_sibs_count;
header.hugechunk_sibs_count = 0; // FIX THIS XXX BUGGO FIXME
header.hugechunk_quire_count = 0; // FIX THIS XXX BUGGO FIXME
if (!IS_EXTERNAL_TAG( root_chunk )) {
Sibid sibid = SIBID_FOR_POINTER( book_to_sibid__global, root_chunk );
if (!SIBID_KIND_IS_CODE(sibid)) {
// This is the normal case --
// we're saving a vanilla heap value.
Vunt addr = HEAP_POINTER_AS_UNT( root_chunk );
int age = GET_AGE_FROM_SIBID( sibid) - 1;
int kind = GET_KIND_FROM_SIBID(sibid) - 1; // GET_KIND_FROM_SIBID def in src/c/h/sibid.h
addr -= adjust[ age ][ kind ].base;
addr += adjust[ age ][ kind ].offset;
header.root_chunk = HIO_TAG_PTR(kind, addr); // HIO_TAG_PTR def in src/c/heapcleaner/runtime-heap-image.h
} else {
//
Embedded_Chunk_Info* p
=
FIND_EMBEDDED_CHUNK( result->embedded_chunk_table, root_chunk );
if ((p == NULL) || (p->kind == USED_CODE)) {
//
say_error( "Pickling compiled Mythryl code not implemented\n" );
FREE (sib_header_buffer);
return PICKLER_ERROR;
} else {
header.root_chunk = p->relocated_address;
}
}
} else { // IS_EXTERNAL_TAG( root_chunk )
//
ASSERT( smallchunk_sibs_count == 0 );
header.root_chunk = root_chunk;
}
WR_WRITE(wr, &header, sizeof(header)); // WR_WRITE def in src/c/heapcleaner/writer.h
//
if (WR_ERROR(wr)) {
FREE (sib_header_buffer);
return PICKLER_ERROR;
}
}
// Record in the pickle the table of heap-referenced
// runtime C functions. May also include
// a handful of assembly fns, exceptions
// and refcells:
//
{ int bytes_written = heapio__write_cfun_table( wr, result->cfun_table ); // heapio__write_cfun_table def in src/c/heapcleaner/export-heap-stuff.c
if (bytes_written == -1) {
FREE( sib_header_buffer );
return PICKLER_ERROR;
}
}
// Write the pickle sib headers:
//
WR_WRITE (wr, sib_header_buffer, sib_header_bytesize);
//
if (WR_ERROR(wr)) {
FREE (sib_header_buffer);
return PICKLER_ERROR;
}
// Write the pickled datastructure proper:
//
for (int ilk = 0; ilk < MAX_PLAIN_SIBS; ilk++) {
//
if (ilk == NONPTR_DATA_SIB) {
// Write into the pickle the required embedded literals:
//
pickler__pickle_embedded_literals( wr ); // pickler__pickle_embedded_literals def in src/c/heapcleaner/datastructure-pickler-cleaner.c
// Write into the pickle remaining required strings:
//
for (int age = 0; age < max_age; age++) {
//
Sib* sib = heap->agegroup[ age ]->sib[ ilk ];
if (sib_is_active(sib)) { // sib_is_active def in src/c/h/heap.h
//
WR_WRITE(
wr,
sib->tospace.start,
(Vunt) sib->tospace.first_free
-(Vunt) sib->tospace.start
);
}
}
} else {
for (int age = 0; age < max_age; age++) {
//
Sib* sib = heap->agegroup[ age ]->sib[ ilk ];
if (sib_is_active( sib )) {
//
Val* top = sib->tospace.first_free;
//
for (Val*
p = sib->tospace.start;
p < top;
p++
){
Val w = *p;
if (IS_POINTER(w)) {
//
Sibid sibid = SIBID_FOR_POINTER( book_to_sibid__global, w );
if (BOOK_IS_UNMAPPED(sibid)) {
//
w = add_cfun_to_heapfile_cfun_table( result->cfun_table, w);
ASSERT (w != HEAP_VOID);
} else if (SIBID_KIND_IS_CODE(sibid)) {
Embedded_Chunk_Info* chunk_info
=
FIND_EMBEDDED_CHUNK( result->embedded_chunk_table, w );
if (chunk_info == NULL
|| chunk_info->kind == USED_CODE
){
die("Pickling of Mythryl compiled code not implemented");
} else {
w = chunk_info->relocated_address;
}
} else {
// Adjust the pointer:
//
int age = GET_AGE_FROM_SIBID( sibid)-1;
int kind = GET_KIND_FROM_SIBID(sibid)-1;
Vunt addr = HEAP_POINTER_AS_UNT(w);
addr -= adjust[ age ][ kind ].base;
addr += adjust[ age ][ kind ].offset;
w = HIO_TAG_PTR( kind, addr );
}
} // if (IS_POINTER(w))
WR_PUT(wr, (Vunt)w);
} // for
}
}
}
}
FREE( sib_header_buffer );
if (WR_ERROR(wr)) return PICKLER_ERROR;
return make_vector_header(task, STRING_TAGWORD, pickle, total_bytesize);
} // fun pickle_heap_datastructure
static int
tclInputFormatGen(char **buf, char *name, DCL_NOM_STR *nom,
RQST_INPUT_INFO_LIST **iinfo, int level)
{
char *arrayName = NULL; /* in the case of an array */
static char defaultDefault[20];
if (IS_POINTER(nom)) {
fprintf(stderr, "Pointer %s does not make sense here.\n", name);
return -1;
}
/* For an array, must do some loop */
if (IS_ARRAY(nom)) {
int i;
bufcat(&arrayName, name);
for(i=0;i<nom->ndimensions-IS_STRING(nom)?1:0;i++) {
bufcat(buf," for {set loop%d(%d) 0} "
"{ \\$loop%d(%d)<%d } { incr loop%d(%d)} {\n",
level, i, level, i, nom->dimensions[i], level, i);
bufcat(&arrayName, "\\\\[\\$loop%d(%d)\\\\]", level, i);
}
if (arrayName == NULL) {
/* must give up */
fprintf(stderr, "Warning: could not generate array name for %s.\n",
name);
return -1;
}
name = arrayName;
}
if (nom->type->type != STRUCT && nom->type->type != UNION) {
bufcat(buf, " lappend format [list ");
/* Echo the tcl func call */
switch (nom->type->type) {
case CHAR:
if (IS_STRING(nom))
bufcat(buf, "string");
else
bufcat(buf, "short");
strcpy(defaultDefault, "\"\"");
break;
case SHORT:
bufcat(buf, "short");
strcpy(defaultDefault, "0");
break;
case INT:
if (nom->type->flags & LONG_LONG_INT)
bufcat(buf, "wide");
else
bufcat(buf, "int");
strcpy(defaultDefault, "0");
break;
case FLOAT:
bufcat(buf, "float");
strcpy(defaultDefault, "0.0");
break;
case DOUBLE:
bufcat(buf, "double");
strcpy(defaultDefault, "0.0");
break;
case STRUCT:
case UNION:
/* see 'else' statement below */
break;
/* Affichage en clair des symboles de l'enum */
case ENUM:
bufcat(buf, "{ ");
if (tclGenEnumList(buf, nom->type) != 0)
return -1;
bufcat(buf, "}");
strcpy(defaultDefault, "\"\"");
break;
case TYPEDEF:
fprintf(stderr, "Warning: encountered a typedef for %s.\n", name);
break;
}
if (*iinfo != NULL && (*iinfo)->doc != NULL) {
bufcat(buf, " \"%s\"", (*iinfo)->doc);
switch((*iinfo)->type) {
case INT:
if (nom->type->type == ENUM) {
int ok = 0;
DCL_NOM_LIST *member;
for(member = nom->type->members;
member != NULL;
member = member->next) {
if (member->dcl_nom->pointeur ==
(*iinfo)->default_val.i_val) {
bufcat(buf, " \"%s\"", member->dcl_nom->name);
ok = 1;
break;
}
}
if (!ok)
bufcat(buf, " %d", (*iinfo)->default_val.i_val);
} else
bufcat(buf, " %d", (*iinfo)->default_val.i_val);
break;
case DOUBLE:
bufcat(buf, " %f", (*iinfo)->default_val.d_val);
break;
case CHAR:
bufcat(buf, " \"%s\"", (*iinfo)->default_val.str_val);
break;
}
}
else
bufcat(buf, " \"%s\" %s", name, defaultDefault);
bufcat(buf, " ]\n");
} else { /* STRUCT || UNION */
/* recurse */
DCL_NOM_LIST *m;
char *var;
for (m = nom->type->members; m != NULL; m = m->next) {
var = NULL;
bufcat(&var, "%s.%s", name, m->dcl_nom->name);
if (var == NULL) {
fprintf(stderr, "Warning: null member name in %s.\n", name);
continue;
}
if (tclInputFormatGen(buf, var, m->dcl_nom, iinfo, level+1))
fprintf(stderr, "Warning: struct member %s was problematic.\n",
var);
free(var);
}
}
if (IS_ARRAY(nom)) {
int i;
/* End array scanning */
for(i=IS_STRING(nom)?1:0;i<nom->ndimensions;i++) {
bufcat(buf, "}\n");
}
free(arrayName);
}
if (nom->type->type != STRUCT && nom->type->type != UNION)
if ((*iinfo) != NULL) *iinfo = (*iinfo)->next;
return 0;
}
static Val forward_special_chunk (Agegroup* ag1, Val* chunk, Val tagword) {
// =====================
//
// Forward a special chunk (suspension or weak pointer).
Sib* sib = ag1->sib[ RW_POINTERS_SIB ]; // Special chunks can be updated (modified)
// so they have to go in RW_POINTERS_SIB.
Val* new_chunk = sib->tospace.first_free;
sib->tospace.first_free += SPECIAL_CHUNK_SIZE_IN_WORDS; // All specials are two words.
switch (GET_LENGTH_IN_WORDS_FROM_TAGWORD( tagword )) {
//
case EVALUATED_LAZY_SUSPENSION_CTAG:
case UNEVALUATED_LAZY_SUSPENSION_CTAG:
//
*new_chunk++ = tagword;
*new_chunk = *chunk;
break;
case WEAK_POINTER_CTAG:
{
//
Val v = *chunk;
#ifdef DEBUG_WEAKREFS
debug_say ("MinorGC: weak [%#x ==> %#x] --> %#x", chunk, new_chunk+1, v);
#endif
if (! IS_POINTER( v )) {
#ifdef DEBUG_WEAKREFS
debug_say (" unboxed\n");
#endif
// Weak references to unboxed chunks (i.e., immediate Int31)
// can never be nullified, since Int31 values, being stored
// in-pointer, take no actual heapspace and thus cannot actually
// ever get garbage-collected. Consequently, we can just copy
// such weakrefs over and skip the rest of our usual processing:
//
new_chunk[0] = WEAKREF_TAGWORD;
new_chunk[1] = v;
++new_chunk;
} else {
Sibid sibid = SIBID_FOR_POINTER( book_to_sibid__global, v );
Val* vp = PTR_CAST( Val*, v );
if (sibid != AGEGROUP0_SIBID) {
// Weakref points to a value in an older heap agegroup.
// Since we are only heapcleaning agegroup0 in
// this file, the referenced value cannot get
// garbage-collected this pass, so we can skip
// the usual work to check for that and if necessary
// null out the weakref:
//
#ifdef DEBUG_WEAKREFS
debug_say (" old chunk\n");
#endif
new_chunk[0] = WEAKREF_TAGWORD;
new_chunk[1] = v;
++new_chunk;
} else {
//
if (vp[-1] == FORWARDED_CHUNK_TAGWORD) {
//
// Reference to a chunk that has already been forwarded.
// Note that we have to put the pointer to the non-forwarded
// copy of the chunk (i.e, v) into the to-space copy
// of the weak pointer, since the heapcleaner has the invariant
// that it never sees to-space pointers during sweeping.
#ifdef DEBUG_WEAKREFS
debug_say (" already forwarded to %#x\n", PTR_CAST( Val, FOLLOW_FORWARDING_POINTER(vp)));
#endif
new_chunk[0] = WEAKREF_TAGWORD;
new_chunk[1] = v;
++new_chunk;
} else {
// This is the important case: We are copying a weakref
// of an agegroup0 value. That agegroup0 value might get
// get garbage-collected this pass; if it does, we must null
// out the weakref.
//
// To do this efficiently, as we copy such weakrefs from
// agegroup0 into agegroup1 we chain them togther via
// their tagword fields with the root pointer kept
// in ag1->heap->weakrefs_forwarded_during_heapcleaning.
//
// At the end of heapcleaning we will consume this chain of
// weakrefs in null_out_newly_dead_weakrefs() where // null_out_newly_dead_weakrefs is from src/c/heapcleaner/heapcleaner-stuff.c
// we will null out any newly dead weakrefs and then
// replace the chainlinks with valid tagwords -- either
// WEAKREF_TAGWORD or NULLED_WEAKREF_TAGWORD,
// as appropriate, thus erasing our weakref chain and
// restoring sanity.
//
// We mark the chunk reference field in the forwarded copy
// to make it look like an Tagged_Int so that the to-space
// sweeper does not follow the weak reference.
#ifdef DEBUG_WEAKREFS
debug_say (" forward\n");
#endif
new_chunk[0] = MARK_POINTER(PTR_CAST( Val, ag1->heap->weakrefs_forwarded_during_heapcleaning )); // MARK_POINTER just sets the low bit to 1, making it look like an Int31 value
new_chunk[1] = MARK_POINTER( vp ); // MARK_POINTER is from src/c/h/heap-tags.h
ag1->heap->weakrefs_forwarded_during_heapcleaning = new_chunk;
++new_chunk;
}
}
}
}
break;
case NULLED_WEAK_POINTER_CTAG: // Shouldn't happen in agegroup0.
default:
die (
"strange/unexpected special chunk @ %#x; tagword = %#x\n",
chunk, tagword
);
} // switch (GET_LENGTH_IN_WORDS_FROM_TAGWORD(tagword))
chunk[-1] = FORWARDED_CHUNK_TAGWORD;
chunk[ 0] = (Val) (Vunt) new_chunk;
return PTR_CAST( Val, new_chunk );
} // fun forward_special_chunk
static void process_task_heap_changelog (Task* task, Heap* heap) {
// ===========================
//
// As tasks run, they note all stores into pointer-valued // Tagged-Int-valued refcells cannot contain cross-generation pointers so we don't track them in changelog.
// refcells and rw_vectors in the 'heap_changelog',
// a lisp-style list of "CONS cells" -- (val,next) pointer-pairs.
//
// We need this done because such stores into the heap
// can introduce pointers from one agegroup into a
// younger agegroup, which we need to take into account
// when doing partial heapcleanings ("garbage collections").
//
// Our job here is to promote to agegroup 1 all agegroup0
// values referenced by a refcell/vectorslot in the heap_changelog.
Val this_heap_changelog_cell = task->heap_changelog;
if (this_heap_changelog_cell == HEAP_CHANGELOG_NIL) return; // Abort quickly if no work to do.
int updates = 0; // Heapcleaner statistics.
Agegroup* age1 = heap->agegroup[ 0 ]; // Cache heap entry for speed.
Sibid* b2s = book_to_sibid__global; // Cache global locally for speed. book_to_sibid__global def in src/c/heapcleaner/heapcleaner-initialization.c
while (this_heap_changelog_cell != HEAP_CHANGELOG_NIL) { // Over all entries in the heap_changelog.
//
++updates; // Heapcleaner statistics.
Val* pointer = HEAP_CHANGELOG_HEAD( this_heap_changelog_cell ); // Get pointer to next updated refcell/vector slot to process.
this_heap_changelog_cell = HEAP_CHANGELOG_TAIL( this_heap_changelog_cell ); // Step to next cell in heap_changelog list.
Val pointee = *pointer; // Get contents of updated refcell/vectorslot.
if (!IS_POINTER( pointee )) continue; // Ignore refcells and vectorslots containing Tagged_Int values.
Sibid src_sibid = SIBID_FOR_POINTER(b2s, pointer ); // Get the Sibid tag for the ram-book containing the refcell/vectorslot. Sibid def in src/c/h/sibid.h
if (src_sibid == AGEGROUP0_SIBID) continue; // Ignore updates to agegroup0 refcells and vectorslots.
if (BOOK_IS_UNMAPPED( src_sibid )) continue; // Ignore updates to runtime-global refcells and vectorslots, which are handled elsewhere.
Sibid dst_sibid = SIBID_FOR_POINTER(b2s, pointee ); // Get the Sibid tag for the ram-book containing the value referenced by the refcell/vectorslot.
//
int src_age = GET_AGE_FROM_SIBID( src_sibid ); // agegroup of the updated refcell/vectorslot.
int dst_age = GET_AGE_FROM_SIBID( dst_sibid ); // agegroup of the chunk that the refcell/vectorslot points to.
if (!SIBID_KIND_IS_CODE( dst_sibid )) {
//
if (dst_age == AGEGROUP0) {
//
*pointer = forward_agegroup0_chunk_to_agegroup1( age1, pointee,task, 1); // Promote pointee to agegroup 1.
dst_age = 1; // Remember pointee now has age 1, not 0.
//
}
} else { // Refcell/vector slot is pointing to code.
if (dst_age >= src_age) continue;
dst_age = get_age_of_codechunk( pointee );
}
// Maybe update min_age value for
// the card containing 'pointer':
//
if (src_age > dst_age) {
//
MAYBE_UPDATE_CARD_MIN_AGE_PER_POINTER( // MAYBE_UPDATE_CARD_MIN_AGE_PER_POINTER def in src/c/h/coarse-inter-agegroup-pointers-map.h
//
heap->agegroup[ src_age-1 ]->coarse_inter_agegroup_pointers_map,
pointer,
dst_age
);
}
}
update_count__global += updates; // Cleaner statistics. Apparently never used.
task->heap_changelog = HEAP_CHANGELOG_NIL; // We're done with heap_changelog so clear it.
} // fun process_task_heap_changelog
