shithub: femtolisp

Download patch

ref: 66c671bfeeb94ffaf3f475f30f6dd2c522d3fd2e
parent: 0278b152b887c495dbd4d9c4feb75e384cd996e2
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Tue Jul 21 22:10:20 EDT 2009

making long argument lists more efficient


--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -24,7 +24,7 @@
 	  
 	  :closure :argc :vargc :trycatch :copyenv :let :for :tapply
 	  :add2 :sub2 :neg :largc :lvargc
-	  :loada0 :loada1 :loadc00 :loadc01
+	  :loada0 :loada1 :loadc00 :loadc01 :call.l :tcall.l
 	  
 	  dummy_t dummy_f dummy_nil]))
     (for 0 (1- (length keys))
@@ -148,7 +148,7 @@
 		      ((number? nxt)
 		       (case vi
 			 ((:loadv.l :loadg.l :setg.l :loada.l :seta.l
-			   :largc :lvargc)
+			   :largc :lvargc :call.l :tcall.l)
 			  (io.write bcode (int32 nxt))
 			  (set! i (+ i 1)))
 			 
@@ -306,22 +306,6 @@
 (define (compile-or g env tail? forms)
   (compile-short-circuit g env tail? forms #f :brt))
 
-(define (list-partition l n)
-  (define (list-part- l n  i subl acc)
-    (cond ((atom? l) (if (> i 0)
-			 (cons (reverse! subl) acc)
-			 acc))
-	  ((>= i n)  (list-part- l n 0 () (cons (reverse! subl) acc)))
-	  (else      (list-part- (cdr l) n (+ 1 i) (cons (car l) subl) acc))))
-  (if (<= n 0)
-      (error "list-partition: invalid count")
-      (reverse! (list-part- l n 0 () ()))))
-
-(define (make-nested-arglist args n)
-  (cons nconc
-	(map (lambda (l) (cons list l))
-	     (list-partition args n))))
-
 (define (compile-arglist g env lst)
   (for-each (lambda (a)
 	      (compile-in g env #f a))
@@ -410,10 +394,10 @@
 	       (top-level-value head)
 	       head)))
       (if (length> (cdr x) 255)
-	  ; argument count is a uint8, so for more than 255 arguments
-	  ; we use apply on a list built from sublists that fit the limit
-	  (compile-in g env tail?
-		      `(#.apply ,head ,(make-nested-arglist (cdr x) 255)))
+	  ; more than 255 arguments, need long versions of instructions
+	  (begin (compile-in g env #f head)
+		 (let ((nargs (compile-arglist g env (cdr x))))
+		   (emit g (if tail? :tcall.l :call.l) nargs)))
 	  (let ((b (and (builtin? head)
 			(builtin->instruction head))))
 	    (if (not b)
@@ -590,7 +574,7 @@
 		  (princ (number->string (aref code i)))
 		  (set! i (+ i 1)))
 		 
-		 ((:loada.l :seta.l :largc :lvargc)
+		 ((:loada.l :seta.l :largc :lvargc :call.l :tcall.l)
 		  (princ (number->string (ref-int32-LE code i)))
 		  (set! i (+ i 4)))
 
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -1038,6 +1038,8 @@
                 NEXT_OP;
             }
             type_error("apply", "function", func);
+        OP(OP_TCALLL) n = GET_INT32(ip); ip+=4; goto do_tcall;
+        OP(OP_CALLL)  n = GET_INT32(ip); ip+=4; goto do_call;
         OP(OP_JMP) ip += (ptrint_t)GET_INT16(ip); NEXT_OP;
         OP(OP_BRF)
             v = POP();
@@ -1580,7 +1582,7 @@
                 pv[0] = fixnum(n+1);
                 pv++;
                 do {
-                  pv[n] = Stack[bp+n];
+                    pv[n] = Stack[bp+n];
                 } while (n--);
                 // environment representation changed; install
                 // the new representation so everybody can see it
--- a/femtolisp/opcodes.h
+++ b/femtolisp/opcodes.h
@@ -25,7 +25,7 @@
 
     OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_COPYENV, OP_LET, OP_FOR,
     OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
-    OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01,
+    OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
 
     OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
 
@@ -66,7 +66,8 @@
     &&L_OP_LET, &&L_OP_FOR,                                             \
     &&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC,  \
     &&L_OP_LVARGC,                                                      \
-    &&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01        \
+    &&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01,       \
+    &&L_OP_CALLL, &&L_OP_TCALLL                                         \
     }
 
 #define VM_APPLY_LABELS                                                 \
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -972,8 +972,6 @@
 - #+, #- reader macros
 - printing improvements: *print-big*, keep track of horiz. position
   per-stream so indenting works across print calls
-- improve bootstrapping process so compiled version can recompile
-  itself for a broader set of changes
 - remaining c types
 - remaining cvalues functions
 - finish ios