void print_array_layout(secd_t *secd) {
errorf(";; Array heap layout:\n");
errorf(";; arrayptr = %ld\n", cell_index(secd, secd->arrayptr));
errorf(";; arrlist = %ld\n", cell_index(secd, secd->arrlist));
errorf(";; Array list is:\n");
cell_t *cur = secd->arrlist;
while (not_nil(mcons_next(cur))) {
cur = mcons_next(cur);
errorf(";; %ld\t%ld (size=%zd,\t%s)\n", cell_index(secd, cur),
cell_index(secd, mcons_prev(cur)), arrmeta_size(secd, cur),
(is_array_free(secd, cur)? "free" : "used"));
}
}
cell_t *alloc_array(secd_t *secd, size_t size) {
/* look through the list of arrays */
cell_t *cur = secd->arrlist;
while (not_nil(mcons_next(cur))) {
if (is_array_free(secd, cur)) {
size_t cursize = arrmeta_size(secd, cur);
if (cursize >= size) {
/* allocate this gap */
if (cursize > size + 1) {
/* make a free gap after */
cell_t *newmeta = cur + size + 1;
cell_t *prevmeta = mcons_prev(cur);
init_meta(secd, newmeta, prevmeta, cur);
cur->as.mcons.prev = newmeta;
prevmeta->as.mcons.next = newmeta;
mark_free(newmeta, true);
}
mark_free(cur, false);
return meta_mem(cur);
}
}
cur = mcons_next(cur);
}
/* no chunks of sufficient size found, move secd->arrayptr */
if (secd->arrayptr - secd->fixedptr <= (int)size)
return &secd_out_of_memory;
/* create new metadata cons at arrayptr - size - 1 */
cell_t *oldmeta = secd->arrayptr;
cell_t *meta = oldmeta - size - 1;
init_meta(secd, meta, oldmeta, SECD_NIL);
oldmeta->as.mcons.next = meta;
secd->arrayptr = meta;
memdebugf("NEW ARR[%ld], size %zd\n", cell_index(secd, meta), size);
mark_free(meta, false);
return meta_mem(meta);
}
int secd_dump_state(secd_t *secd, cell_t *fname) {
cell_t *p = secd_newport(secd, "w", "file", fname);
secd_pprintf(secd, p,
";; secd->fixedptr = %ld\n", cell_index(secd, secd->fixedptr));
secd_pprintf(secd, p,
";; secd->arrayptr = %ld\n", cell_index(secd, secd->arrayptr));
secd_pprintf(secd, p,
";; secd->end = %ld\n", cell_index(secd, secd->end));
secd_pprintf(secd, p, ";; secd->input_port = %ld, secd->output_port = %ld\n",
cell_index(secd, secd->input_port), cell_index(secd, secd->output_port));
secd_pprintf(secd, p, ";; SECD = (%ld, %ld, %ld, %ld)\n",
cell_index(secd, secd->stack), cell_index(secd, secd->env),
cell_index(secd, secd->control), cell_index(secd, secd->dump));
secd_pprintf(secd, p, ";; secd->free = %ld (%ld free)\n",
cell_index(secd, secd->free), secd->stat.free_cells);
/* dump fixed heap */
long i;
long n_fixed = secd->fixedptr - secd->begin;
secd_pprintf(secd, p, "\n;; SECD persistent heap:\n");
for (i = 0; i < n_fixed; ++i) {
cell_t *cell_info = serialize_cell(secd, secd->begin + i);
sexp_pprint(secd, p, cell_info);
secd_pprintf(secd, p, "\n");
free_cell(secd, cell_info);
}
secd_pprintf(secd, p, "\n;; SECD array heap:\n");
cell_t *mcons = secd->arrlist;
while (mcons_next(mcons)) {
cell_t *cell_info = serialize_cell(secd, mcons);
sexp_pprint(secd, p, cell_info);
if (!mcons->as.mcons.free)
secd_pdump_array(secd, p, mcons);
secd_pprintf(secd, p, "\n");
free_cell(secd, cell_info);
mcons = mcons_next(mcons);
}
secd_pclose(secd, p);
free_cell(secd, p);
return 0;
}
void dbg_print_cell(secd_t *secd, const cell_t *c) {
if (is_nil(c)) {
secd_printf(secd, "NIL\n");
return;
}
char buf[128];
if (c->nref > DONT_FREE_THIS - 100000) strncpy(buf, "-", 64);
else snprintf(buf, 128, "%ld", (long)c->nref);
printf("[%ld]^%s: ", cell_index(secd, c), buf);
switch (cell_type(c)) {
case CELL_CONS:
printf("CONS([%ld], [%ld])\n",
cell_index(secd, get_car(c)), cell_index(secd, get_cdr(c)));
break;
case CELL_FRAME:
printf("FRAME(syms: [%ld], vals: [%ld])\n",
cell_index(secd, get_car(c)), cell_index(secd, get_cdr(c)));
break;
case CELL_INT: printf("%d\n", c->as.num); break;
case CELL_CHAR:
if (isprint(c->as.num)) printf("#\\%c\n", (char)c->as.num);
else printf("#x%x\n", c->as.num);
break;
case CELL_OP:
sexp_print_opcode(secd, secd->output_port, c->as.op);
printf("\n");
break;
case CELL_FUNC: printf("*%p()\n", c->as.ptr); break;
case CELL_KONT: printf("KONT[%ld, %ld, %ld]\n",
cell_index(secd, c->as.kont.stack),
cell_index(secd, c->as.kont.env),
cell_index(secd, c->as.kont.ctrl)); break;
case CELL_ARRAY: printf("ARR[%ld]\n",
cell_index(secd, arr_val(c, 0))); break;
case CELL_STR: printf("STR[%ld\n",
cell_index(secd, (cell_t*)strval(c))); break;
case CELL_SYM: printf("SYM[%08x]='%s'\n",
symhash(c), symname(c)); break;
case CELL_BYTES: printf("BVECT[%ld]\n",
cell_index(secd, (cell_t*)strval(c))); break;
case CELL_REF: printf("REF[%ld]\n",
cell_index(secd, c->as.ref)); break;
case CELL_ERROR: printf("ERR[%s]\n", errmsg(c)); break;
case CELL_ARRMETA: printf("META[%ld, %ld]\n",
cell_index(secd, mcons_prev((cell_t*)c)),
cell_index(secd, mcons_next((cell_t*)c))); break;
case CELL_UNDEF: printf("#?\n"); break;
case CELL_FREE: printf("FREE\n"); break;
default: printf("unknown type: %d\n", cell_type(c));
}
}
void free_array(secd_t *secd, cell_t *mem) {
assertv(mem <= secd->arrlist, "free_array: tried to free arrlist");
assertv(secd->arrayptr < mem, "free_array: not an array");
cell_t *meta = arr_meta(mem);
cell_t *prev = mcons_prev(meta);
assertv(meta->nref == 0, "free_array: someone seems to still use the array");
mark_free(meta, true);
if (meta != secd->arrayptr) {
if (is_array_free(secd, prev)) {
/* merge with the previous array */
cell_t *pprev = prev->as.mcons.prev;
pprev->as.mcons.next = meta;
meta->as.mcons.prev = pprev;
}
cell_t *next = mcons_next(meta);
if (is_array_free(secd, next)) {
/* merge with the next array */
cell_t *newprev = meta->as.mcons.prev;
next->as.mcons.prev = newprev;
newprev->as.mcons.next = next;
}
mark_free(meta, true);
} else {
/* move arrayptr into the array area */
prev->as.mcons.next = SECD_NIL;
secd->arrayptr = prev;
if (is_array_free(secd, prev)) {
/* at most one array after 'arr' may be free */
cell_t *pprev = prev->as.mcons.prev;
pprev->as.mcons.next = SECD_NIL;
secd->arrayptr = pprev;
}
}
memdebugf("FREE ARR[%ld]", cell_index(secd, meta));
}
cell_t *serialize_cell(secd_t *secd, cell_t *cell) {
cell_t *opt = SECD_NIL;
switch (cell_type(cell)) {
case CELL_CONS: {
cell_t *cdrc = chain_index(secd, get_cdr(cell), SECD_NIL);
opt = chain_index(secd, get_car(cell), cdrc);
}
break;
case CELL_PORT:
opt = secd_pserialize(secd, cell);
break;
case CELL_SYM:
opt = new_cons(secd, cell, SECD_NIL);
break;
case CELL_INT:
case CELL_CHAR:
opt = new_cons(secd, cell, SECD_NIL);
break;
case CELL_OP: {
cell_t *namec = new_symbol(secd, opcode_table[ cell->as.op ].name);
opt = new_cons(secd, namec, SECD_NIL);
}
break;
case CELL_FUNC:
opt = new_cons(secd, new_number(secd, (long)cell->as.ptr), SECD_NIL);
break;
case CELL_ARRMETA: {
cell_t *typec = chain_sym(secd,
(cell->as.mcons.cells ? "cell" : "byte"),
SECD_NIL);
cell_t *nextc = chain_index(secd, mcons_next(cell), typec);
opt = chain_index(secd, mcons_prev(cell), nextc);
}
break;
case CELL_FRAME: {
cell_t *ioc = chain_index(secd, cell->as.frame.io, SECD_NIL);
cell_t *nextc = chain_index(secd, cell->as.frame.cons.cdr, ioc);
opt = chain_index(secd, cell->as.frame.cons.car, nextc);
}
break;
case CELL_KONT: {
cell_t *kctrl = chain_index(secd, cell->as.kont.ctrl, SECD_NIL);
cell_t *kenv = chain_index(secd, cell->as.kont.env, kctrl);
opt = chain_index(secd, cell->as.kont.stack, kenv);
}
break;
case CELL_FREE: {
cell_t *nextc = chain_index(secd, get_cdr(cell), SECD_NIL);
opt = chain_index(secd, get_car(cell), nextc);
}
break;
case CELL_REF:
opt = chain_index(secd, cell->as.ref, SECD_NIL);
break;
case CELL_ERROR:
opt = chain_string(secd, errmsg(cell), SECD_NIL);
break;
case CELL_UNDEF:
opt = SECD_NIL;
break;
case CELL_ARRAY:
opt = chain_index(secd, arr_val(cell, -1), SECD_NIL);
break;
case CELL_STR:
case CELL_BYTES:
opt = chain_index(secd, arr_meta((cell_t *)strmem(cell)), SECD_NIL);
break;
}
opt = new_cons(secd, secd_type_sym(secd, cell), opt);
cell_t *refc = new_cons(secd, new_number(secd, cell->nref), opt);
return new_cons(secd, new_number(secd, cell - secd->begin), refc);
}
