summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-01-30 14:12:57 +0100
committerAndy Wingo <wingo@pobox.com>2009-01-30 14:12:57 +0100
commitd7236899f5752fab1ad1e8d3e5b51cfe18abe5c7 (patch)
treef91d833a7d8a048d81b8cd5e62d9b40a77958a53 /module/language
parent7b107cceb9adcc966b639fd2c217f4708b53a2aa (diff)
downloadguile-d7236899f5752fab1ad1e8d3e5b51cfe18abe5c7.tar.gz
add disassembler that fits in with old compiler tower
* module/language/assembly/Makefile.am: * module/language/assembly/disassemble.scm: Add a disassembler, based on the old one but fitting in with the decompiler tower. * module/language/objcode/spec.scm (decompile-value): When decompiling programs, shove all the metadata that we know about into the "env". * module/system/base/compile.scm (decompile-fold, decompile): Return the env from `decompile' as a second value. Not sure if `compile' should do this too.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/assembly/Makefile.am2
-rw-r--r--module/language/assembly/disassemble.scm171
-rw-r--r--module/language/objcode/spec.scm21
3 files changed, 191 insertions, 3 deletions
diff --git a/module/language/assembly/Makefile.am b/module/language/assembly/Makefile.am
index 468daf081..081aab384 100644
--- a/module/language/assembly/Makefile.am
+++ b/module/language/assembly/Makefile.am
@@ -1,3 +1,3 @@
-SOURCES = spec.scm compile-bytecode.scm decompile-bytecode.scm
+SOURCES = spec.scm compile-bytecode.scm decompile-bytecode.scm disassemble.scm
modpath = language/assembly
include $(top_srcdir)/am/guilec
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
new file mode 100644
index 000000000..7c7ba15e2
--- /dev/null
+++ b/module/language/assembly/disassemble.scm
@@ -0,0 +1,171 @@
+;;; 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 (language assembly disassemble)
+ #:use-module (ice-9 format)
+ #: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 ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code)
+ (let ((objs (and env (assq-ref env 'objects)))
+ (meta (and env (assq-ref env 'meta)))
+ (exts (and env (assq-ref env 'exts)))
+ (blocs (and env (assq-ref env 'blocs)))
+ (bexts (and env (assq-ref env 'bexts)))
+ (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))))
+ (else
+ (print-info pos asm
+ (code-annotation end asm objs nargs blocs bexts)
+ (and=> (and srcs (assq end srcs)) source->string))
+ (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
+
+ (if (pair? exts)
+ (disassemble-externals exts))
+ (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))))
+ (cddr (vector->list objs))))))
+ (else
+ (error "bad load-program form" asm))))
+
+(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 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 (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)
+ (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=> (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))
+
+(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/language/objcode/spec.scm b/module/language/objcode/spec.scm
index ce67dcff5..d4212be48 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -46,8 +46,25 @@
(define (decompile-value x env opts)
(cond
((program? x)
- (values (program-objcode x)
- (cons (program-objects x) (program-externals x))))
+ (let ((objs (program-objects x))
+ (meta (program-meta x))
+ (exts (program-external x))
+ (binds (program-bindings x))
+ (srcs (program-sources x))
+ (nargs (arity:nargs (program-arity x))))
+ (let ((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))))
+ (values (program-objcode x)
+ `((objects . ,objs)
+ (meta . ,(and meta (meta)))
+ (exts . ,exts)
+ (blocs . ,blocs)
+ (bexts . ,bexts)
+ (sources . ,srcs))))))
((objcode? x)
(values x #f))
(else