QScheme--so long! (Re: guile-vm-0.1)

[Mikael Djurfeldt <mdj at mdj dot nada dot kth dot se>]

Mikael Djurfeldt <mdj@mdj.nada.kth.se> writes:

> (define (foo n p)
>   (cond ((zero? n) p)
> 	((null? p) (foo (- n 1) (cons p p)))
> 	(else (foo (- n 1) (car p)))))
> 
> Your vm evaluates (foo 10000000 '()) in 31 s.
> 
> The normal Guile evaluator does it in 53 s,
>                           MzScheme in 25 s
>                        and QScheme in 11 s.

With the patch below (again made from guile-vm-0.1) which, apart from
what was described in my previous message, introduces a new
instruction for calling Guile subrs of one argument your VM runs the
benchmark above in 11 s!

I believe we have just beaten (well, almost) QScheme!  8-)

This is soo cool!

Please forgive me, Keisuke, for being so childish.  This is completely
wrong time of fooling around with these kinds of optimizations.  I
just couldn't keep the fingers away...

I'm not sure at all that I've made changes which fit in with how
you're planning things.  There are also some obvious shortcomings such
that I didn't provide a proper disassembly of the new instruction.
(But if the assembler is complemented so that %subr1 can take a
number, the assembly and disassembly operation will at least be
invertible.)

While fooling around with these things I noticed that the VM isn't
integrated with the module system.  But I think it's wise to postpone
such matters and now concentrate on the essentials, which is the basic
architecture of your vm (exactly what you're working on right now in
fact).

Now I can sleep well.  QScheme 1, qscheme 2, qscheme 3, ....

diff -r guile-vm-0.1/ChangeLog guile-vm-0.1.2/ChangeLog
0a1,16
> 2000-08-15  Mikael Djurfeldt  <mdj@linnaeus.mit.edu>
> 
> 	* vm/bytecomp.scm (byte-translate): Detect subrs with one arg and
> 	translate into %subr1.
> 
> 	* vm/types.scm (env-variable-value, env-top-level-variable-value):
> 	New procedures.
> 
> 	* src/vm.h (scm_inst_type): New code: INST_SUBR.
> 
> 	* src/vm.c (scm_make_bytecode): Decode SCM_SUBR.
> 
> 	* src/vm_base.c (%subr1): New instruction.
> 
> 	* src/vm_engine.h (APPLY1): New macro.
> 
diff -r guile-vm-0.1/src/vm.c guile-vm-0.1.2/src/vm.c
149a150
> 	case INST_SUBR:
282a284,293
> 	case INST_SUBR:
> 	  /* a Guile builtin */
> 	  SCM_VALIDATE_SYMBOL (1, old[i]);
> 	  {
> 	    /* Should find a better way to lookup things. */
> 	    SCM proc = SCM_CDR (scm_intern0 (SCM_CHARS (old[i])));
> 	    /* Need to do better type checking (subr1 etc). */
> 	    SCM_VALIDATE_PROC (1, proc);
> 	    new[i] = (SCM) SCM_SUBRF (proc);
> 	  }
338a350,353
> 	  break;
> 	case INST_SUBR:
> 	  /* a raw subr address */
> 	  new[i] = scm_ulong2num ((ulong) old[i]);
diff -r guile-vm-0.1/src/vm.h guile-vm-0.1.2/src/vm.h
50a51
>   INST_SUBR,			/* Guile subr */
diff -r guile-vm-0.1/src/vm_base.c guile-vm-0.1.2/src/vm_base.c
299a300,305
> SCM_DEFINE_INSTRUCTION (subr1, "%subr1", INST_SUBR)
> {
>   ac = APPLY1 (FETCH (), ac);
>   NEXT;
> }
> 
diff -r guile-vm-0.1/src/vm_engine.h guile-vm-0.1.2/src/vm_engine.h
139a140,141
> #define APPLY1(F,X)	(((SCM (*) ()) F) (X))
> 
diff -r guile-vm-0.1/src/vm_scm.c guile-vm-0.1.2/src/vm_scm.c
35a36,41
> SCM_DEFINE_INSTRUCTION (nullp, "null?", INST_NONE)
> {
>   ac = SCM_BOOL (SCM_NULLP (ac));
>   NEXT;
> }
> 
diff -r guile-vm-0.1/vm/Makefile.am guile-vm-0.1.2/vm/Makefile.am
13c13,14
< 	$(LN_S) $(libdir)/libguilevm.so $(vmdatadir)/libvm.so
---
> 	rm -f $(vmdatadir)/libvm.so \
> 	&& $(LN_S) $(libdir)/libguilevm.so $(vmdatadir)/libvm.so
diff -r guile-vm-0.1/vm/bytecomp.scm guile-vm-0.1.2/vm/bytecomp.scm
53a54
>     (,null? #f null? #f #f)
87c88
<       (let ((tag (code-tag code))
---
>       (let ((ctag (code-tag code))
90c91
< 	(case tag
---
> 	(case ctag
96c97
< 	   (case tag
---
> 	   (case ctag
194c195
< 	   (case tag
---
> 	   (case ctag
365,371c366,374
< 		      (case nargs
< 			((0)
< 			 ;;   %func0 SYMBOL
< 			 (push-code! '%func0 addr))
< 			((1)
< 			 ;;   ARG1
< 			 ;;   %func1 SYMBOL
---
> 		      (case (tag (env-variable-value env var))
> 			;; Optimized application
> 			;;
> 			;; FIXME: We can do this only for read-only bindings
> 			;;        otherwise we don't get the correct semantics
> 			;;        when people `set!' it to a different value.
> 			;;
> 			((#.utag_subr_1)
> 			 ;;   %subr1 SYMBOL
373,380c376,377
< 			 (push-code! '%func1 addr))
< 			((2)
< 			 ;;   ARG1 (-> stack)
< 			 ;;   ARG2
< 			 ;;   %func2 SYMBOL
< 			 (comp-use-stack (car args))
< 			 (comp-non-stack (cadr args))
< 			 (push-code! '%func2 addr))
---
> 			 (push-code! '%subr1 addr)
> 			 )
382,387c379,401
< 			 ;;   ARGS... (-> stack)
< 			 ;;   %loadi NARGS
< 			 ;;   %func  SYMBOL
< 			 (for-each comp-use-stack args)
< 			 (push-code! '%loadi nargs)
< 			 (push-code! '%func addr)))))
---
> 			 (case nargs
> 			   ((0)
> 			    ;;   %func0 SYMBOL
> 			    (push-code! '%func0 addr))
> 			   ((1)
> 			    ;;   ARG1
> 			    ;;   %func1 SYMBOL
> 			    (comp-non-stack (car args))
> 			    (push-code! '%func1 addr))
> 			   ((2)
> 			    ;;   ARG1 (-> stack)
> 			    ;;   ARG2
> 			    ;;   %func2 SYMBOL
> 			    (comp-use-stack (car args))
> 			    (comp-non-stack (cadr args))
> 			    (push-code! '%func2 addr))
> 			   (else
> 			    ;;   ARGS... (-> stack)
> 			    ;;   %loadi NARGS
> 			    ;;   %func  SYMBOL
> 			    (for-each comp-use-stack args)
> 			    (push-code! '%loadi nargs)
> 			    (push-code! '%func addr)))))))
422c436
< 	   (error "Unknown tag:" tag)))))
---
> 	   (error "Unknown tag:" ctag)))))
diff -r guile-vm-0.1/vm/compile.scm guile-vm-0.1.2/vm/compile.scm
246c246,247
< 	 (cons name (eval (symbol-append "parse-" name))))
---
> 	 (cons name (eval (symbol-append "parse-" name)
> 			  (interaction-environment))))
302c303,305
< 	 (cons (eval name) (eval (symbol-append "parse-" name))))
---
> 	 (cons (eval name (interaction-environment))
> 	       (eval (symbol-append "parse-" name)
> 		     (interaction-environment))))
diff -r guile-vm-0.1/vm/types.scm guile-vm-0.1.2/vm/types.scm
230c230
< 	(let ((obj (eval sym)))
---
> 	(let ((obj (eval sym (interaction-environment))))
281a282,295
> 
> (define-public (env-variable-value env var)
>   (env-finalize! env)
>   (cond ((local-variable? var)
> 	 (env-local-variable-value env var))
> 	((external-variable? var)
> 	 (env-external-variable-value env var))
> 	((top-level-variable? var)
> 	 (env-top-level-variable-value env var))
> 	(else
> 	 (error "Wrong type argument: ~S" var))))
> 
> (define (env-top-level-variable-value env var)
>   (variable-value var))