adding support for finalization of values

enabling type-specific print and relocate behavior

allowing GC to be triggered by large buffer allocations

adding hash table constructor and print function

renamed some functions
This commit is contained in:
JeffBezanson 2008-12-20 06:16:00 +00:00
parent ee9f565d89
commit b5dda68eab
7 changed files with 189 additions and 41 deletions

View File

@ -345,6 +345,7 @@ value_t fl_randf(value_t *args, u_int32_t nargs)
}
extern void stringfuncs_init();
extern void table_init();
static builtinspec_t builtin_info[] = {
{ "set-syntax", fl_setsyntax },
@ -383,4 +384,5 @@ void builtins_init()
{
assign_global_builtins(builtin_info);
stringfuncs_init();
table_init();
}

View File

@ -18,15 +18,15 @@ value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
value_t unionsym;
static htable_t TypeTable;
static fltype_t *builtintype;
static fltype_t *int8type, *uint8type;
static fltype_t *int16type, *uint16type;
static fltype_t *int32type, *uint32type;
static fltype_t *int64type, *uint64type;
static fltype_t *longtype, *ulongtype;
static fltype_t *floattype, *doubletype;
fltype_t *chartype, *wchartype;
fltype_t *stringtype, *wcstringtype;
static fltype_t *floattype, *doubletype;
fltype_t *builtintype;
static void cvalue_init(fltype_t *type, value_t v, void *dest);
@ -36,6 +36,60 @@ value_t cvalue_new(value_t *args, u_int32_t nargs);
value_t cvalue_sizeof(value_t *args, u_int32_t nargs);
value_t cvalue_typeof(value_t *args, u_int32_t nargs);
// trigger unconditional GC after this many bytes are allocated
#define ALLOC_LIMIT_TRIGGER 67108864
static cvalue_t **Finalizers = NULL;
static size_t nfinalizers=0;
static size_t maxfinalizers=0;
static size_t malloc_pressure = 0;
static void add_finalizer(cvalue_t *cv)
{
if (nfinalizers == maxfinalizers) {
size_t nn = (maxfinalizers==0 ? 256 : maxfinalizers*2);
cvalue_t **temp = (cvalue_t**)realloc(Finalizers, nn*sizeof(value_t));
if (temp == NULL)
lerror(MemoryError, "out of memory");
Finalizers = temp;
maxfinalizers = nn;
}
Finalizers[nfinalizers++] = cv;
}
// remove dead objects from finalization list in-place
static void sweep_finalizers()
{
cvalue_t **lst = Finalizers;
size_t n=0, ndel=0, l=nfinalizers;
cvalue_t *tmp;
#define SWAP_sf(a,b) (tmp=a,a=b,b=tmp,1)
if (l == 0)
return;
do {
tmp = lst[n];
if (isforwarded((value_t)tmp)) {
// object is alive
lst[n] = (cvalue_t*)ptr(forwardloc((value_t)tmp));
n++;
}
else {
fltype_t *t = cv_class(tmp);
if (t->vtable != NULL && t->vtable->finalize != NULL) {
t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
}
if (!isinlined(tmp) && owned(tmp)) {
free(cv_data(tmp));
}
ndel++;
}
} while ((n < l-ndel) && SWAP_sf(lst[n],lst[n+ndel]));
nfinalizers -= ndel;
malloc_pressure = 0;
}
// compute the size of the metadata object for a cvalue
static size_t cv_nwords(cvalue_t *cv)
{
@ -51,7 +105,7 @@ static size_t cv_nwords(cvalue_t *cv)
static void autorelease(cvalue_t *cv)
{
cv->type = (fltype_t*)(((uptrint_t)cv->type) | CV_OWNED_BIT);
// TODO: add to finalizer list
add_finalizer(cv);
}
value_t cvalue(fltype_t *type, size_t sz)
@ -61,15 +115,21 @@ value_t cvalue(fltype_t *type, size_t sz)
if (sz <= MAX_INL_SIZE) {
size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz==0 ? 1 : 0);
pcv = (cvalue_t*)alloc_words(nw);
pcv->type = type;
pcv->data = &pcv->_space[0];
if (type->vtable != NULL && type->vtable->finalize != NULL)
add_finalizer(pcv);
}
else {
if (malloc_pressure > ALLOC_LIMIT_TRIGGER)
gc(0);
pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
pcv->type = type;
pcv->data = malloc(sz);
autorelease(pcv);
malloc_pressure += sz;
}
pcv->len = sz;
pcv->type = type;
return tagptr(pcv, TAG_CVALUE);
}
@ -439,6 +499,9 @@ value_t cvalue_relocate(value_t v)
if (isinlined(cv))
nv->data = &nv->_space[0];
ncv = tagptr(nv, TAG_CVALUE);
fltype_t *t = cv_class(cv);
if (t->vtable != NULL && t->vtable->relocate != NULL)
t->vtable->relocate(v, ncv);
forward(v, ncv);
return ncv;
}

View File

@ -77,7 +77,6 @@ value_t printwidthsym;
static value_t eval_sexpr(value_t e, uint32_t penv, int tail);
static value_t *alloc_words(int n);
static value_t relocate(value_t v);
static void do_print(ios_t *f, value_t v, int princ);
typedef struct _readstate_t {
htable_t backrefs;
@ -459,6 +458,9 @@ void gc(int mustgrow)
}
lasterror = relocate(lasterror);
special_apply_form = relocate(special_apply_form);
sweep_finalizers();
#ifdef VERBOSEGC
printf("gc found %d/%d live conses\n",
(curheap-tospace)/sizeof(cons_t), heapsize/sizeof(cons_t));

View File

@ -136,9 +136,6 @@ value_t compare(value_t a, value_t b); // -1, 0, or 1
value_t equal(value_t a, value_t b); // T or nil
int equal_lispvalue(value_t a, value_t b);
uptrint_t hash_lispvalue(value_t a);
value_t relocate_lispvalue(value_t v);
void print_traverse(value_t v);
value_t fl_hash(value_t *args, u_int32_t nargs);
/* safe casts */
cons_t *tocons(value_t v, char *fname);
@ -165,6 +162,13 @@ typedef struct {
void (*print_traverse)(value_t self);
} cvtable_t;
/* functions needed to implement the value interface (cvtable_t) */
value_t relocate_lispvalue(value_t v);
void print_traverse(value_t v);
void fl_print_chr(char c, ios_t *f);
void fl_print_str(char *s, ios_t *f);
void fl_print_child(ios_t *f, value_t v, int princ);
typedef void (*cvinitfunc_t)(struct _fltype_t*, value_t, void*);
typedef struct _fltype_t {
@ -200,8 +204,8 @@ typedef struct {
#define CV_OWNED_BIT 0x1
#define CV_PARENT_BIT 0x2
#define owned(cv) ((cv)->type & CV_OWNED_BIT)
#define hasparent(cv) ((cv)->type & CV_PARENT_BIT)
#define owned(cv) ((uptrint_t)(cv)->type & CV_OWNED_BIT)
#define hasparent(cv) ((uptrint_t)(cv)->type & CV_PARENT_BIT)
#define isinlined(cv) ((cv)->data == &(cv)->_space[0])
#define cv_class(cv) ((fltype_t*)(((uptrint_t)(cv)->type)&~3))
#define cv_len(cv) ((cv)->len)
@ -234,6 +238,7 @@ extern value_t stringtypesym, wcstringtypesym, emptystringsym;
extern value_t unionsym, floatsym, doublesym, builtinsym;
extern fltype_t *chartype, *wchartype;
extern fltype_t *stringtype, *wcstringtype;
extern fltype_t *builtintype;
value_t cvalue(fltype_t *type, size_t sz);
size_t ctype_sizeof(value_t type, int *palign);
@ -250,8 +255,6 @@ value_t string_from_cstr(char *str);
int isstring(value_t v);
int isnumber(value_t v);
value_t cvalue_compare(value_t a, value_t b);
value_t cvalue_char(value_t *args, uint32_t nargs);
value_t cvalue_wchar(value_t *args, uint32_t nargs);
fltype_t *get_type(value_t t);
fltype_t *get_array_type(value_t eltype);
@ -273,4 +276,9 @@ typedef struct {
void assign_global_builtins(builtinspec_t *b);
/* builtins */
value_t fl_hash(value_t *args, u_int32_t nargs);
value_t cvalue_char(value_t *args, uint32_t nargs);
value_t cvalue_wchar(value_t *args, uint32_t nargs);
#endif

View File

@ -30,6 +30,16 @@ static void outindent(int n, ios_t *f)
}
}
void fl_print_chr(char c, ios_t *f)
{
outc(c, f);
}
void fl_print_str(char *s, ios_t *f)
{
outs(s, f);
}
void print_traverse(value_t v)
{
value_t *bp;
@ -64,6 +74,9 @@ void print_traverse(value_t v)
// don't consider shared references to ""
if (!cv_isstr(cv) || cv_len(cv)!=0)
mark_cons(v);
fltype_t *t = cv_class(cv);
if (t->vtable != NULL && t->vtable->print_traverse != NULL)
t->vtable->print_traverse(v);
}
}
@ -219,7 +232,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
unmark_cons(v);
unmark_cons(cdr_(v));
outs(op, f);
do_print(f, car_(cdr_(v)), princ);
fl_print_child(f, car_(cdr_(v)), princ);
return;
}
int startpos = HPOS;
@ -232,12 +245,12 @@ static void print_pair(ios_t *f, value_t v, int princ)
while (1) {
lastv = VPOS;
unmark_cons(v);
do_print(f, car_(v), princ);
fl_print_child(f, car_(v), princ);
cd = cdr_(v);
if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) {
if (cd != NIL) {
outs(" . ", f);
do_print(f, cd, princ);
fl_print_child(f, cd, princ);
}
outc(')', f);
break;
@ -292,7 +305,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
void cvalue_print(ios_t *f, value_t v, int princ);
static void do_print(ios_t *f, value_t v, int princ)
void fl_print_child(ios_t *f, value_t v, int princ)
{
value_t label;
char *name;
@ -338,7 +351,7 @@ static void do_print(ios_t *f, value_t v, int princ)
unmark_cons(v);
int i, sz = vector_size(v);
for(i=0; i < sz; i++) {
do_print(f, vector_elt(v,i), princ);
fl_print_child(f, vector_elt(v,i), princ);
if (i < sz-1) {
if (princ) {
outc(' ', f);
@ -541,7 +554,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
size_t i;
if (!weak) {
outs("#array(", f);
do_print(f, eltype, princ);
fl_print_child(f, eltype, princ);
if (cnt > 0)
outc(' ', f);
}
@ -563,14 +576,14 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
value_t sym = list_nth(car(cdr_(type)), *(size_t*)data);
if (!weak) {
outs("#enum(", f);
do_print(f, car(cdr_(type)), princ);
fl_print_child(f, car(cdr_(type)), princ);
outc(' ', f);
}
if (sym == NIL) {
cvalue_printdata(f, data, len, int32sym, princ, 1);
}
else {
do_print(f, sym, princ);
fl_print_child(f, sym, princ);
}
if (!weak)
outc(')', f);
@ -583,14 +596,18 @@ void cvalue_print(ios_t *f, value_t v, int princ)
cvalue_t *cv = (cvalue_t*)ptr(v);
void *data = cv_data(cv);
if (isbuiltinish(v)) {
if (cv_class(cv) == builtintype) {
HPOS+=ios_printf(f, "#<builtin @0x%08lx>",
(unsigned long)(builtin_t)data);
return;
}
else if (cv_class(cv)->vtable != NULL &&
cv_class(cv)->vtable->print != NULL) {
cv_class(cv)->vtable->print(v, f, princ);
}
else {
cvalue_printdata(f, data, cv_len(cv), cv_type(cv), princ, 0);
}
}
static void set_print_width()
{
@ -613,7 +630,7 @@ void print(ios_t *f, value_t v, int princ)
print_traverse(v);
HPOS = VPOS = 0;
do_print(f, v, princ);
fl_print_child(f, v, princ);
htable_reset(&printconses, 32);
}

View File

@ -7,6 +7,9 @@
#include "llt.h"
#include "flisp.h"
static value_t tablesym;
static fltype_t *tabletype;
/*
there are 2 kinds of hash tables (eq and equal), each with some
optimized special cases. here are the building blocks:
@ -36,8 +39,23 @@ typedef struct {
htable_t ht;
} fltable_t;
void print_htable(value_t h, ios_t *f, int princ)
void print_htable(value_t v, ios_t *f, int princ)
{
fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(v));
htable_t *h = &pt->ht;
size_t i;
int first=1;
fl_print_str("#table(", f);
for(i=0; i < h->size; i+=2) {
if (h->table[i+1] != HT_NOTFOUND) {
if (!first) fl_print_str(" ", f);
fl_print_child(f, (value_t)h->table[i], princ);
fl_print_chr(' ', f);
fl_print_child(f, (value_t)h->table[i+1], princ);
first = 0;
}
}
fl_print_chr(')', f);
}
void free_htable(value_t self)
@ -57,27 +75,50 @@ void relocate_htable(value_t oldv, value_t newv)
}
}
void print_traverse_htable(value_t self)
{
fltable_t *pt = (fltable_t*)cv_data((cvalue_t*)ptr(self));
htable_t *h = &pt->ht;
size_t i;
for(i=0; i < h->size; i++) {
if (h->table[i] != HT_NOTFOUND)
print_traverse((value_t)h->table[i]);
}
}
void rehash_htable(value_t oldv, value_t newv)
{
}
cvtable_t h_r1_vtable = { print_htable, NULL, free_htable, NULL };
cvtable_t h_r2_vtable = { print_htable, relocate_htable, free_htable, NULL };
cvtable_t h_r3_vtable = { print_htable, rehash_htable, free_htable, NULL };
cvtable_t h_r1_vtable = { print_htable, NULL, free_htable,
print_traverse_htable };
cvtable_t h_r2_vtable = { print_htable, relocate_htable, free_htable,
print_traverse_htable };
cvtable_t h_r3_vtable = { print_htable, rehash_htable, free_htable,
print_traverse_htable };
int ishashtable(value_t v)
{
return 0;
}
value_t fl_table(value_t *args, u_int32_t nargs)
{
return NIL;
return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == tabletype;
}
value_t fl_hashtablep(value_t *args, u_int32_t nargs)
{
return NIL;
argcount("hashtablep", nargs, 1);
return ishashtable(args[0]) ? T : NIL;
}
value_t fl_table(value_t *args, u_int32_t nargs)
{
if (nargs & 1)
lerror(ArgError, "table: arguments must come in pairs");
value_t nt = cvalue(tabletype, sizeof(fltable_t));
fltable_t *h = (fltable_t*)cv_data((cvalue_t*)ptr(nt));
htable_new(&h->ht, 8);
int i;
for(i=0; i < nargs; i+=2)
equalhash_put(&h->ht, args[i], args[i+1]);
return nt;
}
// (put table key value)
@ -87,7 +128,7 @@ value_t fl_hash_put(value_t *args, u_int32_t nargs)
return NIL;
}
// (get table key)
// (get table key [default])
value_t fl_hash_get(value_t *args, u_int32_t nargs)
{
argcount("get", nargs, 2);
@ -107,3 +148,16 @@ value_t fl_hash_delete(value_t *args, u_int32_t nargs)
argcount("del", nargs, 2);
return NIL;
}
static builtinspec_t tablefunc_info[] = {
{ "table", fl_table },
{ NULL, NULL }
};
void table_init()
{
tablesym = symbol("table");
tabletype = define_opaque_type(tablesym, sizeof(fltable_t),
&h_r2_vtable, NULL);
assign_global_builtins(tablefunc_info);
}

View File

@ -102,6 +102,9 @@ possible optimizations:
env in-place in tail position
- allocate memory by mmap'ing a large uncommitted block that we cut
in half. then each half heap can be grown without moving addresses.
- try making (list ...) a builtin by moving the list-building code to
a static function, see if vararg call performance is affected.
- try making foldl a builtin, implement table iterator as table.foldl
* represent lambda environment as a vector (in lispv)
x setq builtin (didn't help)
(- list builtin, to use cons_reserve)
@ -547,7 +550,7 @@ lisp variant ideas
cvalues reserves the following global symbols:
int8, uint8, int16, uint16, int32, uint32, int64, uint64
char, uchar, short, ushort, int, uint, long, ulong
char, uchar, wchar, short, ushort, int, uint, long, ulong
float, double
struct, array, enum, union, function, void, pointer, lispvalue
@ -919,10 +922,9 @@ switch to miser mode, otherwise default is ok, for example:
-----------------------------------------------------------------------------
consolidated todo list as of 8/30:
- new cvalues, types representation
* new cvalues, types representation
- use the unused tag for TAG_PRIM, add smaller prim representation
- implement support for defining new opaque values
- finalizers in gc
* finalizers in gc
- hashtable
- expose io stream object