diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 5c23bef..1d0c49e 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -540,15 +540,12 @@ value_t cvalue_relocate(value_t v) cvalue_t *nv; value_t ncv; - if (cv->flags.moved) - return cv->type; - nw = cv_nwords(cv); if (!cv->flags.islispfunction) { + nw = cv_nwords(cv); nv = (cvalue_t*)alloc_words(nw); memcpy(nv, cv, nw*sizeof(value_t)); ncv = tagptr(nv, TAG_CVALUE); - cv->type = ncv; - cv->flags.moved = 1; + forward(v, ncv); } else { // guestfunctions are permanent objects, unmanaged diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 22c220c..9665454 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -14,26 +14,19 @@ expressions. this is due to the closure representation (lambda args body . env) - This is a fork of femtoLisp with advanced reading and printing facilities: + This is a fully fleshed-out lisp built up from femtoLisp. It has all the + remaining features needed to be taken seriously: * circular structure can be printed and read * #. read macro for eval-when-read and correctly printing builtins * read macros for backquote * symbol character-escaping printer - - The value of this extra complexity, and what makes this fork worthy of - the femtoLisp brand, is that the interpreter is fully "closed" in the - sense that all representable values can be read and printed. - - This is a fully fleshed-out lisp built up from femtoLisp. It has all the - remaining features needed to be taken seriously: * vectors * exceptions * gensyms (can be usefully read back in, too) * #| multiline comments |# - * generic compare function + * generic compare function, cyclic equal * cvalues system providing C data types and a C FFI * constructor notation for nicely printing arbitrary values - * cyclic equal * strings - hash tables @@ -199,8 +192,14 @@ static symbol_t *mk_symbol(char *str) strlen(str)+1, 8); sym->left = sym->right = NULL; - sym->binding = UNBOUND; - sym->syntax = 0; + if (str[0] == ':') { + value_t s = tagptr(sym, TAG_SYM); + setc(s, s); + } + else { + sym->binding = UNBOUND; + sym->syntax = 0; + } strcpy(&sym->name[0], str); return sym; } @@ -232,9 +231,9 @@ value_t symbol(char *str) } typedef struct { - value_t binding; // global value binding value_t syntax; // syntax environment entry - void *dlcache; // dlsym address + value_t binding; // global value binding + void *dlcache; // dlsym address (not used here) u_int32_t id; } gensym_t; @@ -352,39 +351,37 @@ static value_t relocate(value_t v) { value_t a, d, nc, first, *pcdr; - if (isfixnum(v)) - return(v); - else if (iscons(v)) { + if (iscons(v)) { // iterative implementation allows arbitrarily long cons chains pcdr = &first; do { - if ((a=car_(v)) == UNBOUND) { + if ((a=car_(v)) == TAG_FWD) { *pcdr = cdr_(v); return first; } *pcdr = nc = mk_cons(); d = cdr_(v); - car_(v) = UNBOUND; cdr_(v) = nc; + car_(v) = TAG_FWD; cdr_(v) = nc; car_(nc) = relocate(a); pcdr = &cdr_(nc); v = d; } while (iscons(v)); *pcdr = (d==NIL) ? NIL : relocate(d); - return first; } - else if (isvector(v)) { - // 0-length vectors secretly have space for a first element - if (vector_elt(v,0) == UNBOUND) - return vector_elt(v,-1); + uptrint_t t = tag(v); + if ((t&(t-1)) == 0) return v; // tags 0,1,2,4 + if (isforwarded(v)) + return forwardloc(v); + if (isvector(v)) { + // N.B.: 0-length vectors secretly have space for a first element size_t i, newsz, sz = vector_size(v); newsz = sz; if (vector_elt(v,-1) & 0x1) newsz += vector_grow_amt(sz); nc = alloc_vector(newsz, 0); a = vector_elt(v,0); - vector_elt(v,0) = UNBOUND; - vector_elt(v,-1) = nc; + forward(v, nc); i = 0; if (sz > 0) { vector_elt(nc,0) = relocate(a); i++; @@ -401,15 +398,16 @@ static value_t relocate(value_t v) else if (ismanaged(v)) { assert(issymbol(v)); gensym_t *gs = (gensym_t*)ptr(v); - if (gs->id == 0xffffffff) - return gs->binding; gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*)); - *ng = *gs; - gs->id = 0xffffffff; + ng->id = gs->id; + ng->binding = gs->binding; + ng->syntax = gs->syntax; nc = tagptr(ng, TAG_SYM); - gs->binding = nc; + forward(v, nc); if (ng->binding != UNBOUND) ng->binding = relocate(ng->binding); + if (iscons(ng->syntax)) + ng->syntax = relocate(ng->syntax); return nc; } return v; @@ -418,7 +416,8 @@ static value_t relocate(value_t v) static void trace_globals(symbol_t *root) { while (root != NULL) { - root->binding = relocate(root->binding); + if (root->binding != UNBOUND) + root->binding = relocate(root->binding); if (iscons(root->syntax)) root->syntax = relocate(root->syntax); trace_globals(root->left); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index ac01c2b..67c1901 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -15,8 +15,8 @@ typedef struct { } cons_t; typedef struct _symbol_t { - value_t binding; // global value binding value_t syntax; // syntax environment entry + value_t binding; // global value binding void *dlcache; // dlsym address // below fields are private struct _symbol_t *left; @@ -36,6 +36,7 @@ typedef struct _symbol_t { #define TAG_SYM 0x6 #define TAG_CONS 0x7 #define UNBOUND ((value_t)0x1) // an invalid value +#define TAG_FWD UNBOUND #define TAG_CONST ((value_t)-2) // in sym->syntax for constants #define tag(x) ((x)&0x7) #define ptr(x) ((void*)((x)&(~(value_t)0x7))) @@ -65,6 +66,11 @@ typedef struct _symbol_t { // doesn't lead to other values #define leafp(a) (((a)&3) != 3) +#define isforwarded(v) (((value_t*)ptr(v))[0] == TAG_FWD) +#define forwardloc(v) (((value_t*)ptr(v))[1]) +#define forward(v,to) do { (((value_t*)ptr(v))[0] = TAG_FWD); \ + (((value_t*)ptr(v))[1] = to); } while (0) + #define vector_size(v) (((size_t*)ptr(v))[0]>>2) #define vector_setsize(v,n) (((size_t*)ptr(v))[0] = ((n)<<2)) #define vector_elt(v,i) (((value_t*)ptr(v))[1+(i)]) @@ -74,6 +80,7 @@ typedef struct _symbol_t { #define cdr_(v) (((cons_t*)ptr(v))->cdr) #define car(v) (tocons((v),"car")->car) #define cdr(v) (tocons((v),"cdr")->cdr) + #define set(s, v) (((symbol_t*)ptr(s))->binding = (v)) #define setc(s, v) do { ((symbol_t*)ptr(s))->syntax = TAG_CONST; \ ((symbol_t*)ptr(s))->binding = (v); } while (0) @@ -148,11 +155,11 @@ static inline void argcount(char *fname, int nargs, int c) #define INL_SIZE_NBITS 16 typedef struct { unsigned two:2; - unsigned moved:1; + unsigned unused0:1; unsigned numtype:4; unsigned inllen:INL_SIZE_NBITS; unsigned cstring:1; - unsigned unused:4; + unsigned unused1:4; unsigned prim:1; unsigned inlined:1; unsigned islispfunction:1; @@ -178,7 +185,7 @@ typedef struct { #endif typedef struct { - void (*print)(ios_t *f, value_t v, int princ); + void (*print)(value_t self, ios_t *f, int princ); void (*relocate)(value_t old, value_t new); void (*finalize)(value_t self); void (*print_traverse)(value_t self); diff --git a/femtolisp/print.c b/femtolisp/print.c index 749ca7a..983857c 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -252,7 +252,7 @@ static void print_pair(ios_t *f, value_t v, int princ) est = lengthestimate(car_(cd)); nextsmall = smallp(car_(cd)); ind = (((n > 0) && - ((!nextsmall && HPOS>L_PAD) || (VPOS > lastv))) || + ((!nextsmall && HPOS>C_MARGIN) || (VPOS > lastv))) || ((VPOS > lastv) && (!nextsmall || n==0)) || @@ -266,7 +266,9 @@ static void print_pair(ios_t *f, value_t v, int princ) (n > 0 && always) || - (n == 2 && after3)); + (n == 2 && after3) || + + (n == 0 && !smallp(head))); } if (ind) { diff --git a/femtolisp/todo b/femtolisp/todo index 353358f..6195dad 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -100,6 +100,8 @@ possible optimizations: that follow calls to cons_reserve. - case of lambda expression in head (as produced by let), can just modify 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. * represent lambda environment as a vector (in lispv) x setq builtin (didn't help) (- list builtin, to use cons_reserve) @@ -112,6 +114,8 @@ for internal use: * a special version of apply that takes arguments on the stack, to avoid consing when implementing "call-with" style primitives like trycatch, hashtable-foreach, or the fl_apply API +- partial_apply, reapply interface so other iterators can use the same + fast mechanism as for * try this environment representation: for all kinds of functions (except maybe builtin special forms) push all arguments on the stack, either evaluated or not. @@ -136,6 +140,8 @@ bugs: - (setf (car x) y) doesn't return y * reader needs to check errno in isnumtok * prettyprint size measuring is not utf-8 correct +- stack is too limited. possibly allocate user frames with alloca so the + only limit is the process stack size. femtoLisp3...with symbolic C interface diff --git a/llt/bitvector.c b/llt/bitvector.c index 40aeed6..567860a 100644 --- a/llt/bitvector.c +++ b/llt/bitvector.c @@ -44,7 +44,7 @@ // greater than this # of words we use malloc instead of alloca #define MALLOC_CUTOFF 2000 -u_int32_t *bitvector_resize(u_int32_t *b, size_t n, int initzero) +u_int32_t *bitvector_resize(u_int32_t *b, u_int64_t n, int initzero) { u_int32_t *p; size_t sz = ((n+31)>>5) * 4; @@ -54,12 +54,17 @@ u_int32_t *bitvector_resize(u_int32_t *b, size_t n, int initzero) return p; } -u_int32_t *bitvector_new(size_t n, int initzero) +u_int32_t *bitvector_new(u_int64_t n, int initzero) { return bitvector_resize(NULL, n, initzero); } -void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c) +size_t bitvector_nwords(u_int64_t nbits) +{ + return ((nbits+31)>>5) * 4; +} + +void bitvector_set(u_int32_t *b, u_int64_t n, u_int32_t c) { if (c) b[n>>5] |= (1<<(n&31)); @@ -67,7 +72,7 @@ void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c) b[n>>5] &= ~(1<<(n&31)); } -u_int32_t bitvector_get(u_int32_t *b, u_int32_t n) +u_int32_t bitvector_get(u_int32_t *b, u_int64_t n) { return b[n>>5] & (1<<(n&31)); } @@ -399,14 +404,14 @@ void bitvector_reverse(u_int32_t *b, u_int32_t offs, u_int32_t nbits) if (nw > MALLOC_CUTOFF) free(temp); } -u_int32_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int32_t nbits) +u_int64_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int64_t nbits) { - index_t i; - u_int32_t nw, tail; - u_int32_t ans; + size_t i, nw; + u_int32_t ntail; + u_int64_t ans; if (nbits == 0) return 0; - nw = (offs+nbits+31)>>5; + nw = ((u_int64_t)offs+nbits+31)>>5; if (nw == 1) { return count_bits(b[0] & (lomask(nbits)<0?lomask(tail):ONES32)); // last end cap + ntail = (offs+(u_int32_t)nbits)&31; + ans += count_bits(b[i]&(ntail>0?lomask(ntail):ONES32)); // last end cap return ans; } diff --git a/llt/bitvector.h b/llt/bitvector.h index be5ca9a..0f3360e 100644 --- a/llt/bitvector.h +++ b/llt/bitvector.h @@ -31,10 +31,10 @@ static inline u_int32_t count_bits(u_int32_t b) u_int32_t bitreverse(u_int32_t x); -u_int32_t *bitvector_new(size_t n, int initzero); -u_int32_t *bitvector_resize(u_int32_t *b, size_t n, int initzero); -void bitvector_set(u_int32_t *b, u_int32_t n, u_int32_t c); -u_int32_t bitvector_get(u_int32_t *b, u_int32_t n); +u_int32_t *bitvector_new(u_int64_t n, int initzero); +u_int32_t *bitvector_resize(u_int32_t *b, u_int64_t n, int initzero); +void bitvector_set(u_int32_t *b, u_int64_t n, u_int32_t c); +u_int32_t bitvector_get(u_int32_t *b, u_int64_t n); void bitvector_shr(u_int32_t *b, size_t n, u_int32_t s); void bitvector_shr_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s); @@ -59,7 +59,7 @@ void bitvector_or_to(u_int32_t *dest, u_int32_t doffs, void bitvector_xor_to(u_int32_t *dest, u_int32_t doffs, u_int32_t *a, u_int32_t aoffs, u_int32_t *b, u_int32_t boffs, u_int32_t nbits); -u_int32_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int32_t nbits); +u_int64_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int64_t nbits); u_int32_t bitvector_any0(u_int32_t *b, u_int32_t offs, u_int32_t nbits); u_int32_t bitvector_any1(u_int32_t *b, u_int32_t offs, u_int32_t nbits); diff --git a/llt/llt.h b/llt/llt.h index 4a789e8..a1d8e2c 100644 --- a/llt/llt.h +++ b/llt/llt.h @@ -1,6 +1,7 @@ #ifndef __LLT_H_ #define __LLT_H_ +#include #include "dtypes.h" #include "utils.h" #include "utf8.h"