diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 56bf98f..8f43dc3 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -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(); } diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 342da95..eb2c0ca 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -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; } diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 8150d6d..cdd0213 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -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)); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 0241867..2680e23 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -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 diff --git a/femtolisp/print.c b/femtolisp/print.c index f2fa38b..71a522c 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -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, "#", (unsigned long)(builtin_t)data); - return; } - - cvalue_printdata(f, data, cv_len(cv), cv_type(cv), princ, 0); + 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); } diff --git a/femtolisp/table.c b/femtolisp/table.c index 97ad7a9..5a16994 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -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); +} diff --git a/femtolisp/todo b/femtolisp/todo index 3674f47..3bdd01a 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -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