*** empty log message ***

module/system/repl/command.gs

@@ -288,7 +288,7 @@ Generate compiled code.
   -D    Add debug information"
   (let ((x (apply repl-compile repl form opts)))
     (cond ((null? opts)
-	   (disassemble-program x))
+	   (puts x))
 	  ((memq :l opts)
 	   (disassemble-bytecode x))
 	  ((memq :c opts)
@@ -304,7 +304,7 @@ Compile a file."
 (define (disassemble repl prog)
   "disassemble PROGRAM
 Disassemble a program."
-  (disassemble-program (repl.vm (repl-compile repl prog))))
+  (disassemble-program (repl-eval repl prog)))
 
 (define (disassemble-file repl file)
   "disassemble-file FILE

module/system/repl/common.scm

@@ -63,16 +63,13 @@
   (apply read-in repl.language args))
 
 (define (repl-compile repl form . opts)
-  (let ((bytes (apply compile-in form repl.module repl.language opts)))
+  (apply compile-in form repl.module repl.language opts))
-    (if (or (memq :c opts) (memq :l opts) (memq :t opts) (memq :e opts))
-	bytes
-	(vm-load repl.vm bytes))))
 
 (define (repl-eval repl form)
   (let ((evaler repl.language.evaler))
     (if evaler
 	(evaler form repl.module)
-	(repl.vm (repl-compile repl form)))))
+	(vm-load repl.vm (repl-compile repl form)))))
 
 (define (repl-print repl val)
   (if (not (eq? val *unspecified*))
@@ -89,6 +86,6 @@
 
 (define (repl-load-file repl file . opts)
   (let ((bytes (apply load-file-in file repl.module repl.language opts)))
-    (if (memq #:t opts) (vm-trace-start! repl.vm #:a))
+    (if (memq :t opts)
-    (repl.vm (vm-load repl.vm bytes))
+	(vm-trace repl.vm bytes :a)
-    (if (memq #:t opts) (vm-trace-end! repl.vm #:a))))
+	(vm-load repl.vm bytes))))

module/system/vm/assemble.scm

@@ -30,7 +30,7 @@
   :export (assemble))
 
 (define (assemble glil env . opts)
-  (dump (codegen (preprocess glil #f) #t)))
+  (optimizing-dump (codegen (preprocess glil #f) #t)))
 
 
 ;;;
@@ -89,16 +89,19 @@
 	   (set! label-alist (assq-set! label-alist key addr))))
        (define (generate-code x)
 	 (match x
-	   (($ <vm-asm> env)
+	   (($ <vm-asm> venv)
-	    (push-object! (codegen x #f))
+	    (let ((spec (codegen x #f)))
-	    (if (venv-closure? env) (push-code! `(make-closure))))
+	      (if toplevel
+		  (dump-object! spec push-code!)
+		  (push-object! spec)))
+	    (if (venv-closure? venv) (push-code! `(make-closure))))
 
 	   (($ <glil-void>)
 	    (push-code! `(void)))
 
 	   (($ <glil-const> x)
 	    (if toplevel
-		(for-each push-code! (object->dump-code x))
+		(dump-object! x push-code!)
 		(cond ((object->code x) => push-code!)
 		      (else (push-object! x)))))
 
@@ -117,13 +120,11 @@
 		 (push-code! `(,(symbol-append 'external- op) ,(+ index i))))))
 
 	   (($ <glil-module> op module name)
-	    (if toplevel
+	    ;; (let ((vlink (make-vlink (make-vmod module) name)))
-		(begin
+	    (let ((vlink (make-vlink #f name)))
-		  ;; (push-code! `(load-module ,module))
+	      (if toplevel
-		  (for-each push-code! (object->dump-code name))
+		  (dump-object! vlink push-code!)
-		  (push-code! `(link/current-module)))
+		  (push-object! vlink)))
-		;; (let ((vlink (make-vlink (make-vmod module) name)))
-		(push-object! (make-vlink #f name)))
 	    (push-code! (list (symbol-append 'variable- op))))
 
 	   (($ <glil-label> label)
@@ -192,48 +193,23 @@
 
 
 ;;;
-;;; Stage3: Dumpcode generation
+;;; Stage3: Dump optimization
 ;;;
 
-(define (dump bytespec)
+(define (optimizing-dump bytespec)
-  (let* ((table (build-object-table bytespec))
+  ;; no optimization yet
-	 (bytes (bytespec->bytecode bytespec table '(return))))
+  (bytespec-bytes bytespec))
-    (if (null? table)
-	bytes
-	(let ((spec (make-bytespec 0 0 (length table) bytes '())))
-	  (bytespec->bytecode spec '() '(tail-call 0))))))
 
-(define (bytespec->bytecode bytespec object-table last-code)
+(define (dump-object! x push-code!)
-  (let ((stack '()))
+  (let dump! ((x x))
-    (define (push-code! x)
+    (cond
-      (set! stack (cons x stack)))
+     ((object->code x) => push-code!)
-    (define (object-index x)
+     ((bytespec? x)
-      (cond ((object-find object-table x) => cdr)
+      (let ((nargs (bytespec-nargs x))
-	    (else #f)))
+	    (nrest (bytespec-nrest x))
-    (define (dump-table-object! obj+index)
+	    (nlocs (bytespec-nlocs x))
-      (let dump! ((x (car obj+index)))
+	    (bytes (bytespec-bytes x))
-	(cond
+	    (objs  (bytespec-objs x)))
-	 ((vlink? x)
-	  ;; (push-code! `(local-ref ,(object-index (vlink-module x))))
-	  (for-each push-code! (object->dump-code (vlink-name x)))
-	  (push-code! `(link/current-module)))
-	 ;;((vmod? x)
-	 ;;  (push-code! `(load-module ,(vmod-id x))))
-	 (else
-	  (for-each push-code! (object->dump-code x)))))
-      (push-code! `(local-set ,(cdr obj+index))))
-    (define (dump-object! x)
-      (let dump! ((x x))
-	(cond
-	 ((bytespec? x) (dump-bytecode! x))
-	 ((object-index x) => (lambda (i) (push-code! `(local-ref ,i))))
-	 (else
-	  (error "Cannot dump:" x)))))
-    (define (dump-bytecode! spec)
-      (let ((nargs (bytespec-nargs spec))
-	    (nrest (bytespec-nrest spec))
-	    (nlocs (bytespec-nlocs spec))
-	    (objs  (bytespec-objs spec)))
 	;; dump parameters
 	(if (and (< nargs 4) (< nlocs 16))
 	    (push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs)))
@@ -244,31 +220,44 @@
 	      (push-code! (object->code #f))))
 	;; dump object table
 	(cond ((not (null? objs))
-	       (for-each dump-object! objs)
+	       (for-each dump! objs)
 	       (push-code! `(vector ,(length objs)))))
 	;; dump bytecode
-	(push-code! `(load-program ,(bytespec-bytes spec)))))
+	(push-code! `(load-program ,bytes))))
-    ;;
+     ((vlink? x)
-    ;; main
+      ;; (push-code! `(local-ref ,(object-index (vlink-module x))))
-    (for-each dump-table-object! object-table)
+      (dump! (vlink-name x))
-    (dump-bytecode! bytespec)
+      (push-code! `(link/current-module)))
-    (push-code! last-code)
+     ;;((vmod? x)
-    (apply string-append
+     ;;  (push-code! `(load-module ,(vmod-id x))))
-	   (map code->bytes (map code-pack (reverse! stack))))))
+     ((integer? x)
+      (let ((str (do ((n x (quotient n 256))
+		      (l '() (cons (modulo n 256) l)))
+		     ((= n 0)
+		      (list->string (map integer->char l))))))
+	(push-code! `(load-integer ,str))))
+     ((string? x)
+      (push-code! `(load-string ,x)))
+     ((symbol? x)
+      (push-code! `(load-symbol ,(symbol->string x))))
+     ((keyword? x)
+      (push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
+     ((list? x)
+      (for-each dump! x)
+      (push-code! `(list ,(length x))))
+     ((pair? x)
+      (dump! (car x))
+      (dump! (cdr x))
+      (push-code! `(cons)))
+     ((vector? x)
+      (for-each dump! (vector->list x))
+      (push-code! `(vector ,(vector-length x))))
+     (else
+      (error "Cannot dump:" x)))))
 
-(define (object-find table x)
+;;;(define (dump-table-object! obj+index)
-  ((if (or (vlink? x) (vmod? x)) assoc assq) x table))
+;;;  (let dump! ((x (car obj+index)))
-
+;;;    (cond
-(define (build-object-table bytespec)
+;;;     (else
-  (let ((table '()) (index 0))
+;;;      (for-each push-code! (dump-object! x)))))
-    (define (insert! x)
+;;;  (push-code! `(local-set ,(cdr obj+index))))
-      ;; (if (vlink? x) (begin (insert! (vlink-module x))))
-      (if (not (object-find table x))
-	  (begin
-	    (set! table (acons x index table))
-	    (set! index (1+ index)))))
-    (let loop ((spec bytespec))
-      (for-each (lambda (x)
-		  (if (bytespec? x) (loop x) (insert! x)))
-		(bytespec-objs spec)))
-    (reverse! table)))

module/system/vm/conv.scm

@@ -23,7 +23,7 @@
   :use-module (system vm core)
   :use-module (ice-9 match)
   :use-module (ice-9 regex)
-  :export (code-pack code-unpack object->code object->dump-code code->object))
+  :export (code-pack code-unpack object->code code->object code->bytes))
 
 ;;;
 ;;; Code compress/decompression
@@ -72,39 +72,6 @@
 	((char? x) `(make-char8 ,(char->integer x)))
 	(else #f)))
 
-(define (object->dump-code x)
-  (let ((stack '()))
-    (define (push-code! code)
-      (set! stack (cons code stack)))
-    (let dump! ((x x))
-      (cond
-       ((object->code x) => push-code!)
-       ((integer? x)
-	(let ((str (do ((n x (quotient n 256))
-			(l '() (cons (modulo n 256) l)))
-		       ((= n 0)
-			(list->string (map integer->char l))))))
-	  (push-code! `(load-integer ,str))))
-       ((string? x)
-	(push-code! `(load-string ,x)))
-       ((symbol? x)
-	(push-code! `(load-symbol ,(symbol->string x))))
-       ((keyword? x)
-	(push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
-       ((list? x)
-	(for-each dump! x)
-	(push-code! `(list ,(length x))))
-       ((pair? x)
-	(dump! (car x))
-	(dump! (cdr x))
-	(push-code! `(cons)))
-       ((vector? x)
-	(for-each dump! (vector->list x))
-	(push-code! `(vector ,(vector-length x))))
-       (else
-	(error "Cannot dump:" x))))
-    (reverse! stack)))
-
 (define (code->object code)
   (match code
     (('make-true) #t)
@@ -122,7 +89,7 @@
     (('load-keyword s) (symbol->keyword (string->symbol s)))
     (else #f)))
 
-(define-public (code->bytes code)
+(define (code->bytes code)
   (let* ((inst (car code))
 	 (rest (cdr code))
 	 (head (make-string 1 (integer->char (instruction->opcode inst))))

module/system/vm/load.scm

@@ -36,7 +36,7 @@
     (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
       (call-with-input-file compiled
 	(lambda (p) (uniform-vector-read! bytes p)))
-      ((vm-load *the-vm* bytes)))))
+      (vm-load *the-vm* bytes))))
 
 (define (file-name-full-name filename)
   (let ((oldname (and (current-load-port)

module/system/vm/profile.scm

@@ -24,7 +24,7 @@
   :use-module (ice-9 format)
   :export (vm-profile))
 
-(define (vm-profile vm prog . opts)
+(define (vm-profile vm bytes . opts)
   (let ((flag (vm-option vm 'debug)))
     (dynamic-wind
 	(lambda ()
@@ -34,7 +34,7 @@
 	  (add-hook! (vm-enter-hook vm) profile-enter)
 	  (add-hook! (vm-exit-hook vm) profile-exit))
 	(lambda ()
-	  (let ((val (vm prog)))
+	  (let ((val (vm-load vm bytes)))
 	    (display-result vm)
 	    val))
 	(lambda ()

module/system/vm/trace.scm

@@ -24,26 +24,23 @@
   :use-module (system vm frame)
   :use-module (ice-9 format)
   :use-module (ice-9 and-let-star)
-  :export (vm-trace vm-trace-start! vm-trace-end!))
+  :export (vm-trace))
 
-(define (vm-trace vm prog . opts)
+(define (vm-trace vm bytes . opts)
   (dynamic-wind
-      (lambda () (apply vm-trace-start! vm opts))
+      (lambda ()
-      (lambda () (vm prog))
+	(set-vm-option! vm 'trace-first #t)
-      (lambda () (apply vm-trace-end! vm opts))))
+	(if (memq :a opts)
-
+	    (add-hook! (vm-next-hook vm) trace-next))
-(define (vm-trace-start! vm . opts)
+	(add-hook! (vm-apply-hook vm) trace-apply)
-  (set-vm-option! vm 'trace-first #t)
+	(add-hook! (vm-return-hook vm) trace-return))
-  (if (memq :a opts)
+      (lambda ()
-      (add-hook! (vm-next-hook vm) trace-next))
+	(vm-load vm bytes))
-  (add-hook! (vm-apply-hook vm) trace-apply)
+      (lambda ()
-  (add-hook! (vm-return-hook vm) trace-return))
+	(if (memq :a opts)
-
+	    (remove-hook! (vm-next-hook vm) trace-next))
-(define (vm-trace-end! vm . opts)
+	(remove-hook! (vm-apply-hook vm) trace-apply)
-  (if (memq :a opts)
+	(remove-hook! (vm-return-hook vm) trace-return))))
-      (remove-hook! (vm-next-hook vm) trace-next))
-  (remove-hook! (vm-apply-hook vm) trace-apply)
-  (remove-hook! (vm-return-hook vm) trace-return))
 
 (define (trace-next vm)
   (let ((frame (vm-current-frame vm)))

src/vm_system.c

@@ -176,12 +176,6 @@ VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0, 0, 1)
-{
-  PUSH (LOCAL_REF (0));
-  NEXT;
-}
-
 VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1)
 {
   unsigned int i;