adding gc handles, making evaluator stack static

this provides a better interface and could only help performance
starting to add some useful library code

femtolisp/builtins.c

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

femtolisp/flisp.c

@@ -84,9 +84,15 @@ static short builtin_arg_counts[] =
       ANYARGS, 2, 3 };
 
 #define N_STACK 262144
-value_t StaticStack[N_STACK];
+static value_t Stack[N_STACK];
-value_t *Stack = StaticStack;
+static uint32_t SP = 0;
-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;

femtolisp/flisp.h

@@ -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;
+void fl_gc_handle(value_t *pv);
-extern uint32_t SP;
+void fl_free_gc_handles(int n);
-#define PUSH(v) (Stack[SP++] = (v))
-#define POP()   (Stack[--SP])
-#define POPN(n) (SP-=(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

femtolisp/iostream.c

@@ -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));
+        arg = symbol_value(instrsym);
-        args = &Stack[SP-1];
     }
-    (void)toiostream(args[0], "read");
+    else {
-    return read_sexpr(args[0]);
+        arg = args[0];
+    }
+    (void)toiostream(arg, "read");
+    return read_sexpr(arg);
 }
 
 value_t fl_iogetc(value_t *args, u_int32_t nargs)

femtolisp/lib/lazy.scm

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

femtolisp/lib/sort.scm

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

femtolisp/string.c

@@ -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);
+        term = (args[1] != FL_F);
-        nargs--;
+    }
+    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);
+    fl_gc_handle(&buf);
-    value_t outp = stream_to_string(&Stack[SP-1]);
+    value_t outp = stream_to_string(&buf);
-    (void)POP();
+    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) {
+        if (last == NIL)
-            Stack[SP-2] = c;   // first time, save first cons
+            first = c;   // first time, save first cons
-            (void)POP();
+        else
-        }
+            ((cons_t*)ptr(last))->cdr = c;
-        else {
-            ((cons_t*)ptr(POP()))->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)