summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-08 16:45:10 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-08 16:45:10 +0100
commitf3c0b533468990a59f3495bdbde5c73b6a9bf8a6 (patch)
tree54e6287974434da4e802d2106719606b193d128c
parentf7f5f49a6bc8f26031e73b6632f3dd86c755c179 (diff)
downloadguile-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.am9
-rw-r--r--module/language/assembly.scm165
-rw-r--r--module/language/assembly/compile-bytecode.scm178
-rw-r--r--module/language/assembly/decompile-bytecode.scm144
-rw-r--r--module/language/assembly/disassemble.scm171
-rw-r--r--module/language/assembly/spec.scm35
-rw-r--r--module/system/repl/command.scm6
-rw-r--r--module/system/vm/inspect.scm9
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))))