diff options
author | Andy Wingo <wingo@pobox.com> | 2009-01-30 14:36:49 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-01-30 14:36:49 +0100 |
commit | 9bb8012dd63869682edf2af5f708430646eabef5 (patch) | |
tree | d5bbefad9df87e3bce7eec56296c30f02c34b9dc | |
parent | d7236899f5752fab1ad1e8d3e5b51cfe18abe5c7 (diff) | |
download | guile-9bb8012dd63869682edf2af5f708430646eabef5.tar.gz |
remove conv.scm, disasm.scm; objcode->bytecode rename
* module/system/vm/Makefile.am:
* module/system/vm/conv.scm:
* module/system/vm/disasm.scm: Remove these modules, as their
functionality is now in (language ...).
* libguile/objcodes.h:
* libguile/objcodes.c:
* module/system/vm/objcode.scm: Rename objcode->u8vector to
objcode->bytecode.
* module/system/vm/frame.scm:
* module/language/bytecode/spec.scm: Fix for objcode->bytecode.
* scripts/disassemble:
* testsuite/run-vm-tests.scm: Fix for (system vm disasm) removal.
* module/system/repl/command.scm: Use the right disassembler.
-rw-r--r-- | libguile/objcodes.c | 4 | ||||
-rw-r--r-- | libguile/objcodes.h | 2 | ||||
-rw-r--r-- | module/language/bytecode/spec.scm | 2 | ||||
-rw-r--r-- | module/system/repl/command.scm | 8 | ||||
-rw-r--r-- | module/system/vm/Makefile.am | 3 | ||||
-rw-r--r-- | module/system/vm/conv.scm | 186 | ||||
-rw-r--r-- | module/system/vm/disasm.scm | 183 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 5 | ||||
-rw-r--r-- | module/system/vm/objcode.scm | 2 | ||||
-rwxr-xr-x | scripts/disassemble | 4 | ||||
-rw-r--r-- | testsuite/run-vm-tests.scm | 1 |
11 files changed, 15 insertions, 385 deletions
diff --git a/libguile/objcodes.c b/libguile/objcodes.c index 7ef47b66c..5796a5486 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -204,10 +204,10 @@ SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0, +SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0, (SCM objcode), "") -#define FUNC_NAME s_scm_objcode_to_u8vector +#define FUNC_NAME s_scm_objcode_to_bytecode { scm_t_uint8 *u8vector; scm_t_uint32 len; diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 60ec0e64c..6b3c2aec9 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -79,7 +79,7 @@ SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr); extern SCM scm_load_objcode (SCM file); extern SCM scm_objcode_p (SCM obj); extern SCM scm_bytecode_to_objcode (SCM bytecode); -extern SCM scm_objcode_to_u8vector (SCM objcode); +extern SCM scm_objcode_to_bytecode (SCM objcode); extern SCM scm_write_objcode (SCM objcode, SCM port); extern void scm_bootstrap_objcodes (void); diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm index 7164eba44..7d9b955a7 100644 --- a/module/language/bytecode/spec.scm +++ b/module/language/bytecode/spec.scm @@ -28,7 +28,7 @@ (values (bytecode->objcode x) e)) (define (decompile-objcode x e opts) - (values (objcode->u8vector x) e)) + (values (objcode->bytecode x) e)) (define-language bytecode #:title "Guile Bytecode Vectors" diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 2e9299a34..cf09e01af 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -28,7 +28,6 @@ #:use-module (system vm program) #:use-module (system vm vm) #:autoload (system base language) (lookup-language) - #:autoload (system vm disasm) (disassemble-program disassemble-objcode) #:autoload (system vm debug) (vm-debugger vm-backtrace) #:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off) #:autoload (system vm profile) (vm-profile) @@ -276,15 +275,18 @@ Generate compiled code. Compile a file." (guile:compile-file (->string file) #:opts opts)) +(define (guile:disassemble x) + ((@ (language assembly disassemble) disassemble) x)) + (define (disassemble repl prog) "disassemble PROGRAM Disassemble a program." - (disassemble-program (repl-eval repl (repl-parse repl prog)))) + (guile:disassemble (repl-eval repl (repl-parse repl prog)))) (define (disassemble-file repl file) "disassemble-file FILE Disassemble a file." - (disassemble-objcode (load-objcode (->string file)))) + (guile:disassemble (load-objcode (->string file)))) ;;; diff --git a/module/system/vm/Makefile.am b/module/system/vm/Makefile.am index 594e4cf67..a99559441 100644 --- a/module/system/vm/Makefile.am +++ b/module/system/vm/Makefile.am @@ -1,5 +1,4 @@ -SOURCES = conv.scm debug.scm \ - disasm.scm frame.scm instruction.scm objcode.scm \ +SOURCES = debug.scm frame.scm instruction.scm objcode.scm \ profile.scm program.scm trace.scm vm.scm modpath = system/vm include $(top_srcdir)/am/guilec diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm deleted file mode 100644 index 873d7ab7c..000000000 --- a/module/system/vm/conv.scm +++ /dev/null @@ -1,186 +0,0 @@ -;;; Guile VM code converters - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define-module (system vm conv) - #:use-module (system vm instruction) - #:use-module (system base pmatch) - #:use-module (ice-9 regex) - #:use-module (srfi srfi-4) - #:use-module (srfi srfi-1) - #:export (code-pack code-unpack object->code code->object code->bytes - make-byte-decoder)) - -;;; -;;; Code compress/decompression -;;; - -(define (code-pack code) - (pmatch code - ((,inst ,n) (guard (integer? n)) - (cond ((< n 10) - (let ((abbrev (string->symbol (format #f "~A:~A" inst n)))) - (if (instruction? abbrev) (list abbrev) code))) - (else code))) - (else code))) - -(define (code-unpack code) - (let ((inst (symbol->string (car code)))) - (cond - ((string-match "^([^:]*):([0-9]+)$" inst) => - (lambda (data) - (cons* (string->symbol (match:substring data 1)) - (string->number (match:substring data 2)) - (cdr code)))) - (else code)))) - - -;;; -;;; Encoder/decoder -;;; - -(define (object->code x) - (cond ((eq? x #t) `(make-true)) - ((eq? x #f) `(make-false)) - ((null? x) `(make-eol)) - ((and (integer? x) (exact? x)) - (cond ((and (<= -128 x) (< x 128)) - `(make-int8 ,(modulo x 256))) - ((and (<= -32768 x) (< x 32768)) - (let ((n (if (< x 0) (+ x 65536) x))) - `(make-int16 ,(quotient n 256) ,(modulo n 256)))) - (else #f))) - ((char? x) `(make-char8 ,(char->integer x))) - (else #f))) - -(define (code->object code) - (pmatch code - ((make-true) #t) - ((make-false) #f) ;; FIXME: Same as the `else' case! - ((make-eol) '()) - ((make-int8 ,n) - (if (< n 128) n (- n 256))) - ((make-int16 ,n1 ,n2) - (let ((n (+ (* n1 256) n2))) - (if (< n 32768) n (- n 65536)))) - ((make-char8 ,n) - (integer->char n)) - ((load-string ,s) s) - ((load-symbol ,s) (string->symbol s)) - ((load-keyword ,s) (symbol->keyword (string->symbol s))) - (else #f))) - -; (let ((c->o code->object)) -; (set! code->object -; (lambda (code) -; (format #t "code->object: ~a~%" code) -; (let ((ret (c->o code))) -; (format #t "code->object returned ~a~%" ret) -; ret)))) - -(define (code->bytes code) - (define (string->u8vector str) - (apply u8vector (map char->integer (string->list str)))) - - (let* ((code (code-pack code)) - (inst (car code)) - (rest (cdr code)) - (len (instruction-length inst)) - (head (instruction->opcode inst))) - (cond ((< len 0) - ;; Variable-length code - ;; Typical instructions are `link' and `load-program'. - (if (string? (car rest)) - (set-car! rest (string->u8vector (car rest)))) - (let* ((str (car rest)) - (str-len (u8vector-length str)) - (encoded-len (encode-length str-len)) - (encoded-len-len (u8vector-length encoded-len))) - (apply u8vector - (append (cons head (u8vector->list encoded-len)) - (u8vector->list str))))) - ((= len (length rest)) - ;; Fixed-length code - (apply u8vector (cons head rest))) - (else - (error "Invalid code:" code))))) - -; (let ((c->b code->bytes)) -; ;; XXX: Debugging output -; (set! code->bytes -; (lambda (code) -; (format #t "code->bytes: ~a~%" code) -; (let ((result (c->b code))) -; (format #t "code->bytes: returned ~a~%" result) -; result)))) - - -(define (make-byte-decoder bytes) - (let ((addr 8) (size (u8vector-length bytes))) - (define (pop) - (let ((byte (u8vector-ref bytes addr))) - (set! addr (1+ addr)) - byte)) - (define (sublist lst start end) - (take (drop lst start) (- end start))) - (lambda () - (cond - ((>= addr size) - (values #f #f #f)) - (else - (let* ((start addr) - (inst (opcode->instruction (pop)))) - (cond - ((eq? inst 'load-program) - ;; FIXME just turn it into a bytecode slice? - (pk 'yo addr size) - (let* ((len (+ 8 - (u8vector-ref bytes (+ addr 4)) - (ash (u8vector-ref bytes (+ addr 5)) 8) - (ash (u8vector-ref bytes (+ addr 6)) 16) - (ash (u8vector-ref bytes (+ addr 7)) 24))) - (end (+ len addr)) - (subbytes (sublist (u8vector->list bytes) addr end))) - (set! addr end) - (values start addr - (list inst (list->u8vector subbytes))))) - ((< (instruction-length inst) 0) - (let* ((end (+ (decode-length pop) addr)) - (subbytes (sublist - (u8vector->list bytes) - addr end))) - (set! addr end) - (values start addr - (list inst - (list->string (map integer->char subbytes)))))) - (else - ;; fixed length - (do ((n (instruction-length inst) (1- n)) - (l '() (cons (pop) l))) - ((= n 0) (values start addr (cons* inst (reverse! l))))))))))))) - - -;;; -;;; Variable-length interface -;;; - -(define (decode-length pop) - (let* ((a (pop)) (b (pop)) (c (pop))) - (+ (ash a 16) (ash b 8) c))) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm deleted file mode 100644 index 5d7ebde88..000000000 --- a/module/system/vm/disasm.scm +++ /dev/null @@ -1,183 +0,0 @@ -;;; Guile VM Disassembler - -;; Copyright (C) 2001 Free Software Foundation, Inc. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define-module (system vm disasm) - #:use-module (system base pmatch) - #:use-module (system vm objcode) - #:use-module (system vm program) - #:use-module (system vm conv) - #:use-module (ice-9 regex) - #:use-module (ice-9 format) - #:use-module (ice-9 receive) - #:export (disassemble-objcode disassemble-program disassemble-bytecode)) - -;; FIXME: the header, and arity -(define (disassemble-objcode objcode . opts) - (let* ((prog (make-program objcode)) ;; fixme: no need to make a program... - (arity (program-arity prog)) - (nlocs (arity:nlocs arity)) - (nexts (arity:nexts arity)) - (bytes (objcode->u8vector (program-objcode prog)))) - (format #t "Disassembly of ~A:\n\n" objcode) - (format #t "nlocs = ~A nexts = ~A\n\n" nlocs nexts) - (disassemble-bytecode bytes #f 0 #f #f '()))) - -(define (disassemble-program prog . opts) - (let* ((arity (program-arity prog)) - (nargs (arity:nargs arity)) - (nrest (arity:nrest arity)) - (nlocs (arity:nlocs arity)) - (nexts (arity:nexts arity)) - ;; FIXME: header and arity, etc - (bytes (objcode->u8vector (program-objcode prog))) - (objs (program-objects prog)) - (meta (program-meta prog)) - (exts (program-external prog)) - (binds (program-bindings prog)) - (blocs (and binds - (append (list-head binds nargs) - (filter (lambda (x) (not (binding:extp x))) - (list-tail binds nargs))))) - (bexts (and binds - (filter binding:extp binds))) - (srcs (program-sources prog))) - ;; Disassemble this bytecode - (format #t "Disassembly of ~A:\n\n" prog) - (format #t "Bytecode:\n\n") - (disassemble-bytecode bytes objs nargs blocs bexts srcs) - (if (pair? exts) - (disassemble-externals exts)) - (if meta - (disassemble-meta prog (meta))) - ;; Disassemble other bytecode in it - ;; FIXME: something about the module. - (if objs - (for-each - (lambda (x) - (if (program? x) - (begin (display "----------------------------------------\n") - (apply disassemble-program x opts)))) - (cddr (vector->list objs)))))) - -(define (disassemble-bytecode bytes objs nargs blocs bexts sources) - (let ((decode (make-byte-decoder bytes)) - (programs '())) - (define (lp start end code) - (pmatch code - (#f (newline)) - ((load-program ,x) - (let ((sym (gensym ""))) - (set! programs (acons sym x programs)) - (print-info start `(load-program ,sym) #f #f))) - (else - (print-info start code - (code-annotation end code objs nargs blocs bexts) - (and=> (assq end sources) source->string)))) - (if code (call-with-values decode lp))) - (call-with-values decode lp) - (for-each (lambda (sym+bytes) - (format #t "Bytecode #~A:\n\n" (car sym+bytes)) - (disassemble-bytecode (cdr sym+bytes) #f 0 #f #f '())) - (reverse! programs)))) - -(define (disassemble-objects objs) - (display "Objects:\n\n") - (let ((len (vector-length objs))) - (do ((n 0 (1+ n))) - ((= n len) (newline)) - (print-info n (vector-ref objs n) #f #f)))) - -(define (disassemble-externals exts) - (display "Externals:\n\n") - (let ((len (length exts))) - (do ((n 0 (1+ n)) - (l exts (cdr l))) - ((null? l) (newline)) - (print-info n (car l) #f #f)))) - -(define-macro (unless test . body) - `(if (not ,test) (begin ,@body))) - -(define *uninteresting-props* '(name)) - -(define (disassemble-meta program meta) - (let ((sources (cadr meta)) - (props (filter (lambda (x) - (not (memq (car x) *uninteresting-props*))) - (cddr meta)))) - (unless (null? props) - (display "Properties:\n\n") - (for-each (lambda (x) (print-info #f x #f #f)) props) - (newline)))) - -(define (source->string src) - (format #f "~a:~a:~a" (or (source:file src) "(unknown file)") - (source:line src) (source:column src))) - -(define (make-int16 byte1 byte2) - (+ (* byte1 256) byte2)) - -(define (code-annotation end-addr code objs nargs blocs bexts) - (let* ((code (code-unpack code)) - (inst (car code)) - (args (cdr code))) - (case inst - ((list vector) - (list "~a element~:p" (apply make-int16 args))) - ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null) - (list "-> ~A" (+ end-addr (apply make-int16 args)))) - ((object-ref) - (and objs (list "~s" (vector-ref objs (car args))))) - ((local-ref local-set) - (and blocs - (let ((b (list-ref blocs (car args)))) - (list "`~a'~@[ (arg)~]" - (binding:name b) (< (binding:index b) nargs))))) - ((external-ref external-set) - (and bexts - (if (< (car args) (length bexts)) - (let ((b (list-ref bexts (car args)))) - (list "`~a'~@[ (arg)~]" - (binding:name b) (< (binding:index b) nargs))) - (list "(closure variable)")))) - ((toplevel-ref toplevel-set) - (and objs - (let ((v (vector-ref objs (car args)))) - (if (and (variable? v) (variable-bound? v)) - (list "~s" (variable-ref v)) - (list "`~s'" v))))) - ((mv-call) - (list "MV -> ~A" (+ end-addr (apply make-int16 (cdr args))))) - (else - (and=> (code->object code) - (lambda (obj) (list "~s" obj))))))) - -;; i am format's daddy. -(define (print-info addr info extra src) - (format #t "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src)) - -(define (simplify x) - (cond ((string? x) - (cond ((string-index x #\newline) => - (lambda (i) (set! x (substring x 0 i))))) - (cond ((> (string-length x) 16) - (set! x (string-append (substring x 0 13) "...")))))) - x) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 6c8adf80c..a74d903da 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -54,9 +54,8 @@ ;; FIXME: the header. (define (bootstrap-frame? frame) - (let ((code (objcode->u8vector (program-objcode (frame-program frame))))) - (and (= (uniform-vector-length code) 6) - (= (uniform-vector-ref code 5) + (let ((code (objcode->bytecode (program-objcode (frame-program frame))))) + (and (= (uniform-vector-ref code (1- (uniform-vector-length code))) (instruction->opcode 'halt))))) (define (make-frame-chain frame addr) diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm index cf21220ee..209f2da54 100644 --- a/module/system/vm/objcode.scm +++ b/module/system/vm/objcode.scm @@ -20,7 +20,7 @@ ;;; Code: (define-module (system vm objcode) - #:export (objcode->u8vector objcode? bytecode->objcode + #:export (objcode? bytecode->objcode objcode->bytecode load-objcode write-objcode word-size byte-order)) diff --git a/scripts/disassemble b/scripts/disassemble index be55cf338..71ec05705 100755 --- a/scripts/disassemble +++ b/scripts/disassemble @@ -32,10 +32,10 @@ exec ${GUILE-guile} -e '(@ (scripts disassemble) disassemble)' -s $0 "$@" (define-module (scripts disassemble) #:use-module (system vm objcode) - #:use-module (system vm disasm) + #:use-module (language assembly disassemble) #:export (disassemble)) (define (disassemble args) (for-each (lambda (file) - (disassemble-objcode (load-objcode file))) + (disassemble (load-objcode file))) (cdr args))) diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm index 68379e5e1..1485fc1e6 100644 --- a/testsuite/run-vm-tests.scm +++ b/testsuite/run-vm-tests.scm @@ -19,7 +19,6 @@ (use-modules (system vm vm) - (system vm disasm) (system base compile) (system base language) (language scheme spec) |