From d7236899f5752fab1ad1e8d3e5b51cfe18abe5c7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 30 Jan 2009 14:12:57 +0100 Subject: [PATCH] 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. --- module/language/assembly/Makefile.am | 2 +- module/language/assembly/disassemble.scm | 171 +++++++++++++++++++++++ module/language/objcode/spec.scm | 21 ++- module/system/base/compile.scm | 14 +- 4 files changed, 201 insertions(+), 7 deletions(-) create mode 100644 module/language/assembly/disassemble.scm 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 diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 1cf7d6c15..f83834da9 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -181,12 +181,18 @@ time. Useful for supporting some forms of dynamic compilation. Returns (or (lookup-decompilation-order from to) (error "no way to decompile" from "to" to)))) +(define (decompile-fold passes exp env opts) + (if (null? passes) + (values exp env) + (receive (exp env) ((car passes) exp env opts) + (decompile-fold (cdr passes) exp env opts)))) + (define* (decompile x #:key (env #f) (from 'value) (to 'assembly) (opts '())) - (compile-fold (decompile-passes from to opts) - x - env - opts)) + (decompile-fold (decompile-passes from to opts) + x + env + opts))