diff --git a/module/system/base/language.scm b/module/system/base/language.scm index e5588b314..e467d3e77 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -90,21 +90,15 @@ (do ((x (read-in lang in) (read-in lang in)) (l '() (cons (lang.translator (lang.expander x)) l))) ((eof-object? x) (reverse! l)))))) - (asm (apply compile (cons '@begin code) env opts)) - (bytes (apply assemble asm env opts))) - (call-with-output-file (object-file-name file) - (lambda (out) (uniform-vector-write bytes out))))) + (asm (apply compile (cons '@begin code) env opts))) + (save-dumpcode (apply assemble asm env opts) (object-file-name file)))) (define (load-file-in file env lang . opts) (let ((compiled (object-file-name file))) (if (or (not (file-exists? compiled)) (> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) (compile-file-in file env lang :O)) - (call-with-input-file compiled - (lambda (p) - (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a))) - (uniform-vector-read! bytes p) - bytes))))) + (load-dumpcode compiled))) (define (object-file-name file) (let ((m (string-match "\\.[^.]*$" file))) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 414c8fe06..583f099e9 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -303,7 +303,7 @@ Generate compiled code. (let ((x (apply repl-compile repl form opts))) (cond ((or (memq :e opts) (memq :t opts)) (puts x)) ((memq :c opts) (pprint-glil x)) - (else (disassemble-bootcode x))))) + (else (disassemble-dumpcode x))))) (define (compile-file repl file . opts) "compile-file [options] FILE @@ -318,7 +318,7 @@ Disassemble a program." (define (disassemble-file repl file) "disassemble-file FILE Disassemble a file." - (disassemble-bootcode + (disassemble-dumpcode (load-file-in (->string file) repl.module repl.language))) (define (->string x) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index d60f5d9b6..3a4578a58 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -151,7 +151,7 @@ (let ((bytes (stack->bytes stack)) (objs (map car (reverse! object-alist)))) (if toplevel - (make-bootcode nlocs nexts bytes) + (make-dumpcode nlocs nexts bytes) (make-bytespec nargs nrest nlocs nexts bytes objs))))))) (define (stack->bytes stack) diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm index 79e73c0dc..1f7d7ed61 100644 --- a/module/system/vm/core.scm +++ b/module/system/vm/core.scm @@ -33,37 +33,48 @@ (module-obarray (current-module))))) ;;; -;;; Bootcode interface +;;; Dumpcode interface ;;; -(export make-bootcode bootcode? bootcode-version - bootcode-nlocs bootcode-nexts bootcode-bytecode) +(export make-dumpcode dumpcode? dumpcode-version + dumpcode-nlocs dumpcode-nexts dumpcode-bytecode + load-dumpcode save-dumpcode) -(define *bootcode-cookie* (string-append "\0GBC-" (vm-version))) +(define *dumpcode-cookie* (string-append "\0GBC-" (vm-version))) -(define (make-bootcode nlocs nexts bytes) - (string-append *bootcode-cookie* +(define (make-dumpcode nlocs nexts bytes) + (string-append *dumpcode-cookie* (integer->bytes nlocs) (integer->bytes nexts) bytes)) -(define (bootcode? x) +(define (dumpcode? x) (and (string? x) (> (string-length x) 10) (string=? (substring x 1 4) "GBC"))) -(define (bootcode-version x) +(define (dumpcode-version x) (substring x 5 8)) -(define (bootcode-nlocs x) +(define (dumpcode-nlocs x) (bytes->integer x 8)) -(define (bootcode-nexts x) +(define (dumpcode-nexts x) (bytes->integer x 9)) -(define (bootcode-bytecode x) +(define (dumpcode-bytecode x) (substring x 10)) +(define (load-dumpcode file) + (let ((bytes (make-uniform-vector (stat:size (stat file)) #\a))) + (call-with-input-file file + (lambda (p) (uniform-vector-read! bytes p))) + bytes)) + +(define (save-dumpcode dump file) + (call-with-output-file file + (lambda (out) (uniform-vector-write bytes out)))) + (define (integer->bytes n) (string (integer->char n))) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 09fcfef29..7c6df92ff 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -27,15 +27,15 @@ :use-module (ice-9 format) :use-module (ice-9 receive) :use-module (ice-9 and-let-star) - :export (disassemble-bootcode disassemble-program)) + :export (disassemble-dumpcode disassemble-program)) -(define (disassemble-bootcode bytes . opts) - (if (not (bootcode? bytes)) (error "Invalid bootcode")) - (format #t "Disassembly of bootcode:\n\n") - (format #t "Compiled for Guile VM ~A\n\n" (bootcode-version bytes)) +(define (disassemble-dumpcode dumpcode . opts) + (if (not (dumpcode? dumpcode)) (error "Invalid dumpcode")) + (format #t "Disassembly of dumpcode:\n\n") + (format #t "Compiled for Guile VM ~A\n\n" (dumpcode-version dumpcode)) (format #t "nlocs = ~A nexts = ~A\n\n" - (bootcode-nlocs bytes) (bootcode-nexts bytes)) - (disassemble-bytecode (bootcode-bytecode bytes) #f)) + (dumpcode-nlocs dumpcode) (dumpcode-nexts dumpcode)) + (disassemble-bytecode (dumpcode-bytecode dumpcode) #f)) (define (disassemble-program prog . opts) (let* ((arity (program-arity prog)) @@ -63,14 +63,14 @@ (define (disassemble-bytecode bytes objs) (let ((decode (make-byte-decoder bytes)) - (rest '())) + (programs '())) (do ((addr+code (decode) (decode))) ((not addr+code) (newline)) (receive (addr code) addr+code (match code (('load-program x) (let ((sym (gensym ""))) - (set! rest (acons sym x rest)) + (set! programs (acons sym x programs)) (print-info addr (format #f "load-program #~A" sym) #f))) (else (let ((info (list->info code)) @@ -79,7 +79,7 @@ (for-each (lambda (sym+bytes) (format #t "Bytecode #~A:\n\n" (car sym+bytes)) (disassemble-bytecode (cdr sym+bytes) #f)) - (reverse! rest)))) + (reverse! programs)))) (define (disassemble-objects objs) (display "Objects:\n\n") @@ -109,13 +109,6 @@ ((make-false) "#f") ((object-ref) (if objs (object->string (vector-ref objs (car args))) #f)) -;;; ((local-ref local-set) -;;; ;;'(ref x)) -;;; #f) -;;; ((module-ref module-set) -;;; (let ((var (vector-ref objs (car args)))) -;;; (list (if (eq? inst 'module-ref) 'ref 'set) -;;; (if (pair? var) (car var) var)))) (else #f))))))) (define (list->info list) diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm index 6dca082a5..6214cc95a 100644 --- a/module/system/vm/load.scm +++ b/module/system/vm/load.scm @@ -31,10 +31,7 @@ (if (or (not (file-exists? compiled)) (> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) (compile-file-in file #f (lookup-language 'gscheme) #:O)) - (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) (load-dumpcode compiled)))) (define (file-name-full-name filename) (let ((oldname (and (current-load-port)