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))
(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)))

View file

@ -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)

View file

@ -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)

View file

@ -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)))

View file

@ -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)

View file

@ -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)