diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-08 16:45:10 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-08 16:45:10 +0100 |
commit | f3c0b533468990a59f3495bdbde5c73b6a9bf8a6 (patch) | |
tree | 54e6287974434da4e802d2106719606b193d128c | |
parent | f7f5f49a6bc8f26031e73b6632f3dd86c755c179 (diff) | |
download | guile-f3c0b533468990a59f3495bdbde5c73b6a9bf8a6.tar.gz |
Remove assembly language.
* module/system/repl/command.scm: Remove disassembly cases for stack
procedures.
* module/system/vm/inspect.scm: Adapt to disassemble RTL programs.
* module/language/assembly.scm:
* module/language/assembly/compile-bytecode.scm:
* module/language/assembly/decompile-bytecode.scm:
* module/language/assembly/disassemble.scm:
* module/language/assembly/spec.scm: Remove assembly language.
* module/Makefile.am: Adapt.
-rw-r--r-- | module/Makefile.am | 9 | ||||
-rw-r--r-- | module/language/assembly.scm | 165 | ||||
-rw-r--r-- | module/language/assembly/compile-bytecode.scm | 178 | ||||
-rw-r--r-- | module/language/assembly/decompile-bytecode.scm | 144 | ||||
-rw-r--r-- | module/language/assembly/disassemble.scm | 171 | ||||
-rw-r--r-- | module/language/assembly/spec.scm | 35 | ||||
-rw-r--r-- | module/system/repl/command.scm | 6 | ||||
-rw-r--r-- | module/system/vm/inspect.scm | 9 |
8 files changed, 4 insertions, 713 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 21d2f08b9..2d2706ddd 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -50,12 +50,9 @@ SOURCES = \ language/tree-il/cse.scm \ \ language/tree-il.scm \ - language/assembly.scm \ $(TREE_IL_LANG_SOURCES) \ $(CPS_LANG_SOURCES) \ $(RTL_LANG_SOURCES) \ - $(GLIL_LANG_SOURCES) \ - $(ASSEMBLY_LANG_SOURCES) \ $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) \ $(VALUE_LANG_SOURCES) \ @@ -135,12 +132,6 @@ RTL_LANG_SOURCES = \ language/rtl.scm \ language/rtl/spec.scm -ASSEMBLY_LANG_SOURCES = \ - language/assembly/spec.scm \ - language/assembly/compile-bytecode.scm \ - language/assembly/decompile-bytecode.scm \ - language/assembly/disassemble.scm - BYTECODE_LANG_SOURCES = \ language/bytecode/spec.scm diff --git a/module/language/assembly.scm b/module/language/assembly.scm deleted file mode 100644 index ad8dead65..000000000 --- a/module/language/assembly.scm +++ /dev/null @@ -1,165 +0,0 @@ -;;; Guile Virtual Machine Assembly - -;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc. - -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language assembly) - #:use-module (rnrs bytevectors) - #:use-module (system base pmatch) - #:use-module (system vm instruction) - #:use-module ((srfi srfi-1) #:select (fold)) - #:export (byte-length - addr+ align-program align-code align-block - assembly-pack assembly-unpack - object->assembly assembly->object)) - -;; len, metalen -(define *program-header-len* (+ 4 4)) - -;; lengths are encoded in 3 bytes -(define *len-len* 3) - - -(define (byte-length assembly) - (pmatch assembly - ((,inst . _) (guard (>= (instruction-length inst) 0)) - (+ 1 (instruction-length inst))) - ((load-number ,str) - (+ 1 *len-len* (string-length str))) - ((load-string ,str) - (+ 1 *len-len* (string-length str))) - ((load-wide-string ,str) - (+ 1 *len-len* (* 4 (string-length str)))) - ((load-symbol ,str) - (+ 1 *len-len* (string-length str))) - ((load-array ,bv) - (+ 1 *len-len* (bytevector-length bv))) - ((load-program ,labels ,len ,meta . ,code) - (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0))) - (,label (guard (not (pair? label))) - 0) - (else (error "unknown instruction" assembly)))) - - -(define *program-alignment* 8) - -(define (addr+ addr code) - (fold (lambda (x len) (+ (byte-length x) len)) - addr - code)) - -(define (code-alignment addr alignment header-len) - (make-list (modulo (- alignment - (modulo (+ addr header-len) alignment)) - alignment) - '(nop))) - -(define (align-block addr) - '()) - -(define (align-code code addr alignment header-len) - `(,@(code-alignment addr alignment header-len) - ,code)) - -(define (align-program prog addr) - (align-code prog addr *program-alignment* 1)) - -;;; -;;; Code compress/decompression -;;; - -(define *abbreviations* - '(((make-int8 0) . (make-int8:0)) - ((make-int8 1) . (make-int8:1)))) - -(define *expansions* - (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*)) - -(define (assembly-pack code) - (or (assoc-ref *abbreviations* code) - code)) - -(define (assembly-unpack code) - (or (assoc-ref *expansions* code) - code)) - - -;;; -;;; Encoder/decoder -;;; - -(define (object->assembly x) - (cond ((eq? x #t) `(make-true)) - ((eq? x #f) `(make-false)) - ((eq? x #nil) `(make-nil)) - ((null? x) `(make-eol)) - ((and (integer? x) (exact? x)) - (cond ((and (<= -128 x) (< x 128)) - (assembly-pack `(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)))) - ((and (<= 0 x #xffffffffffffffff)) - `(make-uint64 ,@(bytevector->u8-list - (let ((bv (make-bytevector 8))) - (bytevector-u64-set! bv 0 x (endianness big)) - bv)))) - ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff)) - `(make-int64 ,@(bytevector->u8-list - (let ((bv (make-bytevector 8))) - (bytevector-s64-set! bv 0 x (endianness big)) - bv)))) - (else #f))) - ((char? x) - (cond ((<= (char->integer x) #xff) - `(make-char8 ,(char->integer x))) - (else - `(make-char32 ,(char->integer x))))) - (else #f))) - -(define (assembly->object code) - (pmatch code - ((make-true) #t) - ((make-false) #f) ;; FIXME: Same as the `else' case! - ((make-nil) #nil) - ((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-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8) - (bytevector-u64-ref - (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8)) - 0 - (endianness big))) - ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8) - (bytevector-s64-ref - (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8)) - 0 - (endianness big))) - ((make-char8 ,n) - (integer->char n)) - ((make-char32 ,n1 ,n2 ,n3 ,n4) - (integer->char (+ (* n1 #x1000000) - (* n2 #x10000) - (* n3 #x100) - n4))) - ((load-string ,s) s) - ((load-symbol ,s) (string->symbol s)) - (else #f))) diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm deleted file mode 100644 index d54186e16..000000000 --- a/module/language/assembly/compile-bytecode.scm +++ /dev/null @@ -1,178 +0,0 @@ -;;; Guile VM assembler - -;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. - -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language assembly compile-bytecode) - #:use-module (system base pmatch) - #:use-module (system base target) - #:use-module (language assembly) - #:use-module (system vm instruction) - #:use-module (rnrs bytevectors) - #:use-module ((srfi srfi-1) #:select (fold)) - #:export (compile-bytecode)) - -(define (compile-bytecode assembly env . opts) - (define-syntax-rule (define-inline1 (proc arg) body body* ...) - (define-syntax proc - (syntax-rules () - ((_ (arg-expr (... ...))) - (let ((x (arg-expr (... ...)))) - (proc x))) - ((_ arg) - (begin body body* ...))))) - - (define (fill-bytecode bv target-endianness) - (let ((pos 0)) - (define-inline1 (write-byte b) - (bytevector-u8-set! bv pos b) - (set! pos (1+ pos))) - (define u32-bv (make-bytevector 4)) - (define-inline1 (write-int24-be x) - (bytevector-s32-set! u32-bv 0 x (endianness big)) - (bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1)) - (bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2)) - (bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3)) - (set! pos (+ pos 3))) - (define-inline1 (write-uint32-be x) - (bytevector-u32-set! bv pos x (endianness big)) - (set! pos (+ pos 4))) - (define-inline1 (write-uint32 x) - (bytevector-u32-set! bv pos x target-endianness) - (set! pos (+ pos 4))) - (define-inline1 (write-loader-len len) - (bytevector-u8-set! bv pos (ash len -16)) - (bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255)) - (bytevector-u8-set! bv (+ pos 2) (logand len 255)) - (set! pos (+ pos 3))) - (define-inline1 (write-latin1-string s) - (let ((len (string-length s))) - (write-loader-len len) - (let lp ((i 0)) - (if (< i len) - (begin - (bytevector-u8-set! bv (+ pos i) - (char->integer (string-ref s i))) - (lp (1+ i))))) - (set! pos (+ pos len)))) - (define-inline1 (write-bytevector bv*) - (let ((len (bytevector-length bv*))) - (write-loader-len len) - (bytevector-copy! bv* 0 bv pos len) - (set! pos (+ pos len)))) - (define-inline1 (write-wide-string s) - (write-bytevector (string->utf32 s target-endianness))) - (define-inline1 (write-break label) - (let ((offset (- (assq-ref labels label) (+ (get-addr) 3)))) - (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset)) - ((< offset (- (ash 1 23))) (error "jump too far backwards" offset)) - (else (write-int24-be offset))))) - - (define (write-bytecode asm labels address emit-opcode?) - ;; Write ASM's bytecode to BV. If EMIT-OPCODE? is false, don't - ;; emit bytecode for the first opcode encountered. Assume code - ;; starts at ADDRESS (an integer). LABELS is assumed to be an - ;; alist mapping labels to addresses. - (define get-addr - (let ((start pos)) - (lambda () - (+ address (- pos start))))) - (define (write-break label) - (let ((offset (- (assq-ref labels label) (+ (get-addr) 3)))) - (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset)) - ((< offset (- (ash 1 23))) (error "jump too far backwards" offset)) - (else (write-int24-be offset))))) - - (let ((inst (car asm)) - (args (cdr asm))) - (let ((opcode (instruction->opcode inst)) - (len (instruction-length inst))) - (if emit-opcode? - (write-byte opcode)) - (pmatch asm - ((load-program ,labels ,length ,meta . ,code) - (write-uint32 length) - (write-uint32 (if meta (1- (byte-length meta)) 0)) - (fold (lambda (asm address) - (let ((start pos)) - (write-bytecode asm labels address #t) - (+ address (- pos start)))) - 0 - code) - (if meta - ;; Don't emit the `load-program' byte for metadata. Note that - ;; META's bytecode meets the alignment requirements of - ;; `scm_objcode', thanks to the alignment computed in `(language - ;; assembly)'. - (write-bytecode meta '() 0 #f))) - ((make-char32 ,x) (write-uint32-be x)) - ((load-number ,str) (write-latin1-string str)) - ((load-string ,str) (write-latin1-string str)) - ((load-wide-string ,str) (write-wide-string str)) - ((load-symbol ,str) (write-latin1-string str)) - ((load-array ,bv) (write-bytevector bv)) - ((br ,l) (write-break l)) - ((br-if ,l) (write-break l)) - ((br-if-not ,l) (write-break l)) - ((br-if-eq ,l) (write-break l)) - ((br-if-not-eq ,l) (write-break l)) - ((br-if-null ,l) (write-break l)) - ((br-if-not-null ,l) (write-break l)) - ((br-if-nil ,l) (write-break l)) - ((br-if-not-nil ,l) (write-break l)) - ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) - ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) - ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l)) - ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo - ,nreq-and-nopt-hi ,nreq-and-nopt-lo - ,ntotal-hi ,ntotal-lo - ,l) - (write-byte nreq-hi) - (write-byte nreq-lo) - (write-byte nreq-and-nopt-hi) - (write-byte nreq-and-nopt-lo) - (write-byte ntotal-hi) - (write-byte ntotal-lo) - (write-break l)) - ((mv-call ,n ,l) (write-byte n) (write-break l)) - ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l)) - (else - (cond - ((< len 0) - (error "unhanded variable-length instruction" asm)) - ((not (= (length args) len)) - (error "bad number of args to instruction" asm len)) - (else - (for-each (lambda (x) (write-byte x)) args)))))))) - - ;; Don't emit the `load-program' byte. - (write-bytecode assembly '() 0 #f) - (if (= pos (bytevector-length bv)) - (values bv env env) - (error "failed to fill bytevector" bv pos - (bytevector-length bv))))) - - (pmatch assembly - ((load-program ,labels ,length ,meta . ,code) - (fill-bytecode (make-bytevector (+ 4 4 length - (if meta - (1- (byte-length meta)) - 0))) - (target-endianness))) - - (else (error "bad assembly" assembly)))) diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm deleted file mode 100644 index c3469bde8..000000000 --- a/module/language/assembly/decompile-bytecode.scm +++ /dev/null @@ -1,144 +0,0 @@ -;;; Guile VM code converters - -;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc. - -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language assembly decompile-bytecode) - #:use-module (system vm instruction) - #:use-module (system base pmatch) - #:use-module (srfi srfi-4) - #:use-module (rnrs bytevectors) - #:use-module (language assembly) - #:use-module ((system vm objcode) #:select (byte-order)) - #:export (decompile-bytecode)) - -(define (decompile-bytecode x env opts) - (let ((i 0) (size (u8vector-length x))) - (define (pop) - (let ((b (cond ((< i size) (u8vector-ref x i)) - ((= i size) #f) - (else (error "tried to decode too many bytes"))))) - (if b (set! i (1+ i))) - b)) - (let ((ret (decode-load-program pop))) - (if (= i size) - (values ret env) - (error "bad bytecode: only decoded ~a out of ~a bytes" i size))))) - -(define (br-instruction? x) - (memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null br-if-not-null))) -(define (br-nargs-instruction? x) - (memq x '(br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt br-if-nargs-lt/non-kw))) - -(define (bytes->s24 a b c) - (let ((x (+ (ash a 16) (ash b 8) c))) - (if (zero? (logand (ash 1 23) x)) - x - (- x (ash 1 24))))) - -;; FIXME: this is a little-endian disassembly!!! -(define (decode-load-program pop) - (let* ((a (pop)) (b (pop)) (c (pop)) (d (pop)) - (e (pop)) (f (pop)) (g (pop)) (h (pop)) - (len (+ a (ash b 8) (ash c 16) (ash d 24))) - (metalen (+ e (ash f 8) (ash g 16) (ash h 24))) - (labels '()) - (i 0)) - (define (ensure-label rel1 rel2 rel3) - (let ((where (+ i (bytes->s24 rel1 rel2 rel3)))) - (or (assv-ref labels where) - (begin - (let ((l (gensym ":L"))) - (set! labels (acons where l labels)) - l))))) - (define (sub-pop) ;; ...records. ha. ha. - (let ((b (cond ((< i len) (pop)) - ((= i len) #f) - (else (error "tried to decode too many bytes"))))) - (if b (set! i (1+ i))) - b)) - (let lp ((out '())) - (cond ((> i len) - (error "error decoding program -- read too many bytes" out)) - ((= i len) - `(load-program ,(map (lambda (x) (cons (cdr x) (car x))) - (reverse labels)) - ,len - ,(if (zero? metalen) #f (decode-load-program pop)) - ,@(reverse! out))) - (else - (let ((exp (decode-bytecode sub-pop))) - (pmatch exp - ((,br ,rel1 ,rel2 ,rel3) (guard (br-instruction? br)) - (lp (cons `(,br ,(ensure-label rel1 rel2 rel3)) out))) - ((,br ,hi ,lo ,rel1 ,rel2 ,rel3) (guard (br-nargs-instruction? br)) - (lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3)) out))) - ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo - ,nreq-and-nopt-hi ,nreq-and-nopt-lo - ,ntotal-hi ,ntotal-lo - ,rel1 ,rel2 ,rel3) - (lp (cons `(bind-optionals/shuffle-or-br - ,nreq-hi ,nreq-lo - ,nreq-and-nopt-hi ,nreq-and-nopt-lo - ,ntotal-hi ,ntotal-lo - ,(ensure-label rel1 rel2 rel3)) - out))) - ((mv-call ,n ,rel1 ,rel2 ,rel3) - (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out))) - ((prompt ,n0 ,rel1 ,rel2 ,rel3) - (lp (cons `(prompt ,n0 ,(ensure-label rel1 rel2 rel3)) out))) - (else - (lp (cons exp out)))))))))) - -(define (decode-bytecode pop) - (and=> (pop) - (lambda (opcode) - (let ((inst (opcode->instruction opcode))) - (cond - ((eq? inst 'load-program) - (decode-load-program pop)) - - ((< (instruction-length inst) 0) - ;; the negative length indicates a variable length - ;; instruction - (let* ((make-sequence - (if (or (memq inst '(load-array load-wide-string))) - make-bytevector - make-string)) - (sequence-set! - (if (or (memq inst '(load-array load-wide-string))) - bytevector-u8-set! - (lambda (str pos value) - (string-set! str pos (integer->char value))))) - (len (let* ((a (pop)) (b (pop)) (c (pop))) - (+ (ash a 16) (ash b 8) c))) - (seq (make-sequence len))) - (let lp ((i 0)) - (if (= i len) - `(,inst ,(if (eq? inst 'load-wide-string) - (utf32->string seq (native-endianness)) - seq)) - (begin - (sequence-set! seq i (pop)) - (lp (1+ i))))))) - (else - ;; fixed length - (let lp ((n (instruction-length inst)) (out (list inst))) - (if (zero? n) - (reverse! out) - (lp (1- n) (cons (pop) out)))))))))) diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm deleted file mode 100644 index dcdd78073..000000000 --- a/module/language/assembly/disassemble.scm +++ /dev/null @@ -1,171 +0,0 @@ -;;; Guile VM code converters - -;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc. - -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language assembly disassemble) - #:use-module (ice-9 format) - #:use-module (srfi srfi-1) - #:use-module (system vm instruction) - #:use-module (system vm program) - #:use-module (system base pmatch) - #:use-module (language assembly) - #:use-module (system base compile) - #:export (disassemble)) - -(define (disassemble x) - (format #t "Disassembly of ~A:\n\n" x) - (call-with-values - (lambda () (decompile x #:from 'value #:to 'assembly)) - disassemble-load-program)) - -(define (disassemble-load-program asm env) - (pmatch asm - ((load-program ,labels ,len ,meta . ,code) - (let ((objs (and env (assq-ref env 'objects))) - (free-vars (and env (assq-ref env 'free-vars))) - (meta (and env (assq-ref env 'meta))) - (blocs (and env (assq-ref env 'blocs))) - (srcs (and env (assq-ref env 'sources)))) - (let lp ((pos 0) (code code) (programs '())) - (cond - ((null? code) - (newline) - (for-each - (lambda (sym+asm) - (format #t "Embedded program ~A:\n\n" (car sym+asm)) - (disassemble-load-program (cdr sym+asm) '())) - (reverse! programs))) - (else - (let* ((asm (car code)) - (len (byte-length asm)) - (end (+ pos len))) - (pmatch asm - ((load-program . _) - (let ((sym (gensym ""))) - (print-info pos `(load-program ,sym) #f #f) - (lp (+ pos (byte-length asm)) (cdr code) - (acons sym asm programs)))) - ((nop) - (lp (+ pos (byte-length asm)) (cdr code) programs)) - (else - (print-info pos asm - ;; FIXME: code-annotation for whether it's - ;; an arg or not, currently passing nargs=-1 - (code-annotation end asm objs -1 blocs - labels) - (and=> (and srcs (assq end srcs)) source->string)) - (lp (+ pos (byte-length asm)) (cdr code) programs))))))) - - (if (pair? free-vars) - (disassemble-free-vars free-vars)) - (if meta - (disassemble-meta meta)) - - ;; Disassemble other bytecode in it - ;; FIXME: something about the module. - (if objs - (for-each - (lambda (x) - (if (program? x) - (begin (display "----------------------------------------\n") - (disassemble x)))) - (cdr (vector->list objs)))))) - (else - (error "bad load-program form" asm)))) - -(define (disassemble-free-vars free-vars) - (display "Free variables:\n\n") - (fold (lambda (free-var i) - (print-info i free-var #f #f) - (+ 1 i)) - 0 - free-vars)) - -(define-macro (unless test . body) - `(if (not ,test) (begin ,@body))) - -(define *uninteresting-props* '(name)) - -(define (disassemble-meta meta) - (let ((props (filter (lambda (x) - (not (memq (car x) *uninteresting-props*))) - (cdddr 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-for-user src) (source:column src))) - -(define (make-int16 byte1 byte2) - (+ (* byte1 256) byte2)) - -(define (code-annotation end-addr code objs nargs blocs labels) - (let* ((code (assembly-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 - br-if-nil br-if-not-nil) - (list "-> ~A" (assq-ref labels (car args)))) - ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt) - (list "-> ~A" (assq-ref labels (caddr args)))) - ((bind-optionals/shuffle-or-br) - (list "-> ~A" (assq-ref labels (car (last-pair args))))) - ((object-ref) - (and objs (list "~s" (vector-ref objs (car args))))) - ((local-ref local-boxed-ref local-set local-boxed-set) - (and blocs - (let lp ((bindings (list-ref blocs (car args)))) - (and (pair? bindings) - (let ((b (car bindings))) - (if (and (< (binding:start (car bindings)) end-addr) - (>= (binding:end (car bindings)) end-addr)) - (list "`~a'~@[ (arg)~]" - (binding:name b) (< (binding:index b) nargs)) - (lp (cdr bindings)))))))) - ((assert-nargs-ee/locals assert-nargs-ge/locals) - (list "~a arg~:p, ~a local~:p" - (logand (car args) #x7) (ash (car args) -3))) - ((free-ref free-boxed-ref free-boxed-set) - ;; FIXME: we can do better than this - (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" (assq-ref labels (cadr args)))) - ((prompt) - ;; the H is for handler - (list "H -> ~A" (assq-ref labels (cadr args)))) - (else - (and=> (assembly->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)) diff --git a/module/language/assembly/spec.scm b/module/language/assembly/spec.scm deleted file mode 100644 index 0a497e4cf..000000000 --- a/module/language/assembly/spec.scm +++ /dev/null @@ -1,35 +0,0 @@ -;;; Guile Virtual Machine Assembly - -;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc. - -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language assembly spec) - #:use-module (system base language) - #:use-module (language assembly compile-bytecode) - #:use-module (language assembly decompile-bytecode) - #:export (assembly)) - -(define-language assembly - #:title "Guile Virtual Machine Assembly Language" - #:reader (lambda (port env) (read port)) - #:printer write - #:parser read ;; fixme: make a verifier? - #:compilers `((bytecode . ,compile-bytecode)) - #:decompilers `((bytecode . ,decompile-bytecode)) - #:for-humans? #f - ) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 1e6aaff3d..8f72430c8 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -466,7 +466,6 @@ Change languages." Generate compiled code." (let ((x (repl-compile repl (repl-parse repl form)))) (cond ((bytevector? x) (disassemble-image (load-image x))) - ((objcode? x) (guile:disassemble x)) (else (repl-print repl x))))) (define-meta-command (compile-file repl file . opts) @@ -488,9 +487,6 @@ Run the optimizer on a piece of code and print the result." (run-hook before-print-hook x) (pp x))) -(define (guile:disassemble x) - ((@ (language assembly disassemble) disassemble) x)) - (define-meta-command (disassemble repl (form)) "disassemble EXP Disassemble a compiled procedure." @@ -500,8 +496,6 @@ Disassemble a compiled procedure." (disassemble-program obj)) ((bytevector? obj) (disassemble-image (load-image obj))) - ((or (program? obj) (objcode? obj)) - (guile:disassemble obj)) (else (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%" obj))))) diff --git a/module/system/vm/inspect.scm b/module/system/vm/inspect.scm index 1023437bf..1f6d99d19 100644 --- a/module/system/vm/inspect.scm +++ b/module/system/vm/inspect.scm @@ -1,6 +1,6 @@ ;;; Guile VM debugging facilities -;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -23,8 +23,7 @@ #:use-module (system base syntax) #:use-module (system vm vm) #:use-module (system vm frame) - #:use-module ((language assembly disassemble) - #:select ((disassemble . %disassemble))) + #:use-module (system vm disassembler) #:use-module (ice-9 rdelim) #:use-module (ice-9 pretty-print) #:use-module (ice-9 format) @@ -112,10 +111,10 @@ (display x)) (define-command ((commands disassemble x)) - "Disassemble the current object, which should be objcode or a procedure." + "Disassemble the current object, which should be a procedure." (catch #t (lambda () - (%disassemble x)) + (disassemble-program x)) (lambda args (format #t "Error disassembling object: ~a\n" args)))) |