From f41cb00ce25d0263bb58e83e3d632ec6bf79b05a Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Mon, 2 May 2005 16:32:32 +0000 Subject: [PATCH] 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 | 3 ++ benchmark/lib.scm | 22 +++++----- benchmark/measure.scm | 35 ++++++++++++---- doc/guile-vm.texi | 94 +++++++++++++++++++++++++++++++++++++++---- src/frames.c | 2 +- src/programs.c | 2 +- src/vm.c | 6 +-- src/vm_engine.h | 6 ++- src/vm_loader.c | 8 ++-- src/vm_system.c | 9 ++++- 10 files changed, 149 insertions(+), 38 deletions(-) diff --git a/README b/README index 0fc507ff7..72ab6c914 100644 --- a/README +++ b/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 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~%" diff --git a/doc/guile-vm.texi b/doc/guile-vm.texi index 1d3896dda..ecf6d5808 100644 --- a/doc/guile-vm.texi +++ b/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 diff --git a/src/frames.c b/src/frames.c index baa31d9b9..1b83bf022 100644 --- a/src/frames.c +++ b/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 diff --git a/src/programs.c b/src/programs.c index 756348d70..423b14b11 100644 --- a/src/programs.c +++ b/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 diff --git a/src/vm.c b/src/vm.c index 560afb6be..242a7dd78 100644 --- a/src/vm.c +++ b/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 diff --git a/src/vm_engine.h b/src/vm_engine.h index 2632b413b..5dcb0c45f 100644 --- a/src/vm_engine.h +++ b/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; \ diff --git a/src/vm_loader.c b/src/vm_loader.c index a21e8a2d4..59aae86a2 100644 --- a/src/vm_loader.c +++ b/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; } diff --git a/src/vm_system.c b/src/vm_system.c index e10263f19..a5cd7d0ce 100644 --- a/src/vm_system.c +++ b/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; -- 2.20.1