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
parent
ee9f565d89
commit
b5dda68eab
|
|
@ -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();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,13 +596,17 @@ 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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue