simplifying code by eliminating the hybrid stack/heap calling convention

other misc. cleanup

femtolisp/bootstrap.sh

@@ -3,7 +3,7 @@
 cp flisp.boot flisp.boot.bak
 
 echo "Creating stage 0 boot file..."
-#../../branches/interpreter/femtolisp/flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot
+#../../branches/interpreter/femtolisp/flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new
 ./flisp mkboot0.lsp system.lsp compiler.lsp > flisp.boot.new
 mv flisp.boot.new flisp.boot
 

femtolisp/builtins.c

@@ -35,15 +35,8 @@ static value_t fl_nconc(value_t *args, u_int32_t nargs)
     cons_t *c;
     uint32_t i=0;
     while (1) {
-        if (i >= MAX_ARGS) {
+        lst = args[i++];
-            lst = car_(args[MAX_ARGS]);
+        if (i >= nargs) break;
-            args[MAX_ARGS] = cdr_(args[MAX_ARGS]);
-            if (!iscons(args[MAX_ARGS])) break;
-        }
-        else {
-            lst = args[i++];
-            if (i >= nargs) break;
-        }
         if (iscons(lst)) {
             *pcdr = lst;
             c = (cons_t*)ptr(lst);

femtolisp/compiler.lsp

@@ -209,6 +209,8 @@
 ; number of non-nulls
 (define (nnn e) (count (lambda (x) (not (null? x))) e))
 
+(define (printable? x) (not (iostream? x)))
+
 (define (compile-sym g env s Is)
   (let ((loc (lookup-sym s env 0 #t)))
     (case (car loc)
@@ -216,7 +218,11 @@
       (closed  (emit g (aref Is 1) (cadr loc) (caddr loc))
 	       ; update index of most distant captured frame
 	       (bcode:cdepth g (- (nnn (cdr env)) 1 (cadr loc))))
-      (else    (emit g (aref Is 2) s)))))
+      (else
+       (if (and (constant? s)
+		(printable? (top-level-value s)))
+	   (emit g :loadv (top-level-value s))
+	   (emit g (aref Is 2) s))))))
 
 (define (compile-if g env tail? x)
   (let ((elsel (make-label g))
@@ -300,8 +306,6 @@
 (define (compile-or g env tail? forms)
   (compile-short-circuit g env tail? forms #f :brt))
 
-(define MAX_ARGS 127)
-
 (define (list-partition l n)
   (define (list-part- l n  i subl acc)
     (cond ((atom? l) (if (> i 0)
@@ -313,23 +317,16 @@
       (error "list-partition: invalid count")
       (reverse! (list-part- l n 0 () ()))))
 
-(define (just-compile-args g lst env)
+(define (make-nested-arglist args n)
-  (for-each (lambda (a)
+  (cons nconc
-	      (compile-in g env #f a))
+	(map (lambda (l) (cons list l))
-	    lst))
+	     (list-partition args n))))
 
 (define (compile-arglist g env lst)
-  (let ((argtail (length> lst MAX_ARGS)))
+  (for-each (lambda (a)
-    (if argtail
+	      (compile-in g env #f a))
-	(begin (just-compile-args g (list-head lst MAX_ARGS) env)
+	    lst)
-	       (let ((rest
+  (length lst))
-		      (cons nconc
-			    (map (lambda (l) (cons list l))
-				 (list-partition argtail MAX_ARGS)))))
-		 (compile-in g env #f rest))
-	       (+ MAX_ARGS 1))
-	(begin (just-compile-args g lst env)
-	       (length lst)))))
 
 (define (argc-error head count)
   (error (string "compile error: " head " expects " count
@@ -342,7 +339,7 @@
     (if (and (pair? head)
 	     (eq? (car head) 'lambda)
 	     (list? (cadr head))
-	     (not (length> (cadr head) MAX_ARGS)))
+	     (not (length> (cadr head) 255)))
 	(compile-let  g env tail? x)
 	(compile-call g env tail? x))))
 
@@ -375,6 +372,33 @@
     (lambda (b)
       (get b2i b #f))))
 
+(define (compile-builtin-call g env tail? x head b nargs)
+  (let ((count (get arg-counts b #f)))
+    (if (and count
+	     (not (length= (cdr x) count)))
+	(argc-error head count))
+    (case b  ; handle special cases of vararg builtins
+      (:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs)))
+      (:+    (cond ((= nargs 0) (emit g :load0))
+		   ((= nargs 2) (emit g :add2))
+		   (else (emit g b nargs))))
+      (:-    (cond ((= nargs 0) (argc-error head 1))
+		   ((= nargs 1) (emit g :neg))
+		   ((= nargs 2) (emit g :sub2))
+		   (else (emit g b nargs))))
+      (:*    (if (= nargs 0) (emit g :load1)
+		 (emit g b nargs)))
+      (:/    (if (= nargs 0)
+		 (argc-error head 1)
+		 (emit g b nargs)))
+      (:vector   (if (= nargs 0)
+		     (emit g :loadv [])
+		     (emit g b nargs)))
+      (:apply    (if (< nargs 2)
+		     (argc-error head 2)
+		     (emit g (if tail? :tapply :apply) nargs)))
+      (else      (emit g b)))))
+
 (define (compile-call g env tail? x)
   (let ((head  (car x)))
     (let ((head
@@ -385,38 +409,19 @@
 		    (builtin? (top-level-value head)))
 	       (top-level-value head)
 	       head)))
-      (let ((b (and (builtin? head)
+      (if (length> (cdr x) 255)
-		    (builtin->instruction head))))
+	  ; argument count is a uint8, so for more than 255 arguments
-	(if (not b)
+	  ; we use apply on a list built from sublists that fit the limit
-	    (compile-in g env #f head))
+	  (compile-in g env tail?
-	(let ((nargs (compile-arglist g env (cdr x))))
+		      `(#.apply ,head ,(make-nested-arglist (cdr x) 255)))
-	  (if b
+	  (let ((b (and (builtin? head)
-	      (let ((count (get arg-counts b #f)))
+			(builtin->instruction head))))
-		(if (and count
+	    (if (not b)
-			 (not (length= (cdr x) count)))
+		(compile-in g env #f head))
-		    (argc-error head count))
+	    (let ((nargs (compile-arglist g env (cdr x))))
-		(case b  ; handle special cases of vararg builtins
+	      (if b
-		  (:list (if (= nargs 0) (emit g :loadnil) (emit g b nargs)))
+		  (compile-builtin-call g env tail? x head b nargs)
-		  (:+    (cond ((= nargs 0) (emit g :load0))
+		  (emit g (if tail? :tcall :call) nargs))))))))
-			       ((= nargs 2) (emit g :add2))
-			       (else (emit g b nargs))))
-		  (:-    (cond ((= nargs 0) (argc-error head 1))
-			       ((= nargs 1) (emit g :neg))
-			       ((= nargs 2) (emit g :sub2))
-			       (else (emit g b nargs))))
-		  (:*    (if (= nargs 0) (emit g :load1)
-			     (emit g b nargs)))
-		  (:/    (if (= nargs 0)
-			     (argc-error head 1)
-			     (emit g b nargs)))
-		  (:vector   (if (= nargs 0)
-				 (emit g :loadv [])
-				 (emit g b nargs)))
-		  (:apply    (if (< nargs 2)
-				 (argc-error head 2)
-				 (emit g (if tail? :tapply :apply) nargs)))
-		  (else      (emit g b))))
-	      (emit g (if tail? :tcall :call) nargs)))))))
 
 (define (expand-define form body)
   (if (symbol? form)
@@ -514,7 +519,7 @@
 		      'lambda
 		      (lastcdr f))))
 	(cond ((not (null? let?))      (emit g :let))
-	      ((length> args MAX_ARGS) (emit g (if (null? (lastcdr args))
+	      ((length> args 255)      (emit g (if (null? (lastcdr args))
 						   :largc :lvargc)
 					     (length args)))
 	      ((null? (lastcdr args))  (emit g :argc  (length args)))

femtolisp/cvalues.c

@@ -464,8 +464,6 @@ value_t cvalue_array(value_t *args, u_int32_t nargs)
         argcount("array", nargs, 1);
 
     cnt = nargs - 1;
-    if (nargs > MAX_ARGS)
-        cnt += (llength(args[MAX_ARGS])-1);
     fltype_t *type = get_array_type(args[0]);
     elsize = type->elsz;
     sz = elsize * cnt;

femtolisp/flisp.c

@@ -578,12 +578,21 @@ void gc(int mustgrow)
         gc(0);
 }
 
+static void grow_stack()
+{
+    size_t newsz = N_STACK + (N_STACK>>1);
+    value_t *ns = realloc(Stack, newsz*sizeof(value_t));
+    if (ns == NULL)
+        lerror(MemoryError, "stack overflow");
+    Stack = ns;
+    N_STACK = newsz;
+}
+
 // utils ----------------------------------------------------------------------
 
 // apply function with n args on the stack
 static value_t _applyn(uint32_t n)
 {
-    assert(n <= MAX_ARGS+1);
     value_t f = Stack[SP-n-1];
     uint32_t saveSP = SP;
     value_t v;
@@ -607,10 +616,8 @@ value_t apply(value_t f, value_t l)
 
     PUSH(f);
     while (iscons(v)) {
-        if ((SP-n-1) == MAX_ARGS) {
+        if (SP >= N_STACK)
-            PUSH(v);
+            grow_stack();
-            break;
-        }
         PUSH(car_(v));
         v = cdr_(v);
     }
@@ -622,12 +629,13 @@ value_t apply(value_t f, value_t l)
 
 value_t applyn(uint32_t n, value_t f, ...)
 {
-    assert(n <= MAX_ARGS);
     va_list ap;
     va_start(ap, f);
     size_t i;
 
     PUSH(f);
+    while (SP+n > N_STACK)
+        grow_stack();
     for(i=0; i < n; i++) {
         value_t a = va_arg(ap, value_t);
         PUSH(a);
@@ -644,6 +652,8 @@ value_t listn(size_t n, ...)
     uint32_t si = SP;
     size_t i;
 
+    while (SP+n > N_STACK)
+        grow_stack();
     for(i=0; i < n; i++) {
         value_t a = va_arg(ap, value_t);
         PUSH(a);
@@ -715,7 +725,7 @@ static value_t _list(value_t *args, uint32_t nargs, int star)
         c->cdr = tagptr(c+1, TAG_CONS);
         c++;
     }
-    if (star || nargs > MAX_ARGS)
+    if (star)
         (c-2)->cdr = (c-1)->car;
     else
         (c-1)->cdr = NIL;
@@ -805,18 +815,8 @@ static value_t do_trycatch()
 #define DISPATCH goto dispatch
 #endif
 
-static void grow_stack()
-{
-    size_t newsz = N_STACK + (N_STACK>>1);
-    value_t *ns = realloc(Stack, newsz*sizeof(value_t));
-    if (ns == NULL)
-        lerror(MemoryError, "stack overflow");
-    Stack = ns;
-    N_STACK = newsz;
-}
-
 /*
-  stack on entry: <func>  <up to MAX_ARGS args...>  <arglist if nargs>MAX_ARGS>
+  stack on entry: <func>  <nargs args...>
   caller's responsibility:
   - put the stack in this state
   - provide arg count
@@ -886,18 +886,10 @@ static value_t apply_cl(uint32_t nargs)
             NEXT_OP;
         OP(OP_VARGC)
             i = *ip++;
+        do_vargc:
             s = (fixnum_t)nargs - (fixnum_t)i;
             if (s > 0) {
                 v = list(&Stack[bp+i], s);
-                if (nargs > MAX_ARGS) {
-                    if (s == 1) {
-                        v = car_(v);
-                    }
-                    else {
-                        c = (cons_t*)curheap;
-                        (c-2)->cdr = (c-1)->car;
-                    }
-                }
                 Stack[bp+i] = v;
                 if (s > 1) {
                     Stack[bp+i+1] = Stack[bp+nargs+0];
@@ -923,39 +915,17 @@ static value_t apply_cl(uint32_t nargs)
             nargs = i+1;
             NEXT_OP;
         OP(OP_LARGC)
-        OP(OP_LVARGC)
+            n = GET_INT32(ip); ip+=4;
-            // move extra arguments from list to stack
+            if (nargs != n) {
-            i = GET_INT32(ip); ip+=4;
+                if (nargs > n)
-            e = Stack[curr_frame-5];  // cloenv
-            n = Stack[curr_frame-4];  // prev curr_frame
-            POPN(5);
-            if (nargs > MAX_ARGS) {
-                v = POP();  // list of rest args
-                nargs--;
-            }
-            else v = NIL;
-            while (nargs < i) {
-                if (!iscons(v))
-                    lerror(ArgError, "apply: too few arguments");
-                PUSH(car_(v));
-                nargs++;
-                v = cdr_(v);
-            }
-            if (ip[-5] == OP_LVARGC) {
-                PUSH(v);
-                nargs++;
-            }
-            else {
-                if (iscons(v))
                     lerror(ArgError, "apply: too many arguments");
+                else
+                    lerror(ArgError, "apply: too few arguments");
             }
-            PUSH(e);
-            PUSH(n);
-            PUSH(nargs);
-            SP++;//PUSH(0);
-            PUSH(0);
-            curr_frame = SP;
             NEXT_OP;
+        OP(OP_LVARGC)
+            i = GET_INT32(ip); ip+=4;
+            goto do_vargc;
         OP(OP_LET)
             // last arg is closure environment to use
             nargs--;
@@ -1166,15 +1136,10 @@ static value_t apply_cl(uint32_t nargs)
             n = *ip++;
         apply_apply:
             v = POP();     // arglist
-            if (n > MAX_ARGS) {
-                v = apply_liststar(v, 1);
-            }
             n = SP-(n-2);  // n-2 == # leading arguments not in the list
             while (iscons(v)) {
-                if (SP-n == MAX_ARGS) {
+                if (SP >= N_STACK)
-                    PUSH(v);
+                    grow_stack();
-                    break;
-                }
                 PUSH(car_(v));
                 v = cdr_(v);
             }
@@ -1187,7 +1152,6 @@ static value_t apply_cl(uint32_t nargs)
         apply_add:
             s = 0;
             i = SP-n;
-            if (n > MAX_ARGS) goto add_ovf;
             for (; i < SP; i++) {
                 if (isfixnum(Stack[i])) {
                     s += numval(Stack[i]);
@@ -1265,13 +1229,11 @@ static value_t apply_cl(uint32_t nargs)
         apply_mul:
             accum = 1;
             i = SP-n;
-            if (n > MAX_ARGS) goto mul_ovf;
             for (; i < SP; i++) {
                 if (isfixnum(Stack[i])) {
                     accum *= numval(Stack[i]);
                 }
                 else {
-                mul_ovf:
                     v = fl_mul_any(&Stack[i], SP-i, accum);
                     break;
                 }
@@ -1343,23 +1305,10 @@ static value_t apply_cl(uint32_t nargs)
         OP(OP_VECTOR)
             n = *ip++;
         apply_vector:
-            if (n > MAX_ARGS) {
+            v = alloc_vector(n, 0);
-                i = llength(Stack[SP-1])-1;
-            }
-            else i = 0;
-            v = alloc_vector(n+i, 0);
             if (n) {
                 memcpy(&vector_elt(v,0), &Stack[SP-n], n*sizeof(value_t));
-                e = POP();
+                POPN(n);
-                POPN(n-1);
-            }
-            if (n > MAX_ARGS) {
-                i = n-1;
-                while (iscons(e)) {
-                    vector_elt(v,i) = car_(e);
-                    i++;
-                    e = cdr_(e);
-                }
             }
             PUSH(v);
             NEXT_OP;
@@ -1684,7 +1633,6 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
             break;
 
         case OP_TAPPLY: case OP_APPLY:
-            if (sp+MAX_ARGS+1 > maxsp) maxsp = sp+MAX_ARGS+1;
             n = *ip++;
             sp -= (n-1);
             break;
@@ -1860,15 +1808,8 @@ value_t fl_append(value_t *args, u_int32_t nargs)
     fl_gc_handle(&lastcons);
     uint32_t i=0;
     while (1) {
-        if (i >= MAX_ARGS) {
+        lst = args[i++];
-            lst = car_(args[MAX_ARGS]);
+        if (i >= nargs) break;
-            args[MAX_ARGS] = cdr_(args[MAX_ARGS]);
-            if (!iscons(args[MAX_ARGS])) break;
-        }
-        else {
-            lst = args[i++];
-            if (i >= nargs) break;
-        }
         if (iscons(lst)) {
             lst = FL_COPYLIST(lst);
             if (first == NIL)
@@ -1893,10 +1834,6 @@ value_t fl_liststar(value_t *args, u_int32_t nargs)
 {
     if (nargs == 1) return args[0];
     else if (nargs == 0) argcount("list*", nargs, 1);
-    if (nargs > MAX_ARGS) {
-        args[MAX_ARGS] = apply_liststar(args[MAX_ARGS], 1);
-        return list(args, nargs);
-    }
     return _list(args, nargs, 1);
 }
 

femtolisp/flisp.h

@@ -102,22 +102,13 @@ typedef struct _symbol_t {
 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
-#define MAX_ARGS 127
-
 #include "opcodes.h"
 
 // utility for iterating over all arguments in a builtin
 // i=index, i0=start index, arg = var for each arg, args = arg array
 // assumes "nargs" is the argument count
-// modifies args[MAX_ARGS] when nargs==MAX_ARGS+1
+#define FOR_ARGS(i, i0, arg, args)     \
-#define FOR_ARGS(i, i0, arg, args)                                      \
+    for(i=i0; ((size_t)i)<nargs && ((arg=args[i]) || 1); i++)
-    for(i=i0; (((size_t)i<nargs ||                                      \
-                (i>MAX_ARGS && iscons(args[MAX_ARGS]))) &&              \
-               ((i>=MAX_ARGS?(arg=car_(args[MAX_ARGS]),                 \
-                              args[MAX_ARGS]=cdr_(args[MAX_ARGS])) :    \
-                 (arg = args[i])) || 1)); i++)
 
 #define N_BUILTINS ((int)N_OPCODES)
 

femtolisp/iostream.c

@@ -171,7 +171,7 @@ value_t fl_ioseek(value_t *args, u_int32_t nargs)
 
 static void do_ioprint(value_t *args, u_int32_t nargs, char *fname)
 {
-    if (nargs < 2 || nargs > MAX_ARGS)
+    if (nargs < 2)
         argcount(fname, nargs, 2);
     ios_t *s = toiostream(args[0], fname);
     unsigned i;

femtolisp/system.lsp

@@ -309,6 +309,11 @@
     (or (and (pair? x) (or (eq (car x) '*comma-at*)
 			   (eq (car x) '*comma-dot*)))
 	(eq x '*comma*)))
+  ; bracket without splicing
+  (define (bq-bracket1 x)
+    (if (and (pair? x) (eq (car x) '*comma*))
+	(cadr x)
+	(bq-process x)))
   (cond ((self-evaluating? x)
          (if (vector? x)
              (let ((body (bq-process (vector->list x))))
@@ -345,12 +350,6 @@
         ((eq (car x) '*comma-dot*)  (cadr x))
         (#t                         (list list (bq-process x)))))
 
-; bracket without splicing
-(define (bq-bracket1 x)
-  (if (and (pair? x) (eq (car x) '*comma*))
-      (cadr x)
-      (bq-process x)))
-
 ; standard macros -------------------------------------------------------------
 
 (define (quote-value v)

femtolisp/table.c

@@ -84,8 +84,6 @@ static htable_t *totable(value_t v, char *fname)
 value_t fl_table(value_t *args, uint32_t nargs)
 {
     size_t cnt = (size_t)nargs;
-    if (nargs > MAX_ARGS)
-        cnt += (llength(args[MAX_ARGS])-1);
     if (cnt & 1)
         lerror(ArgError, "table: arguments must come in pairs");
     value_t nt;

femtolisp/todo

@@ -1042,7 +1042,8 @@ new evaluator todo:
   * stack traces and better debugging support
   - make maxstack calculation robust against invalid bytecode
 * improve internal define
-- try removing MAX_ARGS trickery
+* try removing MAX_ARGS trickery
+- apply optimization, avoid redundant list copying calling vararg fns
 - let eversion
 * lambda lifting
 * let optimization

femtolisp/unittest.lsp

@@ -98,6 +98,8 @@
 ; long argument lists
 (assert (= (apply + (iota 100000)) 4999950000))
 
+(define MAX_ARGS 255)
+
 (define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1))))
 (define f (compile `(lambda ,as ,(lastcdr as))))
 (assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))