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
(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'
;;
; 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)
; 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)
(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))
+\f
(define (measure . args)
(if (< (length args) 2)
(begin
(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~%"
* 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 *********************************************************************
@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
@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
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
above).
@end itemize
-In the end, push a program object onto the stack.
-
@end deffn
@deffn @insn{} object-ref offset
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
#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
{
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
#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
#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
#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
#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
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; \
long val = 0;
while (len-- > 0)
val = (val << 8) + FETCH ();
- PUSH (scm_long2num (val));
+ PUSH (scm_from_ulong (val));
NEXT;
}
else
{
size_t len;
FETCH_LENGTH (len);
- PUSH (scm_mem2symbol (ip, len));
+ PUSH (scm_from_locale_symboln (ip, len));
ip += len;
NEXT;
}
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;
{
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;
}
*/
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);
VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
{
- SCM x;
+ register SCM x;
nargs = FETCH ();
x = sp[-nargs];
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;
HCoop / bpt / guile.git / commitdiff