Exemple #1
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));
    }
}
Exemple #2
0
Fichier : memory.c Projet : 8l/SECD
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"));
    }
}
Exemple #3
0
Fichier : memory.c Projet : 8l/SECD
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);
}
Exemple #4
0
Fichier : memory.c Projet : 8l/SECD
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));
}
Exemple #5
0
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);
}