[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-922-gbe41919
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-922-gbe41919 |
|
Date: |
Wed, 01 May 2013 20:46:01 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=be41919594ecce43fb34f2c46a7f90ac0266cde7
The branch, wip-rtl has been updated
via be41919594ecce43fb34f2c46a7f90ac0266cde7 (commit)
via c20e6d6a83422348b3e550420f7044700d13b6a9 (commit)
via 5435777906d9ab5ab4baa9ba7a121fa03689ae69 (commit)
via 8365264c818dabbbe243b5b2b704f1c612f7a745 (commit)
via ed399953e59f74f018e56ecc47849d42070acb89 (commit)
from 76068c2a97f745c55312b9471aad9a28283e3d15 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit be41919594ecce43fb34f2c46a7f90ac0266cde7
Author: Andy Wingo <address@hidden>
Date: Wed May 1 22:45:19 2013 +0200
disassemble-program for rtl
* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm:
* module/system/vm/rtl.scm: Split rtl.scm into two modules: an assembler
and a disassembler. The disassembler works now. Fixed a couple bugs
related to symbol table creation.
* module/Makefile.am:
* test-suite/tests/rtl.test: Adapt.
commit c20e6d6a83422348b3e550420f7044700d13b6a9
Author: Andy Wingo <address@hidden>
Date: Wed May 1 22:20:15 2013 +0200
fix linker bug
* module/system/vm/linker.scm (add-elf-objects): Fix bug in which
shentsize was specified as phentsize.
commit 5435777906d9ab5ab4baa9ba7a121fa03689ae69
Author: Andy Wingo <address@hidden>
Date: Wed May 1 22:19:36 2013 +0200
export find-mapped-elf-image from (system vm objcode)
* module/system/vm/objcode.scm: Export find-mapped-elf-image.
commit 8365264c818dabbbe243b5b2b704f1c612f7a745
Author: Andy Wingo <address@hidden>
Date: Wed May 1 22:19:04 2013 +0200
add rtl program predicate and accessor to programs.c
* libguile/programs.c (scm_rtl_program_code): New procedure.
(scm_rtl_program_p): New procedure.
* module/system/vm/program.scm: Export the new functions.
commit ed399953e59f74f018e56ecc47849d42070acb89
Author: Andy Wingo <address@hidden>
Date: Wed May 1 22:17:51 2013 +0200
new helpers in elf.scm
* module/system/vm/elf.scm (elf-section-by-name): New helper.
(elf-symbol-table-len): New helper.
-----------------------------------------------------------------------
Summary of changes:
libguile/programs.c | 23 ++-
libguile/programs.h | 5 +-
module/Makefile.am | 3 +-
module/system/vm/{rtl.scm => assembler.scm} | 209 ++-----------------
module/system/vm/disassembler.scm | 301 +++++++++++++++++++++++++++
module/system/vm/elf.scm | 22 ++-
module/system/vm/linker.scm | 2 +-
module/system/vm/objcode.scm | 5 +-
module/system/vm/program.scm | 1 +
test-suite/tests/rtl.test | 2 +-
10 files changed, 373 insertions(+), 200 deletions(-)
rename module/system/vm/{rtl.scm => assembler.scm} (81%)
create mode 100644 module/system/vm/disassembler.scm
diff --git a/libguile/programs.c b/libguile/programs.c
index 971ea9d..eb5972a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 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
@@ -99,6 +99,18 @@ SCM_DEFINE (scm_make_rtl_program, "make-rtl-program", 1, 2,
0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_rtl_program_code
+{
+ SCM_VALIDATE_RTL_PROGRAM (1, program);
+
+ /* FIXME: we need scm_from_uintptr (). */
+ return scm_from_size_t ((size_t) SCM_RTL_PROGRAM_CODE (program));
+}
+#undef FUNC_NAME
+
void
scm_i_rtl_program_print (SCM program, SCM port, scm_print_state *pstate)
{
@@ -161,6 +173,15 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_rtl_program_p
+{
+ return scm_from_bool (SCM_RTL_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
(SCM program),
"")
diff --git a/libguile/programs.h b/libguile/programs.h
index f2d519c..732594c 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 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
@@ -32,6 +32,7 @@
#define SCM_RTL_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_RTL_PROGRAM_FREE_VARIABLES
(x)[i])
#define SCM_RTL_PROGRAM_FREE_VARIABLE_SET(x,i,v)
(SCM_RTL_PROGRAM_FREE_VARIABLES (x)[i]=(v))
#define SCM_RTL_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
+#define SCM_VALIDATE_RTL_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, RTL_PROGRAM_P)
static inline SCM
scm_i_make_rtl_program (const scm_t_uint32 *code)
@@ -40,6 +41,8 @@ scm_i_make_rtl_program (const scm_t_uint32 *code)
}
SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM byte_offset, SCM
free_variables);
+SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
+SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
SCM_INTERNAL void scm_i_rtl_program_print (SCM program, SCM port,
scm_print_state *pstate);
diff --git a/module/Makefile.am b/module/Makefile.am
index c696b59..9e10f20 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -354,7 +354,8 @@ SYSTEM_SOURCES = \
system/vm/trace.scm \
system/vm/traps.scm \
system/vm/trap-state.scm \
- system/vm/rtl.scm \
+ system/vm/assembler.scm \
+ system/vm/disassembler.scm \
system/vm/vm.scm \
system/foreign.scm \
system/xref.scm \
diff --git a/module/system/vm/rtl.scm b/module/system/vm/assembler.scm
similarity index 81%
rename from module/system/vm/rtl.scm
rename to module/system/vm/assembler.scm
index ea0cbc2..7c7fb48 100644
--- a/module/system/vm/rtl.scm
+++ b/module/system/vm/assembler.scm
@@ -1,4 +1,4 @@
-;;; Guile VM program functions
+;;; Guile RTL assembler
;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
;;;
@@ -18,12 +18,11 @@
;;; Code:
-(define-module (system vm rtl)
+(define-module (system vm assembler)
#:use-module (system base target)
#:use-module (system vm instruction)
#:use-module (system vm elf)
#:use-module (system vm linker)
- #:use-module (system vm program)
#:use-module (system vm objcode)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 vlist)
@@ -36,30 +35,6 @@
link-assembly
assemble-program))
-;;; TODO:
-;;;
-;;; * Make it possible to disassemble a function
-;;; ** Writing function ranges into an ELF section
-;;; *** sorted .symtab section, writing ELF symbols
-;;; ** Being able to determine the bounds of a function
-;;; ** Applying the existing disassemble-buffer function
-;;; ** Write table mapping function IP to name
-;;; ** Making disassemble-buffer better
-;;;
-;;; * Provide line number information
-;;; ** Provide additional macro-assembly for this
-;;; ** Write to separate ELF section: .debug_lines
-;;;
-;;; * More metadata
-;;; Arities, local variable names and ranges, other literal procedure
-;;; metadata
-;;; ** Write to separate ELF section: .debug_info
-;;;
-;;; .symtab and .debug_info (and to an extent, .debug_aranges et al) are
-;;; redundant, but since .symtab is so much smaller and easier it's
-;;; probably OK to duplicate the information, at least while we
-;;; bootstrap the new tools.
-
(define-syntax-rule (pack-u8-u24 x y)
(logior x (ash y 8)))
@@ -334,160 +309,6 @@
(visit-opcodes define-assembler)
-(define-syntax disassembler
- (lambda (x)
- (define (parse-first-word exp type)
- #`(let ((word #,exp))
- #,(case type
- ((U8_X24)
- #'(list))
- ((U8_U24)
- #'(list (ash word -8)))
- ((U8_L24)
- ;; Fixme: translate back to label
- #'(list (ash word -8)))
- ((U8_R24)
- ;; FIXME: parse rest instructions correctly
- #'(list (ash word -8)))
- ((U8_U8_I16)
- #'(list (logand (ash word -8) #xff)
- (ash word -16)))
- ((U8_U12_U12)
- #'(list (logand (ash word -8) #xfff)
- (ash word -20)))
- ((U8_U8_U8_U8)
- #'(list (logand (ash word -8) #xff)
- (logand (ash word -16) #xff)
- (ash word -24)))
- (else
- (error "bad kind" type)))))
-
- (define (parse-tail-word buf offset n type)
- #`(let ((word (u32-ref #,buf (+ #,offset #,n))))
- #,(case type
- ((U8_X24)
- #'(list (logand word #ff)))
- ((U8_U24)
- #'(list (logand word #xff)
- (ash word -8)))
- ((U8_L24)
- ;; Fixme: translate back to label
- #'(list (logand word #xff)
- (ash word -8)))
- ((U8_R24)
- ;; FIXME: parse rest instructions correctly
- #'(list (logand word #xff)
- (ash word -8)))
- ((U8_U8_I16)
- ;; FIXME: immediates
- #'(list (logand word #xff)
- (logand (ash word -8) #xff)
- (ash word -16)))
- ((U8_U12_U12)
- #'(list (logand word #xff)
- (logand (ash word -8) #xfff)
- (ash word -20)))
- ((U8_U8_U8_U8)
- #'(list (logand word #xff)
- (logand (ash word -8) #xff)
- (logand (ash word -16) #xff)
- (ash word -24)))
- ((U32)
- #'(list word))
- ((I32)
- ;; FIXME: immediates
- #'(list word))
- ((A32)
- ;; FIXME: long immediates
- #'(list word))
- ((B32)
- ;; FIXME: long immediates
- #'(list word))
- ((N32)
- ;; FIXME: non-immediate
- #'(list word))
- ((S32)
- ;; FIXME: indirect access
- #'(list word))
- ((L32)
- ;; FIXME: offset
- #'(list word))
- ((LO32)
- ;; FIXME: offset
- #'(list word))
- ((X8_U24)
- #'(list (ash word -8)))
- ((X8_U12_U12)
- #'(list (logand (ash word -8) #xfff)
- (ash word -20)))
- ((X8_R24)
- ;; FIXME: rest
- #'(list (ash word -8)))
- ((X8_L24)
- ;; FIXME: label
- #'(list (ash word -8)))
- ((U1_X7_L24)
- ;; FIXME: label
- #'(list (logand word #x1)
- (ash word -8)))
- ((U1_U7_L24)
- ;; FIXME: label
- #'(list (logand word #x1)
- (logand (ash word -1) #x7f)
- (ash word -8)))
- (else
- (error "bad kind" type)))))
-
- (syntax-case x ()
- ((_ name opcode word0 word* ...)
- (with-syntax ((asm
- (parse-first-word #'first
- (syntax->datum #'word0)))
- ((asm* ...)
- (map (lambda (word n)
- (parse-tail-word #'buf #'offset (1+ n)
- word))
- (syntax->datum #'(word* ...))
- (iota (length #'(word* ...))))))
- #'(lambda (buf offset first)
- (values (+ 1 (length '(word* ...)))
- (cons 'name (append asm asm* ...)))))))))
-
-(define (disasm-invalid buf offset first)
- (error "bad instruction" (logand first #xff) first buf offset))
-
-(define disassemblers (make-vector 256 disasm-invalid))
-
-(define-syntax define-disassembler
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode arg ...)
- (with-syntax ((parse (id-append #'name #'parse- #'name)))
- #'(let ((parse (disassembler name opcode arg ...)))
- (vector-set! disassemblers opcode parse)))))))
-
-(visit-opcodes define-disassembler)
-
-;; -> len list
-(define (disassemble-one buf offset)
- (let ((first (u32-ref buf offset)))
- ((vector-ref disassemblers (logand first #xff)) buf offset first)))
-
-;; -> list
-(define* (disassemble-buffer buf #:optional
- (offset 0)
- (end (u32vector-length buf)))
-
- (let ((locals (u32-ref buf offset))
- (meta (s32-ref buf (1+ offset))))
- (let lp ((offset (+ offset 2))
- (out '()))
- (if (< offset end)
- (call-with-values (lambda () (disassemble-one buf offset))
- (lambda (len elt)
- (lp (+ offset len) (cons elt out))))
- (cons* locals meta (reverse out))))))
-
(define-inlinable (immediate? x)
(not (zero? (logand (object-address x) 6))))
@@ -1012,20 +833,26 @@
(write-elf-symbol bv (* n size) endianness word-size
(make-elf-symbol
#:name name
- #:value (meta-low-pc meta)
- #:size (- (meta-high-pc meta) (meta-low-pc meta))
+ ;; Symbol value and size are measured in
+ ;; bytes, not u32s.
+ #:value (* 4 (meta-low-pc meta))
+ #:size (* 4 (- (meta-high-pc meta)
+ (meta-low-pc meta)))
#:type STT_FUNC
#:visibility STV_HIDDEN
#:shndx (elf-section-index text-section)))))
meta (iota n))
- (values (make-object asm '.symtab
- bv
- '() '()
- #:type SHT_SYMTAB #:flags 0)
- (make-object asm '.strtab
- (link-string-table strtab)
- '() '()
- #:type SHT_STRTAB #:flags 0))))
+ (let ((strtab (make-object asm '.strtab
+ (link-string-table strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.symtab
+ bv
+ '() '()
+ #:type SHT_SYMTAB #:flags 0 #:entsize size
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
(define (link-objects asm)
(let*-values (((ro rw rw-init) (link-constants asm))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
new file mode 100644
index 0000000..1c3a305
--- /dev/null
+++ b/module/system/vm/disassembler.scm
@@ -0,0 +1,301 @@
+;;; Guile RTL disassembler
+
+;;; 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 (system vm disassembler)
+ #:use-module (system vm instruction)
+ #:use-module (system vm elf)
+ #:use-module (system vm program)
+ #:use-module (system vm objcode)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:export (disassemble-program))
+
+(define-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (rtl-instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...))))))
+
+(eval-when (expand compile load eval)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
+
+(define-syntax join-subformats
+ (lambda (x)
+ (syntax-case x ()
+ ((_)
+ #f)
+ ((_ #f rest ...)
+ #'(join-subformats rest ...))
+ ((_ (fmt arg ...))
+ (string? (syntax->datum #'fmt))
+ #'(list fmt arg ...))
+ ((_ (fmt arg ...) #f rest ...)
+ (string? (syntax->datum #'fmt))
+ #'(join-subformats (fmt arg ...) rest ...))
+ ((_ (fmt arg ...) (fmt* arg* ...) rest ...)
+ (and (string? (syntax->datum #'fmt)) (string? (syntax->datum #'fmt*)))
+ (let ((fmt** (string-append (syntax->datum #'fmt)
+ ", "
+ (syntax->datum #'fmt*))))
+ #`(join-subformats (#,fmt** arg ... arg* ...) rest ...))))))
+
+(define (make-immediate n)
+ (pointer->scm (make-pointer n)))
+
+(define-syntax disassembler
+ (lambda (x)
+ (define (parse-first-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'(()
+ #f))
+ ((U8_U24)
+ #'(((ash word -8))
+ #f))
+ ((U8_L24)
+ ;; Fixme: translate back to label
+ #'(((ash word -8))
+ #f))
+ ((U8_R24)
+ ;; FIXME: parse rest instructions correctly
+ #'(((ash word -8))
+ #f))
+ ((U8_U8_I16)
+ #'(((logand (ash word -8) #xff)
+ (ash word -16))
+ ("~S" (make-immediate (ash word -16)))))
+ ((U8_U12_U12)
+ #'(((logand (ash word -8) #xfff)
+ (ash word -20))
+ #f))
+ ((U8_U8_U8_U8)
+ #'(((logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24))
+ #f))
+ (else
+ (error "bad kind" type)))))
+
+ (define (parse-tail-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'(((logand word #ff))
+ #f))
+ ((U8_U24)
+ #'(((logand word #xff)
+ (ash word -8))
+ #f))
+ ((U8_L24)
+ ;; Fixme: translate back to label
+ #'(((logand word #xff)
+ (ash word -8))
+ #f))
+ ((U8_R24)
+ ;; FIXME: parse rest instructions correctly
+ #'(((logand word #xff)
+ (ash word -8))
+ #f))
+ ((U8_U8_I16)
+ ;; FIXME: immediates
+ #'(((logand word #xff)
+ (logand (ash word -8) #xff)
+ (ash word -16))
+ #f))
+ ((U8_U12_U12)
+ #'(((logand word #xff)
+ (logand (ash word -8) #xfff)
+ (ash word -20))
+ #f))
+ ((U8_U8_U8_U8)
+ #'(((logand word #xff)
+ (logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24))
+ #f))
+ ((U32)
+ #'((word)
+ #f))
+ ((I32)
+ ;; FIXME: immediates
+ #'((word)
+ #f))
+ ((A32)
+ ;; FIXME: long immediates
+ #'((word)
+ #f))
+ ((B32)
+ ;; FIXME: long immediates
+ #'((word)
+ #f))
+ ((N32)
+ ;; FIXME: non-immediate
+ #'((word)
+ #f))
+ ((S32)
+ ;; FIXME: indirect access
+ #'((word)
+ #f))
+ ((L32)
+ ;; FIXME: offset
+ #'((word)
+ #f))
+ ((LO32)
+ ;; FIXME: offset
+ #'((word)
+ #f))
+ ((X8_U24)
+ #'(((ash word -8))
+ #f))
+ ((X8_U12_U12)
+ #'(((logand (ash word -8) #xfff)
+ (ash word -20))
+ #f))
+ ((X8_R24)
+ ;; FIXME: rest
+ #'(((ash word -8))
+ #f))
+ ((X8_L24)
+ ;; FIXME: label
+ #'(((ash word -8))
+ #f))
+ ((U1_X7_L24)
+ ;; FIXME: label
+ #'(((logand word #x1)
+ (ash word -8))
+ #f))
+ ((U1_U7_L24)
+ ;; FIXME: label
+ #'(((logand word #x1)
+ (logand (ash word -1) #x7f)
+ (ash word -8))
+ #f))
+ (else
+ (error "bad kind" type)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (let ((vars (generate-temporaries #'(word* ...))))
+ (with-syntax (((word* ...) vars)
+ ((n ...) (map 1+ (iota (length #'(word* ...)))))
+ (((asm ...) note)
+ (parse-first-word #'first (syntax->datum #'word0)))
+ ((((asm* ...) note*) ...)
+ (map (lambda (word type)
+ (parse-tail-word word type))
+ vars
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (buf offset first)
+ (let ((word* (u32-ref buf (+ offset n)))
+ ...)
+ (values (+ 1 (length '(word* ...)))
+ (list 'name asm ... asm* ... ...)
+ (join-subformats note note* ...))))))))))
+
+(define (disasm-invalid buf offset first)
+ (error "bad instruction" (logand first #xff) first buf offset))
+
+(define disassemblers (make-vector 256 disasm-invalid))
+
+(define-syntax define-disassembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode arg ...)
+ (with-syntax ((parse (id-append #'name #'parse- #'name)))
+ #'(let ((parse (disassembler name opcode arg ...)))
+ (vector-set! disassemblers opcode parse)))))))
+
+(visit-opcodes define-disassembler)
+
+;; -> len list
+(define (disassemble-one buf offset)
+ (let ((first (u32-ref buf offset)))
+ ((vector-ref disassemblers (logand first #xff)) buf offset first)))
+
+(define (find-elf-symbol elf text-offset)
+ (and=>
+ (elf-section-by-name elf ".symtab")
+ (lambda (symtab)
+ (let ((len (elf-symbol-table-len symtab))
+ (strtab (elf-section elf (elf-section-link symtab))))
+ ;; The symbols should be sorted, but maybe somehow that fails
+ ;; (for example if multiple objects are relinked together). So,
+ ;; a modicum of tolerance.
+ (define (bisect)
+ #f)
+ (define (linear-search)
+ (let lp ((n 0))
+ (and (< n len)
+ (let ((sym (elf-symbol-table-ref elf symtab n strtab)))
+ (if (and (<= (elf-symbol-value sym) text-offset)
+ (< text-offset (+ (elf-symbol-value sym)
+ (elf-symbol-size sym))))
+ sym
+ (lp (1+ n)))))))
+ (or (bisect) (linear-search))))))
+
+(define (print-info port addr info extra src)
+ (format port "address@hidden address@hidden;; address@hidden@[~61t at
~a~]\n"
+ addr info extra src))
+
+(define* (disassemble-program program #:optional (port (current-output-port)))
+ (let* ((code (rtl-program-code program))
+ (bv (find-mapped-elf-image code))
+ (elf (parse-elf bv))
+ (base (pointer-address (bytevector->pointer (elf-bytes elf))))
+ (text-base (elf-section-offset
+ (or (elf-section-by-name elf ".rtl-text")
+ (error "ELF object has no text section")))))
+ (cond
+ ((find-elf-symbol elf (- code base text-base))
+ => (lambda (sym)
+ ;; The text-base, symbol value, and symbol size are in bytes,
+ ;; but the disassembler operates on u32 units.
+ (let ((start (/ (+ (elf-symbol-value sym) text-base) 4))
+ (size (/ (elf-symbol-size sym) 4)))
+ (format port "Disassembly of ~A at #x~X:\n\n"
+ (elf-symbol-name sym) code)
+ (let lp ((offset 0))
+ (when (< offset size)
+ (call-with-values (lambda ()
+ (disassemble-one bv (+ start offset)))
+ (lambda (len elt extra)
+ (print-info port offset elt extra #f)
+ (lp (+ offset len)))))))))
+ (else
+ (format port "Debugging information unavailable.~%")))
+ (values)))
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index 2f4dee6..5167459 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -123,8 +123,8 @@
parse-elf
elf-segment elf-segments
- elf-section elf-sections elf-sections-by-name
- elf-symbol-table-ref
+ elf-section elf-sections elf-section-by-name elf-sections-by-name
+ elf-symbol-table-len elf-symbol-table-ref
parse-elf-note
elf-note-name elf-note-desc elf-note-type))
@@ -796,6 +796,17 @@
(utf8->string out))
(lp (1+ end)))))
+(define (elf-section-by-name elf name)
+ (let ((off (elf-section-offset (elf-section elf (elf-shstrndx elf)))))
+ (let lp ((n (elf-shnum elf)))
+ (and (> n 0)
+ (let ((section (elf-section elf (1- n))))
+ (if (equal? (string-table-ref (elf-bytes elf)
+ (+ off (elf-section-name section)))
+ name)
+ section
+ (lp (1- n))))))))
+
(define (elf-sections-by-name elf)
(let* ((sections (elf-sections elf))
(off (elf-section-offset (list-ref sections (elf-shstrndx elf)))))
@@ -895,6 +906,13 @@
(else (error "invalid word size" word-size)))
bv offset byte-order sym))
+(define (elf-symbol-table-len section)
+ (let ((len (elf-section-size section))
+ (entsize (elf-section-entsize section)))
+ (unless (and (not (zero? entsize)) (zero? (modulo len entsize)))
+ (error "bad symbol table" section))
+ (/ len entsize)))
+
(define* (elf-symbol-table-ref elf section n #:optional strtab)
(let ((bv (elf-bytes elf))
(byte-order (elf-byte-order elf))
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index 0be5eba..8407462 100644
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -398,7 +398,7 @@
(define (make-header phnum index shoff-label)
(let* ((header (make-elf #:byte-order endianness #:word-size word-size
#:phoff phoff #:phnum phnum #:phentsize phentsize
- #:shoff 0 #:shnum shnum #:shentsize phentsize
+ #:shoff 0 #:shnum shnum #:shentsize shentsize
#:shstrndx (or (find-shstrndx objects)
SHN_UNDEF)))
(shoff-reloc (make-linker-reloc reloc-kind
(elf-header-shoff-offset word-size)
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index f939a55..e2a93d7 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -1,6 +1,6 @@
;;; Guile VM object code
-;; Copyright (C) 2001, 2010, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
@@ -22,7 +22,8 @@
#:export (objcode? objcode-meta
bytecode->objcode objcode->bytecode
load-thunk-from-file load-thunk-from-memory
- word-size byte-order))
+ word-size byte-order
+ find-mapped-elf-image))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_objcodes")
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 47dc927..1875093 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -44,6 +44,7 @@
program-meta
program-objcode program? program-objects
+ rtl-program? rtl-program-code
program-module program-base
program-free-variables
program-num-free-variables
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index 219407c..74a7ff3 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -18,7 +18,7 @@
(define-module (tests rtl)
#:use-module (test-suite lib)
- #:use-module (system vm rtl))
+ #:use-module (system vm assembler))
(define-syntax-rule (assert-equal val expr)
(let ((x val))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-922-gbe41919,
Andy Wingo <=