summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/objcodes.c4
-rw-r--r--libguile/objcodes.h2
-rw-r--r--module/language/bytecode/spec.scm2
-rw-r--r--module/system/repl/command.scm8
-rw-r--r--module/system/vm/Makefile.am3
-rw-r--r--module/system/vm/conv.scm186
-rw-r--r--module/system/vm/disasm.scm183
-rw-r--r--module/system/vm/frame.scm5
-rw-r--r--module/system/vm/objcode.scm2
-rwxr-xr-xscripts/disassemble4
-rw-r--r--testsuite/run-vm-tests.scm1
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)