ref: 120522c2123c09b68539ae064734ce5000b3fc1e
parent: 581afbf636745df48c52cae17678259103f7fce5
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Thu Oct 30 22:50:00 EDT 2008
updating bitvector functions to use int64s in more places, since after all that's the whole point of bitvectors some prettyprinting tweaks more uniform way to handle forwarding pointers. fix forwarding of gensyms :keyword symbols
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -540,15 +540,12 @@
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
--- 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 @@
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 @@
}
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,31 +351,30 @@
{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)
@@ -383,8 +381,7 @@
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 @@
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 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);
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -15,8 +15,8 @@
} 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 @@
#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 @@
// 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 @@
#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 @@
#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 @@
#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);
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -252,7 +252,7 @@
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 @@
(n > 0 && always) ||
- (n == 2 && after3));
+ (n == 2 && after3) ||
+
+ (n == 0 && !smallp(head)));
}
if (ind) {--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -100,6 +100,8 @@
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 @@
* 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 @@
- (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
--- 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,13 +54,18 @@
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));
else
@@ -67,7 +72,7 @@
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 @@
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)<<offs));
@@ -428,8 +433,8 @@
ans += count_bits(b[i]);
}
- tail = (offs+nbits)&31;
- ans += count_bits(b[i]&(tail>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;
}
--- a/llt/bitvector.h
+++ b/llt/bitvector.h
@@ -31,10 +31,10 @@
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_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);
--- a/llt/llt.h
+++ b/llt/llt.h
@@ -1,6 +1,7 @@
#ifndef __LLT_H_
#define __LLT_H_
+#include <stdarg.h>
#include "dtypes.h"
#include "utils.h"
#include "utf8.h"