1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00

*** empty log message ***

This commit is contained in:
Keisuke Nishida 2001-04-09 01:50:48 +00:00
parent f0c9993564
commit 58995613d9
6 changed files with 39 additions and 44 deletions

View file

@ -90,21 +90,15 @@
(do ((x (read-in lang in) (read-in lang in)) (do ((x (read-in lang in) (read-in lang in))
(l '() (cons (lang.translator (lang.expander x)) l))) (l '() (cons (lang.translator (lang.expander x)) l)))
((eof-object? x) (reverse! l)))))) ((eof-object? x) (reverse! l))))))
(asm (apply compile (cons '@begin code) env opts)) (asm (apply compile (cons '@begin code) env opts)))
(bytes (apply assemble asm env opts))) (save-dumpcode (apply assemble asm env opts) (object-file-name file))))
(call-with-output-file (object-file-name file)
(lambda (out) (uniform-vector-write bytes out)))))
(define (load-file-in file env lang . opts) (define (load-file-in file env lang . opts)
(let ((compiled (object-file-name file))) (let ((compiled (object-file-name file)))
(if (or (not (file-exists? compiled)) (if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(compile-file-in file env lang :O)) (compile-file-in file env lang :O))
(call-with-input-file compiled (load-dumpcode compiled)))
(lambda (p)
(let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
(uniform-vector-read! bytes p)
bytes)))))
(define (object-file-name file) (define (object-file-name file)
(let ((m (string-match "\\.[^.]*$" file))) (let ((m (string-match "\\.[^.]*$" file)))

View file

@ -303,7 +303,7 @@ Generate compiled code.
(let ((x (apply repl-compile repl form opts))) (let ((x (apply repl-compile repl form opts)))
(cond ((or (memq :e opts) (memq :t opts)) (puts x)) (cond ((or (memq :e opts) (memq :t opts)) (puts x))
((memq :c opts) (pprint-glil x)) ((memq :c opts) (pprint-glil x))
(else (disassemble-bootcode x))))) (else (disassemble-dumpcode x)))))
(define (compile-file repl file . opts) (define (compile-file repl file . opts)
"compile-file [options] FILE "compile-file [options] FILE
@ -318,7 +318,7 @@ Disassemble a program."
(define (disassemble-file repl file) (define (disassemble-file repl file)
"disassemble-file FILE "disassemble-file FILE
Disassemble a file." Disassemble a file."
(disassemble-bootcode (disassemble-dumpcode
(load-file-in (->string file) repl.module repl.language))) (load-file-in (->string file) repl.module repl.language)))
(define (->string x) (define (->string x)

View file

@ -151,7 +151,7 @@
(let ((bytes (stack->bytes stack)) (let ((bytes (stack->bytes stack))
(objs (map car (reverse! object-alist)))) (objs (map car (reverse! object-alist))))
(if toplevel (if toplevel
(make-bootcode nlocs nexts bytes) (make-dumpcode nlocs nexts bytes)
(make-bytespec nargs nrest nlocs nexts bytes objs))))))) (make-bytespec nargs nrest nlocs nexts bytes objs)))))))
(define (stack->bytes stack) (define (stack->bytes stack)

View file

@ -33,37 +33,48 @@
(module-obarray (current-module))))) (module-obarray (current-module)))))
;;; ;;;
;;; Bootcode interface ;;; Dumpcode interface
;;; ;;;
(export make-bootcode bootcode? bootcode-version (export make-dumpcode dumpcode? dumpcode-version
bootcode-nlocs bootcode-nexts bootcode-bytecode) 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) (define (make-dumpcode nlocs nexts bytes)
(string-append *bootcode-cookie* (string-append *dumpcode-cookie*
(integer->bytes nlocs) (integer->bytes nlocs)
(integer->bytes nexts) (integer->bytes nexts)
bytes)) bytes))
(define (bootcode? x) (define (dumpcode? x)
(and (string? x) (and (string? x)
(> (string-length x) 10) (> (string-length x) 10)
(string=? (substring x 1 4) "GBC"))) (string=? (substring x 1 4) "GBC")))
(define (bootcode-version x) (define (dumpcode-version x)
(substring x 5 8)) (substring x 5 8))
(define (bootcode-nlocs x) (define (dumpcode-nlocs x)
(bytes->integer x 8)) (bytes->integer x 8))
(define (bootcode-nexts x) (define (dumpcode-nexts x)
(bytes->integer x 9)) (bytes->integer x 9))
(define (bootcode-bytecode x) (define (dumpcode-bytecode x)
(substring x 10)) (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) (define (integer->bytes n)
(string (integer->char n))) (string (integer->char n)))

View file

@ -27,15 +27,15 @@
:use-module (ice-9 format) :use-module (ice-9 format)
:use-module (ice-9 receive) :use-module (ice-9 receive)
:use-module (ice-9 and-let-star) :use-module (ice-9 and-let-star)
:export (disassemble-bootcode disassemble-program)) :export (disassemble-dumpcode disassemble-program))
(define (disassemble-bootcode bytes . opts) (define (disassemble-dumpcode dumpcode . opts)
(if (not (bootcode? bytes)) (error "Invalid bootcode")) (if (not (dumpcode? dumpcode)) (error "Invalid dumpcode"))
(format #t "Disassembly of bootcode:\n\n") (format #t "Disassembly of dumpcode:\n\n")
(format #t "Compiled for Guile VM ~A\n\n" (bootcode-version bytes)) (format #t "Compiled for Guile VM ~A\n\n" (dumpcode-version dumpcode))
(format #t "nlocs = ~A nexts = ~A\n\n" (format #t "nlocs = ~A nexts = ~A\n\n"
(bootcode-nlocs bytes) (bootcode-nexts bytes)) (dumpcode-nlocs dumpcode) (dumpcode-nexts dumpcode))
(disassemble-bytecode (bootcode-bytecode bytes) #f)) (disassemble-bytecode (dumpcode-bytecode dumpcode) #f))
(define (disassemble-program prog . opts) (define (disassemble-program prog . opts)
(let* ((arity (program-arity prog)) (let* ((arity (program-arity prog))
@ -63,14 +63,14 @@
(define (disassemble-bytecode bytes objs) (define (disassemble-bytecode bytes objs)
(let ((decode (make-byte-decoder bytes)) (let ((decode (make-byte-decoder bytes))
(rest '())) (programs '()))
(do ((addr+code (decode) (decode))) (do ((addr+code (decode) (decode)))
((not addr+code) (newline)) ((not addr+code) (newline))
(receive (addr code) addr+code (receive (addr code) addr+code
(match code (match code
(('load-program x) (('load-program x)
(let ((sym (gensym ""))) (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))) (print-info addr (format #f "load-program #~A" sym) #f)))
(else (else
(let ((info (list->info code)) (let ((info (list->info code))
@ -79,7 +79,7 @@
(for-each (lambda (sym+bytes) (for-each (lambda (sym+bytes)
(format #t "Bytecode #~A:\n\n" (car sym+bytes)) (format #t "Bytecode #~A:\n\n" (car sym+bytes))
(disassemble-bytecode (cdr sym+bytes) #f)) (disassemble-bytecode (cdr sym+bytes) #f))
(reverse! rest)))) (reverse! programs))))
(define (disassemble-objects objs) (define (disassemble-objects objs)
(display "Objects:\n\n") (display "Objects:\n\n")
@ -109,13 +109,6 @@
((make-false) "#f") ((make-false) "#f")
((object-ref) ((object-ref)
(if objs (object->string (vector-ref objs (car args))) #f)) (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))))))) (else #f)))))))
(define (list->info list) (define (list->info list)

View file

@ -31,10 +31,7 @@
(if (or (not (file-exists? compiled)) (if (or (not (file-exists? compiled))
(> (stat:mtime (stat file)) (stat:mtime (stat compiled)))) (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
(compile-file-in file #f (lookup-language 'gscheme) #:O)) (compile-file-in file #f (lookup-language 'gscheme) #:O))
(let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a))) (vm-load (the-vm) (load-dumpcode compiled))))
(call-with-input-file compiled
(lambda (p) (uniform-vector-read! bytes p)))
(vm-load (the-vm) bytes))))
(define (file-name-full-name filename) (define (file-name-full-name filename)
(let ((oldname (and (current-load-port) (let ((oldname (and (current-load-port)