Fixed a stack leak. Now observing actual performance.

* src/*.[ch]:  Replaced `scm_mem2symbol' by `scm_from_locale_symboln' and
  `scm_ulong2num' by `scm_from_ulong'.
* src/vm_system.c (tail-call):  Fixed stack leak (SP lacked decrement by
  one more Scheme object in the tail-recursive case).
* benchmark/measure.scm (measure):  Make sure we are using the compiled
  procedure (i.e. a program object) when measuring.  This yields better
  results than before.  :-)
* doc/guile-vm.texi:  Augmented the instruction set documentation with
  branch instructions, `call' and `tail-call'.

git-archimport-id: lcourtes@laas.fr--2004-libre/guile-vm--revival--0.6--patch-7

README

@@ -16,6 +16,9 @@ Status of the last release, 0.5
 The very first release, 0.0
   http://sources.redhat.com/ml/guile/2000-07/msg00418.html
 
+Simple benchmark
+  http://sources.redhat.com/ml/guile/2000-07/msg00425.html
+
 Performance, portability, GNU Lightning
   http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00132.html
 

benchmark/lib.scm

@@ -16,12 +16,12 @@
 	  (g-c-d x (- y x))
 	  (g-c-d (- x y) y))))
 
-(define (loop how-long)
+(define (loop n)
   ;; This one shows that procedure calls are no faster than within the
   ;; interpreter: the VM yields no performance improvement.
-  (if (= 0 how-long)
+  (if (= 0 n)
       0
-      (loop (1- how-long))))
+      (loop (1- n))))
 
 ;; Disassembly of `loop'
 ;;
@@ -35,7 +35,7 @@
 ;   11    (link "1-")
 ;   15    (vector 3)
 ;   17    (make-int8:0)                   ;; 0
-;   18    (load-symbol "how-long")        ;; how-long
+;   18    (load-symbol "n")               ;; n
 ;   28    (make-false)                    ;; #f
 ;   29    (make-int8:0)                   ;; 0
 ;   30    (list 3)
@@ -92,25 +92,27 @@
 ;   23    (tail-call 1)
 
 
-(define (loopi how-long)
+(define (loopi n)
   ;; Same as `loop'.
-  (let loopi ((how-long how-long))
-    (if (= 0 how-long)
+  (let loopi ((n n))
+    (if (= 0 n)
 	0
-	(loopi (1- how-long)))))
+	(loopi (1- n)))))
 
 
 (define (do-cons x)
   ;; This one shows that the built-in `cons' instruction yields a significant
-  ;; improvement (speedup: 1.4).
+  ;; improvement (speedup: 1.5).
   (let loop ((x x)
 	     (result '()))
     (if (<= x 0)
 	result
 	(loop (1- x) (cons x result)))))
 
+(define big-list (iota 500000))
+
 (define (copy-list lst)
-  ;; Speedup: 1.3.
+  ;; Speedup: 5.9.
   (let loop ((lst lst)
 	     (result '()))
     (if (null? lst)

benchmark/measure.scm

@@ -10,18 +10,21 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
 (define-module (measure)
   :export (measure)
   :use-module (system vm core)
+  :use-module (system vm disasm)
   :use-module (system base compile)
   :use-module (system base language))
 
+
 (define (time-for-eval sexp eval)
   (let ((before (tms:utime (times))))
-    (eval sexp (current-module))
+    (eval sexp)
     (let ((elapsed (- (tms:utime (times)) before)))
       (format #t "elapsed time: ~a~%" elapsed)
       elapsed)))
 
 (define *scheme* (lookup-language 'scheme))
 
+
 (define (measure . args)
   (if (< (length args) 2)
       (begin
@@ -33,13 +36,29 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
   (let* ((sexp (with-input-from-string (car args)
 		 (lambda ()
 		   (read))))
-	 (time-interpreted (time-for-eval sexp eval))
-	 (objcode (compile-in sexp (current-module) *scheme*))
-	 (time-compiled (time-for-eval objcode
-				       (let ((vm (the-vm))
-					     (prog (objcode->program objcode)))
-					 (lambda (o e)
-					   (vm prog))))))
+	 (eval-here (lambda (sexp) (eval sexp (current-module))))
+	 (proc-name (car sexp))
+	 (proc-source (procedure-source (eval proc-name (current-module))))
+	 (% (format #t "proc: ~a~%source: ~a~%" proc-name proc-source))
+	 (time-interpreted (time-for-eval sexp eval-here))
+	 (& (if (defined? proc-name)
+		(eval `(set! ,proc-name #f) (current-module))
+		(format #t "unbound~%")))
+	 (objcode (compile-in proc-source
+			      (current-module) *scheme*))
+	 (the-program (vm-load (the-vm) objcode))
+
+;	 (%%% (disassemble-objcode objcode))
+	 (time-compiled (time-for-eval `(,proc-name ,@(cdr sexp))
+				       (lambda (sexp)
+					 (eval `(begin
+						  (define ,proc-name
+						    ,the-program)
+						  ,sexp)
+					       (current-module))))))
+
+    (format #t "proc:        ~a => ~a~%"
+	    proc-name (eval proc-name (current-module)))
     (format #t "interpreted: ~a~%" time-interpreted)
     (format #t "compiled:    ~a~%" time-compiled)
     (format #t "speedup:     ~a~%"

doc/guile-vm.texi

@@ -92,6 +92,18 @@ However, be warned that important parts still correspond to version
 * Variable Management::         
 * Program Execution::           
 * Instruction Set::             
+
+@detailmenu
+ --- The Detailed Node Listing ---
+
+Instruction Set
+
+* Environment Control Instructions::  
+* Branch Instructions::         
+* Subprogram Control Instructions::  
+* Data Control Instructions::   
+
+@end detailmenu
 @end menu
 
 @c *********************************************************************
@@ -470,11 +482,12 @@ useful calculations.
 
 @menu
 * Environment Control Instructions::  
+* Branch Instructions::         
 * Subprogram Control Instructions::  
 * Data Control Instructions::   
 @end menu
 
-@node Environment Control Instructions, Subprogram Control Instructions, Instruction Set, Instruction Set
+@node Environment Control Instructions, Branch Instructions, Instruction Set, Instruction Set
 @section Environment Control Instructions
 
 @deffn @insn{} link binding-name
@@ -517,7 +530,61 @@ This call yields the following sequence of instructions:
 @item %unbind
 @end itemize
 
-@node Subprogram Control Instructions, Data Control Instructions, Environment Control Instructions, Instruction Set
+
+@node Branch Instructions, Subprogram Control Instructions, Environment Control Instructions, Instruction Set
+@section Branch Instructions
+
+All the conditional branch instructions described below work in the
+same way:
+
+@itemize
+@item They take the Scheme object located on the stack and use it as
+the branch condition;
+@item If the condition if false, then program execution continues with
+the next instruction;
+@item If the condition is true, then the instruction pointer is
+increased by the offset passed as an argument to the branch
+instruction;
+@item Finally, when the instruction finished, the condition object is
+removed from the stack.
+@end itemize
+
+Note that the offset passed to the instruction is encoded on two 8-bit
+integers which are then combined by the VM as one 16-bit integer.
+
+@deffn @insn{} br offset
+Jump to @var{offset}.
+@end deffn
+
+@deffn @insn{} br-if offset
+Jump to @var{offset} if the condition on the stack is not false.
+@end deffn
+
+@deffn @insn{} br-if-not offset
+Jump to @var{offset} if the condition on the stack is false.
+@end deffn
+
+@deffn @insn{} br-if-eq offset
+Jump to @var{offset} if the two objects located on the stack are
+equal in the sense of @var{eq?}.  Note that, for this instruction, the
+stack pointer is decremented by two Scheme objects instead of only
+one.
+@end deffn
+
+@deffn @insn{} br-if-not-eq offset
+Same as @var{br-if-eq} for non-equal objects.
+@end deffn
+
+@deffn @insn{} br-if-null offset
+Jump to @var{offset} if the object on the stack is @code{'()}.
+@end deffn
+
+@deffn @insn{} br-if-not-null offset
+Jump to @var{offset} if the object on the stack is not @code{'()}.
+@end deffn
+
+
+@node Subprogram Control Instructions, Data Control Instructions, Branch Instructions, Instruction Set
 @section Subprogram Control Instructions
 
 Programs (read: ``compiled procedure'') may refer to external
@@ -582,10 +649,10 @@ This clearly shows that there is little difference between references
 to local variables and references to externally bound variables.
 
 @deffn @insn{} load-program bytecode
-Load the program whose bytecode is @var{bytecode} (a u8vector) and pop
-its meta-information from the stack.  The program's meta-information
-may consist of (in the order in which it should be pushed onto the
-stack):
+Load the program whose bytecode is @var{bytecode} (a u8vector), pop
+its meta-information from the stack, and push a corresponding program
+object onto the stack.  The program's meta-information may consist of
+(in the order in which it should be pushed onto the stack):
 
 @itemize
 @item optionally, a pair representing meta-data (see the
@@ -601,8 +668,6 @@ the number of external variables (@var{nexts}) (see the example
 above).
 @end itemize
 
-In the end, push a program object onto the stack.
-
 @end deffn
 
 @deffn @insn{} object-ref offset
@@ -614,6 +679,19 @@ Push the variable object for the external variable located at
 Free the program's frame.
 @end deffn
 
+@deffn @insn{} call nargs
+Call the procedure, continuation or program located at
+@code{sp[-nargs]} with the @var{nargs} arguments located from
+@code{sp[0]} to @code{sp[-nargs + 1]}.  The
+procedure/continuation/program and its arguments are dropped from the
+stack and the result is pushed.
+@end deffn
+
+@deffn @insn{} tail-call nargs
+Same as @code{call} except that, for tail-recursive calls to a
+program, the current stack frame is re-used, as required by RnRS.
+@end deffn
+
 
 @node Data Control Instructions,  , Subprogram Control Instructions, Instruction Set
 @section Data Control Instructions

src/frames.c

@@ -140,7 +140,7 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
 #define FUNC_NAME s_scm_frame_return_address
 {
   SCM_VALIDATE_HEAP_FRAME (1, frame);
-  return scm_ulong2num ((unsigned long) (SCM_FRAME_RETURN_ADDRESS
+  return scm_from_ulong ((unsigned long) (SCM_FRAME_RETURN_ADDRESS
 					 (SCM_HEAP_FRAME_POINTER (frame))));
 }
 #undef FUNC_NAME

src/programs.c

@@ -135,7 +135,7 @@ SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
 {
   SCM_VALIDATE_PROGRAM (1, program);
 
-  return scm_ulong2num ((unsigned long) SCM_PROGRAM_DATA (program)->base);
+  return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base);
 }
 #undef FUNC_NAME
 

src/vm.c

@@ -339,7 +339,7 @@ SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 #define FUNC_NAME s_scm_vm_ip
 {
   SCM_VALIDATE_VM (1, vm);
-  return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->ip);
+  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 }
 #undef FUNC_NAME
 
@@ -349,7 +349,7 @@ SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 #define FUNC_NAME s_scm_vm_sp
 {
   SCM_VALIDATE_VM (1, vm);
-  return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->sp);
+  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 }
 #undef FUNC_NAME
 
@@ -359,7 +359,7 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 #define FUNC_NAME s_scm_vm_fp
 {
   SCM_VALIDATE_VM (1, vm);
-  return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->fp);
+  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 }
 #undef FUNC_NAME
 

src/vm_engine.h

@@ -214,6 +214,7 @@
 
 #define PUSH(x)	do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
 #define DROP()	do { CHECK_UNDERFLOW (); sp--; } while (0)
+#define DROPN(_n)	do { CHECK_UNDERFLOW (); sp -= (_n); } while (0)
 #define POP(x)	do { x = *sp; DROP (); } while (0)
 
 /* A fast CONS.  This has to be fast since its used, for instance, by
@@ -227,8 +228,11 @@
   x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z));	\
 }
 
+/* Pop the N objects on top of the stack and push a list that contains
+   them.  */
 #define POP_LIST(n)				\
-do {						\
+do						\
+{						\
   int i;					\
   SCM l = SCM_EOL;				\
   sp -= n;					\

src/vm_loader.c

@@ -51,7 +51,7 @@ VM_DEFINE_LOADER (load_integer, "load-integer")
       long val = 0;
       while (len-- > 0)
 	val = (val << 8) + FETCH ();
-      PUSH (scm_long2num (val));
+      PUSH (scm_from_ulong (val));
       NEXT;
     }
   else
@@ -84,7 +84,7 @@ VM_DEFINE_LOADER (load_symbol, "load-symbol")
 {
   size_t len;
   FETCH_LENGTH (len);
-  PUSH (scm_mem2symbol (ip, len));
+  PUSH (scm_from_locale_symboln (ip, len));
   ip += len;
   NEXT;
 }
@@ -94,7 +94,7 @@ VM_DEFINE_LOADER (load_keyword, "load-keyword")
   SCM sym;
   size_t len;
   FETCH_LENGTH (len);
-  sym = scm_mem2symbol (ip, len);
+  sym = scm_from_locale_symboln (ip, len);
   PUSH (scm_make_keyword_from_dash_symbol (sym));
   ip += len;
   NEXT;
@@ -104,7 +104,7 @@ VM_DEFINE_LOADER (load_module, "load-module")
 {
   size_t len;
   FETCH_LENGTH (len);
-  PUSH (scm_c_lookup_env (scm_mem2symbol (ip, len)));
+  PUSH (scm_c_lookup_env (scm_from_locale_symboln (ip, len)));
   ip += len;
   NEXT;
 }

src/vm_system.c

@@ -376,7 +376,10 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
    */
   if (!SCM_FALSEP (scm_procedure_p (x)))
     {
+      /* At this point, the stack contains the procedure and each one of its
+	 arguments.  */
       SCM args;
+
       POP_LIST (nargs);
       POP (args);
       *sp = scm_apply (x, args, SCM_EOL);
@@ -407,7 +410,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 
 VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
 {
-  SCM x;
+  register SCM x;
   nargs = FETCH ();
   x = sp[-nargs];
 
@@ -425,7 +428,9 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
       sp -= bp->nargs - 1;
       for (i = 0; i < bp->nargs; i++)
 	LOCAL_SET (i, sp[i]);
-      sp--;
+
+      /* Drop the first argument and the program itself.  */
+      sp -= 2;
 
       /* Call itself */
       ip = bp->base;