mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
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.
This commit is contained in:
Andy Wingo
parent
d7236899f5
commit
9bb8012dd6
11 changed files with 15 additions and 385 deletions
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,6 @@
|
|||
|
||||
|
||||
(use-modules (system vm vm)
|
||||
(system vm disasm)
|
||||
(system base compile)
|
||||
(system base language)
|
||||
(language scheme spec)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue