ref: b5dda68eab6d6c086316a23e37f71ce288045de5
parent: ee9f565d89d8b953eff1f564508a2044ce844a3c
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat Dec 20 01:16:00 EST 2008
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
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -345,6 +345,7 @@
}
extern void stringfuncs_init();
+extern void table_init();
static builtinspec_t builtin_info[] = { { "set-syntax", fl_setsyntax },@@ -383,4 +384,5 @@
{assign_global_builtins(builtin_info);
stringfuncs_init();
+ table_init();
}
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -18,15 +18,15 @@
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_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 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 @@
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 @@
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;
}
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -77,7 +77,6 @@
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 @@
}
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));
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -136,9 +136,6 @@
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 @@
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 @@
#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 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 @@
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);
@@ -272,5 +275,10 @@
} builtinspec_t;
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
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -30,6 +30,16 @@
}
}
+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 @@
// 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 @@
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 @@
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 @@
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 @@
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 @@
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,7 +576,7 @@
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) {@@ -570,7 +583,7 @@
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 @@
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;
}
-
- 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 @@
print_traverse(v);
HPOS = VPOS = 0;
- do_print(f, v, princ);
+ fl_print_child(f, v, princ);
htable_reset(&printconses, 32);
}
--- 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 @@
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 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;
+ return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == tabletype;
}
-value_t fl_table(value_t *args, u_int32_t nargs)
+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_hashtablep(value_t *args, u_int32_t nargs)
+value_t fl_table(value_t *args, u_int32_t nargs)
{- return NIL;
+ 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 @@
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);@@ -106,4 +147,17 @@
{ 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);
}
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -102,6 +102,9 @@
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 @@
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 @@
-----------------------------------------------------------------------------
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