lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
JeffBezanson 2008-10-31 02:50:00 +00:00
parent 581afbf636
commit 120522c212
8 changed files with 76 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
femtolisp/cvalues.c
View File

@ -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

63
femtolisp/flisp.c
View File

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

15
femtolisp/flisp.h
View File

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

6
femtolisp/print.c
View File

@ -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) {

6
femtolisp/todo
View File

@ -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

27
llt/bitvector.c
View File

@ -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)<<offs));
@ -428,8 +433,8 @@ u_int32_t bitvector_count(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
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;
}

10
llt/bitvector.h
View File

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

1
llt/llt.h
View File

@ -1,6 +1,7 @@
#ifndef __LLT_H_
#define __LLT_H_
#include <stdarg.h>
#include "dtypes.h"
#include "utils.h"
#include "utf8.h"