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

2 files changed, 39 insertions, 18 deletions

diff --git a/benchmark/lib.scm b/benchmark/lib.scm
index f272842b3..31e524453 100644
--- a/benchmark/lib.scm
+++ b/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)
diff --git a/benchmark/measure.scm b/benchmark/measure.scm
index 0fe4b8efa..aadbc516d 100755
--- a/benchmark/measure.scm
+++ b/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~%"