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

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();
 }

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;
 }

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));

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 owned(cv)      ((uptrint_t)(cv)->type & CV_OWNED_BIT)
-#define hasparent(cv)  ((cv)->type & CV_PARENT_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

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, "#<builtin @0x%08lx>",
                          (unsigned long)(builtin_t)data);
-        return;
     }
-
+    else if (cv_class(cv)->vtable != NULL &&
-    cvalue_printdata(f, data, cv_len(cv), cv_type(cv), princ, 0);
+             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);
 }

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_r1_vtable = { print_htable, NULL, free_htable,
-cvtable_t h_r2_vtable = { print_htable, relocate_htable, free_htable, NULL };
+                          print_traverse_htable };
-cvtable_t h_r3_vtable = { print_htable, rehash_htable, free_htable, NULL };
+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)
-{
-    return NIL;
 }
 
 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);
+}

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