diff --git a/module/system/repl/command.gs b/module/system/repl/command.gs index 9de2cd79e..2fc7e1b5b 100644 --- a/module/system/repl/command.gs +++ b/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 diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 4ec482866..3d94df91e 100644 --- a/module/system/repl/common.scm +++ b/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))) - (if (or (memq :c opts) (memq :l opts) (memq :t opts) (memq :e opts)) - bytes - (vm-load repl.vm bytes)))) + (apply compile-in form repl.module repl.language opts)) (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)) - (repl.vm (vm-load repl.vm bytes)) - (if (memq #:t opts) (vm-trace-end! repl.vm #:a)))) + (if (memq :t opts) + (vm-trace repl.vm bytes :a) + (vm-load repl.vm bytes)))) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 41c4e8e55..4ae5fb32c 100644 --- a/module/system/vm/assemble.scm +++ b/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 - (($ env) - (push-object! (codegen x #f)) - (if (venv-closure? env) (push-code! `(make-closure)))) + (($ venv) + (let ((spec (codegen x #f))) + (if toplevel + (dump-object! spec push-code!) + (push-object! spec))) + (if (venv-closure? venv) (push-code! `(make-closure)))) (($ ) (push-code! `(void))) (($ 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)))))) (($ op module name) - (if toplevel - (begin - ;; (push-code! `(load-module ,module)) - (for-each push-code! (object->dump-code name)) - (push-code! `(link/current-module))) - ;; (let ((vlink (make-vlink (make-vmod module) name))) - (push-object! (make-vlink #f name))) + ;; (let ((vlink (make-vlink (make-vmod module) name))) + (let ((vlink (make-vlink #f name))) + (if toplevel + (dump-object! vlink push-code!) + (push-object! vlink))) (push-code! (list (symbol-append 'variable- op)))) (($ label) @@ -192,48 +193,23 @@ ;;; -;;; Stage3: Dumpcode generation +;;; Stage3: Dump optimization ;;; -(define (dump bytespec) - (let* ((table (build-object-table bytespec)) - (bytes (bytespec->bytecode bytespec table '(return)))) - (if (null? table) - bytes - (let ((spec (make-bytespec 0 0 (length table) bytes '()))) - (bytespec->bytecode spec '() '(tail-call 0)))))) +(define (optimizing-dump bytespec) + ;; no optimization yet + (bytespec-bytes bytespec)) -(define (bytespec->bytecode bytespec object-table last-code) - (let ((stack '())) - (define (push-code! x) - (set! stack (cons x stack))) - (define (object-index x) - (cond ((object-find object-table x) => cdr) - (else #f))) - (define (dump-table-object! obj+index) - (let dump! ((x (car obj+index))) - (cond - ((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))) +(define (dump-object! x push-code!) + (let dump! ((x x)) + (cond + ((object->code x) => push-code!) + ((bytespec? x) + (let ((nargs (bytespec-nargs x)) + (nrest (bytespec-nrest x)) + (nlocs (bytespec-nlocs x)) + (bytes (bytespec-bytes x)) + (objs (bytespec-objs x))) ;; 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))))) - ;; - ;; main - (for-each dump-table-object! object-table) - (dump-bytecode! bytespec) - (push-code! last-code) - (apply string-append - (map code->bytes (map code-pack (reverse! stack)))))) + (push-code! `(load-program ,bytes)))) + ((vlink? x) + ;; (push-code! `(local-ref ,(object-index (vlink-module x)))) + (dump! (vlink-name x)) + (push-code! `(link/current-module))) + ;;((vmod? x) + ;; (push-code! `(load-module ,(vmod-id x)))) + ((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) - ((if (or (vlink? x) (vmod? x)) assoc assq) x table)) - -(define (build-object-table bytespec) - (let ((table '()) (index 0)) - (define (insert! x) - ;; (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))) +;;;(define (dump-table-object! obj+index) +;;; (let dump! ((x (car obj+index))) +;;; (cond +;;; (else +;;; (for-each push-code! (dump-object! x))))) +;;; (push-code! `(local-set ,(cdr obj+index)))) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index 63b075a0e..c8a19c2d6 100644 --- a/module/system/vm/conv.scm +++ b/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)))) diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm index eba8d4d74..798dfc7a6 100644 --- a/module/system/vm/load.scm +++ b/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) diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm index c92e6c441..114b7524c 100644 --- a/module/system/vm/profile.scm +++ b/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 () diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 406cdc6fe..f57a69cd7 100644 --- a/module/system/vm/trace.scm +++ b/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 () (vm prog)) - (lambda () (apply vm-trace-end! vm opts)))) - -(define (vm-trace-start! vm . opts) - (set-vm-option! vm 'trace-first #t) - (if (memq :a opts) - (add-hook! (vm-next-hook vm) trace-next)) - (add-hook! (vm-apply-hook vm) trace-apply) - (add-hook! (vm-return-hook vm) trace-return)) - -(define (vm-trace-end! vm . opts) - (if (memq :a opts) - (remove-hook! (vm-next-hook vm) trace-next)) - (remove-hook! (vm-apply-hook vm) trace-apply) - (remove-hook! (vm-return-hook vm) trace-return)) + (lambda () + (set-vm-option! vm 'trace-first #t) + (if (memq :a opts) + (add-hook! (vm-next-hook vm) trace-next)) + (add-hook! (vm-apply-hook vm) trace-apply) + (add-hook! (vm-return-hook vm) trace-return)) + (lambda () + (vm-load vm bytes)) + (lambda () + (if (memq :a opts) + (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))) diff --git a/src/vm_system.c b/src/vm_system.c index 3d094c66a..5297a55c1 100644 --- a/src/vm_system.c +++ b/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;