adding gc handles, making evaluator stack static

this provides a better interface and could only help performance
starting to add some useful library code
This commit is contained in:
JeffBezanson 2009-05-19 02:54:56 +00:00
parent c38c47d264
commit c2026ba77c
7 changed files with 296 additions and 32 deletions

View File

@ -173,9 +173,11 @@ value_t fl_global_env(value_t *args, u_int32_t nargs)
{
(void)args;
argcount("environment", nargs, 0);
PUSH(NIL);
global_env_list(symtab, &Stack[SP-1]);
return POP();
value_t lst = NIL;
fl_gc_handle(&lst);
global_env_list(symtab, &lst);
fl_free_gc_handles(1);
return lst;
}
extern value_t QUOTE;

View File

@ -84,9 +84,15 @@ static short builtin_arg_counts[] =
ANYARGS, 2, 3 };
#define N_STACK 262144
value_t StaticStack[N_STACK];
value_t *Stack = StaticStack;
uint32_t SP = 0;
static value_t Stack[N_STACK];
static uint32_t SP = 0;
#define PUSH(v) (Stack[SP++] = (v))
#define POP() (Stack[--SP])
#define POPN(n) (SP-=(n))
#define N_GC_HANDLES 1024
static value_t *GCHandleStack[N_GC_HANDLES];
static uint32_t N_GCHND = 0;
value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
@ -371,6 +377,19 @@ static int symchar(char c);
// collector ------------------------------------------------------------------
void fl_gc_handle(value_t *pv)
{
if (N_GCHND >= N_GC_HANDLES)
lerror(MemoryError, "out of gc handles");
GCHandleStack[N_GCHND++] = pv;
}
void fl_free_gc_handles(int n)
{
assert(N_GCHND >= n);
N_GCHND -= n;
}
static value_t relocate(value_t v)
{
value_t a, d, nc, first, *pcdr;
@ -493,6 +512,8 @@ void gc(int mustgrow)
for (i=0; i < SP; i++)
Stack[i] = relocate(Stack[i]);
for (i=0; i < N_GCHND; i++)
*GCHandleStack[i] = relocate(*GCHandleStack[i]);
trace_globals(symtab);
relocate_typetable();
rs = readstate;

View File

@ -96,11 +96,8 @@ typedef struct _symbol_t {
#define isclosure(x) isfunction(x)
#define iscbuiltin(x) (iscvalue(x) && (cv_class((cvalue_t*)ptr(x))==builtintype))
extern value_t *Stack;
extern uint32_t SP;
#define PUSH(v) (Stack[SP++] = (v))
#define POP() (Stack[--SP])
#define POPN(n) (SP-=(n))
void fl_gc_handle(value_t *pv);
void fl_free_gc_handles(int n);
// maximum number of explicit arguments. the 128th arg is a list of rest args.
// the largest value nargs can have is MAX_ARGS+1

View File

@ -91,15 +91,18 @@ value_t fl_buffer(value_t *args, u_int32_t nargs)
value_t fl_read(value_t *args, u_int32_t nargs)
{
value_t arg;
if (nargs > 1) {
argcount("read", nargs, 1);
}
else if (nargs == 0) {
PUSH(symbol_value(instrsym));
args = &Stack[SP-1];
arg = symbol_value(instrsym);
}
(void)toiostream(args[0], "read");
return read_sexpr(args[0]);
else {
arg = args[0];
}
(void)toiostream(arg, "read");
return read_sexpr(arg);
}
value_t fl_iogetc(value_t *args, u_int32_t nargs)

47
femtolisp/lib/lazy.scm Normal file
View File

@ -0,0 +1,47 @@
; SRFI 45: Primitives for Expressing Iterative Lazy Algorithms
; by André van Tonder
;=========================================================================
; Boxes
(define (box x) (list x))
(define unbox car)
(define set-box! set-car!)
;=========================================================================
; Primitives for lazy evaluation:
(define (eager x)
(box (cons 'eager x)))
#|
(define-syntax lazy
(syntax-rules ()
((lazy exp)
(box (cons 'lazy (lambda () exp))))))
(define-syntax delay
(syntax-rules ()
((delay exp) (lazy (eager exp)))))
|#
(define-macro (lazy exp)
`(box (cons 'lazy (lambda () ,exp))))
(define-macro (delay exp)
`(lazy (eager ,exp)))
(define (force promise)
(let ((content (unbox promise)))
(case (car content)
((eager) (cdr content))
((lazy) (let* ((promise* ((cdr content)))
(content (unbox promise))) ; *
(if (not (eqv? (car content) 'eager)) ; *
(begin (set-car! content (car (unbox promise*)))
(set-cdr! content (cdr (unbox promise*)))
(set-box! promise* content)))
(force promise))))))
; (*) These two lines re-fetch and check the original promise in case
; the first line of the let* caused it to be forced. For an example
; where this happens, see reentrancy test 3 below.

193
femtolisp/lib/sort.scm Normal file
View File

@ -0,0 +1,193 @@
;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;;
;;; This code is in the public domain.
;;; Updated: 11 June 1991
;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
;;; Updated: 19 June 1995
;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
;;; jaffer: 2006-10-08:
;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
;;; jaffer: 2006-11-05:
;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
;;; per element.
;(require 'array)
;;; (sorted? sequence less?)
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;; such that for all 1 <= i <= m,
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
;@
(define (sorted? seq less? . opt-key)
(define key (if (null? opt-key) identity (car opt-key)))
(cond ((null? seq) #t)
((array? seq)
(let ((dimax (+ -1 (car (array-dimensions seq)))))
(or (<= dimax 1)
(let loop ((idx (+ -1 dimax))
(last (key (array-ref seq dimax))))
(or (negative? idx)
(let ((nxt (key (array-ref seq idx))))
(and (less? nxt last)
(loop (+ -1 idx) nxt))))))))
((null? (cdr seq)) #t)
(else
(let loop ((last (key (car seq)))
(next (cdr seq)))
(or (null? next)
(let ((nxt (key (car next))))
(and (not (less? nxt last))
(loop nxt (cdr next)))))))))
;;; (merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
;;; and returns a new list in which the elements of a and b have been stably
;;; interleaved so that (sorted? (merge a b less?) less?).
;;; Note: this does _not_ accept arrays. See below.
;@
(define (merge a b less? . opt-key)
(define key (if (null? opt-key) identity (car opt-key)))
(cond ((null? a) b)
((null? b) a)
(else
(let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
(y (car b)) (ky (key (car b))) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? ky kx)
(if (null? b)
(cons y (cons x a))
(cons y (loop x kx a (car b) (key (car b)) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
(define (sort:merge! a b less? key)
(define (loop r a kcara b kcarb)
(cond ((less? kcarb kcara)
(set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b)))))
(else ; (car a) <= (car b)
(set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb)))))
(cond ((null? a) b)
((null? b) a)
(else
(let ((kcara (key (car a)))
(kcarb (key (car b))))
(cond
((less? kcarb kcara)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b))))
b)
(else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb))
a))))))
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
;;; Note: this does _not_ accept arrays.
;@
(define (merge! a b less? . opt-key)
(sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
(define (sort:sort-list! seq less? key)
(define keyer (if key car identity))
(define (step n)
(cond ((> n 2) (let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(sort:merge! a b less? keyer)))
((= n 2) (let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(cond ((less? (keyer y) (keyer x))
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1) (let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else '())))
(define (key-wrap! lst)
(cond ((null? lst))
(else (set-car! lst (cons (key (car lst)) (car lst)))
(key-wrap! (cdr lst)))))
(define (key-unwrap! lst)
(cond ((null? lst))
(else (set-car! lst (cdar lst))
(key-unwrap! (cdr lst)))))
(cond (key
(key-wrap! seq)
(set! seq (step (length seq)))
(key-unwrap! seq)
seq)
(else
(step (length seq)))))
(define (rank-1-array->list array)
(define dimensions (array-dimensions array))
(do ((idx (+ -1 (car dimensions)) (+ -1 idx))
(lst '() (cons (array-ref array idx) lst)))
((< idx 0) lst)))
;;; (sort! sequence less?)
;;; sorts the list, array, or string sequence destructively. It uses
;;; a version of merge-sort invented, to the best of my knowledge, by
;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
;;; R. A. O'Keefe adapted it to work destructively in Scheme.
;;; A. Jaffer modified to always return the original list.
;@
(define (sort! seq less? . opt-key)
(define key (if (null? opt-key) #f (car opt-key)))
(cond ((array? seq)
(let ((dims (array-dimensions seq)))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) seq)
(array-set! seq (car sorted) i))))
(else ; otherwise, assume it is a list
(let ((ret (sort:sort-list! seq less? key)))
(if (not (eq? ret seq))
(do ((crt ret (cdr crt)))
((eq? (cdr crt) seq)
(set-cdr! crt ret)
(let ((scar (car seq)) (scdr (cdr seq)))
(set-car! seq (car ret)) (set-cdr! seq (cdr ret))
(set-car! ret scar) (set-cdr! ret scdr)))))
seq))))
;;; (sort sequence less?)
;;; sorts a array, string, or list non-destructively. It does this
;;; by sorting a copy of the sequence. My understanding is that the
;;; Standard says that the result of append is always "newly
;;; allocated" except for sharing structure with "the last argument",
;;; so (append x '()) ought to be a standard way of copying a list x.
;@
(define (sort seq less? . opt-key)
(define key (if (null? opt-key) #f (car opt-key)))
(cond ((array? seq)
(let ((dims (array-dimensions seq)))
(define newra (apply make-array seq dims))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) newra)
(array-set! newra (car sorted) i))))
(else (sort:sort-list! (append seq '()) less? key))))

View File

@ -80,10 +80,11 @@ value_t fl_string_decode(value_t *args, u_int32_t nargs)
{
int term=0;
if (nargs == 2) {
term = (POP() != FL_F);
nargs--;
term = (args[1] != FL_F);
}
else {
argcount("string.decode", nargs, 1);
}
argcount("string.decode", nargs, 1);
if (!isstring(args[0]))
type_error("string.decode", "string", args[0]);
cvalue_t *cv = (cvalue_t*)ptr(args[0]);
@ -119,9 +120,9 @@ value_t fl_string(value_t *args, u_int32_t nargs)
}
set(printreadablysym, oldpr);
set(printprettysym, oldpp);
PUSH(buf);
value_t outp = stream_to_string(&Stack[SP-1]);
(void)POP();
fl_gc_handle(&buf);
value_t outp = stream_to_string(&buf);
fl_free_gc_handles(1);
return outp;
}
@ -132,10 +133,12 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
char *delim = tostring(args[1], "string.split");
size_t len = cv_len((cvalue_t*)ptr(args[0]));
size_t dlen = cv_len((cvalue_t*)ptr(args[1]));
PUSH(NIL);
size_t ssz, tokend=0, tokstart=0, i=0;
value_t c=NIL;
value_t first=NIL, c=NIL, last;
size_t junk;
fl_gc_handle(&first);
fl_gc_handle(&last);
do {
// find and allocate next token
tokstart = tokend = i;
@ -143,7 +146,7 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
!u8_memchr(delim, u8_nextmemchar(s, &i), dlen, &junk))
tokend = i;
ssz = tokend - tokstart;
PUSH(c); // save previous cons cell
last = c; // save previous cons cell
c = fl_cons(cvalue_string(ssz), NIL);
// we've done allocation; reload movable pointers
@ -153,19 +156,17 @@ value_t fl_string_split(value_t *args, u_int32_t nargs)
if (ssz) memcpy(cv_data((cvalue_t*)ptr(car_(c))), &s[tokstart], ssz);
// link new cell
if (Stack[SP-1] == NIL) {
Stack[SP-2] = c; // first time, save first cons
(void)POP();
}
else {
((cons_t*)ptr(POP()))->cdr = c;
}
if (last == NIL)
first = c; // first time, save first cons
else
((cons_t*)ptr(last))->cdr = c;
// note this tricky condition: if the string ends with a
// delimiter, we need to go around one more time to add an
// empty string. this happens when (i==len && tokend<i)
} while (i < len || (i==len && (tokend!=i)));
return POP();
fl_free_gc_handles(2);
return first;
}
value_t fl_string_sub(value_t *args, u_int32_t nargs)