summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
Diffstat (limited to 'module/system')
-rw-r--r--module/system/base/compile.scm11
-rw-r--r--module/system/base/target.scm2
-rw-r--r--module/system/foreign.scm4
-rw-r--r--module/system/repl/command.scm79
-rw-r--r--module/system/repl/common.scm15
-rw-r--r--module/system/repl/debug.scm27
-rw-r--r--module/system/repl/error-handling.scm6
-rw-r--r--module/system/vm/assembler.scm2074
-rw-r--r--module/system/vm/coverage.scm370
-rw-r--r--module/system/vm/debug.scm626
-rw-r--r--module/system/vm/disassembler.scm473
-rw-r--r--module/system/vm/dwarf.scm1852
-rw-r--r--module/system/vm/elf.scm1008
-rw-r--r--module/system/vm/frame.scm36
-rw-r--r--module/system/vm/inspect.scm9
-rw-r--r--module/system/vm/instruction.scm28
-rw-r--r--module/system/vm/linker.scm668
-rw-r--r--module/system/vm/loader.scm (renamed from module/system/vm/objcode.scm)13
-rw-r--r--module/system/vm/program.scm214
-rw-r--r--module/system/vm/trace.scm64
-rw-r--r--module/system/vm/trap-state.scm26
-rw-r--r--module/system/vm/traps.scm258
-rw-r--r--module/system/vm/vm.scm9
-rw-r--r--module/system/xref.scm143
24 files changed, 7321 insertions, 694 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index c522b74b5..d6a53d6b3 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -133,7 +133,7 @@
(define* (compile-file file #:key
(output-file #f)
(from (current-language))
- (to 'objcode)
+ (to 'bytecode)
(env (default-environment from))
(opts '())
(canonicalization 'relative))
@@ -150,7 +150,8 @@
(call-with-output-file/atomic comp
(lambda (port)
((language-printer (ensure-language to))
- (read-and-compile in #:env env #:from from #:to to #:opts opts)
+ (read-and-compile in #:env env #:from from #:to to #:opts
+ (cons* #:to-file? #t opts))
port))
file)
comp)))
@@ -206,7 +207,7 @@
(define* (read-and-compile port #:key
(from (current-language))
- (to 'objcode)
+ (to 'bytecode)
(env (default-environment from))
(opts '()))
(let ((from (ensure-language from))
@@ -270,8 +271,8 @@
(define* (decompile x #:key
(env #f)
- (from 'value)
- (to 'assembly)
+ (from 'tree-il)
+ (to 'scheme)
(opts '()))
(decompile-fold (decompile-passes from to opts)
x
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index c74ae679d..ce5ff33d6 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -35,8 +35,6 @@
;;;
(define %native-word-size
- ;; The native word size. Note: don't use `word-size' from
- ;; (system vm objcode) to avoid a circular dependency.
((@ (system foreign) sizeof) '*))
(define %target-type (make-fluid %host-type))
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index e4db6ffb3..01a71b8b9 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -192,10 +192,6 @@ which does the reverse. PRINT must name a user-defined object printer."
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
(let ((ptr->obj (make-weak-value-hash-table 3000)))
(lambda (ptr)
- ;; XXX: We can't use `hash-create-handle!' +
- ;; `set-cdr!' here because the former would create a
- ;; weak-cdr pair but the latter wouldn't register a
- ;; disappearing link (see `scm_hash_fn_set_x'.)
(or (hash-ref ptr->obj ptr)
(let ((o (%wrap ptr)))
(hash-set! ptr->obj ptr o)
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 8ad00da08..62bc2977a 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,6 +1,6 @@
;;; Repl commands
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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
@@ -25,11 +25,11 @@
#:use-module (system base compile)
#:use-module (system repl common)
#:use-module (system repl debug)
- #:use-module (system vm objcode)
+ #:use-module (system vm disassembler)
+ #:use-module (system vm loader)
#:use-module (system vm program)
#:use-module (system vm trap-state)
#:use-module (system vm vm)
- #:use-module ((system vm frame) #:select (frame-return-values))
#:autoload (system base language) (lookup-language language-reader)
#:autoload (system vm trace) (call-with-trace)
#:use-module (ice-9 format)
@@ -40,6 +40,7 @@
#:use-module (ice-9 control)
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
+ #:use-module (rnrs bytevectors)
#:use-module (statprof)
#:export (meta-command define-meta-command))
@@ -456,11 +457,15 @@ Change languages."
;;; Compile commands
;;;
+(define (load-image x)
+ (let ((thunk (load-thunk-from-memory x)))
+ (find-mapped-elf-image (program-code thunk))))
+
(define-meta-command (compile repl (form))
"compile EXP
Generate compiled code."
(let ((x (repl-compile repl (repl-parse repl form))))
- (cond ((objcode? x) (guile:disassemble x))
+ (cond ((bytevector? x) (disassemble-image (load-image x)))
(else (repl-print repl x)))))
(define-meta-command (compile-file repl file . opts)
@@ -482,22 +487,24 @@ 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."
(let ((obj (repl-eval repl (repl-parse repl form))))
- (if (or (program? obj) (objcode? obj))
- (guile:disassemble obj)
- (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
- obj))))
+ (cond
+ ((program? obj)
+ (disassemble-program obj))
+ ((bytevector? obj)
+ (disassemble-image (load-image obj)))
+ (else
+ (format #t
+ "Argument to ,disassemble not a procedure or a bytevector: ~a~%"
+ obj)))))
(define-meta-command (disassemble-file repl file)
"disassemble-file FILE
Disassemble a file."
- (guile:disassemble (load-objcode (->string file))))
+ (disassemble-file (->string file)))
;;;
@@ -557,8 +564,6 @@ Trace execution."
(identifier-syntax (debug-frames debug)))
(#,(datum->syntax #'repl 'message)
(identifier-syntax (debug-error-message debug)))
- (#,(datum->syntax #'repl 'for-trap?)
- (identifier-syntax (debug-for-trap? debug)))
(#,(datum->syntax #'repl 'index)
(identifier-syntax
(id (debug-index debug))
@@ -580,8 +585,7 @@ If COUNT is negative, the last COUNT frames will be shown."
(print-frames frames
#:count count
#:width width
- #:full? full?
- #:for-trap? for-trap?))
+ #:full? full?))
(define-stack-command (up repl #:optional (count 1))
"up [COUNT]
@@ -598,12 +602,10 @@ An argument says how many frames up to go."
(format #t "Already at outermost frame.\n"))
(else
(set! index (1- (vector-length frames)))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(else
(set! index (+ count index))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(define-stack-command (down repl #:optional (count 1))
"down [COUNT]
@@ -620,11 +622,10 @@ An argument says how many frames down to go."
(format #t "Already at innermost frame.\n"))
(else
(set! index 0)
- (print-frame cur #:index index #:next-source? for-trap?))))
+ (print-frame cur #:index index))))
(else
(set! index (- index count))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(define-stack-command (frame repl #:optional idx)
"frame [IDX]
@@ -639,12 +640,10 @@ With an argument, select a frame by index, then show it."
(format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
((< idx (vector-length frames))
(set! index idx)
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))
+ (print-frame cur #:index index))
(else
(format #t "No such frame.~%"))))
- (else (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (else (print-frame cur #:index index))))
(define-stack-command (procedure repl)
"procedure
@@ -688,8 +687,8 @@ Note that the given source location must be inside a procedure."
(format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))
(define (repl-pop-continuation-resumer repl msg)
- ;; Capture the dynamic environment with this prompt thing. The
- ;; result is a procedure that takes a frame.
+ ;; Capture the dynamic environment with this prompt thing. The result
+ ;; is a procedure that takes a frame and number of values returned.
(% (call-with-values
(lambda ()
(abort
@@ -697,20 +696,20 @@ Note that the given source location must be inside a procedure."
;; Call frame->stack-vector before reinstating the
;; continuation, so that we catch the %stacks fluid at
;; the time of capture.
- (lambda (frame)
+ (lambda (frame . values)
(k frame
(frame->stack-vector
- (frame-previous frame)))))))
- (lambda (from stack)
+ (frame-previous frame))
+ values)))))
+ (lambda (from stack values)
(format #t "~a~%" msg)
- (let ((vals (frame-return-values from)))
- (if (null? vals)
- (format #t "No return values.~%")
- (begin
- (format #t "Return values:~%")
- (for-each (lambda (x) (repl-print repl x)) vals))))
+ (if (null? values)
+ (format #t "No return values.~%")
+ (begin
+ (format #t "Return values:~%")
+ (for-each (lambda (x) (repl-print repl x)) values)))
((module-ref (resolve-interface '(system repl repl)) 'start-repl)
- #:debug (make-debug stack 0 msg #t))))))
+ #:debug (make-debug stack 0 msg))))))
(define-stack-command (finish repl)
"finish
@@ -734,7 +733,7 @@ Resume execution, breaking when the current frame finishes."
(k (frame->stack-vector frame)))))))
(format #t "~a~%" msg)
((module-ref (resolve-interface '(system repl repl)) 'start-repl)
- #:debug (make-debug stack 0 msg #t)))))
+ #:debug (make-debug stack 0 msg)))))
(define-stack-command (step repl)
"step
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index c72629828..f0e6e03a0 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -25,7 +25,8 @@
#:use-module (system base language)
#:use-module (system base message)
#:use-module (system vm program)
- #:autoload (language tree-il optimize) (optimize!)
+ #:use-module (system vm loader)
+ #:autoload (language tree-il optimize) (optimize)
#:use-module (ice-9 control)
#:use-module (ice-9 history)
#:export (<repl> make-repl repl-language repl-options
@@ -176,7 +177,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(define (repl-compile repl form)
(let ((from (repl-language repl))
(opts (repl-compile-options repl)))
- (compile form #:from from #:to 'objcode #:opts opts
+ (compile form #:from from #:to 'bytecode #:opts opts
#:env (current-module))))
(define (repl-expand repl form)
@@ -189,10 +190,10 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(define (repl-optimize repl form)
(let ((from (repl-language repl))
(opts (repl-compile-options repl)))
- (decompile (optimize! (compile form #:from from #:to 'tree-il #:opts opts
- #:env (current-module))
- (current-module)
- opts)
+ (decompile (optimize (compile form #:from from #:to 'tree-il #:opts opts
+ #:env (current-module))
+ (current-module)
+ opts)
#:from 'tree-il #:to from)))
(define (repl-parse repl form)
@@ -205,7 +206,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(or (null? (language-compilers (repl-language repl)))
(repl-option-ref repl 'interp)))
(lambda () (eval form (current-module)))
- (make-program (repl-compile repl form)))))
+ (load-thunk-from-memory (repl-compile repl form)))))
(define (repl-eval repl form)
(let ((thunk (repl-prepare-eval-thunk repl form)))
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index cf408063e..fdf6bb7be 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.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
@@ -31,7 +31,7 @@
#:use-module (system vm program)
#:export (<debug>
make-debug debug?
- debug-frames debug-index debug-error-message debug-for-trap?
+ debug-frames debug-index debug-error-message
terminal-width
print-registers print-locals print-frame print-frames frame->module
stack->vector narrow-stack->vector
@@ -55,7 +55,7 @@
;;; accessors, and provides some helper functions.
;;;
-(define-record <debug> frames index error-message for-trap?)
+(define-record <debug> frames index error-message)
@@ -94,7 +94,12 @@
(format port fmt val))
(format port "~aRegisters:~%" per-line-prefix)
- (print "ip = ~d\n" (frame-instruction-pointer frame))
+ (print "ip = #x~x" (frame-instruction-pointer frame))
+ (when (program? (frame-procedure frame))
+ (let ((code (program-code (frame-procedure frame))))
+ (format port " (#x~x~@d)" code
+ (- (frame-instruction-pointer frame) code))))
+ (newline port)
(print "sp = #x~x\n" (frame-stack-pointer frame))
(print "fp = #x~x\n" (frame-address frame)))
@@ -125,7 +130,7 @@
(if source
(or (source:file source) "current input")
"unknown file"))
- (let* ((source ((if next-source? frame-next-source frame-source) frame))
+ (let* ((source (frame-source frame))
(file (source:pretty-file source))
(line (and=> source source:line-for-user))
(col (and=> source source:column)))
@@ -141,7 +146,7 @@
(define* (print-frames frames
#:optional (port (current-output-port))
#:key (width (terminal-width)) (full? #f)
- (forward? #f) count for-trap?)
+ (forward? #f) count)
(let* ((len (vector-length frames))
(lower-idx (if (or (not count) (positive? count))
0
@@ -155,12 +160,9 @@
(if (<= lower-idx i upper-idx)
(let* ((frame (vector-ref frames i)))
(print-frame frame port #:index i #:width width #:full? full?
- #:last-source last-source
- #:next-source? (and (zero? i) for-trap?))
+ #:last-source last-source)
(lp (+ i inc)
- (if (and (zero? i) for-trap?)
- (frame-next-source frame)
- (frame-source frame))))))))
+ (frame-source frame)))))))
;; Ideally here we would have something much more syntactic, in that a set! to a
;; local var that is not settable would raise an error, and export etc forms
@@ -168,7 +170,8 @@
;; Patches welcome!
(define (frame->module frame)
(let ((proc (frame-procedure frame)))
- (if (program? proc)
+ (if #f
+ ;; FIXME!
(let* ((mod (or (program-module proc) (current-module)))
(mod* (make-module)))
(module-use! mod* mod)
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index 0e31eb941..d0d7967a3 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -1,6 +1,6 @@
;;; Error handling in the REPL
-;; 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
@@ -72,7 +72,7 @@
(error-msg (if trap-idx
(format #f "Trap ~d: ~a" trap-idx trap-name)
trap-name))
- (debug (make-debug stack 0 error-msg #t)))
+ (debug (make-debug stack 0 error-msg)))
(with-saved-ports
(lambda ()
(if trap-idx
@@ -138,7 +138,7 @@
;; the start-stack thunk has its own frame too.
0 (and tag 1)))
(error-msg (error-string stack key args))
- (debug (make-debug stack 0 error-msg #f)))
+ (debug (make-debug stack 0 error-msg)))
(with-saved-ports
(lambda ()
(format #t "~a~%" error-msg)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
new file mode 100644
index 000000000..5ddc64205
--- /dev/null
+++ b/module/system/vm/assembler.scm
@@ -0,0 +1,2074 @@
+;;; Guile bytecode assembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; This module implements an assembler that creates an ELF image from
+;;; bytecode assembly and macro-assembly. The input can be given in
+;;; s-expression form, like ((OP ARG ...) ...). Internally there is a
+;;; procedural interface, the emit-OP procedures, but that is not
+;;; currently exported.
+;;;
+;;; "Primitive instructions" correspond to VM operations. Assemblers
+;;; for primitive instructions are generated programmatically from
+;;; (instruction-list), which itself is derived from the VM sources.
+;;; There are also "macro-instructions" like "label" or "load-constant"
+;;; that expand to 0 or more primitive instructions.
+;;;
+;;; The assembler also handles some higher-level tasks, like creating
+;;; the symbol table, other metadata sections, creating a constant table
+;;; for the whole compilation unit, and writing the dynamic section of
+;;; the ELF file along with the appropriate initialization routines.
+;;;
+;;; Most compilers will want to use the trio of make-assembler,
+;;; emit-text, and link-assembly. That will result in the creation of
+;;; an ELF image as a bytevector, which can then be loaded using
+;;; load-thunk-from-memory, or written to disk as a .go file.
+;;;
+;;; Code:
+
+(define-module (system vm assembler)
+ #:use-module (system base target)
+ #:use-module (system vm dwarf)
+ #:use-module (system vm elf)
+ #:use-module (system vm linker)
+ #:use-module (language bytecode)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:export (make-assembler
+ emit-text
+ link-assembly))
+
+
+
+
+;;; Bytecode consists of 32-bit units, often subdivided in some way.
+;;; These helpers create one 32-bit unit from multiple components.
+
+(define-inlinable (pack-u8-u24 x y)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (logior x (ash y 8)))
+
+(define-inlinable (pack-u8-s24 x y)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (logior x (ash (cond
+ ((< 0 (- y) #x800000)
+ (+ y #x1000000))
+ ((<= 0 y #xffffff)
+ y)
+ (else (error "out of range" y)))
+ 8)))
+
+(define-inlinable (pack-u1-u7-u24 x y z)
+ (unless (<= 0 x 1)
+ (error "out of range" x))
+ (unless (<= 0 y 127)
+ (error "out of range" y))
+ (logior x (ash y 1) (ash z 8)))
+
+(define-inlinable (pack-u8-u12-u12 x y z)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 4095)
+ (error "out of range" y))
+ (logior x (ash y 8) (ash z 20)))
+
+(define-inlinable (pack-u8-u8-u16 x y z)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 255)
+ (error "out of range" y))
+ (logior x (ash y 8) (ash z 16)))
+
+(define-inlinable (pack-u8-u8-u8-u8 x y z w)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 255)
+ (error "out of range" y))
+ (unless (<= 0 z 255)
+ (error "out of range" z))
+ (logior x (ash y 8) (ash z 16) (ash w 24)))
+
+(define-syntax pack-flags
+ (syntax-rules ()
+ ;; Add clauses as needed.
+ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
+ (if f2 (ash 2 0) 0)))))
+
+;;; Helpers to read and write 32-bit units in a buffer.
+
+(define-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-syntax-rule (u32-set! buf n val)
+ (bytevector-u32-native-set! buf (* n 4) val))
+
+(define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-syntax-rule (s32-set! buf n val)
+ (bytevector-s32-native-set! buf (* n 4) val))
+
+
+
+
+;;; A <meta> entry collects metadata for one procedure. Procedures are
+;;; written as contiguous ranges of bytecode.
+;;;
+(define-syntax-rule (assert-match arg pattern kind)
+ (let ((x arg))
+ (unless (match x (pattern #t) (_ #f))
+ (error (string-append "expected " kind) x))))
+
+(define-record-type <meta>
+ (%make-meta label properties low-pc high-pc arities)
+ meta?
+ (label meta-label)
+ (properties meta-properties set-meta-properties!)
+ (low-pc meta-low-pc)
+ (high-pc meta-high-pc set-meta-high-pc!)
+ (arities meta-arities set-meta-arities!))
+
+(define (make-meta label properties low-pc)
+ (assert-match label (? symbol?) "symbol")
+ (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
+ (%make-meta label properties low-pc #f '()))
+
+(define (meta-name meta)
+ (assq-ref (meta-properties meta) 'name))
+
+;; Metadata for one <lambda-case>.
+(define-record-type <arity>
+ (make-arity req opt rest kw-indices allow-other-keys?
+ low-pc high-pc)
+ arity?
+ (req arity-req)
+ (opt arity-opt)
+ (rest arity-rest)
+ (kw-indices arity-kw-indices)
+ (allow-other-keys? arity-allow-other-keys?)
+ (low-pc arity-low-pc)
+ (high-pc arity-high-pc set-arity-high-pc!))
+
+(define-syntax *block-size* (identifier-syntax 32))
+
+;;; An assembler collects all of the words emitted during assembly, and
+;;; also maintains ancillary information such as the constant table, a
+;;; relocation list, and so on.
+;;;
+;;; Bytecode consists of 32-bit units. We emit bytecode using native
+;;; endianness. If we're targeting a foreign endianness, we byte-swap
+;;; the bytevector as a whole instead of conditionalizing each access.
+;;;
+(define-record-type <asm>
+ (make-asm cur idx start prev written
+ labels relocs
+ word-size endianness
+ constants inits
+ shstrtab next-section-number
+ meta sources
+ dead-slot-maps)
+ asm?
+
+ ;; We write bytecode into what is logically a growable vector,
+ ;; implemented as a list of blocks. asm-cur is the current block, and
+ ;; asm-idx is the current index into that block, in 32-bit units.
+ ;;
+ (cur asm-cur set-asm-cur!)
+ (idx asm-idx set-asm-idx!)
+
+ ;; asm-start is an absolute position, indicating the offset of the
+ ;; beginning of an instruction (in u32 units). It is updated after
+ ;; writing all the words for one primitive instruction. It models the
+ ;; position of the instruction pointer during execution, given that
+ ;; the VM updates the IP only at the end of executing the instruction,
+ ;; and is thus useful for computing offsets between two points in a
+ ;; program.
+ ;;
+ (start asm-start set-asm-start!)
+
+ ;; The list of previously written blocks.
+ ;;
+ (prev asm-prev set-asm-prev!)
+
+ ;; The number of u32 words written in asm-prev, which is the same as
+ ;; the offset of the current block.
+ ;;
+ (written asm-written set-asm-written!)
+
+ ;; An alist of symbol -> position pairs, indicating the labels defined
+ ;; in this compilation unit.
+ ;;
+ (labels asm-labels set-asm-labels!)
+
+ ;; A list of relocations needed by the program text. We use an
+ ;; internal representation for relocations, and handle textualn
+ ;; relative relocations in the assembler. Other kinds of relocations
+ ;; are later reified as linker relocations and resolved by the linker.
+ ;;
+ (relocs asm-relocs set-asm-relocs!)
+
+ ;; Target information.
+ ;;
+ (word-size asm-word-size)
+ (endianness asm-endianness)
+
+ ;; The constant table, as a vhash of object -> label. All constants
+ ;; get de-duplicated and written into separate sections -- either the
+ ;; .rodata section, for read-only data, or .data, for constants that
+ ;; need initialization at load-time (like symbols). Constants can
+ ;; depend on other constants (e.g. a symbol depending on a stringbuf),
+ ;; so order in this table is important.
+ ;;
+ (constants asm-constants set-asm-constants!)
+
+ ;; A list of instructions needed to initialize the constants. Will
+ ;; run in a thunk with 2 local variables.
+ ;;
+ (inits asm-inits set-asm-inits!)
+
+ ;; The shstrtab, for section names.
+ ;;
+ (shstrtab asm-shstrtab set-asm-shstrtab!)
+
+ ;; The section number for the next section to be written.
+ ;;
+ (next-section-number asm-next-section-number set-asm-next-section-number!)
+
+ ;; A list of <meta>, corresponding to procedure metadata.
+ ;;
+ (meta asm-meta set-asm-meta!)
+
+ ;; A list of (pos . source) pairs, indicating source information. POS
+ ;; is relative to the beginning of the text section, and SOURCE is in
+ ;; the same format that source-properties returns.
+ ;;
+ (sources asm-sources set-asm-sources!)
+
+ ;; A list of (pos . dead-slot-map) pairs, indicating dead slot maps.
+ ;; POS is relative to the beginning of the text section.
+ ;; DEAD-SLOT-MAP is a bitfield of slots that are dead at call sites,
+ ;; as an integer.
+ ;;
+ (dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!))
+
+(define-inlinable (fresh-block)
+ (make-u32vector *block-size*))
+
+(define* (make-assembler #:key (word-size (target-word-size))
+ (endianness (target-endianness)))
+ "Create an assembler for a given target @var{word-size} and
+@var{endianness}, falling back to appropriate values for the configured
+target."
+ (make-asm (fresh-block) 0 0 '() 0
+ (make-hash-table) '()
+ word-size endianness
+ vlist-null '()
+ (make-string-table) 1
+ '() '() '()))
+
+(define (intern-section-name! asm string)
+ "Add a string to the section name table (shstrtab)."
+ (string-table-intern! (asm-shstrtab asm) string))
+
+(define-inlinable (asm-pos asm)
+ "The offset of the next word to be written into the code buffer, in
+32-bit units."
+ (+ (asm-idx asm) (asm-written asm)))
+
+(define (allocate-new-block asm)
+ "Close off the current block, and arrange for the next word to be
+written to a fresh block."
+ (let ((new (fresh-block)))
+ (set-asm-prev! asm (cons (asm-cur asm) (asm-prev asm)))
+ (set-asm-written! asm (asm-pos asm))
+ (set-asm-cur! asm new)
+ (set-asm-idx! asm 0)))
+
+(define-inlinable (emit asm u32)
+ "Emit one 32-bit word into the instruction stream. Assumes that there
+is space for the word, and ensures that there is space for the next
+word."
+ (u32-set! (asm-cur asm) (asm-idx asm) u32)
+ (set-asm-idx! asm (1+ (asm-idx asm)))
+ (if (= (asm-idx asm) *block-size*)
+ (allocate-new-block asm)))
+
+(define-inlinable (make-reloc type label base word)
+ "Make an internal relocation of type @var{type} referencing symbol
+@var{label}, @var{word} words after position @var{start}. @var{type}
+may be x8-s24, indicating a 24-bit relative label reference that can be
+fixed up by the assembler, or s32, indicating a 32-bit relative
+reference that needs to be fixed up by the linker."
+ (list type label base word))
+
+(define-inlinable (reset-asm-start! asm)
+ "Reset the asm-start after writing the words for one instruction."
+ (set-asm-start! asm (asm-pos asm)))
+
+(define (record-label-reference asm label)
+ "Record an x8-s24 local label reference. This value will get patched
+up later by the assembler."
+ (let* ((start (asm-start asm))
+ (pos (asm-pos asm))
+ (reloc (make-reloc 'x8-s24 label start (- pos start))))
+ (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
+
+(define* (record-far-label-reference asm label #:optional (offset 0))
+ "Record an s32 far label reference. This value will get patched up
+later by the linker."
+ (let* ((start (- (asm-start asm) offset))
+ (pos (asm-pos asm))
+ (reloc (make-reloc 's32 label start (- pos start))))
+ (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
+
+
+
+
+;;;
+;;; Primitive assemblers are defined by expanding `assembler' for each
+;;; opcode in `(instruction-list)'.
+;;;
+
+(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 assembler
+ (lambda (x)
+ (define-syntax op-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ asm name ((type arg ...) code ...) clause ...)
+ #`(if (eq? name 'type)
+ (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
+ #'((arg ...)
+ code ...))
+ (op-case asm name clause ...)))
+ ((_ asm name)
+ #'(error "unmatched name" name)))))
+
+ (define (pack-first-word asm opcode type)
+ (with-syntax ((opcode opcode))
+ (op-case
+ asm type
+ ((U8_X24)
+ (emit asm opcode))
+ ((U8_U24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((U8_L24 label)
+ (record-label-reference asm label)
+ (emit asm opcode))
+ ((U8_U8_I16 a imm)
+ (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((U8_U8_U8_U8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
+
+ (define (pack-tail-word asm type)
+ (op-case
+ asm type
+ ((U8_U24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((U8_L24 a label)
+ (record-label-reference asm label)
+ (emit asm a))
+ ((U8_U8_I16 a b imm)
+ (emit asm (pack-u8-u8-u16 a b (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 a b c)))
+ ((U8_U8_U8_U8 a b c d)
+ (emit asm (pack-u8-u8-u8-u8 a b c d)))
+ ((U32 a)
+ (emit asm a))
+ ((I32 imm)
+ (let ((val (object-address imm)))
+ (unless (zero? (ash val -32))
+ (error "FIXME: enable truncation of negative fixnums when cross-compiling"))
+ (emit asm val)))
+ ((A32 imm)
+ (unless (= (asm-word-size asm) 8)
+ (error "make-long-immediate unavailable for this target"))
+ (emit asm (ash (object-address imm) -32))
+ (emit asm (logand (object-address imm) (1- (ash 1 32)))))
+ ((B32))
+ ((N32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((S32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((L32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((LO32 label offset)
+ (record-far-label-reference asm label
+ (* offset (/ (asm-word-size asm) 4)))
+ (emit asm 0))
+ ((X8_U24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 0 a b)))
+ ((X8_L24 label)
+ (record-label-reference asm label)
+ (emit asm 0))
+ ((B1_X7_L24 a label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_U7_L24 a b label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))
+ ((B1_X31 a)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_X7_U24 a b)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (with-syntax ((((formal0 ...)
+ code0 ...)
+ (pack-first-word #'asm
+ (syntax->datum #'opcode)
+ (syntax->datum #'word0)))
+ ((((formal* ...)
+ code* ...) ...)
+ (map (lambda (word) (pack-tail-word #'asm word))
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (unless (asm? asm) (error "not an asm"))
+ code0 ...
+ code* ... ...
+ (reset-asm-start! asm)))))))
+
+(define assemblers (make-hash-table))
+
+(define-syntax define-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(begin
+ (define emit
+ (let ((emit (assembler name opcode arg ...)))
+ (hashq-set! assemblers 'name emit)
+ emit))
+ (export emit)))))))
+
+(define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...))))))
+
+(visit-opcodes define-assembler)
+
+(define (emit-text asm instructions)
+ "Assemble @var{instructions} using the assembler @var{asm}.
+@var{instructions} is a sequence of instructions, expressed as a list of
+lists. This procedure can be called many times before calling
+@code{link-assembly}."
+ (for-each (lambda (inst)
+ (apply (or (hashq-ref assemblers (car inst))
+ (error 'bad-instruction inst))
+ asm
+ (cdr inst)))
+ instructions))
+
+
+
+;;;
+;;; The constant table records a topologically sorted set of literal
+;;; constants used by a program. For example, a pair uses its car and
+;;; cdr, a string uses its stringbuf, etc.
+;;;
+;;; Some things we want to add to the constant table are not actually
+;;; Scheme objects: for example, stringbufs, cache cells for toplevel
+;;; references, or cache cells for non-closure procedures. For these we
+;;; define special record types and add instances of those record types
+;;; to the table.
+;;;
+
+(define-inlinable (immediate? x)
+ "Return @code{#t} if @var{x} is immediate, and @code{#f} otherwise."
+ (not (zero? (logand (object-address x) 6))))
+
+(define-record-type <stringbuf>
+ (make-stringbuf string)
+ stringbuf?
+ (string stringbuf-string))
+
+(define-record-type <static-procedure>
+ (make-static-procedure code)
+ static-procedure?
+ (code static-procedure-code))
+
+(define-record-type <uniform-vector-backing-store>
+ (make-uniform-vector-backing-store bytes element-size)
+ uniform-vector-backing-store?
+ (bytes uniform-vector-backing-store-bytes)
+ (element-size uniform-vector-backing-store-element-size))
+
+(define-record-type <cache-cell>
+ (make-cache-cell scope key)
+ cache-cell?
+ (scope cache-cell-scope)
+ (key cache-cell-key))
+
+(define (simple-vector? obj)
+ (and (vector? obj)
+ (equal? (array-shape obj) (list (list 0 (1- (vector-length obj)))))))
+
+(define (simple-uniform-vector? obj)
+ (and (array? obj)
+ (symbol? (array-type obj))
+ (equal? (array-shape obj) (list (list 0 (1- (array-length obj)))))))
+
+(define (statically-allocatable? x)
+ "Return @code{#t} if a non-immediate constant can be allocated
+statically, and @code{#f} if it would need some kind of runtime
+allocation."
+ (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x) (array? x)))
+
+(define (intern-constant asm obj)
+ "Add an object to the constant table, and return a label that can be
+used to reference it. If the object is already present in the constant
+table, its existing label is used directly."
+ (define (recur obj)
+ (intern-constant asm obj))
+ (define (field dst n obj)
+ (let ((src (recur obj)))
+ (if src
+ (if (statically-allocatable? obj)
+ `((static-patch! ,dst ,n ,src))
+ `((static-ref 1 ,src)
+ (static-set! 1 ,dst ,n)))
+ '())))
+ (define (intern obj label)
+ (cond
+ ((pair? obj)
+ (append (field label 0 (car obj))
+ (field label 1 (cdr obj))))
+ ((simple-vector? obj)
+ (let lp ((i 0) (inits '()))
+ (if (< i (vector-length obj))
+ (lp (1+ i)
+ (append-reverse (field label (1+ i) (vector-ref obj i))
+ inits))
+ (reverse inits))))
+ ((stringbuf? obj) '())
+ ((static-procedure? obj)
+ `((static-patch! ,label 1 ,(static-procedure-code obj))))
+ ((cache-cell? obj) '())
+ ((symbol? obj)
+ `((make-non-immediate 1 ,(recur (symbol->string obj)))
+ (string->symbol 1 1)
+ (static-set! 1 ,label 0)))
+ ((string? obj)
+ `((static-patch! ,label 1 ,(recur (make-stringbuf obj)))))
+ ((keyword? obj)
+ `((static-ref 1 ,(recur (keyword->symbol obj)))
+ (symbol->keyword 1 1)
+ (static-set! 1 ,label 0)))
+ ((number? obj)
+ `((make-non-immediate 1 ,(recur (number->string obj)))
+ (string->number 1 1)
+ (static-set! 1 ,label 0)))
+ ((uniform-vector-backing-store? obj) '())
+ ((simple-uniform-vector? obj)
+ `((static-patch! ,label 2
+ ,(recur (make-uniform-vector-backing-store
+ (uniform-array->bytevector obj)
+ (if (bitvector? obj)
+ ;; Bitvectors are addressed in
+ ;; 32-bit units.
+ 4
+ (uniform-vector-element-size obj)))))))
+ (else
+ (error "don't know how to intern" obj))))
+ (cond
+ ((immediate? obj) #f)
+ ((vhash-assoc obj (asm-constants asm)) => cdr)
+ (else
+ ;; Note that calling intern may mutate asm-constants and
+ ;; asm-constant-inits.
+ (let* ((label (gensym "constant"))
+ (inits (intern obj label)))
+ (set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
+ (set-asm-inits! asm (append-reverse inits (asm-inits asm)))
+ label))))
+
+(define (intern-non-immediate asm obj)
+ "Intern a non-immediate into the constant table, and return its
+label."
+ (when (immediate? obj)
+ (error "expected a non-immediate" obj))
+ (intern-constant asm obj))
+
+(define (intern-cache-cell asm scope key)
+ "Intern a cache cell into the constant table, and return its label.
+If there is already a cache cell with the given scope and key, it is
+returned instead."
+ (intern-constant asm (make-cache-cell scope key)))
+
+;; Return the label of the cell that holds the module for a scope.
+(define (intern-module-cache-cell asm scope)
+ "Intern a cache cell for a module, and return its label."
+ (intern-cache-cell asm scope #t))
+
+
+
+
+;;;
+;;; Macro assemblers bridge the gap between primitive instructions and
+;;; some higher-level operations.
+;;;
+
+(define-syntax define-macro-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name arg ...) body body* ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(begin
+ (define emit
+ (let ((emit (lambda (arg ...) body body* ...)))
+ (hashq-set! assemblers 'name emit)
+ emit))
+ (export emit)))))))
+
+(define-macro-assembler (load-constant asm dst obj)
+ (cond
+ ((immediate? obj)
+ (let ((bits (object-address obj)))
+ (cond
+ ((and (< dst 256) (zero? (ash bits -16)))
+ (emit-make-short-immediate asm dst obj))
+ ((zero? (ash bits -32))
+ (emit-make-long-immediate asm dst obj))
+ (else
+ (emit-make-long-long-immediate asm dst obj)))))
+ ((statically-allocatable? obj)
+ (emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
+ (else
+ (emit-static-ref asm dst (intern-non-immediate asm obj)))))
+
+(define-macro-assembler (load-static-procedure asm dst label)
+ (let ((loc (intern-constant asm (make-static-procedure label))))
+ (emit-make-non-immediate asm dst loc)))
+
+(define-syntax-rule (define-tc7-macro-assembler name tc7)
+ (define-macro-assembler (name asm slot invert? label)
+ (emit-br-if-tc7 asm slot invert? tc7 label)))
+
+;; Keep in sync with tags.h. Part of Guile's ABI. Currently unused
+;; macro assemblers are commented out. See also
+;; *branching-primcall-arities* in (language cps primitives), the set of
+;; macro-instructions in assembly.scm, and
+;; disassembler.scm:code-annotation.
+;;
+;; FIXME: Define all tc7 values in Scheme in one place, derived from
+;; tags.h.
+(define-tc7-macro-assembler br-if-symbol 5)
+(define-tc7-macro-assembler br-if-variable 7)
+(define-tc7-macro-assembler br-if-vector 13)
+;(define-tc7-macro-assembler br-if-weak-vector 13)
+(define-tc7-macro-assembler br-if-string 21)
+;(define-tc7-macro-assembler br-if-heap-number 23)
+;(define-tc7-macro-assembler br-if-stringbuf 39)
+(define-tc7-macro-assembler br-if-bytevector 77)
+;(define-tc7-macro-assembler br-if-pointer 31)
+;(define-tc7-macro-assembler br-if-hashtable 29)
+;(define-tc7-macro-assembler br-if-fluid 37)
+;(define-tc7-macro-assembler br-if-dynamic-state 45)
+;(define-tc7-macro-assembler br-if-frame 47)
+;(define-tc7-macro-assembler br-if-vm 55)
+;(define-tc7-macro-assembler br-if-vm-cont 71)
+;(define-tc7-macro-assembler br-if-rtl-program 69)
+;(define-tc7-macro-assembler br-if-weak-set 85)
+;(define-tc7-macro-assembler br-if-weak-table 87)
+;(define-tc7-macro-assembler br-if-array 93)
+(define-tc7-macro-assembler br-if-bitvector 95)
+;(define-tc7-macro-assembler br-if-port 125)
+;(define-tc7-macro-assembler br-if-smob 127)
+
+(define-macro-assembler (begin-program asm label properties)
+ (emit-label asm label)
+ (let ((meta (make-meta label properties (asm-start asm))))
+ (set-asm-meta! asm (cons meta (asm-meta asm)))))
+
+(define-macro-assembler (end-program asm)
+ (let ((meta (car (asm-meta asm))))
+ (set-meta-high-pc! meta (asm-start asm))
+ (set-meta-arities! meta (reverse (meta-arities meta)))))
+
+(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
+ (emit-begin-opt-arity asm req '() #f nlocals alternate))
+
+(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
+ (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
+
+(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (assert-match req ((? symbol?) ...) "list of symbols")
+ (assert-match opt ((? symbol?) ...) "list of symbols")
+ (assert-match rest (or #f (? symbol?)) "#f or symbol")
+ (assert-match kw-indices (((? keyword?) . (? integer?)) ...)
+ "alist of keyword -> integer")
+ (assert-match allow-other-keys? (? boolean?) "boolean")
+ (assert-match nlocals (? integer?) "integer")
+ (assert-match alternate (or #f (? symbol?)) "#f or symbol")
+ (let* ((meta (car (asm-meta asm)))
+ (arity (make-arity req opt rest kw-indices allow-other-keys?
+ (asm-start asm) #f))
+ ;; The procedure itself is in slot 0, in the standard calling
+ ;; convention. For procedure prologues, nreq includes the
+ ;; procedure, so here we add 1.
+ (nreq (1+ (length req)))
+ (nopt (length opt))
+ (rest? (->bool rest)))
+ (set-meta-arities! meta (cons arity (meta-arities meta)))
+ (cond
+ ((or allow-other-keys? (pair? kw-indices))
+ (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys?
+ nlocals alternate))
+ ((or rest? (pair? opt))
+ (emit-opt-prelude asm nreq nopt rest? nlocals alternate))
+ (else
+ (emit-standard-prelude asm nreq nlocals alternate)))))
+
+(define-macro-assembler (end-arity asm)
+ (let ((arity (car (meta-arities (car (asm-meta asm))))))
+ (set-arity-high-pc! arity (asm-start asm))))
+
+(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
+ (cond
+ (alternate
+ (emit-br-if-nargs-ne asm nreq alternate)
+ (emit-alloc-frame asm nlocals))
+ ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12)))
+ (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
+ (else
+ (emit-assert-nargs-ee asm nreq)
+ (emit-alloc-frame asm nlocals))))
+
+(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (cond
+ (rest?
+ (emit-bind-rest asm (+ nreq nopt)))
+ (alternate
+ (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
+ (else
+ (emit-assert-nargs-le asm (+ nreq nopt))))
+ (emit-alloc-frame asm nlocals))
+
+(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
+ allow-other-keys? nlocals alternate)
+ (if alternate
+ (begin
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (unless rest?
+ (emit-br-if-npos-gt asm nreq (+ nreq nopt) alternate)))
+ (emit-assert-nargs-ge asm nreq))
+ (let ((ntotal (fold (lambda (kw ntotal)
+ (match kw
+ (((? keyword?) . idx)
+ (max (1+ idx) ntotal))))
+ (+ nreq nopt) kw-indices)))
+ ;; FIXME: port 581f410f
+ (emit-bind-kwargs asm nreq
+ (pack-flags allow-other-keys? rest?)
+ (+ nreq nopt)
+ ntotal
+ (intern-constant asm kw-indices))
+ (emit-alloc-frame asm nlocals)))
+
+(define-macro-assembler (label asm sym)
+ (hashq-set! (asm-labels asm) sym (asm-start asm)))
+
+(define-macro-assembler (source asm source)
+ (set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm))))
+
+(define-macro-assembler (cache-current-module! asm module scope)
+ (let ((mod-label (intern-module-cache-cell asm scope)))
+ (emit-static-set! asm module mod-label 0)))
+
+(define-macro-assembler (cached-toplevel-box asm dst scope sym bound?)
+ (let ((sym-label (intern-non-immediate asm sym))
+ (mod-label (intern-module-cache-cell asm scope))
+ (cell-label (intern-cache-cell asm scope sym)))
+ (emit-toplevel-box asm dst cell-label mod-label sym-label bound?)))
+
+(define-macro-assembler (cached-module-box asm dst module-name sym public? bound?)
+ (let* ((sym-label (intern-non-immediate asm sym))
+ (key (cons public? module-name))
+ (mod-name-label (intern-constant asm key))
+ (cell-label (intern-cache-cell asm key sym)))
+ (emit-module-box asm dst cell-label mod-name-label sym-label bound?)))
+
+(define-macro-assembler (dead-slot-map asm proc-slot dead-slot-map)
+ (unless (zero? dead-slot-map)
+ (set-asm-dead-slot-maps! asm
+ (cons
+ (cons* (asm-start asm) proc-slot dead-slot-map)
+ (asm-dead-slot-maps asm)))))
+
+
+
+;;;
+;;; Helper for linking objects.
+;;;
+
+(define (make-object asm name bv relocs labels . kwargs)
+ "Make a linker object. This helper handles interning the name in the
+shstrtab, assigning the size, allocating a fresh index, and defining a
+corresponding linker symbol for the start of the section."
+ (let ((name-idx (intern-section-name! asm (symbol->string name)))
+ (index (asm-next-section-number asm)))
+ (set-asm-next-section-number! asm (1+ index))
+ (make-linker-object (apply make-elf-section
+ #:index index
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (cons (make-linker-symbol name 0) labels))))
+
+
+
+
+;;;
+;;; Linking the constant table. This code is somewhat intertwingled
+;;; with the intern-constant code above, as that procedure also
+;;; residualizes instructions to initialize constants at load time.
+;;;
+
+(define (write-immediate asm buf pos x)
+ (let ((val (object-address x))
+ (endianness (asm-endianness asm)))
+ (case (asm-word-size asm)
+ ((4) (bytevector-u32-set! buf pos val endianness))
+ ((8) (bytevector-u64-set! buf pos val endianness))
+ (else (error "bad word size" asm)))))
+
+(define (emit-init-constants asm)
+ "If there is writable data that needs initialization at runtime, emit
+a procedure to do that and return its label. Otherwise return
+@code{#f}."
+ (let ((inits (asm-inits asm)))
+ (and (not (null? inits))
+ (let ((label (gensym "init-constants")))
+ (emit-text asm
+ `((begin-program ,label ())
+ (assert-nargs-ee/locals 1 1)
+ ,@(reverse inits)
+ (load-constant 1 ,*unspecified*)
+ (return 1)
+ (end-program)))
+ label))))
+
+(define (link-data asm data name)
+ "Link the static data for a program into the @var{name} section (which
+should be .data or .rodata), and return the resulting linker object.
+@var{data} should be a vhash mapping objects to labels."
+ (define (align address alignment)
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment)))
+
+ (define tc7-vector 13)
+ (define stringbuf-shared-flag #x100)
+ (define stringbuf-wide-flag #x400)
+ (define tc7-stringbuf 39)
+ (define tc7-narrow-stringbuf
+ (+ tc7-stringbuf stringbuf-shared-flag))
+ (define tc7-wide-stringbuf
+ (+ tc7-stringbuf stringbuf-shared-flag stringbuf-wide-flag))
+ (define tc7-ro-string (+ 21 #x200))
+ (define tc7-program 69)
+ (define tc7-bytevector 77)
+ (define tc7-bitvector 95)
+
+ (let ((word-size (asm-word-size asm))
+ (endianness (asm-endianness asm)))
+ (define (byte-length x)
+ (cond
+ ((stringbuf? x)
+ (let ((x (stringbuf-string x)))
+ (+ (* 2 word-size)
+ (case (string-bytes-per-char x)
+ ((1) (1+ (string-length x)))
+ ((4) (* (1+ (string-length x)) 4))
+ (else (error "bad string bytes per char" x))))))
+ ((static-procedure? x)
+ (* 2 word-size))
+ ((string? x)
+ (* 4 word-size))
+ ((pair? x)
+ (* 2 word-size))
+ ((simple-vector? x)
+ (* (1+ (vector-length x)) word-size))
+ ((simple-uniform-vector? x)
+ (* 4 word-size))
+ ((uniform-vector-backing-store? x)
+ (bytevector-length (uniform-vector-backing-store-bytes x)))
+ (else
+ word-size)))
+
+ (define (write-constant-reference buf pos x)
+ ;; The asm-inits will fix up any reference to a non-immediate.
+ (write-immediate asm buf pos (if (immediate? x) x #f)))
+
+ (define (write buf pos obj)
+ (cond
+ ((stringbuf? obj)
+ (let* ((x (stringbuf-string obj))
+ (len (string-length x))
+ (tag (if (= (string-bytes-per-char x) 1)
+ tc7-narrow-stringbuf
+ tc7-wide-stringbuf)))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tag endianness)
+ (bytevector-u32-set! buf (+ pos 4) len endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tag endianness)
+ (bytevector-u64-set! buf (+ pos 8) len endianness))
+ (else
+ (error "bad word size" asm)))
+ (let ((pos (+ pos (* word-size 2))))
+ (case (string-bytes-per-char x)
+ ((1)
+ (let lp ((i 0))
+ (if (< i len)
+ (let ((u8 (char->integer (string-ref x i))))
+ (bytevector-u8-set! buf (+ pos i) u8)
+ (lp (1+ i)))
+ (bytevector-u8-set! buf (+ pos i) 0))))
+ ((4)
+ (let lp ((i 0))
+ (if (< i len)
+ (let ((u32 (char->integer (string-ref x i))))
+ (bytevector-u32-set! buf (+ pos (* i 4)) u32 endianness)
+ (lp (1+ i)))
+ (bytevector-u32-set! buf (+ pos (* i 4)) 0 endianness))))
+ (else (error "bad string bytes per char" x))))))
+
+ ((static-procedure? obj)
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tc7-program endianness)
+ (bytevector-u32-set! buf (+ pos 4) 0 endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tc7-program endianness)
+ (bytevector-u64-set! buf (+ pos 8) 0 endianness))
+ (else (error "bad word size"))))
+
+ ((cache-cell? obj)
+ (write-immediate asm buf pos #f))
+
+ ((string? obj)
+ (let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tc7-ro-string endianness)
+ (write-immediate asm buf (+ pos 4) #f) ; stringbuf
+ (bytevector-u32-set! buf (+ pos 8) 0 endianness)
+ (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tc7-ro-string endianness)
+ (write-immediate asm buf (+ pos 8) #f) ; stringbuf
+ (bytevector-u64-set! buf (+ pos 16) 0 endianness)
+ (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness))
+ (else (error "bad word size")))))
+
+ ((pair? obj)
+ (write-constant-reference buf pos (car obj))
+ (write-constant-reference buf (+ pos word-size) (cdr obj)))
+
+ ((simple-vector? obj)
+ (let* ((len (vector-length obj))
+ (tag (logior tc7-vector (ash len 8))))
+ (case word-size
+ ((4) (bytevector-u32-set! buf pos tag endianness))
+ ((8) (bytevector-u64-set! buf pos tag endianness))
+ (else (error "bad word size")))
+ (let lp ((i 0))
+ (when (< i (vector-length obj))
+ (let ((pos (+ pos word-size (* i word-size)))
+ (elt (vector-ref obj i)))
+ (write-constant-reference buf pos elt)
+ (lp (1+ i)))))))
+
+ ((symbol? obj)
+ (write-immediate asm buf pos #f))
+
+ ((keyword? obj)
+ (write-immediate asm buf pos #f))
+
+ ((number? obj)
+ (write-immediate asm buf pos #f))
+
+ ((simple-uniform-vector? obj)
+ (let ((tag (if (bitvector? obj)
+ tc7-bitvector
+ (let ((type-code (uniform-vector-element-type-code obj)))
+ (logior tc7-bytevector (ash type-code 7))))))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tag endianness)
+ (bytevector-u32-set! buf (+ pos 4)
+ (if (bitvector? obj)
+ (bitvector-length obj)
+ (bytevector-length obj))
+ endianness) ; length
+ (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer
+ (write-immediate asm buf (+ pos 12) #f)) ; owner
+ ((8)
+ (bytevector-u64-set! buf pos tag endianness)
+ (bytevector-u64-set! buf (+ pos 8)
+ (if (bitvector? obj)
+ (bitvector-length obj)
+ (bytevector-length obj))
+ endianness) ; length
+ (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer
+ (write-immediate asm buf (+ pos 24) #f)) ; owner
+ (else (error "bad word size")))))
+
+ ((uniform-vector-backing-store? obj)
+ (let ((bv (uniform-vector-backing-store-bytes obj)))
+ (bytevector-copy! bv 0 buf pos (bytevector-length bv))
+ (unless (or (= 1 (uniform-vector-backing-store-element-size obj))
+ (eq? endianness (native-endianness)))
+ ;; Need to swap units of element-size bytes
+ (error "FIXME: Implement byte order swap"))))
+
+ (else
+ (error "unrecognized object" obj))))
+
+ (cond
+ ((vlist-null? data) #f)
+ (else
+ (let* ((byte-len (vhash-fold (lambda (k v len)
+ (+ (byte-length k) (align len 8)))
+ 0 data))
+ (buf (make-bytevector byte-len 0)))
+ (let lp ((i 0) (pos 0) (symbols '()))
+ (if (< i (vlist-length data))
+ (let* ((pair (vlist-ref data i))
+ (obj (car pair))
+ (obj-label (cdr pair)))
+ (write buf pos obj)
+ (lp (1+ i)
+ (align (+ (byte-length obj) pos) 8)
+ (cons (make-linker-symbol obj-label pos) symbols)))
+ (make-object asm name buf '() symbols
+ #:flags (match name
+ ('.data (logior SHF_ALLOC SHF_WRITE))
+ ('.rodata SHF_ALLOC))))))))))
+
+(define (link-constants asm)
+ "Link sections to hold constants needed by the program text emitted
+using @var{asm}.
+
+Returns three values: an object for the .rodata section, an object for
+the .data section, and a label for an initialization procedure. Any of
+these may be @code{#f}."
+ (define (shareable? x)
+ (cond
+ ((stringbuf? x) #t)
+ ((pair? x)
+ (and (immediate? (car x)) (immediate? (cdr x))))
+ ((simple-vector? x)
+ (let lp ((i 0))
+ (or (= i (vector-length x))
+ (and (immediate? (vector-ref x i))
+ (lp (1+ i))))))
+ ((uniform-vector-backing-store? x) #t)
+ (else #f)))
+ (let* ((constants (asm-constants asm))
+ (len (vlist-length constants)))
+ (let lp ((i 0)
+ (ro vlist-null)
+ (rw vlist-null))
+ (if (= i len)
+ (values (link-data asm ro '.rodata)
+ (link-data asm rw '.data)
+ (emit-init-constants asm))
+ (let ((pair (vlist-ref constants i)))
+ (if (shareable? (car pair))
+ (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
+ (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
+
+
+
+;;;
+;;; Linking program text.
+;;;
+
+(define (process-relocs buf relocs labels)
+ "Patch up internal x8-s24 relocations, and any s32 relocations that
+reference symbols in the text section. Return a list of linker
+relocations for references to symbols defined outside the text section."
+ (fold
+ (lambda (reloc tail)
+ (match reloc
+ ((type label base word)
+ (let ((abs (hashq-ref labels label))
+ (dst (+ base word)))
+ (case type
+ ((s32)
+ (if abs
+ (let ((rel (- abs base)))
+ (s32-set! buf dst rel)
+ tail)
+ (cons (make-linker-reloc 'rel32/4 (* dst 4) word label)
+ tail)))
+ ((x8-s24)
+ (unless abs
+ (error "unbound near relocation" reloc))
+ (let ((rel (- abs base))
+ (u32 (u32-ref buf dst)))
+ (u32-set! buf dst (pack-u8-s24 (logand u32 #xff) rel))
+ tail))
+ (else (error "bad relocation kind" reloc)))))))
+ '()
+ relocs))
+
+(define (process-labels labels)
+ "Define linker symbols for the label-offset map in @var{labels}.
+The offsets are expected to be expressed in words."
+ (hash-map->list (lambda (label loc)
+ (make-linker-symbol label (* loc 4)))
+ labels))
+
+(define (swap-bytes! buf)
+ "Patch up the text buffer @var{buf}, swapping the endianness of each
+32-bit unit."
+ (unless (zero? (modulo (bytevector-length buf) 4))
+ (error "unexpected length"))
+ (let ((byte-len (bytevector-length buf)))
+ (let lp ((pos 0))
+ (unless (= pos byte-len)
+ (bytevector-u32-set!
+ buf pos
+ (bytevector-u32-ref buf pos (endianness big))
+ (endianness little))
+ (lp (+ pos 4))))))
+
+(define (link-text-object asm)
+ "Link the .rtl-text section, swapping the endianness of the bytes if
+needed."
+ (let ((buf (make-u32vector (asm-pos asm))))
+ (let lp ((pos 0) (prev (reverse (asm-prev asm))))
+ (if (null? prev)
+ (let ((byte-size (* (asm-idx asm) 4)))
+ (bytevector-copy! (asm-cur asm) 0 buf pos byte-size)
+ (unless (eq? (asm-endianness asm) (native-endianness))
+ (swap-bytes! buf))
+ (make-object asm '.rtl-text
+ buf
+ (process-relocs buf (asm-relocs asm)
+ (asm-labels asm))
+ (process-labels (asm-labels asm))))
+ (let ((len (* *block-size* 4)))
+ (bytevector-copy! (car prev) 0 buf pos len)
+ (lp (+ pos len) (cdr prev)))))))
+
+
+
+
+;;;
+;;; Create the frame maps. These maps are used by GC to identify dead
+;;; slots in pending call frames, to avoid marking them. We only do
+;;; this when frame makes a non-tail call, as that is the common case.
+;;; Only the topmost frame will see a GC at any other point, but we mark
+;;; top frames conservatively as serializing live slot maps at every
+;;; instruction would take up too much space in the object file.
+;;;
+
+;; The .guile.frame-maps section starts with two packed u32 values: one
+;; indicating the offset of the first byte of the .rtl-text section, and
+;; another indicating the relative offset in bytes of the slots data.
+(define frame-maps-prefix-len 8)
+
+;; Each header is 8 bytes: 4 for the offset from .rtl_text, and 4 for
+;; the offset of the slot map from the beginning of the
+;; .guile.frame-maps section. The length of a frame map depends on the
+;; frame size at the call site, and is not encoded into this section as
+;; it is available at run-time.
+(define frame-map-header-len 8)
+
+(define (link-frame-maps asm)
+ (define (map-byte-length proc-slot)
+ (ceiling-quotient (- proc-slot 2) 8))
+ (define (make-frame-maps maps count map-len)
+ (let* ((endianness (asm-endianness asm))
+ (header-pos frame-maps-prefix-len)
+ (map-pos (+ header-pos (* count frame-map-header-len)))
+ (bv (make-bytevector (+ map-pos map-len) 0)))
+ (bytevector-u32-set! bv 4 map-pos endianness)
+ (let lp ((maps maps) (header-pos header-pos) (map-pos map-pos))
+ (match maps
+ (()
+ (make-object asm '.guile.frame-maps bv
+ (list (make-linker-reloc 'abs32/1 0 0 '.rtl-text))
+ '() #:type SHT_PROGBITS #:flags SHF_ALLOC))
+ (((pos proc-slot . map) . maps)
+ (bytevector-u32-set! bv header-pos (* pos 4) endianness)
+ (bytevector-u32-set! bv (+ header-pos 4) map-pos endianness)
+ (let write-bytes ((map-pos map-pos)
+ (map map)
+ (byte-length (map-byte-length proc-slot)))
+ (if (zero? byte-length)
+ (lp maps (+ header-pos frame-map-header-len) map-pos)
+ (begin
+ (bytevector-u8-set! bv map-pos (logand map #xff))
+ (write-bytes (1+ map-pos) (ash map -8)
+ (1- byte-length))))))))))
+ (match (asm-dead-slot-maps asm)
+ (() #f)
+ (in
+ (let lp ((in in) (out '()) (count 0) (map-len 0))
+ (match in
+ (() (make-frame-maps out count map-len))
+ (((and head (pos proc-slot . map)) . in)
+ (lp in (cons head out)
+ (1+ count)
+ (+ (map-byte-length proc-slot) map-len))))))))
+
+
+
+;;;
+;;; Linking other sections of the ELF file, like the dynamic segment,
+;;; the symbol table, etc.
+;;;
+
+;; FIXME: Define these somewhere central, shared with C.
+(define *bytecode-major-version* #x0202)
+(define *bytecode-minor-version* 4)
+
+(define (link-dynamic-section asm text rw rw-init frame-maps)
+ "Link the dynamic section for an ELF image with bytecode @var{text},
+given the writable data section @var{rw} needing fixup from the
+procedure with label @var{rw-init}. @var{rw-init} may be false. If
+@var{rw} is true, it will be added to the GC roots at runtime."
+ (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
+ (let* ((endianness (asm-endianness asm))
+ (words 6)
+ (words (if rw (+ words 4) words))
+ (words (if rw-init (+ words 2) words))
+ (words (if frame-maps (+ words 2) words))
+ (bv (make-bytevector (* word-size words) 0))
+ (set-uword!
+ (lambda (i uword)
+ (%set-uword! bv (* i word-size) uword endianness)))
+ (relocs '())
+ (set-label!
+ (lambda (i label)
+ (set! relocs (cons (make-linker-reloc 'reloc-type
+ (* i word-size) 0 label)
+ relocs))
+ (%set-uword! bv (* i word-size) 0 endianness))))
+ (set-uword! 0 DT_GUILE_VM_VERSION)
+ (set-uword! 1 (logior (ash *bytecode-major-version* 16)
+ *bytecode-minor-version*))
+ (set-uword! 2 DT_GUILE_ENTRY)
+ (set-label! 3 '.rtl-text)
+ (when rw
+ ;; Add roots to GC.
+ (set-uword! 4 DT_GUILE_GC_ROOT)
+ (set-label! 5 '.data)
+ (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
+ (set-uword! 7 (bytevector-length (linker-object-bv rw)))
+ (when rw-init
+ (set-uword! 8 DT_INIT) ; constants
+ (set-label! 9 rw-init)))
+ (when frame-maps
+ (set-uword! (- words 4) DT_GUILE_FRAME_MAPS)
+ (set-label! (- words 3) '.guile.frame-maps))
+ (set-uword! (- words 2) DT_NULL)
+ (set-uword! (- words 1) 0)
+ (make-object asm '.dynamic bv relocs '()
+ #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
+ (case (asm-word-size asm)
+ ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
+ ((8) (emit-dynamic-section 8 bytevector-u64-set! abs64/1))
+ (else (error "bad word size" asm))))
+
+(define (link-shstrtab asm)
+ "Link the string table for the section headers."
+ (intern-section-name! asm ".shstrtab")
+ (make-object asm '.shstrtab
+ (link-string-table! (asm-shstrtab asm))
+ '() '()
+ #:type SHT_STRTAB #:flags 0))
+
+(define (link-symtab text-section asm)
+ (let* ((endianness (asm-endianness asm))
+ (word-size (asm-word-size asm))
+ (size (elf-symbol-len word-size))
+ (meta (reverse (asm-meta asm)))
+ (n (length meta))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* n size) 0)))
+ (define (intern-string! name)
+ (string-table-intern! strtab (if name (symbol->string name) "")))
+ (for-each
+ (lambda (meta n)
+ (let ((name (intern-string! (meta-name meta))))
+ (write-elf-symbol bv (* n size) endianness word-size
+ (make-elf-symbol
+ #:name name
+ ;; 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))
+ (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))))
+
+;;; The .guile.arities section describes the arities that a function can
+;;; have. It is in two parts: a sorted array of headers describing
+;;; basic arities, and an array of links out to a string table (and in
+;;; the case of keyword arguments, to the data section) for argument
+;;; names. The whole thing is prefixed by a uint32 indicating the
+;;; offset of the end of the headers array.
+;;;
+;;; The arity headers array is a packed array of structures of the form:
+;;;
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+;;;
+;;; All of the offsets and addresses are 32 bits. We can expand in the
+;;; future to use 64-bit offsets if appropriate, but there are other
+;;; aspects of bytecode that constrain us to a total image that fits in
+;;; 32 bits, so for the moment we'll simplify the problem space.
+;;;
+;;; The following flags values are defined:
+;;;
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+;;; #x10: is-in-case-lambda?
+;;;
+;;; Functions with a single arity specify their number of required and
+;;; optional arguments in nreq and nopt, and do not have the
+;;; is-case-lambda? flag set. Their "offset" member links to an array
+;;; of pointers into the associated .guile.arities.strtab string table,
+;;; identifying the argument names. This offset is relative to the
+;;; start of the .guile.arities section. Links for required arguments
+;;; are first, in order, as uint32 values. Next follow the optionals,
+;;; then the rest link if has-rest? is set, then a link to the "keyword
+;;; indices" literal if has-keyword-args? is set. Unlike the other
+;;; links, the kw-indices link points into the data section, and is
+;;; relative to the ELF image as a whole.
+;;;
+;;; Functions with no arities have no arities information present in the
+;;; .guile.arities section.
+;;;
+;;; Functions with multiple arities are preceded by a header with
+;;; is-case-lambda? set. All other fields are 0, except low-pc and
+;;; high-pc which should be the bounds of the whole function. Headers
+;;; for the individual arities follow, with the is-in-case-lambda? flag
+;;; set. In this way the whole headers array is sorted in increasing
+;;; low-pc order, and case-lambda clauses are contained within the
+;;; [low-pc, high-pc] of the case-lambda header.
+
+;; Length of the prefix to the arities section, in bytes.
+(define arities-prefix-len 4)
+
+;; Length of an arity header, in bytes.
+(define arity-header-len (* 6 4))
+
+;; The offset of "offset" within arity header, in bytes.
+(define arity-header-offset-offset (* 2 4))
+
+(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
+ has-keyword-args? is-case-lambda?
+ is-in-case-lambda?)
+ (logior (if has-rest? (ash 1 0) 0)
+ (if allow-other-keys? (ash 1 1) 0)
+ (if has-keyword-args? (ash 1 2) 0)
+ (if is-case-lambda? (ash 1 3) 0)
+ (if is-in-case-lambda? (ash 1 4) 0)))
+
+(define (meta-arities-size meta)
+ (define (lambda-size arity)
+ (+ arity-header-len
+ (* 4 ;; name pointers
+ (+ (length (arity-req arity))
+ (length (arity-opt arity))
+ (if (arity-rest arity) 1 0)
+ (if (pair? (arity-kw-indices arity)) 1 0)))))
+ (define (case-lambda-size arities)
+ (fold +
+ arity-header-len ;; case-lambda header
+ (map lambda-size arities))) ;; the cases
+ (match (meta-arities meta)
+ (() 0)
+ ((arity) (lambda-size arity))
+ (arities (case-lambda-size arities))))
+
+(define (write-arity-headers metas bv endianness)
+ (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
+ (bytevector-u32-set! bv pos (* low-pc 4) endianness)
+ (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness)
+ (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
+ (bytevector-u32-set! bv (+ pos 12) flags endianness)
+ (bytevector-u32-set! bv (+ pos 16) nreq endianness)
+ (bytevector-u32-set! bv (+ pos 20) nopt endianness))
+ (define (write-arity-header pos arity in-case-lambda?)
+ (write-arity-header* pos (arity-low-pc arity)
+ (arity-high-pc arity)
+ (pack-arity-flags (arity-rest arity)
+ (arity-allow-other-keys? arity)
+ (pair? (arity-kw-indices arity))
+ #f
+ in-case-lambda?)
+ (length (arity-req arity))
+ (length (arity-opt arity))))
+ (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
+ (match metas
+ (()
+ ;; Fill in the prefix.
+ (bytevector-u32-set! bv 0 pos endianness)
+ (values pos (reverse offsets)))
+ ((meta . metas)
+ (match (meta-arities meta)
+ (() (lp metas pos offsets))
+ ((arity)
+ (write-arity-header pos arity #f)
+ (lp metas
+ (+ pos arity-header-len)
+ (acons arity (+ pos arity-header-offset-offset) offsets)))
+ (arities
+ ;; Write a case-lambda header, then individual arities.
+ ;; The case-lambda header's offset link is 0.
+ (write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta)
+ (pack-arity-flags #f #f #f #t #f) 0 0)
+ (let lp* ((arities arities) (pos (+ pos arity-header-len))
+ (offsets offsets))
+ (match arities
+ (() (lp metas pos offsets))
+ ((arity . arities)
+ (write-arity-header pos arity #t)
+ (lp* arities
+ (+ pos arity-header-len)
+ (acons arity
+ (+ pos arity-header-offset-offset)
+ offsets)))))))))))
+
+(define (write-arity-links asm bv pos arity-offset-pairs strtab)
+ (define (write-symbol sym pos)
+ (bytevector-u32-set! bv pos
+ (string-table-intern! strtab (symbol->string sym))
+ (asm-endianness asm))
+ (+ pos 4))
+ (define (write-kw-indices pos kw-indices)
+ ;; FIXME: Assert that kw-indices is already interned.
+ (make-linker-reloc 'abs32/1 pos 0
+ (intern-constant asm kw-indices)))
+ (let lp ((pos pos) (pairs arity-offset-pairs) (relocs '()))
+ (match pairs
+ (()
+ (unless (= pos (bytevector-length bv))
+ (error "expected to fully fill the bytevector"
+ pos (bytevector-length bv)))
+ relocs)
+ (((arity . offset) . pairs)
+ (bytevector-u32-set! bv offset pos (asm-endianness asm))
+ (let ((pos (fold write-symbol
+ pos
+ (append (arity-req arity)
+ (arity-opt arity)
+ (cond
+ ((arity-rest arity) => list)
+ (else '()))))))
+ (match (arity-kw-indices arity)
+ (() (lp pos pairs relocs))
+ (kw-indices
+ (lp (+ pos 4)
+ pairs
+ (cons (write-kw-indices pos kw-indices) relocs)))))))))
+
+(define (link-arities asm)
+ (let* ((endianness (asm-endianness asm))
+ (metas (reverse (asm-meta asm)))
+ (size (fold (lambda (meta size)
+ (+ size (meta-arities-size meta)))
+ arities-prefix-len
+ metas))
+ (strtab (make-string-table))
+ (bv (make-bytevector size 0)))
+ (let ((kw-indices-relocs
+ (call-with-values
+ (lambda ()
+ (write-arity-headers metas bv endianness))
+ (lambda (pos arity-offset-pairs)
+ (write-arity-links asm bv pos arity-offset-pairs strtab)))))
+ (let ((strtab (make-object asm '.guile.arities.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.arities
+ bv
+ kw-indices-relocs '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab)))))
+
+;;;
+;;; The .guile.docstrs section is a packed, sorted array of (pc, str)
+;;; values. Pc and str are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, in
+;;; bytes, and str is an index into the associated .guile.docstrs.strtab
+;;; string table section.
+;;;
+
+;; The size of a docstrs entry, in bytes.
+(define docstr-size 8)
+
+(define (link-docstrs asm)
+ (define (find-docstrings)
+ (filter-map (lambda (meta)
+ (define (is-documentation? pair)
+ (eq? (car pair) 'documentation))
+ (let* ((props (meta-properties meta))
+ (tail (find-tail is-documentation? props)))
+ (and tail
+ (not (find-tail is-documentation? (cdr tail)))
+ (string? (cdar tail))
+ (cons (* 4 (meta-low-pc meta)) (cdar tail)))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (docstrings (find-docstrings))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* (length docstrings) docstr-size) 0)))
+ (fold (lambda (pair pos)
+ (match pair
+ ((pc . string)
+ (bytevector-u32-set! bv pos pc endianness)
+ (bytevector-u32-set! bv (+ pos 4)
+ (string-table-intern! strtab string)
+ endianness)
+ (+ pos docstr-size))))
+ 0
+ docstrings)
+ (let ((strtab (make-object asm '.guile.docstrs.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.docstrs
+ bv
+ '() '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
+
+;;;
+;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
+;;; values. Pc and addr are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; addr is the address of the associated properties alist, relative to
+;;; the start of the ELF image.
+;;;
+;;; Since procedure properties are stored in the data sections, we need
+;;; to link the procedures property section first. (Note that this
+;;; constraint does not apply to the arities section, which may
+;;; reference the data sections via the kw-indices literal, because
+;;; assembling the text section already makes sure that the kw-indices
+;;; are interned.)
+;;;
+
+;; The size of a procprops entry, in bytes.
+(define procprops-size 8)
+
+(define (link-procprops asm)
+ (define (assoc-remove-one alist key value-pred)
+ (match alist
+ (() '())
+ ((((? (lambda (x) (eq? x key))) . value) . alist)
+ (if (value-pred value)
+ alist
+ (acons key value alist)))
+ (((k . v) . alist)
+ (acons k v (assoc-remove-one alist key value-pred)))))
+ (define (props-without-name-or-docstring meta)
+ (assoc-remove-one
+ (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
+ 'documentation
+ string?))
+ (define (find-procprops)
+ (filter-map (lambda (meta)
+ (let ((props (props-without-name-or-docstring meta)))
+ (and (pair? props)
+ (cons (* 4 (meta-low-pc meta)) props))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (procprops (find-procprops))
+ (bv (make-bytevector (* (length procprops) procprops-size) 0)))
+ (let lp ((procprops procprops) (pos 0) (relocs '()))
+ (match procprops
+ (()
+ (make-object asm '.guile.procprops
+ bv
+ relocs '()
+ #:type SHT_PROGBITS #:flags 0))
+ (((pc . props) . procprops)
+ (bytevector-u32-set! bv pos pc endianness)
+ (lp procprops
+ (+ pos procprops-size)
+ (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
+ (intern-constant asm props))
+ relocs)))))))
+
+;;;
+;;; The DWARF .debug_info, .debug_abbrev, .debug_str, and .debug_loc
+;;; sections provide line number and local variable liveness
+;;; information. Their format is defined by the DWARF
+;;; specifications.
+;;;
+
+(define (asm-language asm)
+ ;; FIXME: Plumb language through to the assembler.
+ 'scheme)
+
+;; -> 5 values: .debug_info, .debug_abbrev, .debug_str, .debug_loc, .debug_lines
+(define (link-debug asm)
+ (define (put-s8 port val)
+ (let ((bv (make-bytevector 1)))
+ (bytevector-s8-set! bv 0 val)
+ (put-bytevector port bv)))
+
+ (define (put-u16 port val)
+ (let ((bv (make-bytevector 2)))
+ (bytevector-u16-set! bv 0 val (asm-endianness asm))
+ (put-bytevector port bv)))
+
+ (define (put-u32 port val)
+ (let ((bv (make-bytevector 4)))
+ (bytevector-u32-set! bv 0 val (asm-endianness asm))
+ (put-bytevector port bv)))
+
+ (define (put-u64 port val)
+ (let ((bv (make-bytevector 8)))
+ (bytevector-u64-set! bv 0 val (asm-endianness asm))
+ (put-bytevector port bv)))
+
+ (define (put-uleb128 port val)
+ (let lp ((val val))
+ (let ((next (ash val -7)))
+ (if (zero? next)
+ (put-u8 port val)
+ (begin
+ (put-u8 port (logior #x80 (logand val #x7f)))
+ (lp next))))))
+
+ (define (put-sleb128 port val)
+ (let lp ((val val))
+ (if (<= 0 (+ val 64) 127)
+ (put-u8 port (logand val #x7f))
+ (begin
+ (put-u8 port (logior #x80 (logand val #x7f)))
+ (lp (ash val -7))))))
+
+ (define (port-position port)
+ (seek port 0 SEEK_CUR))
+
+ (define (meta->subprogram-die meta)
+ `(subprogram
+ (@ ,@(cond
+ ((meta-name meta)
+ => (lambda (name) `((name ,(symbol->string name)))))
+ (else
+ '()))
+ (low-pc ,(meta-label meta))
+ (high-pc ,(* 4 (- (meta-high-pc meta) (meta-low-pc meta)))))))
+
+ (define (make-compile-unit-die asm)
+ `(compile-unit
+ (@ (producer ,(string-append "Guile " (version)))
+ (language ,(asm-language asm))
+ (low-pc .rtl-text)
+ (high-pc ,(* 4 (asm-pos asm)))
+ (stmt-list 0))
+ ,@(map meta->subprogram-die (reverse (asm-meta asm)))))
+
+ (let-values (((die-port get-die-bv) (open-bytevector-output-port))
+ ((die-relocs) '())
+ ((abbrev-port get-abbrev-bv) (open-bytevector-output-port))
+ ;; (tag has-kids? attrs forms) -> code
+ ((abbrevs) vlist-null)
+ ((strtab) (make-string-table))
+ ((line-port get-line-bv) (open-bytevector-output-port))
+ ((line-relocs) '())
+ ;; file -> code
+ ((files) vlist-null))
+
+ (define (write-abbrev code tag has-children? attrs forms)
+ (put-uleb128 abbrev-port code)
+ (put-uleb128 abbrev-port (tag-name->code tag))
+ (put-u8 abbrev-port (children-name->code (if has-children? 'yes 'no)))
+ (for-each (lambda (attr form)
+ (put-uleb128 abbrev-port (attribute-name->code attr))
+ (put-uleb128 abbrev-port (form-name->code form)))
+ attrs forms)
+ (put-uleb128 abbrev-port 0)
+ (put-uleb128 abbrev-port 0))
+
+ (define (intern-abbrev tag has-children? attrs forms)
+ (let ((key (list tag has-children? attrs forms)))
+ (match (vhash-assoc key abbrevs)
+ ((_ . code) code)
+ (#f (let ((code (1+ (vlist-length abbrevs))))
+ (set! abbrevs (vhash-cons key code abbrevs))
+ (write-abbrev code tag has-children? attrs forms)
+ code)))))
+
+ (define (intern-file file)
+ (match (vhash-assoc file files)
+ ((_ . code) code)
+ (#f (let ((code (1+ (vlist-length files))))
+ (set! files (vhash-cons file code files))
+ code))))
+
+ (define (write-sources)
+ ;; Choose line base and line range values that will allow for an
+ ;; address advance range of 16 words. The special opcode range is
+ ;; from 10 to 255, so 246 values.
+ (define base -4)
+ (define range 15)
+
+ (let lp ((sources (asm-sources asm)) (out '()))
+ (match sources
+ (((pc . s) . sources)
+ (let ((file (assq-ref s 'filename))
+ (line (assq-ref s 'line))
+ (col (assq-ref s 'column)))
+ (lp sources
+ ;; Guile line and column numbers are 0-indexed, but
+ ;; they are 1-indexed for DWARF.
+ (cons (list pc
+ (if file (intern-file file) 0)
+ (if line (1+ line))
+ (if col (1+ col)))
+ out))))
+ (()
+ ;; Compilation unit header for .debug_line. We write in
+ ;; DWARF 2 format because more tools understand it than DWARF
+ ;; 4, which incompatibly adds another field to this header.
+
+ (put-u32 line-port 0) ; Length; will patch later.
+ (put-u16 line-port 2) ; DWARF 2 format.
+ (put-u32 line-port 0) ; Prologue length; will patch later.
+ (put-u8 line-port 4) ; Minimum instruction length: 4 bytes.
+ (put-u8 line-port 1) ; Default is-stmt: true.
+
+ (put-s8 line-port base) ; Line base. See the DWARF standard.
+ (put-u8 line-port range) ; Line range. See the DWARF standard.
+ (put-u8 line-port 10) ; Opcode base: the first "special" opcode.
+
+ ;; A table of the number of uleb128 arguments taken by each
+ ;; of the standard opcodes.
+ (put-u8 line-port 0) ; 1: copy
+ (put-u8 line-port 1) ; 2: advance-pc
+ (put-u8 line-port 1) ; 3: advance-line
+ (put-u8 line-port 1) ; 4: set-file
+ (put-u8 line-port 1) ; 5: set-column
+ (put-u8 line-port 0) ; 6: negate-stmt
+ (put-u8 line-port 0) ; 7: set-basic-block
+ (put-u8 line-port 0) ; 8: const-add-pc
+ (put-u8 line-port 1) ; 9: fixed-advance-pc
+
+ ;; Include directories, as a zero-terminated sequence of
+ ;; nul-terminated strings. Nothing, for the moment.
+ (put-u8 line-port 0)
+
+ ;; File table. For each file that contributes to this
+ ;; compilation unit, a nul-terminated file name string, and a
+ ;; uleb128 for each of directory the file was found in, the
+ ;; modification time, and the file's size in bytes. We pass
+ ;; zero for the latter three fields.
+ (vlist-fold-right
+ (lambda (pair seed)
+ (match pair
+ ((file . code)
+ (put-bytevector line-port (string->utf8 file))
+ (put-u8 line-port 0)
+ (put-uleb128 line-port 0) ; directory
+ (put-uleb128 line-port 0) ; mtime
+ (put-uleb128 line-port 0))) ; size
+ seed)
+ #f
+ files)
+ (put-u8 line-port 0) ; 0 byte terminating file list.
+
+ ;; Patch prologue length.
+ (let ((offset (port-position line-port)))
+ (seek line-port 6 SEEK_SET)
+ (put-u32 line-port (- offset 10))
+ (seek line-port offset SEEK_SET))
+
+ ;; Now write the statement program.
+ (let ()
+ (define (extended-op opcode payload-len)
+ (put-u8 line-port 0) ; extended op
+ (put-uleb128 line-port (1+ payload-len)) ; payload-len + opcode
+ (put-uleb128 line-port opcode))
+ (define (set-address sym)
+ (define (add-reloc! kind)
+ (set! line-relocs
+ (cons (make-linker-reloc kind
+ (port-position line-port)
+ 0
+ sym)
+ line-relocs)))
+ (match (asm-word-size asm)
+ (4
+ (extended-op 2 4)
+ (add-reloc! 'abs32/1)
+ (put-u32 line-port 0))
+ (8
+ (extended-op 2 8)
+ (add-reloc! 'abs64/1)
+ (put-u64 line-port 0))))
+ (define (end-sequence pc)
+ (let ((pc-inc (- (asm-pos asm) pc)))
+ (put-u8 line-port 2) ; advance-pc
+ (put-uleb128 line-port pc-inc))
+ (extended-op 1 0))
+ (define (advance-pc pc-inc line-inc)
+ (let ((spec (+ (- line-inc base) (* pc-inc range) 10)))
+ (cond
+ ((or (< line-inc base) (>= line-inc (+ base range)))
+ (advance-line line-inc)
+ (advance-pc pc-inc 0))
+ ((<= spec 255)
+ (put-u8 line-port spec))
+ ((< spec 500)
+ (put-u8 line-port 8) ; const-advance-pc
+ (advance-pc (- pc-inc (floor/ (- 255 10) range))
+ line-inc))
+ (else
+ (put-u8 line-port 2) ; advance-pc
+ (put-uleb128 line-port pc-inc)
+ (advance-pc 0 line-inc)))))
+ (define (advance-line inc)
+ (put-u8 line-port 3)
+ (put-sleb128 line-port inc))
+ (define (set-file file)
+ (put-u8 line-port 4)
+ (put-uleb128 line-port file))
+ (define (set-column col)
+ (put-u8 line-port 5)
+ (put-uleb128 line-port col))
+
+ (set-address '.rtl-text)
+
+ (let lp ((in out) (pc 0) (file 1) (line 1) (col 0))
+ (match in
+ (()
+ (when (null? out)
+ ;; There was no source info in the first place. Set
+ ;; file register to 0 before adding final row.
+ (set-file 0))
+ (end-sequence pc))
+ (((pc* file* line* col*) . in*)
+ (cond
+ ((and (eqv? file file*) (eqv? line line*) (eqv? col col*))
+ (lp in* pc file line col))
+ (else
+ (unless (eqv? col col*)
+ (set-column col*))
+ (unless (eqv? file file*)
+ (set-file file*))
+ (advance-pc (- pc* pc) (- line* line))
+ (lp in* pc* file* line* col*)))))))))))
+
+ (define (compute-code attr val)
+ (match attr
+ ('name (string-table-intern! strtab val))
+ ('low-pc val)
+ ('high-pc val)
+ ('producer (string-table-intern! strtab val))
+ ('language (language-name->code val))
+ ('stmt-list val)))
+
+ (define (exact-integer? val)
+ (and (number? val) (integer? val) (exact? val)))
+
+ (define (choose-form attr val code)
+ (cond
+ ((string? val) 'strp)
+ ((eq? attr 'stmt-list) 'sec-offset)
+ ((exact-integer? code)
+ (cond
+ ((< code 0) 'sleb128)
+ ((<= code #xff) 'data1)
+ ((<= code #xffff) 'data2)
+ ((<= code #xffffffff) 'data4)
+ ((<= code #xffffffffffffffff) 'data8)
+ (else 'uleb128)))
+ ((symbol? val) 'addr)
+ (else (error "unhandled case" attr val code))))
+
+ (define (add-die-relocation! kind sym)
+ (set! die-relocs
+ (cons (make-linker-reloc kind (port-position die-port) 0 sym)
+ die-relocs)))
+
+ (define (write-value code form)
+ (match form
+ ('data1 (put-u8 die-port code))
+ ('data2 (put-u16 die-port code))
+ ('data4 (put-u32 die-port code))
+ ('data8 (put-u64 die-port code))
+ ('uleb128 (put-uleb128 die-port code))
+ ('sleb128 (put-sleb128 die-port code))
+ ('addr
+ (match (asm-word-size asm)
+ (4
+ (add-die-relocation! 'abs32/1 code)
+ (put-u32 die-port 0))
+ (8
+ (add-die-relocation! 'abs64/1 code)
+ (put-u64 die-port 0))))
+ ('sec-offset (put-u32 die-port code))
+ ('strp (put-u32 die-port code))))
+
+ (define (write-die die)
+ (match die
+ ((tag ('@ (attrs vals) ...) children ...)
+ (let* ((codes (map compute-code attrs vals))
+ (forms (map choose-form attrs vals codes))
+ (has-children? (not (null? children)))
+ (abbrev-code (intern-abbrev tag has-children? attrs forms)))
+ (put-uleb128 die-port abbrev-code)
+ (for-each write-value codes forms)
+ (when has-children?
+ (for-each write-die children)
+ (put-uleb128 die-port 0))))))
+
+ ;; Compilation unit header.
+ (put-u32 die-port 0) ; Length; will patch later.
+ (put-u16 die-port 4) ; DWARF 4.
+ (put-u32 die-port 0) ; Abbrevs offset.
+ (put-u8 die-port (asm-word-size asm)) ; Address size.
+
+ (write-die (make-compile-unit-die asm))
+
+ ;; Terminate the abbrevs list.
+ (put-uleb128 abbrev-port 0)
+
+ (write-sources)
+
+ (values (let ((bv (get-die-bv)))
+ ;; Patch DWARF32 length.
+ (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
+ (asm-endianness asm))
+ (make-object asm '.debug_info bv die-relocs '()
+ #:type SHT_PROGBITS #:flags 0))
+ (make-object asm '.debug_abbrev (get-abbrev-bv) '() '()
+ #:type SHT_PROGBITS #:flags 0)
+ (make-object asm '.debug_str (link-string-table! strtab) '() '()
+ #:type SHT_PROGBITS #:flags 0)
+ (make-object asm '.debug_loc #vu8() '() '()
+ #:type SHT_PROGBITS #:flags 0)
+ (let ((bv (get-line-bv)))
+ ;; Patch DWARF32 length.
+ (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
+ (asm-endianness asm))
+ (make-object asm '.debug_line bv line-relocs '()
+ #:type SHT_PROGBITS #:flags 0)))))
+
+(define (link-objects asm)
+ (let*-values (;; Link procprops before constants, because it probably
+ ;; interns more constants.
+ ((procprops) (link-procprops asm))
+ ((ro rw rw-init) (link-constants asm))
+ ;; Link text object after constants, so that the
+ ;; constants initializer gets included.
+ ((text) (link-text-object asm))
+ ((frame-maps) (link-frame-maps asm))
+ ((dt) (link-dynamic-section asm text rw rw-init frame-maps))
+ ((symtab strtab) (link-symtab (linker-object-section text) asm))
+ ((arities arities-strtab) (link-arities asm))
+ ((docstrs docstrs-strtab) (link-docstrs asm))
+ ((dinfo dabbrev dstrtab dloc dline) (link-debug asm))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ ((shstrtab) (link-shstrtab asm)))
+ (filter identity
+ (list text ro frame-maps rw dt symtab strtab
+ arities arities-strtab
+ docstrs docstrs-strtab procprops
+ dinfo dabbrev dstrtab dloc dline
+ shstrtab))))
+
+
+
+
+;;;
+;;; High-level public interfaces.
+;;;
+
+(define* (link-assembly asm #:key (page-aligned? #t))
+ "Produce an ELF image from the code and data emitted into @var{asm}.
+The result is a bytevector, by default linked so that read-only and
+writable data are on separate pages. Pass @code{#:page-aligned? #f} to
+disable this behavior."
+ (link-elf (link-objects asm) #:page-aligned? page-aligned?))
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index 268d2112a..f47e33f58 100644
--- a/module/system/vm/coverage.scm
+++ b/module/system/vm/coverage.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 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
@@ -20,10 +20,14 @@
#:use-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
+ #:use-module (system vm debug)
+ #:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
#:export (with-code-coverage
coverage-data?
instrumented-source-files
@@ -46,61 +50,80 @@
;;; Gathering coverage data.
;;;
-(define (hashq-proc proc n)
- ;; Return the hash of PROC's objcode.
- (hashq (program-objcode proc) n))
-
-(define (assq-proc proc alist)
- ;; Instead of really looking for PROC in ALIST, look for the objcode of PROC.
- ;; IOW the alist is indexed by procedures, not objcodes, but those procedures
- ;; are taken as an arbitrary representative of all the procedures (closures)
- ;; sharing that objcode. This can significantly reduce memory consumption.
- (let ((code (program-objcode proc)))
- (find (lambda (pair)
- (eq? code (program-objcode (car pair))))
- alist)))
-
-(define (with-code-coverage vm thunk)
- "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code
-coverage data. Return code coverage data and the values returned by THUNK."
-
- (define procedure->ip-counts
- ;; Mapping from procedures to hash tables; said hash tables map instruction
- ;; pointers to the number of times they were executed.
- (make-hash-table 500))
+(define (with-code-coverage thunk)
+ "Run THUNK, a zero-argument procedure, while instrumenting Guile's VM to
+collect code coverage data. Return code coverage data and the values returned
+by THUNK."
+
+ (define ip-counts
+ ;; A table mapping instruction pointers to the number of times they were
+ ;; executed.
+ (make-hash-table 5000))
(define (collect! frame)
- ;; Update PROCEDURE->IP-COUNTS with info from FRAME.
- (let* ((proc (frame-procedure frame))
- (ip (frame-instruction-pointer frame))
- (proc-entry (hashx-create-handle! hashq-proc assq-proc
- procedure->ip-counts proc #f)))
- (let loop ()
- (define ip-counts (cdr proc-entry))
- (if ip-counts
- (let ((ip-entry (hashv-create-handle! ip-counts ip 0)))
- (set-cdr! ip-entry (+ (cdr ip-entry) 1)))
- (begin
- (set-cdr! proc-entry (make-hash-table))
- (loop))))))
+ ;; Update IP-COUNTS with info from FRAME.
+ (let* ((ip (frame-instruction-pointer frame))
+ (ip-entry (hashv-create-handle! ip-counts ip 0)))
+ (set-cdr! ip-entry (+ (cdr ip-entry) 1))))
;; FIXME: It's unclear what the dynamic-wind is for, given that if the
;; VM is different from the current one, continuations will not be
;; resumable.
(call-with-values (lambda ()
- (let ((level (vm-trace-level vm))
- (hook (vm-next-hook vm)))
+ (let ((level (vm-trace-level))
+ (hook (vm-next-hook)))
(dynamic-wind
(lambda ()
- (set-vm-trace-level! vm (+ level 1))
+ (set-vm-trace-level! (+ level 1))
(add-hook! hook collect!))
(lambda ()
- (call-with-vm vm thunk))
+ (call-with-vm thunk))
(lambda ()
- (set-vm-trace-level! vm level)
+ (set-vm-trace-level! level)
(remove-hook! hook collect!)))))
(lambda args
- (apply values (make-coverage-data procedure->ip-counts) args))))
+ (apply values (make-coverage-data ip-counts) args))))
+
+
+
+
+;;;
+;;; Source chunks.
+;;;
+
+(define-record-type <source-chunk>
+ (make-source-chunk base length sources)
+ source-chunk?
+ (base source-chunk-base)
+ (length source-chunk-length)
+ (sources source-chunk-sources))
+
+(set-record-type-printer!
+ <source-chunk>
+ (lambda (obj port)
+ (format port "<source-chunk #x~x-#x~x>"
+ (source-chunk-base obj)
+ (+ (source-chunk-base obj) (source-chunk-length obj)))))
+
+(define (compute-source-chunk ctx)
+ "Build a sorted vector of source information for a given debugging
+context (ELF image). The return value is a @code{<source-chunk>}, which also
+records the address range to which the source information applies."
+ (make-source-chunk
+ (debug-context-base ctx)
+ (debug-context-length ctx)
+ ;; The source locations are sorted already, but collected in reverse order.
+ (list->vector (reverse! (fold-source-locations cons '() ctx)))))
+
+(define (all-source-information)
+ "Build and return a vector of source information corresponding to all
+loaded code. The vector will be sorted by ascending address order."
+ (sort! (list->vector (fold-all-debug-contexts
+ (lambda (ctx seed)
+ (cons (compute-source-chunk ctx) seed))
+ '()))
+ (lambda (x y)
+ (< (source-chunk-base x) (source-chunk-base y)))))
;;;
@@ -108,124 +131,137 @@ coverage data. Return code coverage data and the values returned by THUNK."
;;;
(define-record-type <coverage-data>
- (%make-coverage-data procedure->ip-counts
- procedure->sources
+ (%make-coverage-data ip-counts
+ sources
file->procedures
file->line-counts)
coverage-data?
- ;; Mapping from procedures to hash tables; said hash tables map instruction
- ;; pointers to the number of times they were executed.
- (procedure->ip-counts data-procedure->ip-counts)
+ ;; Mapping from instruction pointers to the number of times they were
+ ;; executed, as a sorted vector of IP-count pairs.
+ (ip-counts data-ip-counts)
- ;; Mapping from procedures to the result of `program-sources'.
- (procedure->sources data-procedure->sources)
+ ;; Complete source census at the time the coverage analysis was run, as a
+ ;; sorted vector of <source-chunk> values.
+ (sources data-sources)
;; Mapping from source file names to lists of procedures defined in the file.
+ ;; FIXME.
(file->procedures data-file->procedures)
;; Mapping from file names to hash tables, which in turn map from line numbers
;; to execution counts.
(file->line-counts data-file->line-counts))
+(set-record-type-printer!
+ <coverage-data>
+ (lambda (obj port)
+ (format port "<coverage-data ~x>" (object-address obj))))
-(define (make-coverage-data procedure->ip-counts)
+(define (make-coverage-data ip-counts)
;; Return a `coverage-data' object based on the coverage data available in
- ;; PROCEDURE->IP-COUNTS. Precompute the other hash tables that make up
- ;; `coverage-data' objects.
- (let* ((procedure->sources (make-hash-table 500))
+ ;; IP-COUNTS. Precompute the other hash tables that make up `coverage-data'
+ ;; objects.
+ (let* ((all-sources (all-source-information))
+ (all-counts (sort! (list->vector (hash-fold acons '() ip-counts))
+ (lambda (x y)
+ (< (car x) (car y)))))
(file->procedures (make-hash-table 100))
(file->line-counts (make-hash-table 100))
- (data (%make-coverage-data procedure->ip-counts
- procedure->sources
+ (data (%make-coverage-data all-counts
+ all-sources
file->procedures
file->line-counts)))
- (define (increment-execution-count! file line count)
+
+ (define (observe-execution-count! file line count)
;; Make the execution count of FILE:LINE the maximum of its current value
;; and COUNT. This is so that LINE's execution count is correct when
;; several instruction pointers map to LINE.
- (let ((file-entry (hash-create-handle! file->line-counts file #f)))
- (if (not (cdr file-entry))
- (set-cdr! file-entry (make-hash-table 500)))
- (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
- (set-cdr! line-entry (max (cdr line-entry) count)))))
-
- ;; Update execution counts for procs that were executed.
- (hash-for-each (lambda (proc ip-counts)
- (let* ((sources (program-sources* data proc))
- (file (and (pair? sources)
- (source:file (car sources)))))
- (and file
- (begin
- ;; Add a zero count for all IPs in SOURCES and in
- ;; the sources of procedures closed over by PROC.
- (for-each
- (lambda (source)
- (let ((file (source:file source))
- (line (source:line source)))
- (increment-execution-count! file line 0)))
- (append-map (cut program-sources* data <>)
- (closed-over-procedures proc)))
-
- ;; Add the actual execution count collected.
- (hash-for-each
- (lambda (ip count)
- (let ((line (closest-source-line sources ip)))
- (increment-execution-count! file line count)))
- ip-counts)))))
- procedure->ip-counts)
-
- ;; Set the execution count to zero for procedures loaded and not executed.
- ;; FIXME: Traversing thousands of procedures here is inefficient.
- (for-each (lambda (proc)
- (and (not (hashq-ref procedure->sources proc))
- (for-each (lambda (proc)
- (let* ((sources (program-sources* data proc))
- (file (and (pair? sources)
- (source:file (car sources)))))
- (and file
- (for-each
- (lambda (ip)
- (let ((line (closest-source-line sources ip)))
- (increment-execution-count! file line 0)))
- (map source:addr sources)))))
- (closed-over-procedures proc))))
- (append-map module-procedures (loaded-modules)))
+ (when file
+ (let ((file-entry (hash-create-handle! file->line-counts file #f)))
+ (if (not (cdr file-entry))
+ (set-cdr! file-entry (make-hash-table 500)))
+ (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
+ (set-cdr! line-entry (max (cdr line-entry) count))))))
+
+ ;; First, visit every known source location and mark it as instrumented but
+ ;; unvisited.
+ ;;
+ ;; FIXME: This is not always necessary. It's important to have the ability
+ ;; to know when a source location is not reached, but sometimes all we need
+ ;; to know is that a particular site *was* reached. In that case we
+ ;; wouldn't need to load up all the DWARF sections. As it is, though, we
+ ;; use the complete source census as part of the later phase.
+ (let visit-chunk ((chunk-idx 0))
+ (when (< chunk-idx (vector-length all-sources))
+ (match (vector-ref all-sources chunk-idx)
+ (($ <source-chunk> base chunk-length chunk-sources)
+ (let visit-source ((source-idx 0))
+ (when (< source-idx (vector-length chunk-sources))
+ (let ((s (vector-ref chunk-sources source-idx)))
+ (observe-execution-count! (source-file s) (source-line s) 0)
+ (visit-source (1+ source-idx)))))))
+ (visit-chunk (1+ chunk-idx))))
+
+ ;; Then, visit the measured execution counts, walking the complete source
+ ;; census at the same time. This allows us to map observed addresses to
+ ;; source locations. Record observed execution counts.
+ (let visit-chunk ((chunk-idx 0) (count-idx 0))
+ (when (< chunk-idx (vector-length all-sources))
+ (match (vector-ref all-sources chunk-idx)
+ (($ <source-chunk> base chunk-length chunk-sources)
+ (let visit-count ((count-idx count-idx) (source-idx 0) (source #f))
+ (when (< count-idx (vector-length all-counts))
+ (match (vector-ref all-counts count-idx)
+ ((ip . count)
+ (cond
+ ((< ip base)
+ ;; Address before chunk base; no corresponding source.
+ (visit-count (1+ count-idx) source-idx source))
+ ((< ip (+ base chunk-length))
+ ;; Address in chunk; count it.
+ (let visit-source ((source-idx source-idx) (source source))
+ (define (finish)
+ (when source
+ (observe-execution-count! (source-file source)
+ (source-line source)
+ count))
+ (visit-count (1+ count-idx) source-idx source))
+ (cond
+ ((< source-idx (vector-length chunk-sources))
+ (let ((source* (vector-ref chunk-sources source-idx)))
+ (if (<= (source-pre-pc source*) ip)
+ (visit-source (1+ source-idx) source*)
+ (finish))))
+ (else
+ (finish)))))
+ (else
+ ;; Address past chunk; fetch the next chunk.
+ (visit-chunk (1+ chunk-idx) count-idx)))))))))))
data))
(define (procedure-execution-count data proc)
- "Return the number of times PROC's code was executed, according to DATA, or #f
-if PROC was not executed. When PROC is a closure, the number of times its code
-was executed is returned, not the number of times this code associated with this
-particular closure was executed."
- (let ((sources (program-sources* data proc)))
- (and (pair? sources)
- (and=> (hashx-ref hashq-proc assq-proc
- (data-procedure->ip-counts data) proc)
- (lambda (ip-counts)
- ;; FIXME: broken with lambda*
- (let ((entry-ip (source:addr (car sources))))
- (hashv-ref ip-counts entry-ip 0)))))))
-
-(define (program-sources* data proc)
- ;; A memoizing version of `program-sources'.
- (or (hashq-ref (data-procedure->sources data) proc)
- (and (program? proc)
- (let ((sources (program-sources proc))
- (p->s (data-procedure->sources data))
- (f->p (data-file->procedures data)))
- (if (pair? sources)
- (let* ((file (source:file (car sources)))
- (entry (hash-create-handle! f->p file '())))
- (hashq-set! p->s proc sources)
- (set-cdr! entry (cons proc (cdr entry)))
- sources)
- sources)))))
-
-(define (file-procedures data file)
- ;; Return the list of globally bound procedures defined in FILE.
- (hash-ref (data-file->procedures data) file '()))
+ "Return the number of times PROC's code was executed, according to DATA. When
+PROC is a closure, the number of times its code was executed is returned, not
+the number of times this code associated with this particular closure was
+executed."
+ (define (binary-search v key val)
+ (let lp ((start 0) (end (vector-length v)))
+ (and (not (eqv? start end))
+ (let* ((idx (floor/ (+ start end) 2))
+ (elt (vector-ref v idx))
+ (val* (key elt)))
+ (cond
+ ((< val val*)
+ (lp start idx))
+ ((< val* val)
+ (lp (1+ idx) end))
+ (else elt))))))
+ (and (program? proc)
+ (match (binary-search (data-ip-counts data) car (program-code proc))
+ (#f 0)
+ ((ip . code) code))))
(define (instrumented/executed-lines data file)
"Return the number of instrumented and the number of executed source lines in
@@ -262,62 +298,6 @@ was loaded at the time DATA was collected."
;;;
-;;; Helpers.
-;;;
-
-(define (loaded-modules)
- ;; Return the list of all the modules currently loaded.
- (define seen (make-hash-table))
-
- (let loop ((modules (module-submodules (resolve-module '() #f)))
- (result '()))
- (hash-fold (lambda (name module result)
- (if (hashq-ref seen module)
- result
- (begin
- (hashq-set! seen module #t)
- (loop (module-submodules module)
- (cons module result)))))
- result
- modules)))
-
-(define (module-procedures module)
- ;; Return the list of procedures bound globally in MODULE.
- (hash-fold (lambda (binding var result)
- (if (variable-bound? var)
- (let ((value (variable-ref var)))
- (if (procedure? value)
- (cons value result)
- result))
- result))
- '()
- (module-obarray module)))
-
-(define (closest-source-line sources ip)
- ;; Given SOURCES, as returned by `program-sources' for a given procedure,
- ;; return the source line of code that is the closest to IP. This is similar
- ;; to what `program-source' does.
- (let loop ((sources sources)
- (line (and (pair? sources) (source:line (car sources)))))
- (if (null? sources)
- line
- (let ((source (car sources)))
- (if (> (source:addr source) ip)
- line
- (loop (cdr sources) (source:line source)))))))
-
-(define (closed-over-procedures proc)
- ;; Return the list of procedures PROC closes over, PROC included.
- (let loop ((proc proc)
- (result '()))
- (if (and (program? proc) (not (memq proc result)))
- (fold loop (cons proc result)
- (append (vector->list (or (program-objects proc) #()))
- (program-free-variables proc)))
- result)))
-
-
-;;;
;;; LCOV output.
;;;
@@ -327,9 +307,13 @@ was loaded at the time DATA was collected."
The report will include all the modules loaded at the time coverage data was
gathered, even if their code was not executed."
+ ;; FIXME: Re-enable this code, but using for-each-elf-symbol on each source
+ ;; chunk. Use that to build a map of file -> proc-addr + line + name. Then
+ ;; use something like procedure-execution-count to get the execution count.
+ #;
(define (dump-function proc)
;; Dump source location and basic coverage data for PROC.
- (and (program? proc)
+ (and (or (program? proc))
(let ((sources (program-sources* data proc)))
(and (pair? sources)
(let* ((line (source:line-for-user (car sources)))
@@ -343,11 +327,11 @@ gathered, even if their code was not executed."
;; Output per-file coverage data.
(format port "TN:~%")
(for-each (lambda (file)
- (let ((procs (file-procedures data file))
- (path (search-path %load-path file)))
+ (let ((path (search-path %load-path file)))
(if (string? path)
(begin
(format port "SF:~A~%" path)
+ #;
(for-each dump-function procs)
(for-each (lambda (line+count)
(let ((line (car line+count))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
new file mode 100644
index 000000000..b4dfc3e16
--- /dev/null
+++ b/module/system/vm/debug.scm
@@ -0,0 +1,626 @@
+;;; Guile runtime debug information
+
+;;; Copyright (C) 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
+
+;;; Commentary:
+;;;
+;;; Guile's bytecode compiler and linker serialize debugging information
+;;; into separate sections of the ELF image. This module reads those
+;;; sections.
+;;;
+;;; Code:
+
+(define-module (system vm debug)
+ #:use-module (system vm elf)
+ #:use-module (system vm dwarf)
+ #:use-module (system vm loader)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-9)
+ #:export (debug-context-image
+ debug-context-base
+ debug-context-length
+ debug-context-text-base
+
+ program-debug-info-name
+ program-debug-info-context
+ program-debug-info-image
+ program-debug-info-offset
+ program-debug-info-size
+ program-debug-info-addr
+ program-debug-info-u32-offset
+ program-debug-info-u32-offset-end
+
+ arity?
+ arity-low-pc
+ arity-high-pc
+ arity-nreq
+ arity-nopt
+ arity-has-rest?
+ arity-allow-other-keys?
+ arity-has-keyword-args?
+ arity-is-case-lambda?
+
+ debug-context-from-image
+ fold-all-debug-contexts
+ for-each-elf-symbol
+ find-debug-context
+ find-program-debug-info
+ arity-arguments-alist
+ find-program-arities
+ find-program-minimum-arity
+
+ find-program-docstring
+
+ find-program-properties
+
+ source?
+ source-pre-pc
+ source-post-pc
+ source-file
+ source-line
+ source-line-for-user
+ source-column
+ find-source-for-addr
+ find-program-sources
+ fold-source-locations))
+
+;;; A compiled procedure comes from a specific loaded ELF image. A
+;;; debug context identifies that image.
+;;;
+(define-record-type <debug-context>
+ (make-debug-context elf base text-base)
+ debug-context?
+ (elf debug-context-elf)
+ ;; Address at which this image is loaded in memory, in bytes.
+ (base debug-context-base)
+ ;; Offset of the text section relative to the image start, in bytes.
+ (text-base debug-context-text-base))
+
+(define (debug-context-image context)
+ "Return the bytevector aliasing the mapped ELF image corresponding to
+@var{context}."
+ (elf-bytes (debug-context-elf context)))
+
+(define (debug-context-length context)
+ "Return the size of the mapped ELF image corresponding to
+@var{context}, in bytes."
+ (bytevector-length (debug-context-image context)))
+
+(define (for-each-elf-symbol context proc)
+ "Call @var{proc} on each symbol in the symbol table of @var{context}."
+ (let ((elf (debug-context-elf context)))
+ (cond
+ ((elf-section-by-name elf ".symtab")
+ => (lambda (symtab)
+ (let ((len (elf-symbol-table-len symtab))
+ (strtab (elf-section elf (elf-section-link symtab))))
+ (let lp ((n 0))
+ (when (< n len)
+ (proc (elf-symbol-table-ref elf symtab n strtab))
+ (lp (1+ n))))))))))
+
+;;; A program debug info (PDI) is a handle on debugging meta-data for a
+;;; particular program.
+;;;
+(define-record-type <program-debug-info>
+ (make-program-debug-info context name offset size)
+ program-debug-info?
+ (context program-debug-info-context)
+ (name program-debug-info-name)
+ ;; Offset of the procedure in the text section, in bytes.
+ (offset program-debug-info-offset)
+ (size program-debug-info-size))
+
+(define (program-debug-info-addr pdi)
+ "Return the address in memory of the entry of the program represented
+by the debugging info @var{pdi}."
+ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi))
+ (debug-context-base (program-debug-info-context pdi))))
+
+(define (program-debug-info-image pdi)
+ "Return the ELF image containing @var{pdi}, as a bytevector."
+ (debug-context-image (program-debug-info-context pdi)))
+
+(define (program-debug-info-u32-offset pdi)
+ "Return the start address of the program represented by @var{pdi}, as
+an offset from the beginning of the ELF image in 32-bit units."
+ (/ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi)))
+ 4))
+
+(define (program-debug-info-u32-offset-end pdi)
+ "Return the end address of the program represented by @var{pdi}, as an
+offset from the beginning of the ELF image in 32-bit units."
+ (/ (+ (program-debug-info-size pdi)
+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi)))
+ 4))
+
+(define (debug-context-from-image bv)
+ "Build a debugging context corresponding to a given ELF image."
+ (let* ((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")))))
+ (make-debug-context elf base text-base)))
+
+(define (fold-all-debug-contexts proc seed)
+ "Fold @var{proc} over debug contexts corresponding to all images that
+are mapped at the time this procedure is called. Any images mapped
+during the fold are omitted."
+ (fold (lambda (image seed)
+ (proc (debug-context-from-image image) seed))
+ seed
+ (all-mapped-elf-images)))
+
+(define (find-debug-context addr)
+ "Find and return the debugging context corresponding to the ELF image
+containing the address @var{addr}. @var{addr} is an integer. If no ELF
+image is found, return @code{#f}. It's possible for an bytecode program
+not to have an ELF image if the program was defined in as a stub in C."
+ (and=> (find-mapped-elf-image addr)
+ debug-context-from-image))
+
+(define-inlinable (binary-search start end inc try failure)
+ (let lp ((start start) (end end))
+ (if (eqv? start end)
+ (failure)
+ (let ((mid (+ start (* inc (floor/ (- end start) (* 2 inc))))))
+ (try mid
+ (lambda ()
+ (lp start mid))
+ (lambda ()
+ (lp (+ mid inc) end)))))))
+
+(define (find-elf-symbol elf text-offset)
+ "Search the symbol table of @var{elf} for the ELF symbol containing
+@var{text-offset}. @var{text-offset} is a byte offset in the text
+section of the ELF image. Returns an ELF symbol, or @code{#f}."
+ (and=>
+ (elf-section-by-name elf ".symtab")
+ (lambda (symtab)
+ (let ((strtab (elf-section elf (elf-section-link symtab))))
+ (binary-search
+ 0 (elf-symbol-table-len symtab) 1
+ (lambda (n continue-before continue-after)
+ (let* ((sym (elf-symbol-table-ref elf symtab n strtab))
+ (val (elf-symbol-value sym))
+ (size (elf-symbol-size sym)))
+ (cond
+ ((< text-offset val) (continue-before))
+ ((<= (+ val size) text-offset) (continue-after))
+ (else sym))))
+ (lambda ()
+ #f))))))
+
+(define* (find-program-debug-info addr #:optional
+ (context (find-debug-context addr)))
+ "Find and return the @code{<program-debug-info>} containing
+@var{addr}, or @code{#f}."
+ (cond
+ ((and context
+ (find-elf-symbol (debug-context-elf context)
+ (- addr
+ (debug-context-base context)
+ (debug-context-text-base context))))
+ => (lambda (sym)
+ (make-program-debug-info context
+ (and=> (elf-symbol-name sym)
+ ;; The name might be #f if
+ ;; the string table was
+ ;; stripped somehow.
+ (lambda (x)
+ (and (string? x)
+ (not (string-null? x))
+ (string->symbol x))))
+ (elf-symbol-value sym)
+ (elf-symbol-size sym))))
+ (else #f)))
+
+(define-record-type <arity>
+ (make-arity context base header-offset)
+ arity?
+ (context arity-context)
+ (base arity-base)
+ (header-offset arity-header-offset))
+
+(define arities-prefix-len 4)
+(define arity-header-len (* 6 4))
+
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+
+(define (arity-low-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
+(define (arity-high-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
+(define (arity-offset* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
+(define (arity-flags* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
+(define (arity-nreq* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
+(define (arity-nopt* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+;;; #x10: is-in-case-lambda?
+
+(define (has-rest? flags) (not (zero? (logand flags (ash 1 0)))))
+(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
+(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
+(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
+(define (is-in-case-lambda? flags) (not (zero? (logand flags (ash 1 4)))))
+
+(define (arity-low-pc arity)
+ (let ((ctx (arity-context arity)))
+ (+ (debug-context-base ctx)
+ (debug-context-text-base ctx)
+ (arity-low-pc* (elf-bytes (debug-context-elf ctx))
+ (arity-header-offset arity)))))
+
+(define (arity-high-pc arity)
+ (let ((ctx (arity-context arity)))
+ (+ (debug-context-base ctx)
+ (debug-context-text-base ctx)
+ (arity-high-pc* (elf-bytes (debug-context-elf ctx))
+ (arity-header-offset arity)))))
+
+(define (arity-nreq arity)
+ (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-nopt arity)
+ (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-flags arity)
+ (arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
+(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity)))
+(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity)))
+(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
+(define (arity-is-in-case-lambda? arity) (is-in-case-lambda? (arity-flags arity)))
+
+(define (arity-load-symbol arity)
+ (let ((elf (debug-context-elf (arity-context arity))))
+ (cond
+ ((elf-section-by-name elf ".guile.arities")
+ =>
+ (lambda (sec)
+ (let* ((strtab (elf-section elf (elf-section-link sec)))
+ (bv (elf-bytes elf))
+ (strtab-offset (elf-section-offset strtab)))
+ (lambda (n)
+ (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
+ (else (error "couldn't find arities section")))))
+
+(define (arity-arguments-alist arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (%load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (flags (arity-flags* bv header))
+ (nreq (arity-nreq* bv header))
+ (nopt (arity-nopt* bv header)))
+ (define (load-symbol idx)
+ (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (define (load-symbols skip n)
+ (let lp ((n n) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n)
+ (cons (load-symbol (+ skip (1- n))) out)))))
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (define (load-non-immediate idx)
+ (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
+ (and (not (is-case-lambda? flags))
+ `((required . ,(load-symbols 0 nreq))
+ (optional . ,(load-symbols nreq nopt))
+ (keyword . ,(if (has-keyword-args? flags)
+ (load-non-immediate
+ (+ nreq nopt (if (has-rest? flags) 1 0)))
+ '()))
+ (allow-other-keys? . ,(allow-other-keys? flags))
+ (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))))))
+
+(define (find-first-arity context base addr)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ (binary-search
+ (+ base arities-prefix-len)
+ (+ base (bytevector-u32-native-ref bv base))
+ arity-header-len
+ (lambda (pos continue-before continue-after)
+ (let lp ((pos pos))
+ (cond
+ ((is-in-case-lambda? (arity-flags* bv pos))
+ (lp (- pos arity-header-len)))
+ ((< text-offset (arity-low-pc* bv pos))
+ (continue-before))
+ ((<= (arity-high-pc* bv pos) text-offset)
+ (continue-after))
+ (else
+ (make-arity context base pos)))))
+ (lambda ()
+ #f))))
+
+(define (read-sub-arities context base outer-header-offset)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (headers-end (+ base (bytevector-u32-native-ref bv base)))
+ (low-pc (arity-low-pc* bv outer-header-offset))
+ (high-pc (arity-high-pc* bv outer-header-offset)))
+ (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
+ (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
+ (lp (+ pos arity-header-len)
+ (cons (make-arity context base pos) out))
+ (reverse out)))))
+
+(define* (find-program-arities addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (and context
+ (elf-section-by-name (debug-context-elf context) ".guile.arities"))
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ (cond
+ ((not first) '())
+ ((arity-is-case-lambda? first)
+ (read-sub-arities context base (arity-header-offset first)))
+ (else (list first)))))))
+
+(define* (find-program-minimum-arity addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (and context
+ (elf-section-by-name (debug-context-elf context) ".guile.arities"))
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ (if (arity-is-case-lambda? first)
+ (let ((arities (read-sub-arities context base
+ (arity-header-offset first))))
+ (and (pair? arities)
+ (list (apply min (map arity-nreq arities))
+ 0
+ (or-map (lambda (arity)
+ (or (positive? (arity-nopt arity))
+ (arity-has-rest? arity)
+ (arity-has-keyword-args? arity)
+ (arity-allow-other-keys? arity)))
+ arities))))
+ (list (arity-nreq first)
+ (arity-nopt first)
+ (arity-has-rest? first)))))))
+
+(define* (find-program-docstring addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (and context
+ (elf-section-by-name (debug-context-elf context) ".guile.docstrs"))
+ (lambda (sec)
+ ;; struct docstr {
+ ;; uint32_t pc;
+ ;; uint32_t str;
+ ;; }
+ (let ((start (elf-section-offset sec))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ (binary-search
+ start
+ (+ start (elf-section-size sec))
+ 8
+ (lambda (pos continue-before continue-after)
+ (let ((pc (bytevector-u32-native-ref bv pos)))
+ (cond
+ ((< text-offset pc) (continue-before))
+ ((< pc text-offset) (continue-after))
+ (else
+ (let ((strtab (elf-section (debug-context-elf context)
+ (elf-section-link sec)))
+ (idx (bytevector-u32-native-ref bv (+ pos 4))))
+ (string-table-ref bv (+ (elf-section-offset strtab) idx)))))))
+ (lambda ()
+ #f))))))
+
+(define* (find-program-properties addr #:optional
+ (context (find-debug-context addr)))
+ (define (add-name-and-docstring props)
+ (define (maybe-acons k v tail)
+ (if v (acons k v tail) tail))
+ (let ((name (and=> (find-program-debug-info addr context)
+ program-debug-info-name))
+ (docstring (find-program-docstring addr context)))
+ (maybe-acons 'name name
+ (maybe-acons 'documentation docstring props))))
+ (add-name-and-docstring
+ (cond
+ ((and context
+ (elf-section-by-name (debug-context-elf context) ".guile.procprops"))
+ => (lambda (sec)
+ ;; struct procprop {
+ ;; uint32_t pc;
+ ;; uint32_t offset;
+ ;; }
+ (define procprop-len 8)
+ (let* ((start (elf-section-offset sec))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ (define (unpack-scm addr)
+ (pointer->scm (make-pointer addr)))
+ (define (load-non-immediate offset)
+ (unpack-scm (+ (debug-context-base context) offset)))
+ (binary-search
+ start (+ start (elf-section-size sec)) 8
+ (lambda (pos continue-before continue-after)
+ (let ((pc (bytevector-u32-native-ref bv pos)))
+ (cond
+ ((< text-offset pc) (continue-before))
+ ((< pc text-offset) (continue-after))
+ (else
+ (load-non-immediate
+ (bytevector-u32-native-ref bv (+ pos 4)))))))
+ (lambda ()
+ '())))))
+ (else '()))))
+
+(define-record-type <source>
+ (make-source pre-pc file line column)
+ source?
+ (pre-pc source-pre-pc)
+ (file source-file)
+ (line source-line)
+ (column source-column))
+
+(define (make-source/dwarf pc file line column)
+ (make-source pc file
+ ;; Convert DWARF-numbered (1-based) lines and
+ ;; columns to Guile conventions (0-based).
+ (and line (1- line)) (and column (1- column))))
+
+;; FIXME
+(define (source-post-pc source)
+ (source-pre-pc source))
+
+;; Lines are zero-indexed inside Guile, but users expect them to be
+;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go
+;; figure.
+(define (source-line-for-user source)
+ (1+ (source-line source)))
+
+(define* (find-source-for-addr addr #:optional
+ (context (find-debug-context addr))
+ #:key exact?)
+ (and=>
+ (and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ (lambda (dwarf-ctx)
+ (let* ((base (debug-context-base context))
+ (pc (- addr base)))
+ (or-map (lambda (die)
+ (and=>
+ (die-line-prog die)
+ (lambda (prog)
+ (call-with-values
+ (lambda () (line-prog-scan-to-pc prog pc))
+ (lambda (pc* file line col)
+ (and pc* (or (= pc pc*) (not exact?))
+ (make-source/dwarf (+ pc* base)
+ file line col)))))))
+ (read-die-roots dwarf-ctx))))))
+
+(define* (find-program-die addr #:optional
+ (context (find-debug-context addr)))
+ (and=> (and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ (lambda (dwarf-ctx)
+ (find-die-by-pc (read-die-roots dwarf-ctx)
+ (- addr (debug-context-base context))))))
+
+(define* (find-program-sources addr #:optional
+ (context (find-debug-context addr)))
+ (cond
+ ((find-program-die addr context)
+ => (lambda (die)
+ (let* ((base (debug-context-base context))
+ (low-pc (die-ref die 'low-pc))
+ (high-pc (die-high-pc die))
+ (prog (let line-prog ((die die))
+ (and die
+ (or (die-line-prog die)
+ (line-prog (ctx-die (die-ctx die))))))))
+ (cond
+ ((and low-pc high-pc prog)
+ (let lp ((sources '()))
+ (call-with-values (lambda ()
+ (if (null? sources)
+ (line-prog-scan-to-pc prog low-pc)
+ (line-prog-advance prog)))
+ (lambda (pc file line col)
+ (if (and pc (< pc high-pc))
+ ;; For the first source, it's probable that the
+ ;; address of the line program is before the
+ ;; low-pc, since the line program is for the
+ ;; entire compilation unit, and there are no
+ ;; redundant "rows" in the line program.
+ ;; Therefore in that case use the addr of low-pc
+ ;; instead of the one we got back.
+ (let ((addr (+ (if (null? sources) low-pc pc) base)))
+ (lp (cons (make-source/dwarf addr file line col)
+ sources)))
+ (reverse sources))))))
+ (else '())))))
+ (else '())))
+
+(define* (fold-source-locations proc seed context)
+ "Fold @var{proc} over all source locations in @var{context}.
+@var{proc} will be called with two arguments: the source object and the
+seed."
+ (cond
+ ((and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ =>
+ (lambda (dwarf-ctx)
+ (let ((base (debug-context-base context)))
+ (fold
+ (lambda (die seed)
+ (cond
+ ((die-line-prog die)
+ =>
+ (lambda (prog)
+ (let lp ((seed seed))
+ (call-with-values
+ (lambda () (line-prog-advance prog))
+ (lambda (pc* file line col)
+ (if pc*
+ (lp
+ (proc (make-source/dwarf (+ pc* base) file line col)
+ seed))
+ seed))))))
+ (else seed)))
+ seed
+ (read-die-roots dwarf-ctx)))))
+ (else seed)))
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
new file mode 100644
index 000000000..6eb14c5eb
--- /dev/null
+++ b/module/system/vm/disassembler.scm
@@ -0,0 +1,473 @@
+;;; Guile bytecode 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 (language bytecode)
+ #:use-module (system vm elf)
+ #:use-module (system vm debug)
+ #:use-module (system vm program)
+ #:use-module (system vm loader)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:export (disassemble-program
+ fold-program-code
+ disassemble-image
+ disassemble-file))
+
+(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))
+ (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 (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+
+(define (unpack-s24 s)
+ (if (zero? (logand s (ash 1 23)))
+ s
+ (- s (ash 1 24))))
+
+(define (unpack-s32 s)
+ (if (zero? (logand s (ash 1 31)))
+ s
+ (- s (ash 1 32))))
+
+(define-syntax disassembler
+ (lambda (x)
+ (define (parse-first-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'())
+ ((U8_U24)
+ #'((ash word -8)))
+ ((U8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((U8_U8_I16)
+ #'((logand (ash word -8) #xff)
+ (ash word -16)))
+ ((U8_U12_U12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((U8_U8_U8_U8)
+ #'((logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ (else
+ (error "bad kind" type)))))
+
+ (define (parse-tail-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'((logand word #ff)))
+ ((U8_U24)
+ #'((logand word #xff)
+ (ash word -8)))
+ ((U8_L24)
+ #'((logand word #xff)
+ (unpack-s24 (ash word -8))))
+ ((U8_U8_I16)
+ #'((logand word #xff)
+ (logand (ash word -8) #xff)
+ (ash word -16)))
+ ((U8_U12_U12)
+ #'((logand word #xff)
+ (logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((U8_U8_U8_U8)
+ #'((logand word #xff)
+ (logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ ((U32)
+ #'(word))
+ ((I32)
+ #'(word))
+ ((A32)
+ #'(word))
+ ((B32)
+ #'(word))
+ ((N32)
+ #'((unpack-s32 word)))
+ ((S32)
+ #'((unpack-s32 word)))
+ ((L32)
+ #'((unpack-s32 word)))
+ ((LO32)
+ #'((unpack-s32 word)))
+ ((X8_U24)
+ #'((ash word -8)))
+ ((X8_U12_U12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((X8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((B1_X7_L24)
+ #'((not (zero? (logand word #x1)))
+ (unpack-s24 (ash word -8))))
+ ((B1_U7_L24)
+ #'((not (zero? (logand word #x1)))
+ (logand (ash word -1) #x7f)
+ (unpack-s24 (ash word -8))))
+ ((B1_X31)
+ #'((not (zero? (logand word #x1)))))
+ ((B1_X7_U24)
+ #'((not (zero? (logand word #x1)))
+ (ash word -8)))
+ (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 ...)
+ (parse-first-word #'first (syntax->datum #'word0)))
+ (((asm* ...) ...)
+ (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* ... ...))))))))))
+
+(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 kind 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 (u32-offset->addr offset context)
+ "Given an offset into an image in 32-bit units, return the absolute
+address of that offset."
+ (+ (debug-context-base context) (* offset 4)))
+
+(define (code-annotation code len offset start labels context push-addr!)
+ ;; FIXME: Print names for register loads and stores that correspond to
+ ;; access to named locals.
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+
+ (match code
+ (((or 'br
+ 'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
+ 'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
+ 'br-if-char 'br-if-eq 'br-if-eqv 'br-if-equal
+ 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
+ (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+ (('br-if-tc7 slot invert? tc7 target)
+ (list "~A -> ~A"
+ (let ((tag (case tc7
+ ((5) "symbol?")
+ ((7) "variable?")
+ ((13) "vector?")
+ ((15) "string?")
+ ((77) "bytevector?")
+ ((95) "bitvector?")
+ (else (number->string tc7)))))
+ (if invert? (string-append "not " tag) tag))
+ (vector-ref labels (- (+ offset target) start))))
+ (('prompt tag escape-only? proc-slot handler)
+ ;; The H is for handler.
+ (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
+ (((or 'make-short-immediate 'make-long-immediate) _ imm)
+ (list "~S" (unpack-scm imm)))
+ (('make-long-long-immediate _ high low)
+ (list "~S" (unpack-scm (logior (ash high 32) low))))
+ (('assert-nargs-ee/locals nargs locals)
+ ;; The nargs includes the procedure.
+ (list "~a arg~:p, ~a local~:p" (1- nargs) locals))
+ (('tail-call nargs proc)
+ (list "~a arg~:p" nargs))
+ (('make-closure dst target nfree)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context))
+ (name (or (and pdi (program-debug-info-name pdi))
+ "anonymous procedure")))
+ (push-addr! addr name)
+ (list "~A at #x~X (~A free var~:p)" name addr nfree)))
+ (('make-non-immediate dst target)
+ (let ((val (reference-scm target)))
+ (when (program? val)
+ (push-addr! (program-code val) val))
+ (list "~@Y" val)))
+ (('builtin-ref dst idx)
+ (list "~A" (builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) _ target)
+ (list "~@Y" (dereference-scm target)))
+ (((or 'free-ref 'free-set!) _ _ index)
+ (list "free var ~a" index))
+ (('resolve-module dst name public)
+ (list "~a" (if (zero? public) "private" "public")))
+ (('toplevel-box _ var-offset mod-offset sym-offset bound?)
+ (list "`~A'~A" (dereference-scm sym-offset)
+ (if bound? "" " (maybe unbound)")))
+ (('module-box _ var-offset mod-name-offset sym-offset bound?)
+ (let ((mod-name (reference-scm mod-name-offset)))
+ (list "`(~A ~A ~A)'~A" (if (car mod-name) '@ '@@) (cdr mod-name)
+ (dereference-scm sym-offset)
+ (if bound? "" " (maybe unbound)"))))
+ (('load-typed-array dst type shape target len)
+ (let ((addr (u32-offset->addr (+ offset target) context)))
+ (list "~a bytes from #x~X" len addr)))
+ (_ #f)))
+
+(define (compute-labels bv start end)
+ (let ((labels (make-vector (- end start) #f)))
+ (define (add-label! pos header)
+ (unless (vector-ref labels (- pos start))
+ (vector-set! labels (- pos start) header)))
+
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (match elt
+ ((inst arg ...)
+ (case inst
+ ((br
+ br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
+ br-if-true br-if-null br-if-nil br-if-pair br-if-struct
+ br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
+ br-if-= br-if-< br-if-<= br-if-> br-if->=)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "L"))))
+ ((prompt)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "H")))))))
+ (lp (+ offset len))))))
+ (let lp ((offset start) (n 1))
+ (when (< offset end)
+ (let* ((pos (- offset start))
+ (label (vector-ref labels pos)))
+ (if label
+ (begin
+ (vector-set! labels
+ pos
+ (string->symbol
+ (string-append label (number->string n))))
+ (lp (1+ offset) (1+ n)))
+ (lp (1+ offset) n)))))
+ labels))
+
+(define (print-info port addr label info extra src)
+ (when label
+ (format port "~A:\n" label))
+ (format port "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
+ addr info extra src))
+
+(define (disassemble-buffer port bv start end context push-addr!)
+ (let ((labels (compute-labels bv start end))
+ (sources (find-program-sources (u32-offset->addr start context)
+ context)))
+ (define (lookup-source addr)
+ (let lp ((sources sources))
+ (match sources
+ (() #f)
+ ((source . sources)
+ (let ((pc (source-pre-pc source)))
+ (cond
+ ((< pc addr) (lp sources))
+ ((= pc addr)
+ (format #f "~a:~a:~a"
+ (or (source-file source) "(unknown file)")
+ (source-line-for-user source)
+ (source-column source)))
+ (else #f)))))))
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (let ((pos (- offset start))
+ (addr (u32-offset->addr offset context))
+ (annotation (code-annotation elt len offset start labels
+ context push-addr!)))
+ (print-info port pos (vector-ref labels pos) elt annotation
+ (lookup-source addr))
+ (lp (+ offset len)))))))))
+
+(define (disassemble-addr addr label port)
+ (format port "Disassembly of ~A at #x~X:\n\n" label addr)
+ (cond
+ ((find-program-debug-info addr)
+ => (lambda (pdi)
+ (let ((worklist '()))
+ (define (push-addr! addr label)
+ (unless (assv addr worklist)
+ (set! worklist (acons addr label worklist))))
+ (disassemble-buffer port
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi)
+ push-addr!)
+ (for-each (match-lambda
+ ((addr . label)
+ (display "\n----------------------------------------\n"
+ port)
+ (disassemble-addr addr label port)))
+ worklist))))
+ (else
+ (format port "Debugging information unavailable.~%")))
+ (values))
+
+(define* (disassemble-program program #:optional (port (current-output-port)))
+ (disassemble-addr (program-code program) program port))
+
+(define (fold-code-range proc seed bv start end context raw?)
+ (define (cook code offset)
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+ (match code
+ (((or 'make-short-immediate 'make-long-immediate) dst imm)
+ `(,(car code) ,dst ,(unpack-scm imm)))
+ (('make-long-long-immediate dst high low)
+ `(make-long-long-immediate ,dst
+ ,(unpack-scm (logior (ash high 32) low))))
+ (('make-closure dst target nfree)
+ `(make-closure ,dst
+ ,(u32-offset->addr (+ offset target) context)
+ ,nfree))
+ (('make-non-immediate dst target)
+ `(make-non-immediate ,dst ,(reference-scm target)))
+ (('builtin-ref dst idx)
+ `(builtin-ref ,dst ,(builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) dst target)
+ `(,(car code) ,dst ,(dereference-scm target)))
+ (('toplevel-box dst var-offset mod-offset sym-offset bound?)
+ `(toplevel-box ,dst
+ ,(dereference-scm var-offset)
+ ,(dereference-scm mod-offset)
+ ,(dereference-scm sym-offset)
+ ,bound?))
+ (('module-box dst var-offset mod-name-offset sym-offset bound?)
+ (let ((mod-name (reference-scm mod-name-offset)))
+ `(module-box ,dst
+ ,(dereference-scm var-offset)
+ ,(car mod-name)
+ ,(cdr mod-name)
+ ,(dereference-scm sym-offset)
+ ,bound?)))
+ (_ code)))
+ (let lp ((offset start) (seed seed))
+ (cond
+ ((< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (lp (+ offset len)
+ (proc (if raw? elt (cook elt offset))
+ seed)))))
+ (else seed))))
+
+(define* (fold-program-code proc seed program-or-addr #:key raw?)
+ (cond
+ ((find-program-debug-info (if (program? program-or-addr)
+ (program-code program-or-addr)
+ program-or-addr))
+ => (lambda (pdi)
+ (fold-code-range proc seed
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi)
+ raw?)))
+ (else seed)))
+
+(define* (disassemble-image bv #:optional (port (current-output-port)))
+ (let* ((ctx (debug-context-from-image bv))
+ (base (debug-context-text-base ctx)))
+ (for-each-elf-symbol
+ ctx
+ (lambda (sym)
+ (let ((name (elf-symbol-name sym))
+ (value (elf-symbol-value sym))
+ (size (elf-symbol-size sym)))
+ (format port "Disassembly of ~A at #x~X:\n\n"
+ (if (and (string? name) (not (string-null? name)))
+ name
+ "<unnamed function>")
+ (+ base value))
+ (disassemble-buffer port
+ bv
+ (/ (+ base value) 4)
+ (/ (+ base value size) 4)
+ ctx
+ (lambda (addr name) #t))
+ (display "\n\n" port)))))
+ (values))
+
+(define (disassemble-file file)
+ (let* ((thunk (load-thunk-from-file file))
+ (elf (find-mapped-elf-image (program-code thunk))))
+ (disassemble-image elf)))
diff --git a/module/system/vm/dwarf.scm b/module/system/vm/dwarf.scm
new file mode 100644
index 000000000..f3e45c758
--- /dev/null
+++ b/module/system/vm/dwarf.scm
@@ -0,0 +1,1852 @@
+;;; Guile DWARF reader and writer
+
+;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+;; Parts of this file were derived from sysdeps/generic/dwarf2.h, from
+;; the GNU C Library. That file is available under the LGPL version 2
+;; or later, and is copyright:
+;;
+;; Copyright (C) 1992, 1993, 1995, 1996, 1997, 2000, 2011
+;; Free Software Foundation, Inc.
+;; Contributed by Gary Funck (gary@intrepid.com). Derived from the
+;; DWARF 1 implementation written by Ron Guilmette (rfg@monkeys.com).
+
+;;;; 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
+
+;;; Commentary:
+;;
+;; DWARF is a flexible format for describing compiled programs. It is
+;; used by Guile to record source positions, describe local variables,
+;; function arities, and other function metadata.
+;;
+;; Structurally, DWARF describes a tree of data. Each node in the tree
+;; is a debugging information entry ("DIE"). Each DIE has a "tag",
+;; possible a set of attributes, and possibly some child DIE nodes.
+;; That's basically it!
+;;
+;; The DIE nodes are contained in the .debug_info section of an ELF
+;; file. Attributes within the DIE nodes link them to mapped ranges of
+;; the ELF file (.rtl-text, .data, etc.).
+;;
+;; A .debug_info section logically contains a series of debugging
+;; "contributions", one for each compilation unit. Each contribution is
+;; prefixed by a header and contains a single DIE element whose tag is
+;; "compilation-unit". That node usually contains child nodes, for
+;; example of type "subprogram".
+;;
+;; Since usually one will end up producing many DIE nodes with the same
+;; tag and attribute types, DIE nodes are defined by referencing a known
+;; shape, and then filling in the values. The shapes are defined in the
+;; form of "abbrev" entries, which specify a specific combination of a
+;; tag and an ordered set of attributes, with corresponding attribute
+;; representations ("forms"). Abbrevs are written out to a separate
+;; section, .debug_abbrev. Abbrev nodes also specify whether the
+;; corresponding DIE node has children or not. When a DIE is written
+;; into the .debug_info section, it references one of the abbrevs in
+;; .debug_abbrev. You need the abbrev in order to parse the DIE.
+;;
+;; For completeness, the other sections that DWARF uses are .debug_str,
+;; .debug_loc, .debug_pubnames, .debug_aranges, .debug_frame, and
+;; .debug_line. These are described in section 6 of the DWARF 3.0
+;; specification, at http://dwarfstd.org/.
+;;
+;; This DWARF module is currently capable of parsing all of DWARF 2.0
+;; and parts of DWARF 3.0. For Guile's purposes, we also use DWARF as
+;; the format for our own debugging information. The DWARF generator is
+;; fairly minimal, and is not intended to be complete.
+;;
+;;; Code:
+
+(define-module (system vm dwarf)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module (system vm elf)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
+ #:export (elf->dwarf-context
+ read-die-roots
+ fold-pubnames fold-aranges
+
+ access-name->code
+ address-name->code
+ attribute-name->code
+ call-frame-address-name->code
+ children-name->code
+ convention-name->code
+ discriminant-name->code
+ form-name->code
+ inline-name->code
+ language-name->code
+ macro-name->code
+ ordering-name->code
+ sensitivity-name->code
+ tag-name->code
+ virtuality-name->code
+ visibility-name->code
+
+ abbrev? abbrev-code
+ abbrev-tag abbrev-has-children? abbrev-attrs abbrev-forms
+
+ die? die-ctx die-offset die-abbrev die-vals die-children
+ die-tag die-attrs die-forms die-ref
+ die-name die-specification die-qname die-low-pc die-high-pc
+
+ ctx-parent ctx-die ctx-start ctx-end ctx-children ctx-language
+
+ die-line-prog line-prog-advance line-prog-scan-to-pc
+
+ find-die-context find-die-by-offset find-die find-die-by-pc
+ read-die fold-die-list
+
+ fold-die-children die->tree))
+
+;;;
+;;; First, define a number of constants. The figures numbers refer to
+;;; the DWARF 2.0 draft specification available on http://dwarfstd.org/.
+;;; Extra codes not defined in that document are taken from the dwarf2
+;;; header in glibc.
+;;;
+
+(define-syntax-rule (define-enumeration code->name name->code
+ (tag value) ...)
+ (begin
+ (define code->name
+ (let ((table (make-hash-table)))
+ (hashv-set! table value 'tag)
+ ...
+ (lambda (v)
+ (hashv-ref table v v))))
+ (define name->code
+ (let ((table (make-hash-table)))
+ (hashv-set! table 'tag value)
+ ...
+ (lambda (v)
+ (hashv-ref table v v))))))
+
+;; Figures 14 and 15: Tag names and codes.
+;;
+(define-enumeration tag-code->name tag-name->code
+ (padding #x00)
+ (array-type #x01)
+ (class-type #x02)
+ (entry-point #x03)
+ (enumeration-type #x04)
+ (formal-parameter #x05)
+ (imported-declaration #x08)
+ (label #x0a)
+ (lexical-block #x0b)
+ (member #x0d)
+ (pointer-type #x0f)
+ (reference-type #x10)
+ (compile-unit #x11)
+ (string-type #x12)
+ (structure-type #x13)
+ (subroutine-type #x15)
+ (typedef #x16)
+ (union-type #x17)
+ (unspecified-parameters #x18)
+ (variant #x19)
+ (common-block #x1a)
+ (common-inclusion #x1b)
+ (inheritance #x1c)
+ (inlined-subroutine #x1d)
+ (module #x1e)
+ (ptr-to-member-type #x1f)
+ (set-type #x20)
+ (subrange-type #x21)
+ (with-stmt #x22)
+ (access-declaration #x23)
+ (base-type #x24)
+ (catch-block #x25)
+ (const-type #x26)
+ (constant #x27)
+ (enumerator #x28)
+ (file-type #x29)
+ (friend #x2a)
+ (namelist #x2b)
+ (namelist-item #x2c)
+ (packed-type #x2d)
+ (subprogram #x2e)
+ (template-type-param #x2f)
+ (template-value-param #x30)
+ (thrown-type #x31)
+ (try-block #x32)
+ (variant-part #x33)
+ (variable #x34)
+ (volatile-type #x35)
+ ;; DWARF 3.
+ (dwarf-procedure #x36)
+ (restrict-type #x37)
+ (interface-type #x38)
+ (namespace #x39)
+ (imported-module #x3a)
+ (unspecified-type #x3b)
+ (partial-unit #x3c)
+ (imported-unit #x3d)
+ (condition #x3f)
+ (shared-type #x40)
+ ;; Extensions.
+ (format-label #x4101)
+ (function-template #x4102)
+ (class-template #x4103)
+ (GNU-BINCL #x4104)
+ (GNU-EINCL #x4105)
+ (lo-user #x4080)
+ (hi-user #xffff))
+
+;; Figure 16: Flag that tells whether entry has a child or not.
+;;
+(define-enumeration children-code->name children-name->code
+ (no 0)
+ (yes 1))
+
+;; Figures 17 and 18: Attribute names and codes.
+;;
+(define-enumeration attribute-code->name attribute-name->code
+ (sibling #x01)
+ (location #x02)
+ (name #x03)
+ (ordering #x09)
+ (subscr-data #x0a)
+ (byte-size #x0b)
+ (bit-offset #x0c)
+ (bit-size #x0d)
+ (element-list #x0f)
+ (stmt-list #x10)
+ (low-pc #x11)
+ (high-pc #x12)
+ (language #x13)
+ (member #x14)
+ (discr #x15)
+ (discr-value #x16)
+ (visibility #x17)
+ (import #x18)
+ (string-length #x19)
+ (common-reference #x1a)
+ (comp-dir #x1b)
+ (const-value #x1c)
+ (containing-type #x1d)
+ (default-value #x1e)
+ (inline #x20)
+ (is-optional #x21)
+ (lower-bound #x22)
+ (producer #x25)
+ (prototyped #x27)
+ (return-addr #x2a)
+ (start-scope #x2c)
+ (stride-size #x2e)
+ (upper-bound #x2f)
+ (abstract-origin #x31)
+ (accessibility #x32)
+ (address-class #x33)
+ (artificial #x34)
+ (base-types #x35)
+ (calling-convention #x36)
+ (count #x37)
+ (data-member-location #x38)
+ (decl-column #x39)
+ (decl-file #x3a)
+ (decl-line #x3b)
+ (declaration #x3c)
+ (discr-list #x3d)
+ (encoding #x3e)
+ (external #x3f)
+ (frame-base #x40)
+ (friend #x41)
+ (identifier-case #x42)
+ (macro-info #x43)
+ (namelist-items #x44)
+ (priority #x45)
+ (segment #x46)
+ (specification #x47)
+ (static-link #x48)
+ (type #x49)
+ (use-location #x4a)
+ (variable-parameter #x4b)
+ (virtuality #x4c)
+ (vtable-elem-location #x4d)
+ ;; DWARF 3.
+ (associated #x4f)
+ (data-location #x50)
+ (byte-stride #x51)
+ (entry-pc #x52)
+ (use-UTF8 #x53)
+ (extension #x54)
+ (ranges #x55)
+ (trampoline #x56)
+ (call-column #x57)
+ (call-file #x58)
+ (call-line #x59)
+ (description #x5a)
+ (binary-scale #x5b)
+ (decimal-scale #x5c)
+ (small #x5d)
+ (decimal-sign #x5e)
+ (digit-count #x5f)
+ (picture-string #x60)
+ (mutable #x61)
+ (threads-scaled #x62)
+ (explicit #x63)
+ (object-pointer #x64)
+ (endianity #x65)
+ (elemental #x66)
+ (pure #x67)
+ (recursive #x68)
+ ;; Extensions.
+ (linkage-name #x2007)
+ (sf-names #x2101)
+ (src-info #x2102)
+ (mac-info #x2103)
+ (src-coords #x2104)
+ (body-begin #x2105)
+ (body-end #x2106)
+ (lo-user #x2000)
+ (hi-user #x3fff))
+
+;; Figure 19: Form names and codes.
+;;
+(define-enumeration form-code->name form-name->code
+ (addr #x01)
+ (block2 #x03)
+ (block4 #x04)
+ (data2 #x05)
+ (data4 #x06)
+ (data8 #x07)
+ (string #x08)
+ (block #x09)
+ (block1 #x0a)
+ (data1 #x0b)
+ (flag #x0c)
+ (sdata #x0d)
+ (strp #x0e)
+ (udata #x0f)
+ (ref-addr #x10)
+ (ref1 #x11)
+ (ref2 #x12)
+ (ref4 #x13)
+ (ref8 #x14)
+ (ref-udata #x15)
+ (indirect #x16)
+ (sec-offset #x17)
+ (exprloc #x18)
+ (flag-present #x19)
+ (ref-sig8 #x20))
+
+;; Figures 22 and 23: Location atom names and codes.
+;;
+(define-enumeration location-op->name location-name->op
+ (addr #x03)
+ (deref #x06)
+ (const1u #x08)
+ (const1s #x09)
+ (const2u #x0a)
+ (const2s #x0b)
+ (const4u #x0c)
+ (const4s #x0d)
+ (const8u #x0e)
+ (const8s #x0f)
+ (constu #x10)
+ (consts #x11)
+ (dup #x12)
+ (drop #x13)
+ (over #x14)
+ (pick #x15)
+ (swap #x16)
+ (rot #x17)
+ (xderef #x18)
+ (abs #x19)
+ (and #x1a)
+ (div #x1b)
+ (minus #x1c)
+ (mod #x1d)
+ (mul #x1e)
+ (neg #x1f)
+ (not #x20)
+ (or #x21)
+ (plus #x22)
+ (plus-uconst #x23)
+ (shl #x24)
+ (shr #x25)
+ (shra #x26)
+ (xor #x27)
+ (bra #x28)
+ (eq #x29)
+ (ge #x2a)
+ (gt #x2b)
+ (le #x2c)
+ (lt #x2d)
+ (ne #x2e)
+ (skip #x2f)
+ (lit0 #x30)
+ (lit1 #x31)
+ (lit2 #x32)
+ (lit3 #x33)
+ (lit4 #x34)
+ (lit5 #x35)
+ (lit6 #x36)
+ (lit7 #x37)
+ (lit8 #x38)
+ (lit9 #x39)
+ (lit10 #x3a)
+ (lit11 #x3b)
+ (lit12 #x3c)
+ (lit13 #x3d)
+ (lit14 #x3e)
+ (lit15 #x3f)
+ (lit16 #x40)
+ (lit17 #x41)
+ (lit18 #x42)
+ (lit19 #x43)
+ (lit20 #x44)
+ (lit21 #x45)
+ (lit22 #x46)
+ (lit23 #x47)
+ (lit24 #x48)
+ (lit25 #x49)
+ (lit26 #x4a)
+ (lit27 #x4b)
+ (lit28 #x4c)
+ (lit29 #x4d)
+ (lit30 #x4e)
+ (lit31 #x4f)
+ (reg0 #x50)
+ (reg1 #x51)
+ (reg2 #x52)
+ (reg3 #x53)
+ (reg4 #x54)
+ (reg5 #x55)
+ (reg6 #x56)
+ (reg7 #x57)
+ (reg8 #x58)
+ (reg9 #x59)
+ (reg10 #x5a)
+ (reg11 #x5b)
+ (reg12 #x5c)
+ (reg13 #x5d)
+ (reg14 #x5e)
+ (reg15 #x5f)
+ (reg16 #x60)
+ (reg17 #x61)
+ (reg18 #x62)
+ (reg19 #x63)
+ (reg20 #x64)
+ (reg21 #x65)
+ (reg22 #x66)
+ (reg23 #x67)
+ (reg24 #x68)
+ (reg25 #x69)
+ (reg26 #x6a)
+ (reg27 #x6b)
+ (reg28 #x6c)
+ (reg29 #x6d)
+ (reg30 #x6e)
+ (reg31 #x6f)
+ (breg0 #x70)
+ (breg1 #x71)
+ (breg2 #x72)
+ (breg3 #x73)
+ (breg4 #x74)
+ (breg5 #x75)
+ (breg6 #x76)
+ (breg7 #x77)
+ (breg8 #x78)
+ (breg9 #x79)
+ (breg10 #x7a)
+ (breg11 #x7b)
+ (breg12 #x7c)
+ (breg13 #x7d)
+ (breg14 #x7e)
+ (breg15 #x7f)
+ (breg16 #x80)
+ (breg17 #x81)
+ (breg18 #x82)
+ (breg19 #x83)
+ (breg20 #x84)
+ (breg21 #x85)
+ (breg22 #x86)
+ (breg23 #x87)
+ (breg24 #x88)
+ (breg25 #x89)
+ (breg26 #x8a)
+ (breg27 #x8b)
+ (breg28 #x8c)
+ (breg29 #x8d)
+ (breg30 #x8e)
+ (breg31 #x8f)
+ (regx #x90)
+ (fbreg #x91)
+ (bregx #x92)
+ (piece #x93)
+ (deref-size #x94)
+ (xderef-size #x95)
+ (nop #x96)
+ ;; DWARF 3.
+ (push-object-address #x97)
+ (call2 #x98)
+ (call4 #x99)
+ (call-ref #x9a)
+ (form-tls-address #x9b)
+ (call-frame-cfa #x9c)
+ (bit-piece #x9d)
+ (lo-user #x80)
+ (hi-user #xff))
+
+;; Figure 24: Type encodings.
+;;
+(define-enumeration type-encoding->name type-name->encoding
+ (void #x0)
+ (address #x1)
+ (boolean #x2)
+ (complex-float #x3)
+ (float #x4)
+ (signed #x5)
+ (signed-char #x6)
+ (unsigned #x7)
+ (unsigned-char #x8)
+ ;; DWARF 3.
+ (imaginary-float #x09)
+ (packed-decimal #x0a)
+ (numeric-string #x0b)
+ (edited #x0c)
+ (signed-fixed #x0d)
+ (unsigned-fixed #x0e)
+ (decimal-float #x0f)
+ (lo-user #x80)
+ (hi-user #xff))
+
+;; Figure 25: Access attribute.
+;;
+(define-enumeration access-code->name access-name->code
+ (public 1)
+ (protected 2)
+ (private 3))
+
+;; Figure 26: Visibility.
+;;
+(define-enumeration visibility-code->name visibility-name->code
+ (local 1)
+ (exported 2)
+ (qualified 3))
+
+;; Figure 27: Virtuality.
+;;
+(define-enumeration virtuality-code->name virtuality-name->code
+ (none 0)
+ (virtual 1)
+ (pure-virtual 2))
+
+;; Figure 28: Source language names and codes.
+;;
+(define-enumeration language-code->name language-name->code
+ (c89 #x0001)
+ (c #x0002)
+ (ada83 #x0003)
+ (c++ #x0004)
+ (cobol74 #x0005)
+ (cobol85 #x0006)
+ (fortran77 #x0007)
+ (fortran90 #x0008)
+ (pascal83 #x0009)
+ (modula2 #x000a)
+ (java #x000b)
+ (c99 #x000c)
+ (ada95 #x000d)
+ (fortran95 #x000e)
+ (pli #x000f)
+ (objc #x0010)
+ (objc++ #x0011)
+ (upc #x0012)
+ (d #x0013)
+ (python #x0014)
+ (mips-assembler #x8001)
+
+ (lo-user #x8000)
+
+ ;; FIXME: Ask for proper codes for these.
+ (scheme #xaf33)
+ (emacs-lisp #xaf34)
+ (ecmascript #xaf35)
+ (lua #xaf36)
+ (brainfuck #xaf37)
+
+ (hi-user #xffff))
+
+;; Figure 29: Case sensitivity.
+;;
+(define-enumeration case-sensitivity-code->name case-sensitivity-name->code
+ (case-sensitive 0)
+ (up-case 1)
+ (down-case 2)
+ (case-insensitive 3))
+
+;; Figure 30: Calling convention.
+;;
+(define-enumeration calling-convention-code->name calling-convention-name->code
+ (normal #x1)
+ (program #x2)
+ (nocall #x3)
+ (lo-user #x40)
+ (hi-user #xff))
+
+;; Figure 31: Inline attribute.
+;;
+(define-enumeration inline-code->name inline-name->code
+ (not-inlined 0)
+ (inlined 1)
+ (declared-not-inlined 2)
+ (declared-inlined 3))
+
+;; Figure 32: Array ordering names and codes.
+(define-enumeration ordering-code->name ordering-name->code
+ (row-major 0)
+ (col-major 1))
+
+;; Figure 33: Discriminant lists.
+;;
+(define-enumeration discriminant-code->name discriminant-name->code
+ (label 0)
+ (range 1))
+
+;; Figure 34: "Standard" line number opcodes.
+;;
+(define-enumeration standard-line-opcode->name standard-line-name->opcode
+ (extended-op 0)
+ (copy 1)
+ (advance-pc 2)
+ (advance-line 3)
+ (set-file 4)
+ (set-column 5)
+ (negate-stmt 6)
+ (set-basic-block 7)
+ (const-add-pc 8)
+ (fixed-advance-pc 9)
+ ;; DWARF 3.
+ (set-prologue-end #x0a)
+ (set-epilogue-begin #x0b)
+ (set-isa #x0c))
+
+;; Figure 35: "Extended" line number opcodes.
+;;
+(define-enumeration extended-line-opcode->name extended-line-name->opcode
+ (end-sequence 1)
+ (set-address 2)
+ (define-file 3)
+ ;; DWARF 3.
+ (lo-user #x80)
+ (hi-user #xff))
+
+;; Figure 36: Names and codes for macro information.
+;;
+(define-enumeration macro-code->name macro-name->code
+ (define 1)
+ (undef 2)
+ (start-file 3)
+ (end-file 4)
+ (vendor-ext 255))
+
+;; Figure 37: Call frame information.
+;;
+(define-enumeration call-frame-address-code->name call-frame-address-code->name
+ (advance-loc #x40)
+ (offset #x80)
+ (restore #xc0)
+ (nop #x00)
+ (set-loc #x01)
+ (advance-loc1 #x02)
+ (advance-loc2 #x03)
+ (advance-loc4 #x04)
+ (offset-extended #x05)
+ (restore-extended #x06)
+ (undefined #x07)
+ (same-value #x08)
+ (register #x09)
+ (remember-state #x0a)
+ (restore-state #x0b)
+ (def-cfa #x0c)
+ (def-cfa-register #x0d)
+ (def-cfa-offset #x0e)
+ ;; DWARF 3.
+ (def-cfa-expression #x0f)
+ (expression #x10)
+ (offset-extended-sf #x11)
+ (def-cfa-sf #x12)
+ (def-cfa-offset-sf #x13)
+ (val-offset #x14)
+ (val-offset-sf #x15)
+ (val-expression #x16)
+ (GNU-window-save #x2d)
+ (GNU-args-size #x2e)
+ (GNU-negative-offset-extended #x2f)
+
+ (extended 0)
+ (low-user #x1c)
+ (high-user #x3f))
+
+;(define CIE-ID #xffffffff)
+;(define CIE-VERSION 1)
+;(define ADDR-none 0)
+
+
+;;;
+;;; A general configuration object.
+;;;
+
+(define-record-type <dwarf-meta>
+ (make-dwarf-meta addr-size
+ vaddr memsz
+ path lib-path
+ info-start info-end
+ abbrevs-start abbrevs-end
+ strtab-start strtab-end
+ loc-start loc-end
+ line-start line-end
+ pubnames-start pubnames-end
+ aranges-start aranges-end)
+ dwarf-meta?
+ (addr-size meta-addr-size)
+ (vaddr meta-vaddr)
+ (memsz meta-memsz)
+ (path meta-path)
+ (lib-path meta-lib-path)
+ (info-start meta-info-start)
+ (info-end meta-info-end)
+ (abbrevs-start meta-abbrevs-start)
+ (abbrevs-end meta-abbrevs-end)
+ (strtab-start meta-strtab-start)
+ (strtab-end meta-strtab-end)
+ (loc-start meta-loc-start)
+ (loc-end meta-loc-end)
+ (line-start meta-line-start)
+ (line-end meta-line-end)
+ (pubnames-start meta-pubnames-start)
+ (pubnames-end meta-pubnames-end)
+ (aranges-start meta-aranges-start)
+ (aranges-end meta-aranges-end))
+
+;; A context represents a namespace. The root context is the
+;; compilation unit. DIE nodes of type class-type, structure-type, or
+;; namespace may form child contexts.
+;;
+(define-record-type <dwarf-context>
+ (make-dwarf-context bv offset-size endianness meta
+ abbrevs
+ parent die start end children)
+ dwarf-context?
+ (bv ctx-bv)
+ (offset-size ctx-offset-size)
+ (endianness ctx-endianness)
+ (meta ctx-meta)
+ (abbrevs ctx-abbrevs)
+ (parent ctx-parent)
+ (die ctx-die)
+ (start ctx-start)
+ (end ctx-end)
+ (children ctx-children set-children!))
+
+
+(set-record-type-printer! <dwarf-context>
+ (lambda (x port)
+ (format port "<dwarf-context ~a>"
+ (number->string (object-address x) 16))))
+
+(define-inlinable (ctx-addr-size ctx)
+ (meta-addr-size (ctx-meta ctx)))
+
+;;;
+;;; Procedures for reading DWARF data.
+;;;
+
+(define (read-u8 ctx pos)
+ (values (bytevector-u8-ref (ctx-bv ctx) pos)
+ (1+ pos)))
+(define (read-s8 ctx pos)
+ (values (bytevector-s8-ref (ctx-bv ctx) pos)
+ (1+ pos)))
+(define (skip-8 ctx pos)
+ (+ pos 1))
+
+(define (read-u16 ctx pos)
+ (values (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+ (+ pos 2)))
+(define (skip-16 ctx pos)
+ (+ pos 2))
+
+(define (read-u32 ctx pos)
+ (values (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+ (+ pos 4)))
+(define (skip-32 ctx pos)
+ (+ pos 4))
+
+(define (read-u64 ctx pos)
+ (values (bytevector-u64-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+ (+ pos 8)))
+(define (skip-64 ctx pos)
+ (+ pos 8))
+
+(define (read-addr ctx pos)
+ (case (ctx-addr-size ctx)
+ ((4) (read-u32 ctx pos))
+ ((8) (read-u64 ctx pos))
+ (else (error "unsupported word size" ctx))))
+(define (skip-addr ctx pos)
+ (+ pos (ctx-addr-size ctx)))
+
+(define (%read-uleb128 bv pos)
+ ;; Unrolled by one.
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values b
+ (1+ pos))
+ (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values (logior (ash b shift) n)
+ (1+ pos))
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (1+ pos)
+ (+ shift 7))))))))
+
+(define (%read-sleb128 bv pos)
+ (let lp ((n 0) (pos pos) (shift 0))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values (logior (ash b shift) n
+ (if (zero? (logand #x40 b))
+ 0
+ (- (ash 1 (+ shift 7)))))
+ (1+ pos))
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (1+ pos)
+ (+ shift 7))))))
+
+(define (read-uleb128 ctx pos)
+ (%read-uleb128 (ctx-bv ctx) pos))
+
+(define (read-sleb128 ctx pos)
+ (%read-sleb128 (ctx-bv ctx) pos))
+
+(define (skip-leb128 ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((pos pos))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (1+ pos)
+ (lp (1+ pos)))))))
+
+(define (read-initial-length ctx pos)
+ (let ((len (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))))
+ (cond
+ ((= len #xffffffff)
+ (values (bytevector-u32-ref (ctx-bv ctx) (+ pos 4) (ctx-endianness ctx))
+ (+ pos 12)
+ 8))
+ ((>= len #xfffffff0)
+ (error "bad initial length value" len))
+ (else
+ (values len
+ (+ pos 4)
+ 4)))))
+
+(define* (read-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
+ (case offset-size
+ ((4) (values (read-u32 ctx pos) (+ pos 4)))
+ ((8) (values (read-u64 ctx pos) (+ pos 8)))
+ (else (error "bad word size" offset-size))))
+
+(define* (skip-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
+ (+ pos offset-size))
+
+(define (read-block ctx pos len)
+ (let ((bv (make-bytevector len)))
+ (bytevector-copy! (ctx-bv ctx) pos bv 0 len)
+ (values bv
+ (+ pos len))))
+
+(define (read-string ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((end pos))
+ (if (zero? (bytevector-u8-ref bv end))
+ (let ((out (make-bytevector (- end pos))))
+ (bytevector-copy! bv pos out 0 (- end pos))
+ (values (utf8->string out)
+ (1+ end)))
+ (lp (1+ end))))))
+
+(define (skip-string ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((end pos))
+ (if (zero? (bytevector-u8-ref bv end))
+ (1+ end)
+ (lp (1+ end))))))
+
+(define (read-string-seq ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((pos pos) (strs '()))
+ (if (zero? (bytevector-u8-ref bv pos))
+ (values (list->vector (reverse strs)) (1+ pos))
+ (let-values (((str pos) (read-string ctx pos)))
+ (lp pos (cons str strs)))))))
+
+(define-record-type <abbrev>
+ (make-abbrev code tag has-children? attrs forms)
+ abbrev?
+ (code abbrev-code)
+ (tag abbrev-tag)
+ (has-children? abbrev-has-children?)
+ (attrs abbrev-attrs)
+ (forms abbrev-forms))
+
+(define (read-abbrev ctx pos)
+ (let*-values (((code pos) (read-uleb128 ctx pos))
+ ((tag pos) (read-uleb128 ctx pos))
+ ((children pos) (read-u8 ctx pos)))
+ (let lp ((attrs '()) (forms '()) (pos pos))
+ (let*-values (((attr pos) (read-uleb128 ctx pos))
+ ((form pos) (read-uleb128 ctx pos)))
+ (if (and (zero? attr) (zero? form))
+ (values (make-abbrev code
+ (tag-code->name tag)
+ (eq? (children-code->name children) 'yes)
+ (reverse attrs)
+ (reverse forms))
+ pos)
+ (lp (cons (attribute-code->name attr) attrs)
+ (cons (form-code->name form) forms)
+ pos))))))
+
+(define* (read-abbrevs ctx pos
+ #:optional (start (meta-abbrevs-start
+ (ctx-meta ctx)))
+ (end (meta-abbrevs-end
+ (ctx-meta ctx))))
+ (let lp ((abbrevs '()) (pos (+ start pos)) (max-code -1))
+ (if (zero? (read-u8 ctx pos))
+ (if (< pos end)
+ (let ((av (make-vector (1+ max-code) #f)))
+ (for-each (lambda (a)
+ (vector-set! av (abbrev-code a) a))
+ abbrevs)
+ av)
+ (error "Unexpected length" abbrevs pos start end))
+ (let-values (((abbrev pos) (read-abbrev ctx pos)))
+ (lp (cons abbrev abbrevs)
+ pos
+ (max (abbrev-code abbrev) max-code))))))
+
+(define (ctx-compile-unit-start ctx)
+ (if (ctx-die ctx)
+ (ctx-compile-unit-start (ctx-parent ctx))
+ (ctx-start ctx)))
+
+;; Values.
+;;
+(define *readers* (make-hash-table))
+(define *scanners* (make-hash-table))
+(define-syntax define-value-reader
+ (syntax-rules ()
+ ((_ form reader scanner)
+ (begin
+ (hashq-set! *readers* 'form reader)
+ (hashq-set! *scanners* 'form scanner)))))
+
+(define-value-reader addr read-addr skip-addr)
+
+(define-value-reader block
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-uleb128 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-uleb128 ctx pos)))
+ (+ pos len))))
+
+(define-value-reader block1
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-u8 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (+ pos 1 (bytevector-u8-ref (ctx-bv ctx) pos))))
+
+(define-value-reader block2
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-u16 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (+ pos 2 (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
+
+(define-value-reader block4
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-u32 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (+ pos 4 (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
+
+(define-value-reader data1 read-u8 skip-8)
+(define-value-reader data2 read-u16 skip-16)
+(define-value-reader data4 read-u32 skip-32)
+(define-value-reader data8 read-u64 skip-64)
+(define-value-reader udata read-uleb128 skip-leb128)
+(define-value-reader sdata read-sleb128 skip-leb128)
+
+(define-value-reader flag
+ (lambda (ctx pos)
+ (values (not (zero? (bytevector-u8-ref (ctx-bv ctx) pos)))
+ (1+ pos)))
+ skip-8)
+
+(define-value-reader string
+ read-string
+ skip-string)
+
+(define-value-reader strp
+ (lambda (ctx pos)
+ (let ((strtab (meta-strtab-start (ctx-meta ctx))))
+ (unless strtab
+ (error "expected a string table" ctx))
+ (let-values (((offset pos) (read-offset ctx pos)))
+ (values (read-string ctx (+ strtab offset))
+ pos))))
+ skip-32)
+
+(define-value-reader ref-addr
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-addr ctx pos)))
+ (values (+ addr (meta-info-start (ctx-meta ctx)))
+ pos)))
+ skip-addr)
+
+(define-value-reader ref1
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-u8 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-8)
+
+(define-value-reader ref2
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-u16 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-16)
+
+(define-value-reader ref4
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-u32 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-32)
+
+(define-value-reader ref8
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-u64 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-64)
+
+(define-value-reader ref
+ (lambda (udata ctx pos)
+ (let-values (((addr pos) (read-uleb128 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-leb128)
+
+(define-value-reader indirect
+ (lambda (ctx pos)
+ (let*-values (((form pos) (read-uleb128 ctx pos))
+ ((val pos) (read-value ctx pos (form-code->name form))))
+ (values (cons form val)
+ pos)))
+ (lambda (ctx pos)
+ (let*-values (((form pos) (read-uleb128 ctx pos)))
+ (skip-value ctx pos (form-code->name form)))))
+
+(define-value-reader sec-offset
+ read-offset
+ skip-offset)
+
+(define-value-reader exprloc
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-uleb128 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-uleb128 ctx pos)))
+ (+ pos len))))
+
+(define-value-reader flag-present
+ (lambda (ctx pos)
+ (values #t pos))
+ (lambda (ctx pos)
+ pos))
+
+(define-value-reader ref-sig8
+ read-u64
+ skip-64)
+
+(define (read-value ctx pos form)
+ ((or (hashq-ref *readers* form)
+ (error "unrecognized form" form))
+ ctx pos))
+
+(define (skip-value ctx pos form)
+ ((or (hashq-ref *scanners* form)
+ (error "unrecognized form" form))
+ ctx pos))
+
+;; Parsers for particular attributes.
+;;
+(define (parse-location-list ctx offset)
+ (let lp ((pos (+ (meta-loc-start (ctx-meta ctx)) offset))
+ (out '()))
+ (let*-values (((start pos) (read-addr ctx pos))
+ ((end pos) (read-addr ctx pos)))
+ (if (and (zero? start) (zero? end))
+ (reverse out)
+ (let*-values (((len pos) (read-u16 ctx pos))
+ ((block pos) (read-block ctx pos len)))
+ (lp pos
+ (cons (list start end (parse-location ctx block)) out)))))))
+
+(define (parse-location ctx loc)
+ (cond
+ ((bytevector? loc)
+ (let ((len (bytevector-length loc))
+ (addr-size (ctx-addr-size ctx))
+ (endianness (ctx-endianness ctx)))
+ (define (u8-ref pos) (bytevector-u8-ref loc pos))
+ (define (s8-ref pos) (bytevector-s8-ref loc pos))
+ (define (u16-ref pos) (bytevector-u16-ref loc pos endianness))
+ (define (s16-ref pos) (bytevector-s16-ref loc pos endianness))
+ (define (u32-ref pos) (bytevector-u32-ref loc pos endianness))
+ (define (s32-ref pos) (bytevector-s32-ref loc pos endianness))
+ (define (u64-ref pos) (bytevector-u64-ref loc pos endianness))
+ (define (s64-ref pos) (bytevector-s64-ref loc pos endianness))
+ (let lp ((pos 0) (out '()))
+ (if (= pos len)
+ (reverse out)
+ (let ((op (location-op->name (u8-ref pos))))
+ (case op
+ ((addr)
+ (case addr-size
+ ((4) (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
+ ((8) (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
+ (else (error "what!"))))
+ ((call-ref)
+ (case addr-size
+ ((4) (lp (+ pos 5)
+ (cons (list op (+ (meta-info-start (ctx-meta ctx))
+ (u32-ref (1+ pos))))
+ out)))
+ ((8) (lp (+ pos 9)
+ (cons (list op (+ (meta-info-start (ctx-meta ctx))
+ (u64-ref (1+ pos))))
+ out)))
+ (else (error "what!"))))
+ ((const1u pick deref-size xderef-size)
+ (lp (+ pos 2) (cons (list op (u8-ref (1+ pos))) out)))
+ ((const1s)
+ (lp (+ pos 2) (cons (list op (s8-ref (1+ pos))) out)))
+ ((const2u)
+ (lp (+ pos 3) (cons (list op (u16-ref (1+ pos))) out)))
+ ((call2)
+ (lp (+ pos 3) (cons (list op (+ (ctx-compile-unit-start ctx)
+ (u16-ref (1+ pos))))
+ out)))
+ ((const2s skip bra)
+ (lp (+ pos 3) (cons (list op (s16-ref (1+ pos))) out)))
+ ((const4u)
+ (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
+ ((call4)
+ (lp (+ pos 5) (cons (list op (+ (ctx-compile-unit-start ctx)
+ (u32-ref (1+ pos))))
+ out)))
+ ((const4s)
+ (lp (+ pos 5) (cons (list op (s32-ref (1+ pos))) out)))
+ ((const8u)
+ (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
+ ((const8s)
+ (lp (+ pos 9) (cons (list op (s64-ref (1+ pos))) out)))
+ ((plus-uconst regx piece)
+ (let-values (((val pos) (%read-uleb128 loc (1+ pos))))
+ (lp pos (cons (list op val) out))))
+ ((bit-piece)
+ (let*-values (((bit-len pos) (%read-uleb128 loc (1+ pos)))
+ ((bit-offset pos) (%read-uleb128 loc pos)))
+ (lp pos (cons (list op bit-len bit-offset) out))))
+ ((breg0 breg1 breg2 breg3 breg4 breg5 breg6 breg7 breg8 breg9
+ breg10 breg11 breg12 breg13 breg14 breg15 breg16 breg17
+ breg18 breg19 breg20 breg21 breg22 breg23 breg24 breg25
+ breg26 breg27 breg28 breg29 breg30 breg31 fbreg)
+ (let-values (((val pos) (%read-sleb128 loc (1+ pos))))
+ (lp pos (cons (list op val) out))))
+ (else
+ (if (number? op)
+ ;; We failed to parse this opcode; we have to give
+ ;; up
+ loc
+ (lp (1+ pos) (cons (list op) out))))))))))
+ (else
+ (parse-location-list ctx loc))))
+
+;; Statement programs.
+(define-record-type <lregs>
+ (make-lregs pos pc file line column)
+ lregs?
+ (pos lregs-pos set-lregs-pos!)
+ (pc lregs-pc set-lregs-pc!)
+ (file lregs-file set-lregs-file!)
+ (line lregs-line set-lregs-line!)
+ (column lregs-column set-lregs-column!))
+
+(define-record-type <line-prog>
+ (%make-line-prog ctx version
+ header-offset program-offset end
+ min-insn-length max-insn-ops default-stmt?
+ line-base line-range opcode-base
+ standard-opcode-lengths
+ include-directories file-names
+ regs)
+ line-prog?
+ (ctx line-prog-ctx)
+ (version line-prog-version)
+ (header-offset line-prog-header-offset)
+ (program-offset line-prog-program-offset)
+ (end line-prog-end)
+ (min-insn-length line-prog-min-insn-length)
+ (max-insn-ops line-prog-max-insn-ops)
+ (default-stmt? line-prog-default-stmt?)
+ (line-base line-prog-line-base)
+ (line-range line-prog-line-range)
+ (opcode-base line-prog-opcode-base)
+ (standard-opcode-lengths line-prog-standard-opcode-lengths)
+ (include-directories line-prog-include-directories)
+ (file-names line-prog-file-names)
+ (regs line-prog-regs))
+
+(define (make-line-prog ctx header-pos end)
+ (unless (> end (+ header-pos 12))
+ (error "statement program header too short"))
+ (let-values (((len pos offset-size) (read-initial-length ctx header-pos)))
+ (unless (<= (+ pos len) end)
+ (error (".debug_line too short")))
+ (let*-values (((version pos) (read-u16 ctx pos))
+ ((prologue-len prologue-pos) (read-u32 ctx pos))
+ ((min-insn-len pos) (read-u8 ctx prologue-pos))
+ ;; The maximum_operations_per_instruction field is
+ ;; only present in DWARFv4.
+ ((max-insn-ops pos) (if (< version 4)
+ (values 1 pos)
+ (read-u8 ctx pos)))
+ ((default-stmt pos) (read-u8 ctx pos))
+ ((line-base pos) (read-s8 ctx pos))
+ ((line-range pos) (read-u8 ctx pos))
+ ((opcode-base pos) (read-u8 ctx pos))
+ ((opcode-lens pos) (read-block ctx pos (1- opcode-base)))
+ ((include-directories pos) (read-string-seq ctx pos))
+ ((file-names pos)
+ (let lp ((pos pos) (strs '()))
+ (if (zero? (bytevector-u8-ref (ctx-bv ctx) pos))
+ (values (reverse strs) (1+ pos))
+ (let-values (((str pos) (read-string ctx pos)))
+ (let* ((pos (skip-leb128 ctx pos)) ; skip dir
+ (pos (skip-leb128 ctx pos)) ; skip mtime
+ (pos (skip-leb128 ctx pos))) ; skip len
+ (lp pos (cons str strs))))))))
+ (unless (= pos (+ prologue-pos prologue-len))
+ (error "unexpected prologue length"))
+ (%make-line-prog ctx version header-pos pos end
+ min-insn-len max-insn-ops (not (zero? default-stmt))
+ line-base line-range opcode-base opcode-lens
+ include-directories file-names
+ ;; Initial state: file=1, line=1, col=0
+ (make-lregs pos 0 1 1 0)))))
+
+(define (line-prog-next-row prog pos pc file line col)
+ (let ((ctx (line-prog-ctx prog))
+ (end (line-prog-end prog))
+ (min-insn-len (line-prog-min-insn-length prog))
+ (line-base (line-prog-line-base prog))
+ (line-range (line-prog-line-range prog))
+ (opcode-base (line-prog-opcode-base prog))
+ (opcode-lens (line-prog-standard-opcode-lengths prog)))
+
+ (let lp ((pos pos) (pc pc) (file file) (line line) (col col))
+ (cond
+ ((>= pos end)
+ (values #f #f #f #f #f))
+ (else
+ (let-values (((op pos) (read-u8 ctx pos)))
+ (cond
+ ((zero? op) ; extended opcodes
+ (let*-values (((len pos*) (read-uleb128 ctx pos))
+ ((op pos) (read-u8 ctx pos*)))
+ (case op
+ ((1) ; end-sequence
+ (values pos pc file line col))
+ ((2) ; set-address
+ (let-values (((addr pos) (read-addr ctx pos)))
+ (unless (>= addr pc)
+ (error "pc not advancing"))
+ (lp pos addr file line col)))
+ ((3) ; define-file
+ (warn "define-file unimplemented")
+ (lp (+ pos* len) pc file line col))
+ ((4) ; set-discriminator; ignore.
+ (lp (+ pos* len) pc file line col))
+ (else
+ (warn "unknown extended op" op)
+ (lp (+ pos* len) pc file line col)))))
+
+ ((< op opcode-base) ; standard opcodes
+ (case op
+ ((1) ; copy
+ (values pos pc file line col))
+ ((2) ; advance-pc
+ (let-values (((advance pos) (read-uleb128 ctx pos)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ ((3) ; advance-line
+ (let-values (((diff pos) (read-sleb128 ctx pos)))
+ (lp pos pc file (+ line diff) col)))
+ ((4) ; set-file
+ (let-values (((file pos) (read-uleb128 ctx pos)))
+ (lp pos pc file line col)))
+ ((5) ; set-column
+ (let-values (((col pos) (read-uleb128 ctx pos)))
+ (lp pos pc file line col)))
+ ((6) ; negate-line
+ (lp pos pc file line col))
+ ((7) ; set-basic-block
+ (lp pos pc file line col))
+ ((8) ; const-add-pc
+ (let ((advance (floor/ (- 255 opcode-base) line-range)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ ((9) ; fixed-advance-pc
+ (let-values (((advance pos) (read-u16 ctx pos)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ (else
+ ;; fixme: read args and move on
+ (error "unknown extended op" op))))
+ (else ; special opcodes
+ (let-values (((quo rem) (floor/ (- op opcode-base) line-range)))
+ (values pos (+ pc (* quo min-insn-len))
+ file (+ line (+ rem line-base)) col))))))))))
+
+(define (line-prog-advance prog)
+ (let ((regs (line-prog-regs prog)))
+ (call-with-values (lambda ()
+ (line-prog-next-row prog
+ (lregs-pos regs)
+ (lregs-pc regs)
+ (lregs-file regs)
+ (lregs-line regs)
+ (lregs-column regs)))
+ (lambda (pos pc file line col)
+ (cond
+ ((not pos)
+ (values #f #f #f #f))
+ (else
+ (set-lregs-pos! regs pos)
+ (set-lregs-pc! regs pc)
+ (set-lregs-file! regs file)
+ (set-lregs-line! regs line)
+ (set-lregs-column! regs col)
+ ;; Return DWARF-numbered lines and columns (1-based).
+ (values pc
+ (if (zero? file)
+ #f
+ (list-ref (line-prog-file-names prog) (1- file)))
+ (if (zero? line) #f line)
+ (if (zero? col) #f col))))))))
+
+(define (line-prog-scan-to-pc prog target-pc)
+ (let ((regs (line-prog-regs prog)))
+ (define (finish pos pc file line col)
+ (set-lregs-pos! regs pos)
+ (set-lregs-pc! regs pc)
+ (set-lregs-file! regs file)
+ (set-lregs-line! regs line)
+ (set-lregs-column! regs col)
+ ;; Return DWARF-numbered lines and columns (1-based).
+ (values pc
+ (if (zero? file)
+ #f
+ (list-ref (line-prog-file-names prog) (1- file)))
+ (if (zero? line) #f line)
+ (if (zero? col) #f col)))
+ (define (scan pos pc file line col)
+ (call-with-values (lambda ()
+ (line-prog-next-row prog pos pc file line col))
+ (lambda (pos* pc* file* line* col*)
+ (cond
+ ((not pos*)
+ (values #f #f #f #f))
+ ((< pc* target-pc)
+ (scan pos* pc* file* line* col*))
+ ((= pc* target-pc)
+ (finish pos* pc* file* line* col*))
+ ((zero? pc)
+ ;; We scanned from the beginning didn't find any info.
+ (values #f #f #f #f))
+ (else
+ (finish pos pc file line col))))))
+ (let ((pos (lregs-pos regs))
+ (pc (lregs-pc regs))
+ (file (lregs-file regs))
+ (line (lregs-line regs))
+ (col (lregs-column regs)))
+ (if (< pc target-pc)
+ (scan pos pc file line col)
+ (scan (line-prog-program-offset prog) 0 1 1 0)))))
+
+(define-syntax-rule (define-attribute-parsers parse (name parser) ...)
+ (define parse
+ (let ((parsers (make-hash-table)))
+ (hashq-set! parsers 'name parser)
+ ...
+ (lambda (ctx attr val)
+ (cond
+ ((hashq-ref parsers attr) => (lambda (p) (p ctx val)))
+ (else val))))))
+
+(define-attribute-parsers parse-attribute
+ (encoding (lambda (ctx val) (type-encoding->name val)))
+ (accessibility (lambda (ctx val) (access-code->name val)))
+ (visibility (lambda (ctx val) (visibility-code->name val)))
+ (virtuality (lambda (ctx val) (virtuality-code->name val)))
+ (language (lambda (ctx val) (language-code->name val)))
+ (location parse-location)
+ (data-member-location parse-location)
+ (case-sensitive (lambda (ctx val) (case-sensitivity-code->name val)))
+ (calling-convention (lambda (ctx val) (calling-convention-code->name val)))
+ (inline (lambda (ctx val) (inline-code->name val)))
+ (ordering (lambda (ctx val) (ordering-code->name val)))
+ (discr-value (lambda (ctx val) (discriminant-code->name val))))
+
+;; "Debugging Information Entries": DIEs.
+;;
+(define-record-type <die>
+ (make-die ctx offset abbrev vals)
+ die?
+ (ctx die-ctx)
+ (offset die-offset)
+ (abbrev die-abbrev)
+ (vals %die-vals %set-die-vals!))
+
+(define (die-tag die)
+ (abbrev-tag (die-abbrev die)))
+
+(define (die-attrs die)
+ (abbrev-attrs (die-abbrev die)))
+
+(define (die-forms die)
+ (abbrev-forms (die-abbrev die)))
+
+(define (die-vals die)
+ (let ((vals (%die-vals die)))
+ (or vals
+ (begin
+ (%set-die-vals! die (read-values (die-ctx die) (skip-leb128 (die-ctx die) (die-offset die)) (die-abbrev die)))
+ (die-vals die)))))
+
+(define* (die-next-offset die #:optional offset-vals)
+ (let ((ctx (die-ctx die)))
+ (skip-values ctx (or offset-vals (skip-leb128 ctx (die-offset die)))
+ (die-abbrev die))))
+
+(define* (die-ref die attr #:optional default)
+ (cond
+ ((list-index (die-attrs die) attr)
+ => (lambda (n) (list-ref (die-vals die) n)))
+ (else default)))
+
+(define (die-specification die)
+ (and=> (die-ref die 'specification)
+ (lambda (offset) (find-die-by-offset (die-ctx die) offset))))
+
+(define (die-name die)
+ (or (die-ref die 'name)
+ (and=> (die-specification die) die-name)))
+
+(define (die-qname die)
+ (cond
+ ((eq? (die-tag die) 'compile-unit) "")
+ ((die-ref die 'name)
+ => (lambda (name)
+ (if (eq? (die-tag (ctx-die (die-ctx die))) 'compile-unit)
+ name ; short cut
+ (string-append (die-qname (ctx-die (die-ctx die))) "::" name))))
+ ((die-specification die)
+ => die-qname)
+ (else #f)))
+
+(define (die-line-prog die)
+ (let ((stmt-list (die-ref die 'stmt-list)))
+ (and stmt-list
+ (let* ((ctx (die-ctx die))
+ (meta (ctx-meta ctx)))
+ (make-line-prog ctx
+ (+ (meta-line-start meta) stmt-list)
+ (meta-line-end meta))))))
+
+(define (read-values ctx offset abbrev)
+ (let lp ((attrs (abbrev-attrs abbrev))
+ (forms (abbrev-forms abbrev))
+ (vals '())
+ (pos offset))
+ (if (null? forms)
+ (values (reverse vals) pos)
+ (let-values (((val pos) (read-value ctx pos (car forms))))
+ (lp (cdr attrs) (cdr forms)
+ (cons (parse-attribute ctx (car attrs) val) vals)
+ pos)))))
+
+(define (skip-values ctx offset abbrev)
+ (let lp ((forms (abbrev-forms abbrev))
+ (pos offset))
+ (if (null? forms)
+ pos
+ (lp (cdr forms) (skip-value ctx pos (car forms))))))
+
+(define (read-die-abbrev ctx offset)
+ (let*-values (((code pos) (read-uleb128 ctx offset)))
+ (values (cond ((zero? code) #f)
+ ((vector-ref (ctx-abbrevs ctx) code))
+ (else (error "unknown abbrev" ctx code)))
+ pos)))
+
+(define (read-die ctx offset)
+ (let*-values (((abbrev pos) (read-die-abbrev ctx offset)))
+ (if abbrev
+ (values (make-die ctx offset abbrev #f)
+ (skip-values ctx pos abbrev))
+ (values #f pos))))
+
+(define* (die-sibling ctx abbrev offset #:optional offset-vals offset-end)
+ (cond
+ ((not (abbrev-has-children? abbrev))
+ (or offset-end
+ (skip-values ctx
+ (or offset-vals (skip-leb128 ctx offset))
+ abbrev)))
+ ((memq 'sibling (abbrev-attrs abbrev))
+ (let lp ((offset (or offset-vals (skip-leb128 ctx offset)))
+ (attrs (abbrev-attrs abbrev))
+ (forms (abbrev-forms abbrev)))
+ (if (eq? (car attrs) 'sibling)
+ (read-value ctx offset (car forms))
+ (lp (skip-value ctx offset (car forms))
+ (cdr attrs) (cdr forms)))))
+ (else
+ (call-with-values
+ (lambda ()
+ (fold-die-list ctx
+ (or offset-end
+ (skip-values ctx
+ (or offset-vals
+ (skip-leb128 ctx offset))
+ abbrev))
+ (lambda (ctx offset abbrev) #t)
+ error
+ #f))
+ (lambda (seed pos)
+ pos)))))
+
+(define (find-die-context ctx offset)
+ (define (not-found)
+ (error "failed to find DIE by context" offset))
+ (define (in-context? ctx)
+ (and (<= (ctx-start ctx) offset)
+ (< offset (ctx-end ctx))))
+ (define (find-root ctx)
+ (if (in-context? ctx)
+ ctx
+ (find-root (or (ctx-parent ctx) (not-found)))))
+ (define (find-leaf ctx)
+ (let lp ((kids (ctx-children ctx)))
+ (if (null? kids)
+ ctx
+ (if (in-context? (car kids))
+ (find-leaf (car kids))
+ (lp (cdr kids))))))
+ (find-leaf (find-root ctx)))
+
+(define (find-die-by-offset ctx offset)
+ (or (read-die (find-die-context ctx offset) offset)
+ (error "Failed to read DIE at offset" offset)))
+
+(define-syntax-rule (let/ec k e e* ...)
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (let ((k (lambda args (apply abort-to-prompt tag args))))
+ e e* ...))
+ (lambda (_ res) res))))
+
+(define* (find-die roots pred #:key
+ (skip? (lambda (ctx offset abbrev) #f))
+ (recurse? (lambda (die) #t)))
+ (let/ec k
+ (define (visit-die die)
+ (cond
+ ((pred die)
+ (k die))
+ ((recurse? die)
+ (fold-die-children die (lambda (die seed) (visit-die die)) #f
+ #:skip? skip?))
+ (else #f)))
+ (for-each visit-die roots)
+ #f))
+
+(define (die-low-pc die)
+ (die-ref die 'low-pc))
+(define (die-high-pc die)
+ (let ((val (die-ref die 'high-pc)))
+ (and val
+ (let ((idx (list-index (die-attrs die) 'high-pc)))
+ (case (list-ref (die-forms die) idx)
+ ((addr) val)
+ (else (+ val (die-low-pc die))))))))
+
+(define (find-die-by-pc roots pc)
+ ;; The result will be a subprogram.
+ (define (skip? ctx offset abbrev)
+ (case (abbrev-tag abbrev)
+ ((subprogram compile-unit) #f)
+ (else #t)))
+ (define (recurse? die)
+ (case (die-tag die)
+ ((compile-unit)
+ (not (or (and=> (die-low-pc die)
+ (lambda (low) (< pc low)))
+ (and=> (die-high-pc die)
+ (lambda (high) (<= high pc))))))
+ (else #f)))
+ (find-die roots
+ (lambda (die)
+ (and (eq? (die-tag die) 'subprogram)
+ (equal? (die-low-pc die) pc)))
+ #:skip? skip? #:recurse? recurse?))
+
+(define (fold-die-list ctx offset skip? proc seed)
+ (let ((ctx (find-die-context ctx offset)))
+ (let lp ((offset offset) (seed seed))
+ (let-values (((abbrev pos) (read-die-abbrev ctx offset)))
+ (cond
+ ((not abbrev) (values seed pos))
+ ((skip? ctx offset abbrev)
+ (lp (die-sibling ctx abbrev offset pos) seed))
+ (else
+ (let-values (((vals pos) (read-values ctx pos abbrev)))
+ (let* ((die (make-die ctx offset abbrev vals))
+ (seed (proc die seed)))
+ (lp (die-sibling ctx abbrev offset #f pos) seed)))))))))
+
+(define* (fold-die-children die proc seed #:key
+ (skip? (lambda (ctx offset abbrev) #f)))
+ (if (abbrev-has-children? (die-abbrev die))
+ (values (fold-die-list (die-ctx die) (die-next-offset die)
+ skip? proc seed))
+ seed))
+
+(define (die-children die)
+ (reverse (fold-die-children die cons '())))
+
+(define (add-to-parent! ctx)
+ (let ((parent (ctx-parent ctx)))
+ (set-children! parent
+ (append (ctx-children parent) (list ctx)))
+ ctx))
+
+(define (make-compilation-unit-context ctx offset-size addr-size
+ abbrevs start len)
+ (unless (= addr-size (ctx-addr-size ctx))
+ (error "ELF word size not equal to compilation unit addrsize"))
+ (add-to-parent!
+ (make-dwarf-context (ctx-bv ctx)
+ offset-size (ctx-endianness ctx)
+ (ctx-meta ctx)
+ abbrevs ctx #f start (+ start 4 len) '())))
+
+(define (make-child-context die)
+ (let ((ctx (die-ctx die)))
+ (add-to-parent!
+ (make-dwarf-context (ctx-bv ctx)
+ (ctx-offset-size ctx) (ctx-endianness ctx)
+ (ctx-meta ctx)
+ (ctx-abbrevs ctx)
+ ctx die
+ (die-next-offset die)
+ (die-sibling ctx (die-abbrev die) (die-offset die))
+ '()))))
+
+(define (ctx-language ctx)
+ (or (and=> (ctx-die ctx) (lambda (x) (die-ref x 'language)))
+ (and=> (ctx-parent ctx) ctx-language)))
+
+(define (populate-context-tree! die)
+ (define (skip? ctx offset abbrev)
+ (case (abbrev-tag abbrev)
+ ((class-type structure-type namespace) #f)
+ (else #t)))
+ (case (die-tag die)
+ ((compile-unit class-type structure-type namespace)
+ (let ((ctx (make-child-context die)))
+ ;; For C++, descend into classes and structures so that we
+ ;; populate the context tree. Note that for compile-unit, we
+ ;; still need to call `make-child-context' for its side effect of
+ ;; adding to the context tree.
+ (when (eq? (ctx-language ctx) 'c++)
+ (fold-die-children die
+ (lambda (die seed) (populate-context-tree! die))
+ #f
+ #:skip? skip?))))))
+
+(define (read-compilation-unit ctx pos)
+ (let*-values (((start) pos)
+ ((len pos offset-size) (read-initial-length ctx pos))
+ ((version pos) (read-u16 ctx pos))
+ ((abbrevs-offset pos) (read-offset ctx pos offset-size))
+ ((av) (read-abbrevs ctx abbrevs-offset))
+ ((addrsize pos) (read-u8 ctx pos))
+ ((ctx) (make-compilation-unit-context ctx offset-size addrsize
+ av start len))
+ ((die pos) (read-die ctx pos)))
+ (populate-context-tree! die)
+ (values die (ctx-end ctx))))
+
+(define (read-die-roots ctx)
+ (let lp ((dies '()) (pos (meta-info-start (ctx-meta ctx))))
+ (if (< pos (meta-info-end (ctx-meta ctx)))
+ (let-values (((die pos) (read-compilation-unit ctx pos)))
+ (if die
+ (lp (cons die dies) pos)
+ (reverse dies)))
+ (reverse dies))))
+
+(define (fold-pubname-set ctx pos folder seed)
+ (let*-values (((len pos offset-size) (read-initial-length ctx pos))
+ ((version pos) (read-u16 ctx pos))
+ ((info-offset pos) (read-offset ctx pos offset-size))
+ ((info-offset) (+ info-offset
+ (meta-info-start (ctx-meta ctx))))
+ ((info-len pos) (read-offset ctx pos offset-size)))
+ (let lp ((pos pos) (seed seed))
+ (let-values (((offset pos) (read-offset ctx pos offset-size)))
+ (if (zero? offset)
+ (values seed pos)
+ (let-values (((str pos) (read-string ctx pos)))
+ (lp pos
+ (folder str (+ offset info-offset) seed))))))))
+
+(define (fold-pubnames ctx folder seed)
+ (let ((end (meta-pubnames-end (ctx-meta ctx))))
+ (if end
+ (let lp ((pos (meta-pubnames-start (ctx-meta ctx))) (seed seed))
+ (if (< pos end)
+ (let-values (((seed pos) (fold-pubname-set ctx pos folder seed)))
+ (lp pos seed))
+ seed))
+ seed)))
+
+(define (align address alignment)
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment)))
+
+(define (fold-arange-set ctx pos folder seed)
+ (let*-values (((len pos offset-size) (read-initial-length ctx pos))
+ ((version pos) (read-u16 ctx pos))
+ ((info-offset pos) (read-offset ctx pos offset-size))
+ ((info-offset) (+ info-offset
+ (meta-info-start (ctx-meta ctx))))
+ ((addr-size pos) (read-u8 ctx pos))
+ ((segment-size pos) (read-u8 ctx pos)))
+ (let lp ((pos (align pos (* 2 (ctx-addr-size ctx)))) (seed seed))
+ (let*-values (((addr pos) (read-addr ctx pos))
+ ((len pos) (read-addr ctx pos)))
+ (if (and (zero? addr) (zero? len))
+ (values seed pos)
+ (lp pos
+ (folder info-offset addr len seed)))))))
+
+(define (fold-aranges ctx folder seed)
+ (let ((end (meta-aranges-end (ctx-meta ctx))))
+ (if end
+ (let lp ((pos (meta-aranges-start (ctx-meta ctx))) (seed seed))
+ (if (< pos end)
+ (let-values (((seed pos) (fold-arange-set ctx pos folder seed)))
+ (lp pos seed))
+ seed))
+ seed)))
+
+(define* (elf->dwarf-context elf #:key (vaddr 0) (memsz 0)
+ (path #f) (lib-path path))
+ (let* ((sections (elf-sections-by-name elf))
+ (info (assoc-ref sections ".debug_info"))
+ (abbrevs (assoc-ref sections ".debug_abbrev"))
+ (strtab (assoc-ref sections ".debug_str"))
+ (loc (assoc-ref sections ".debug_loc"))
+ (line (assoc-ref sections ".debug_line"))
+ (pubnames (assoc-ref sections ".debug_pubnames"))
+ (aranges (assoc-ref sections ".debug_aranges")))
+ (make-dwarf-context (elf-bytes elf)
+ 4 ;; initial offset size
+ (elf-byte-order elf)
+ (make-dwarf-meta
+ (elf-word-size elf)
+ vaddr memsz
+ path lib-path
+ (elf-section-offset info)
+ (+ (elf-section-offset info)
+ (elf-section-size info))
+ (elf-section-offset abbrevs)
+ (+ (elf-section-offset abbrevs)
+ (elf-section-size abbrevs))
+ (elf-section-offset strtab)
+ (+ (elf-section-offset strtab)
+ (elf-section-size strtab))
+ (elf-section-offset loc)
+ (+ (elf-section-offset loc)
+ (elf-section-size loc))
+ (and line
+ (elf-section-offset line))
+ (and line
+ (+ (elf-section-offset line)
+ (elf-section-size line)))
+ (and pubnames
+ (elf-section-offset pubnames))
+ (and pubnames
+ (+ (elf-section-offset pubnames)
+ (elf-section-size pubnames)))
+ (and aranges
+ (elf-section-offset aranges))
+ (and aranges
+ (+ (elf-section-offset aranges)
+ (elf-section-size aranges))))
+ #() #f #f
+ (elf-section-offset info)
+ (+ (elf-section-offset info)
+ (elf-section-size info))
+ '())))
+
+(define (die->tree die)
+ (cons* (die-tag die)
+ (cons 'offset (die-offset die))
+ (reverse! (fold-die-children
+ die
+ (lambda (die seed)
+ (cons (die->tree die) seed))
+ (fold acons '() (die-attrs die) (die-vals die))))))
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
new file mode 100644
index 000000000..ec89d4f27
--- /dev/null
+++ b/module/system/vm/elf.scm
@@ -0,0 +1,1008 @@
+;;; Guile ELF reader and writer
+
+;; Copyright (C) 2011, 2012, 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; A module to read and write Executable and Linking Format (ELF)
+;;; files.
+;;;
+;;; This module exports a number of record types that represent the
+;;; various parts that make up ELF files. Fundamentally this is the
+;;; main header, the segment headers (program headers), and the section
+;;; headers. It also exports bindings for symbolic constants and
+;;; utilities to parse and write special kinds of ELF sections.
+;;;
+;;; See elf(5) for more information on ELF.
+;;;
+;;; Code:
+
+(define-module (system vm elf)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:export (has-elf-header?
+
+ (make-elf* . make-elf)
+ elf?
+ elf-bytes elf-word-size elf-byte-order
+ elf-abi elf-type elf-machine-type
+ elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
+ elf-phentsize elf-phnum elf-shentsize elf-shnum elf-shstrndx
+
+ elf-header-len elf-header-shoff-offset
+ write-elf-header
+
+ (make-elf-segment* . make-elf-segment)
+ elf-segment?
+ elf-segment-index
+ elf-segment-type elf-segment-offset elf-segment-vaddr
+ elf-segment-paddr elf-segment-filesz elf-segment-memsz
+ elf-segment-flags elf-segment-align
+
+ elf-program-header-len write-elf-program-header
+
+ PT_NULL PT_LOAD PT_DYNAMIC PT_INTERP PT_NOTE PT_SHLIB
+ PT_PHDR PT_TLS PT_NUM PT_LOOS PT_GNU_EH_FRAME PT_GNU_STACK
+ PT_GNU_RELRO
+
+ PF_R PF_W PF_X
+
+ (make-elf-section* . make-elf-section)
+ elf-section?
+ elf-section-index
+ elf-section-name elf-section-type elf-section-flags
+ elf-section-addr elf-section-offset elf-section-size
+ elf-section-link elf-section-info elf-section-addralign
+ elf-section-entsize
+
+ elf-section-header-len elf-section-header-addr-offset
+ elf-section-header-offset-offset
+ write-elf-section-header
+
+ (make-elf-symbol* . make-elf-symbol)
+ elf-symbol?
+ elf-symbol-name elf-symbol-value elf-symbol-size
+ elf-symbol-info elf-symbol-other elf-symbol-shndx
+ elf-symbol-binding elf-symbol-type elf-symbol-visibility
+
+ elf-symbol-len write-elf-symbol
+
+ SHN_UNDEF
+
+ SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
+ SHT_HASH SHT_DYNAMIC SHT_NOTE SHT_NOBITS SHT_REL SHT_SHLIB
+ SHT_DYNSYM SHT_INIT_ARRAY SHT_FINI_ARRAY SHT_PREINIT_ARRAY
+ SHT_GROUP SHT_SYMTAB_SHNDX SHT_NUM SHT_LOOS SHT_HIOS
+ SHT_LOPROC SHT_HIPROC SHT_LOUSER SHT_HIUSER
+
+ SHF_WRITE SHF_ALLOC SHF_EXECINSTR SHF_MERGE SHF_STRINGS
+ SHF_INFO_LINK SHF_LINK_ORDER SHF_OS_NONCONFORMING SHF_GROUP
+ SHF_TLS
+
+ DT_NULL DT_NEEDED DT_PLTRELSZ DT_PLTGOT DT_HASH DT_STRTAB
+ DT_SYMTAB DT_RELA DT_RELASZ DT_RELAENT DT_STRSZ DT_SYMENT
+ DT_INIT DT_FINI DT_SONAME DT_RPATH DT_SYMBOLIC DT_REL
+ DT_RELSZ DT_RELENT DT_PLTREL DT_DEBUG DT_TEXTREL DT_JMPREL
+ DT_BIND_NOW DT_INIT_ARRAY DT_FINI_ARRAY DT_INIT_ARRAYSZ
+ DT_FINI_ARRAYSZ DT_RUNPATH DT_FLAGS DT_ENCODING
+ DT_PREINIT_ARRAY DT_PREINIT_ARRAYSZ DT_NUM DT_LOGUILE
+ DT_GUILE_GC_ROOT DT_GUILE_GC_ROOT_SZ DT_GUILE_ENTRY
+ DT_GUILE_VM_VERSION DT_GUILE_FRAME_MAPS DT_HIGUILE
+ DT_LOOS DT_HIOS DT_LOPROC DT_HIPROC
+
+ string-table-ref
+
+ STB_LOCAL STB_GLOBAL STB_WEAK STB_NUM STB_LOOS STB_GNU
+ STB_HIOS STB_LOPROC STB_HIPROC
+
+ STT_NOTYPE STT_OBJECT STT_FUNC STT_SECTION STT_FILE
+ STT_COMMON STT_TLS STT_NUM STT_LOOS STT_GNU STT_HIOS
+ STT_LOPROC STT_HIPROC
+
+ STV_DEFAULT STV_INTERNAL STV_HIDDEN STV_PROTECTED
+
+ NT_GNU_ABI_TAG NT_GNU_HWCAP NT_GNU_BUILD_ID NT_GNU_GOLD_VERSION
+
+ parse-elf
+ elf-segment elf-segments
+ 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))
+
+;; #define EI_NIDENT 16
+
+;; typedef struct {
+;; unsigned char e_ident[EI_NIDENT];
+;; uint16_t e_type;
+;; uint16_t e_machine;
+;; uint32_t e_version;
+;; ElfN_Addr e_entry;
+;; ElfN_Off e_phoff;
+;; ElfN_Off e_shoff;
+;; uint32_t e_flags;
+;; uint16_t e_ehsize;
+;; uint16_t e_phentsize;
+;; uint16_t e_phnum;
+;; uint16_t e_shentsize;
+;; uint16_t e_shnum;
+;; uint16_t e_shstrndx;
+;; } ElfN_Ehdr;
+
+(define elf32-header-len 52)
+(define elf64-header-len 64)
+(define (elf-header-len word-size)
+ (case word-size
+ ((4) elf32-header-len)
+ ((8) elf64-header-len)
+ (else (error "invalid word size" word-size))))
+(define (elf-header-shoff-offset word-size)
+ (case word-size
+ ((4) 32)
+ ((8) 40)
+ (else (error "bad word size" word-size))))
+
+(define ELFCLASS32 1) ; 32-bit objects
+(define ELFCLASS64 2) ; 64-bit objects
+
+(define ELFDATA2LSB 1) ; 2's complement, little endian
+(define ELFDATA2MSB 2) ; 2's complement, big endian
+
+(define EV_CURRENT 1) ; Current version
+
+(define ELFOSABI_STANDALONE 255) ; Standalone (embedded) application
+
+(define ET_DYN 3) ; Shared object file
+
+;;
+;; Machine types
+;;
+;; Just a sampling of these values. We could include more, but the
+;; important thing is to recognize architectures for which we have a
+;; native compiler. Recognizing more common machine types is icing on
+;; the cake.
+;;
+(define EM_NONE 0) ; No machine
+(define EM_SPARC 2) ; SUN SPARC
+(define EM_386 3) ; Intel 80386
+(define EM_MIPS 8) ; MIPS R3000 big-endian
+(define EM_PPC 20) ; PowerPC
+(define EM_PPC64 21) ; PowerPC 64-bit
+(define EM_ARM 40) ; ARM
+(define EM_SH 42) ; Hitachi SH
+(define EM_SPARCV9 43) ; SPARC v9 64-bit
+(define EM_IA_64 50) ; Intel Merced
+(define EM_X86_64 62) ; AMD x86-64 architecture
+
+(define cpu-mapping (make-hash-table))
+(for-each (lambda (pair)
+ (hashq-set! cpu-mapping (car pair) (cdr pair)))
+ `((none . ,EM_NONE)
+ (sparc . ,EM_SPARC) ; FIXME: map 64-bit to SPARCV9 ?
+ (i386 . ,EM_386)
+ (mips . ,EM_MIPS)
+ (ppc . ,EM_PPC)
+ (ppc64 . ,EM_PPC64)
+ (arm . ,EM_ARM) ; FIXME: there are more arm cpu variants
+ (sh . ,EM_SH) ; FIXME: there are more sh cpu variants
+ (ia64 . ,EM_IA_64)
+ (x86_64 . ,EM_X86_64)))
+
+(define SHN_UNDEF 0)
+
+(define host-machine-type
+ (hashq-ref cpu-mapping
+ (string->symbol (car (string-split %host-type #\-)))
+ EM_NONE))
+
+(define host-word-size
+ (sizeof '*))
+
+(define host-byte-order
+ (native-endianness))
+
+(define (has-elf-header? bv)
+ (and
+ ;; e_ident
+ (>= (bytevector-length bv) 16)
+ (= (bytevector-u8-ref bv 0) #x7f)
+ (= (bytevector-u8-ref bv 1) (char->integer #\E))
+ (= (bytevector-u8-ref bv 2) (char->integer #\L))
+ (= (bytevector-u8-ref bv 3) (char->integer #\F))
+ (cond
+ ((= (bytevector-u8-ref bv 4) ELFCLASS32)
+ (>= (bytevector-length bv) elf32-header-len))
+ ((= (bytevector-u8-ref bv 4) ELFCLASS64)
+ (>= (bytevector-length bv) elf64-header-len))
+ (else #f))
+ (or (= (bytevector-u8-ref bv 5) ELFDATA2LSB)
+ (= (bytevector-u8-ref bv 5) ELFDATA2MSB))
+ (= (bytevector-u8-ref bv 6) EV_CURRENT)
+ ;; Look at ABI later.
+ (= (bytevector-u8-ref bv 8) 0) ; ABI version
+ ;; The rest of the e_ident is padding.
+
+ ;; e_version
+ (let ((byte-order (if (= (bytevector-u8-ref bv 5) ELFDATA2LSB)
+ (endianness little)
+ (endianness big))))
+ (= (bytevector-u32-ref bv 20 byte-order) EV_CURRENT))))
+
+(define-record-type <elf>
+ (make-elf bytes word-size byte-order abi type machine-type
+ entry phoff shoff flags ehsize
+ phentsize phnum shentsize shnum shstrndx)
+ elf?
+ (bytes elf-bytes)
+ (word-size elf-word-size)
+ (byte-order elf-byte-order)
+ (abi elf-abi)
+ (type elf-type)
+ (machine-type elf-machine-type)
+ (entry elf-entry)
+ (phoff elf-phoff)
+ (shoff elf-shoff)
+ (flags elf-flags)
+ (ehsize elf-ehsize)
+ (phentsize elf-phentsize)
+ (phnum elf-phnum)
+ (shentsize elf-shentsize)
+ (shnum elf-shnum)
+ (shstrndx elf-shstrndx))
+
+(define* (make-elf* #:key (bytes #f)
+ (byte-order (target-endianness))
+ (word-size (target-word-size))
+ (abi ELFOSABI_STANDALONE)
+ (type ET_DYN)
+ (machine-type EM_NONE)
+ (entry 0)
+ (phoff (elf-header-len word-size))
+ (shoff -1)
+ (flags 0)
+ (ehsize (elf-header-len word-size))
+ (phentsize (elf-program-header-len word-size))
+ (phnum 0)
+ (shentsize (elf-section-header-len word-size))
+ (shnum 0)
+ (shstrndx SHN_UNDEF))
+ (make-elf bytes word-size byte-order abi type machine-type
+ entry phoff shoff flags ehsize
+ phentsize phnum shentsize shnum shstrndx))
+
+(define (parse-elf32 bv byte-order)
+ (make-elf bv 4 byte-order
+ (bytevector-u8-ref bv 7)
+ (bytevector-u16-ref bv 16 byte-order)
+ (bytevector-u16-ref bv 18 byte-order)
+ (bytevector-u32-ref bv 24 byte-order)
+ (bytevector-u32-ref bv 28 byte-order)
+ (bytevector-u32-ref bv 32 byte-order)
+ (bytevector-u32-ref bv 36 byte-order)
+ (bytevector-u16-ref bv 40 byte-order)
+ (bytevector-u16-ref bv 42 byte-order)
+ (bytevector-u16-ref bv 44 byte-order)
+ (bytevector-u16-ref bv 46 byte-order)
+ (bytevector-u16-ref bv 48 byte-order)
+ (bytevector-u16-ref bv 50 byte-order)))
+
+(define (write-elf-ident bv class data abi)
+ (bytevector-u8-set! bv 0 #x7f)
+ (bytevector-u8-set! bv 1 (char->integer #\E))
+ (bytevector-u8-set! bv 2 (char->integer #\L))
+ (bytevector-u8-set! bv 3 (char->integer #\F))
+ (bytevector-u8-set! bv 4 class)
+ (bytevector-u8-set! bv 5 data)
+ (bytevector-u8-set! bv 6 EV_CURRENT)
+ (bytevector-u8-set! bv 7 abi)
+ (bytevector-u8-set! bv 8 0) ; ABI version
+ (bytevector-u8-set! bv 9 0) ; Pad to 16 bytes.
+ (bytevector-u8-set! bv 10 0)
+ (bytevector-u8-set! bv 11 0)
+ (bytevector-u8-set! bv 12 0)
+ (bytevector-u8-set! bv 13 0)
+ (bytevector-u8-set! bv 14 0)
+ (bytevector-u8-set! bv 15 0))
+
+(define (write-elf32-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS32
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u32-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u32-set! bv 28 (elf-phoff elf) byte-order)
+ (bytevector-u32-set! bv 32 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 36 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 40 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 42 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 44 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 46 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 48 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 50 (elf-shstrndx elf) byte-order)))
+
+(define (parse-elf64 bv byte-order)
+ (make-elf bv 8 byte-order
+ (bytevector-u8-ref bv 7)
+ (bytevector-u16-ref bv 16 byte-order)
+ (bytevector-u16-ref bv 18 byte-order)
+ (bytevector-u64-ref bv 24 byte-order)
+ (bytevector-u64-ref bv 32 byte-order)
+ (bytevector-u64-ref bv 40 byte-order)
+ (bytevector-u32-ref bv 48 byte-order)
+ (bytevector-u16-ref bv 52 byte-order)
+ (bytevector-u16-ref bv 54 byte-order)
+ (bytevector-u16-ref bv 56 byte-order)
+ (bytevector-u16-ref bv 58 byte-order)
+ (bytevector-u16-ref bv 60 byte-order)
+ (bytevector-u16-ref bv 62 byte-order)))
+
+(define (write-elf64-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS64
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u64-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u64-set! bv 32 (elf-phoff elf) byte-order)
+ (bytevector-u64-set! bv 40 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 48 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 52 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 54 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 56 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 58 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 60 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 62 (elf-shstrndx elf) byte-order)))
+
+(define (parse-elf bv)
+ (cond
+ ((has-elf-header? bv)
+ (let ((class (bytevector-u8-ref bv 4))
+ (byte-order (let ((data (bytevector-u8-ref bv 5)))
+ (cond
+ ((= data ELFDATA2LSB) (endianness little))
+ ((= data ELFDATA2MSB) (endianness big))
+ (else (error "unhandled byte order" data))))))
+ (cond
+ ((= class ELFCLASS32) (parse-elf32 bv byte-order))
+ ((= class ELFCLASS64) (parse-elf64 bv byte-order))
+ (else (error "unhandled class" class)))))
+ (else
+ (error "Invalid ELF" bv))))
+
+(define* (write-elf-header bv elf)
+ ((case (elf-word-size elf)
+ ((4) write-elf32-header)
+ ((8) write-elf64-header)
+ (else (error "unknown word size" (elf-word-size elf))))
+ bv elf))
+
+;;
+;; Segment types
+;;
+(define PT_NULL 0) ; Program header table entry unused
+(define PT_LOAD 1) ; Loadable program segment
+(define PT_DYNAMIC 2) ; Dynamic linking information
+(define PT_INTERP 3) ; Program interpreter
+(define PT_NOTE 4) ; Auxiliary information
+(define PT_SHLIB 5) ; Reserved
+(define PT_PHDR 6) ; Entry for header table itself
+(define PT_TLS 7) ; Thread-local storage segment
+(define PT_NUM 8) ; Number of defined types
+(define PT_LOOS #x60000000) ; Start of OS-specific
+(define PT_GNU_EH_FRAME #x6474e550) ; GCC .eh_frame_hdr segment
+(define PT_GNU_STACK #x6474e551) ; Indicates stack executability
+(define PT_GNU_RELRO #x6474e552) ; Read-only after relocation
+
+;;
+;; Segment flags
+;;
+(define PF_X (ash 1 0)) ; Segment is executable
+(define PF_W (ash 1 1)) ; Segment is writable
+(define PF_R (ash 1 2)) ; Segment is readable
+
+(define-record-type <elf-segment>
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align)
+ elf-segment?
+ (index elf-segment-index)
+ (type elf-segment-type)
+ (offset elf-segment-offset)
+ (vaddr elf-segment-vaddr)
+ (paddr elf-segment-paddr)
+ (filesz elf-segment-filesz)
+ (memsz elf-segment-memsz)
+ (flags elf-segment-flags)
+ (align elf-segment-align))
+
+(define* (make-elf-segment* #:key (index -1) (type PT_LOAD) (offset 0) (vaddr 0)
+ (paddr 0) (filesz 0) (memsz filesz)
+ (flags (logior PF_W PF_R))
+ (align 8))
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align))
+
+;; typedef struct {
+;; uint32_t p_type;
+;; Elf32_Off p_offset;
+;; Elf32_Addr p_vaddr;
+;; Elf32_Addr p_paddr;
+;; uint32_t p_filesz;
+;; uint32_t p_memsz;
+;; uint32_t p_flags;
+;; uint32_t p_align;
+;; } Elf32_Phdr;
+
+(define (parse-elf32-program-header index bv offset byte-order)
+ (if (<= (+ offset 32) (bytevector-length bv))
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u32-ref bv (+ offset 12) byte-order)
+ (bytevector-u32-ref bv (+ offset 16) byte-order)
+ (bytevector-u32-ref bv (+ offset 20) byte-order)
+ (bytevector-u32-ref bv (+ offset 24) byte-order)
+ (bytevector-u32-ref bv (+ offset 28) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf32-program-header bv offset byte-order seg)
+ (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-segment-offset seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-segment-vaddr seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 12) (elf-segment-paddr seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 16) (elf-segment-filesz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 20) (elf-segment-memsz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 24) (elf-segment-flags seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 28) (elf-segment-align seg) byte-order))
+
+
+;; typedef struct {
+;; uint32_t p_type;
+;; uint32_t p_flags;
+;; Elf64_Off p_offset;
+;; Elf64_Addr p_vaddr;
+;; Elf64_Addr p_paddr;
+;; uint64_t p_filesz;
+;; uint64_t p_memsz;
+;; uint64_t p_align;
+;; } Elf64_Phdr;
+
+;; NB: position of `flags' is different!
+
+(define (parse-elf64-program-header index bv offset byte-order)
+ (if (<= (+ offset 56) (bytevector-length bv))
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u64-ref bv (+ offset 24) byte-order)
+ (bytevector-u64-ref bv (+ offset 32) byte-order)
+ (bytevector-u64-ref bv (+ offset 40) byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u64-ref bv (+ offset 48) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf64-program-header bv offset byte-order seg)
+ (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-segment-offset seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-segment-vaddr seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 24) (elf-segment-paddr seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 32) (elf-segment-filesz seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 40) (elf-segment-memsz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-segment-flags seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 48) (elf-segment-align seg) byte-order))
+
+(define (write-elf-program-header bv offset byte-order word-size seg)
+ ((case word-size
+ ((4) write-elf32-program-header)
+ ((8) write-elf64-program-header)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order seg))
+
+(define (elf-program-header-len word-size)
+ (case word-size
+ ((4) 32)
+ ((8) 56)
+ (else (error "bad word size" word-size))))
+
+(define (elf-segment elf n)
+ (if (not (< -1 n (elf-phnum elf)))
+ (error "bad segment number" n))
+ ((case (elf-word-size elf)
+ ((4) parse-elf32-program-header)
+ ((8) parse-elf64-program-header)
+ (else (error "unhandled pointer size")))
+ (elf-bytes elf)
+ (+ (elf-phoff elf) (* n (elf-phentsize elf)))
+ (elf-byte-order elf)))
+
+(define (elf-segments elf)
+ (let lp ((n (elf-phnum elf)) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n) (cons (elf-segment elf (1- n)) out)))))
+
+(define-record-type <elf-section>
+ (make-elf-section index name type flags
+ addr offset size link info addralign entsize)
+ elf-section?
+ (index elf-section-index)
+ (name elf-section-name)
+ (type elf-section-type)
+ (flags elf-section-flags)
+ (addr elf-section-addr)
+ (offset elf-section-offset)
+ (size elf-section-size)
+ (link elf-section-link)
+ (info elf-section-info)
+ (addralign elf-section-addralign)
+ (entsize elf-section-entsize))
+
+(define* (make-elf-section* #:key (index SHN_UNDEF) (name 0) (type SHT_PROGBITS)
+ (flags SHF_ALLOC) (addr 0) (offset 0) (size 0)
+ (link 0) (info 0) (addralign 8) (entsize 0))
+ (make-elf-section index name type flags addr offset size link info addralign
+ entsize))
+
+;; typedef struct {
+;; uint32_t sh_name;
+;; uint32_t sh_type;
+;; uint32_t sh_flags;
+;; Elf32_Addr sh_addr;
+;; Elf32_Off sh_offset;
+;; uint32_t sh_size;
+;; uint32_t sh_link;
+;; uint32_t sh_info;
+;; uint32_t sh_addralign;
+;; uint32_t sh_entsize;
+;; } Elf32_Shdr;
+
+(define (parse-elf32-section-header index bv offset byte-order)
+ (if (<= (+ offset 40) (bytevector-length bv))
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u32-ref bv (+ offset 12) byte-order)
+ (bytevector-u32-ref bv (+ offset 16) byte-order)
+ (bytevector-u32-ref bv (+ offset 20) byte-order)
+ (bytevector-u32-ref bv (+ offset 24) byte-order)
+ (bytevector-u32-ref bv (+ offset 28) byte-order)
+ (bytevector-u32-ref bv (+ offset 32) byte-order)
+ (bytevector-u32-ref bv (+ offset 36) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf32-section-header bv offset byte-order sec)
+ (bytevector-u32-set! bv offset (elf-section-name sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-section-flags sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 12) (elf-section-addr sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 16) (elf-section-offset sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 20) (elf-section-size sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 24) (elf-section-link sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 28) (elf-section-info sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 32) (elf-section-addralign sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 36) (elf-section-entsize sec) byte-order))
+
+
+;; typedef struct {
+;; uint32_t sh_name;
+;; uint32_t sh_type;
+;; uint64_t sh_flags;
+;; Elf64_Addr sh_addr;
+;; Elf64_Off sh_offset;
+;; uint64_t sh_size;
+;; uint32_t sh_link;
+;; uint32_t sh_info;
+;; uint64_t sh_addralign;
+;; uint64_t sh_entsize;
+;; } Elf64_Shdr;
+
+(define (elf-section-header-len word-size)
+ (case word-size
+ ((4) 40)
+ ((8) 64)
+ (else (error "bad word size" word-size))))
+
+(define (elf-section-header-addr-offset word-size)
+ (case word-size
+ ((4) 12)
+ ((8) 16)
+ (else (error "bad word size" word-size))))
+
+(define (elf-section-header-offset-offset word-size)
+ (case word-size
+ ((4) 16)
+ ((8) 24)
+ (else (error "bad word size" word-size))))
+
+(define (parse-elf64-section-header index bv offset byte-order)
+ (if (<= (+ offset 64) (bytevector-length bv))
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u64-ref bv (+ offset 24) byte-order)
+ (bytevector-u64-ref bv (+ offset 32) byte-order)
+ (bytevector-u32-ref bv (+ offset 40) byte-order)
+ (bytevector-u32-ref bv (+ offset 44) byte-order)
+ (bytevector-u64-ref bv (+ offset 48) byte-order)
+ (bytevector-u64-ref bv (+ offset 56) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf64-section-header bv offset byte-order sec)
+ (bytevector-u32-set! bv offset (elf-section-name sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-section-flags sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-section-addr sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 24) (elf-section-offset sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 32) (elf-section-size sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 40) (elf-section-link sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 44) (elf-section-info sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 48) (elf-section-addralign sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 56) (elf-section-entsize sec) byte-order))
+
+(define (elf-section elf n)
+ (if (not (< -1 n (elf-shnum elf)))
+ (error "bad section number" n))
+ ((case (elf-word-size elf)
+ ((4) parse-elf32-section-header)
+ ((8) parse-elf64-section-header)
+ (else (error "unhandled pointer size")))
+ n
+ (elf-bytes elf)
+ (+ (elf-shoff elf) (* n (elf-shentsize elf)))
+ (elf-byte-order elf)))
+
+(define (write-elf-section-header bv offset byte-order word-size sec)
+ ((case word-size
+ ((4) write-elf32-section-header)
+ ((8) write-elf64-section-header)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order sec))
+
+(define (elf-sections elf)
+ (let lp ((n (elf-shnum elf)) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n) (cons (elf-section elf (1- n)) out)))))
+
+;;
+;; Section Types
+;;
+(define SHT_NULL 0) ; Section header table entry unused
+(define SHT_PROGBITS 1) ; Program data
+(define SHT_SYMTAB 2) ; Symbol table
+(define SHT_STRTAB 3) ; String table
+(define SHT_RELA 4) ; Relocation entries with addends
+(define SHT_HASH 5) ; Symbol hash table
+(define SHT_DYNAMIC 6) ; Dynamic linking information
+(define SHT_NOTE 7) ; Notes
+(define SHT_NOBITS 8) ; Program space with no data (bss)
+(define SHT_REL 9) ; Relocation entries, no addends
+(define SHT_SHLIB 10) ; Reserved
+(define SHT_DYNSYM 11) ; Dynamic linker symbol table
+(define SHT_INIT_ARRAY 14) ; Array of constructors
+(define SHT_FINI_ARRAY 15) ; Array of destructors
+(define SHT_PREINIT_ARRAY 16) ; Array of pre-constructors
+(define SHT_GROUP 17) ; Section group
+(define SHT_SYMTAB_SHNDX 18) ; Extended section indeces
+(define SHT_NUM 19) ; Number of defined types.
+(define SHT_LOOS #x60000000) ; Start OS-specific.
+(define SHT_HIOS #x6fffffff) ; End OS-specific type
+(define SHT_LOPROC #x70000000) ; Start of processor-specific
+(define SHT_HIPROC #x7fffffff) ; End of processor-specific
+(define SHT_LOUSER #x80000000) ; Start of application-specific
+(define SHT_HIUSER #x8fffffff) ; End of application-specific
+
+;;
+;; Section Flags
+;;
+(define SHF_WRITE (ash 1 0)) ; Writable
+(define SHF_ALLOC (ash 1 1)) ; Occupies memory during execution
+(define SHF_EXECINSTR (ash 1 2)) ; Executable
+(define SHF_MERGE (ash 1 4)) ; Might be merged
+(define SHF_STRINGS (ash 1 5)) ; Contains nul-terminated strings
+(define SHF_INFO_LINK (ash 1 6)) ; `sh_info' contains SHT index
+(define SHF_LINK_ORDER (ash 1 7)) ; Preserve order after combining
+(define SHF_OS_NONCONFORMING (ash 1 8)) ; Non-standard OS specific handling required
+(define SHF_GROUP (ash 1 9)) ; Section is member of a group.
+(define SHF_TLS (ash 1 10)) ; Section hold thread-local data.
+
+;;
+;; Dynamic entry types. The DT_GUILE types are non-standard.
+;;
+(define DT_NULL 0) ; Marks end of dynamic section
+(define DT_NEEDED 1) ; Name of needed library
+(define DT_PLTRELSZ 2) ; Size in bytes of PLT relocs
+(define DT_PLTGOT 3) ; Processor defined value
+(define DT_HASH 4) ; Address of symbol hash table
+(define DT_STRTAB 5) ; Address of string table
+(define DT_SYMTAB 6) ; Address of symbol table
+(define DT_RELA 7) ; Address of Rela relocs
+(define DT_RELASZ 8) ; Total size of Rela relocs
+(define DT_RELAENT 9) ; Size of one Rela reloc
+(define DT_STRSZ 10) ; Size of string table
+(define DT_SYMENT 11) ; Size of one symbol table entry
+(define DT_INIT 12) ; Address of init function
+(define DT_FINI 13) ; Address of termination function
+(define DT_SONAME 14) ; Name of shared object
+(define DT_RPATH 15) ; Library search path (deprecated)
+(define DT_SYMBOLIC 16) ; Start symbol search here
+(define DT_REL 17) ; Address of Rel relocs
+(define DT_RELSZ 18) ; Total size of Rel relocs
+(define DT_RELENT 19) ; Size of one Rel reloc
+(define DT_PLTREL 20) ; Type of reloc in PLT
+(define DT_DEBUG 21) ; For debugging ; unspecified
+(define DT_TEXTREL 22) ; Reloc might modify .text
+(define DT_JMPREL 23) ; Address of PLT relocs
+(define DT_BIND_NOW 24) ; Process relocations of object
+(define DT_INIT_ARRAY 25) ; Array with addresses of init fct
+(define DT_FINI_ARRAY 26) ; Array with addresses of fini fct
+(define DT_INIT_ARRAYSZ 27) ; Size in bytes of DT_INIT_ARRAY
+(define DT_FINI_ARRAYSZ 28) ; Size in bytes of DT_FINI_ARRAY
+(define DT_RUNPATH 29) ; Library search path
+(define DT_FLAGS 30) ; Flags for the object being loaded
+(define DT_ENCODING 32) ; Start of encoded range
+(define DT_PREINIT_ARRAY 32) ; Array with addresses of preinit fc
+(define DT_PREINIT_ARRAYSZ 33) ; size in bytes of DT_PREINIT_ARRAY
+(define DT_NUM 34) ; Number used
+(define DT_LOGUILE #x37146000) ; Start of Guile-specific
+(define DT_GUILE_GC_ROOT #x37146000) ; Offset of GC roots
+(define DT_GUILE_GC_ROOT_SZ #x37146001) ; Size in machine words of GC roots
+(define DT_GUILE_ENTRY #x37146002) ; Address of entry thunk
+(define DT_GUILE_VM_VERSION #x37146003) ; Bytecode version
+(define DT_GUILE_FRAME_MAPS #x37146004) ; Offset of .guile.frame-maps
+(define DT_HIGUILE #x37146fff) ; End of Guile-specific
+(define DT_LOOS #x6000000d) ; Start of OS-specific
+(define DT_HIOS #x6ffff000) ; End of OS-specific
+(define DT_LOPROC #x70000000) ; Start of processor-specific
+(define DT_HIPROC #x7fffffff) ; End of processor-specific
+
+
+(define (string-table-ref bv offset)
+ (let lp ((end offset))
+ (if (zero? (bytevector-u8-ref bv end))
+ (let ((out (make-bytevector (- end offset))))
+ (bytevector-copy! bv offset out 0 (- end offset))
+ (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)))))
+ (map (lambda (section)
+ (cons (string-table-ref (elf-bytes elf)
+ (+ off (elf-section-name section)))
+ section))
+ sections)))
+
+(define-record-type <elf-symbol>
+ (make-elf-symbol name value size info other shndx)
+ elf-symbol?
+ (name elf-symbol-name)
+ (value elf-symbol-value)
+ (size elf-symbol-size)
+ (info elf-symbol-info)
+ (other elf-symbol-other)
+ (shndx elf-symbol-shndx))
+
+(define* (make-elf-symbol* #:key (name 0) (value 0) (size 0)
+ (binding STB_LOCAL) (type STT_NOTYPE)
+ (info (logior (ash binding 4) type))
+ (visibility STV_DEFAULT) (other visibility)
+ (shndx SHN_UNDEF))
+ (make-elf-symbol name value size info other shndx))
+
+;; typedef struct {
+;; uint32_t st_name;
+;; Elf32_Addr st_value;
+;; uint32_t st_size;
+;; unsigned char st_info;
+;; unsigned char st_other;
+;; uint16_t st_shndx;
+;; } Elf32_Sym;
+
+(define (elf-symbol-len word-size)
+ (case word-size
+ ((4) 16)
+ ((8) 24)
+ (else (error "bad word size" word-size))))
+
+(define (parse-elf32-symbol bv offset stroff byte-order)
+ (if (<= (+ offset 16) (bytevector-length bv))
+ (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
+ (if stroff
+ (string-table-ref bv (+ stroff name))
+ name))
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u8-ref bv (+ offset 12))
+ (bytevector-u8-ref bv (+ offset 13))
+ (bytevector-u16-ref bv (+ offset 14) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf32-symbol bv offset byte-order sym)
+ (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-symbol-value sym) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-symbol-size sym) byte-order)
+ (bytevector-u8-set! bv (+ offset 12) (elf-symbol-info sym))
+ (bytevector-u8-set! bv (+ offset 13) (elf-symbol-other sym))
+ (bytevector-u16-set! bv (+ offset 14) (elf-symbol-shndx sym) byte-order))
+
+;; typedef struct {
+;; uint32_t st_name;
+;; unsigned char st_info;
+;; unsigned char st_other;
+;; uint16_t st_shndx;
+;; Elf64_Addr st_value;
+;; uint64_t st_size;
+;; } Elf64_Sym;
+
+(define (parse-elf64-symbol bv offset stroff byte-order)
+ (if (<= (+ offset 24) (bytevector-length bv))
+ (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
+ (if stroff
+ (string-table-ref bv (+ stroff name))
+ name))
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u8-ref bv (+ offset 4))
+ (bytevector-u8-ref bv (+ offset 5))
+ (bytevector-u16-ref bv (+ offset 6) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf64-symbol bv offset byte-order sym)
+ (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+ (bytevector-u8-set! bv (+ offset 4) (elf-symbol-info sym))
+ (bytevector-u8-set! bv (+ offset 5) (elf-symbol-other sym))
+ (bytevector-u16-set! bv (+ offset 6) (elf-symbol-shndx sym) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-symbol-value sym) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-symbol-size sym) byte-order))
+
+(define (write-elf-symbol bv offset byte-order word-size sym)
+ ((case word-size
+ ((4) write-elf32-symbol)
+ ((8) write-elf64-symbol)
+ (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))
+ (stroff (and strtab (elf-section-offset strtab)))
+ (base (elf-section-offset section))
+ (len (elf-section-size section))
+ (entsize (elf-section-entsize section)))
+ (unless (<= (* (1+ n) entsize) len)
+ (error "out of range symbol table access" section n))
+ (case (elf-word-size elf)
+ ((4)
+ (unless (<= 16 entsize)
+ (error "bad entsize for symbol table" section))
+ (parse-elf32-symbol bv (+ base (* n entsize)) stroff byte-order))
+ ((8)
+ (unless (<= 24 entsize)
+ (error "bad entsize for symbol table" section))
+ (parse-elf64-symbol bv (+ base (* n entsize)) stroff byte-order))
+ (else (error "bad word size" elf)))))
+
+;; Legal values for ST_BIND subfield of st_info (symbol binding).
+
+(define STB_LOCAL 0) ; Local symbol
+(define STB_GLOBAL 1) ; Global symbol
+(define STB_WEAK 2) ; Weak symbol
+(define STB_NUM 3) ; Number of defined types.
+(define STB_LOOS 10) ; Start of OS-specific
+(define STB_GNU_UNIQUE 10) ; Unique symbol.
+(define STB_HIOS 12) ; End of OS-specific
+(define STB_LOPROC 13) ; Start of processor-specific
+(define STB_HIPROC 15) ; End of processor-specific
+
+;; Legal values for ST_TYPE subfield of st_info (symbol type).
+
+(define STT_NOTYPE 0) ; Symbol type is unspecified
+(define STT_OBJECT 1) ; Symbol is a data object
+(define STT_FUNC 2) ; Symbol is a code object
+(define STT_SECTION 3) ; Symbol associated with a section
+(define STT_FILE 4) ; Symbol's name is file name
+(define STT_COMMON 5) ; Symbol is a common data object
+(define STT_TLS 6) ; Symbol is thread-local data objec
+(define STT_NUM 7) ; Number of defined types.
+(define STT_LOOS 10) ; Start of OS-specific
+(define STT_GNU_IFUNC 10) ; Symbol is indirect code object
+(define STT_HIOS 12) ; End of OS-specific
+(define STT_LOPROC 13) ; Start of processor-specific
+(define STT_HIPROC 15) ; End of processor-specific
+
+;; Symbol visibility specification encoded in the st_other field.
+
+(define STV_DEFAULT 0) ; Default symbol visibility rules
+(define STV_INTERNAL 1) ; Processor specific hidden class
+(define STV_HIDDEN 2) ; Sym unavailable in other modules
+(define STV_PROTECTED 3) ; Not preemptible, not exported
+
+(define (elf-symbol-binding sym)
+ (ash (elf-symbol-info sym) -4))
+
+(define (elf-symbol-type sym)
+ (logand (elf-symbol-info sym) #xf))
+
+(define (elf-symbol-visibility sym)
+ (logand (elf-symbol-other sym) #x3))
+
+(define NT_GNU_ABI_TAG 1)
+(define NT_GNU_HWCAP 2)
+(define NT_GNU_BUILD_ID 3)
+(define NT_GNU_GOLD_VERSION 4)
+
+(define-record-type <elf-note>
+ (make-elf-note name desc type)
+ elf-note?
+ (name elf-note-name)
+ (desc elf-note-desc)
+ (type elf-note-type))
+
+(define (parse-elf-note elf section)
+ (let ((bv (elf-bytes elf))
+ (byte-order (elf-byte-order elf))
+ (offset (elf-section-offset section)))
+ (unless (<= (+ offset 12) (bytevector-length bv))
+ (error "corrupt ELF (offset out of range)" offset))
+ (let ((namesz (bytevector-u32-ref bv offset byte-order))
+ (descsz (bytevector-u32-ref bv (+ offset 4) byte-order))
+ (type (bytevector-u32-ref bv (+ offset 8) byte-order)))
+ (unless (<= (+ offset 12 namesz descsz) (bytevector-length bv))
+ (error "corrupt ELF (offset out of range)" offset))
+ (let ((name (make-bytevector (1- namesz)))
+ (desc (make-bytevector descsz)))
+ (bytevector-copy! bv (+ offset 12) name 0 (1- namesz))
+ (bytevector-copy! bv (+ offset 12 namesz) desc 0 descsz)
+ (make-elf-note (utf8->string name) desc type)))))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 40d4080a3..a5de861e4 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 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
@@ -21,21 +21,16 @@
(define-module (system vm frame)
#:use-module (system base pmatch)
#:use-module (system vm program)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
#:export (frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
- frame-next-source frame-call-representation
+ frame-call-representation
frame-environment
- frame-object-binding frame-object-name
- frame-return-values))
+ frame-object-binding frame-object-name))
(define (frame-bindings frame)
(let ((p (frame-procedure frame)))
- (if (program? p)
- (program-bindings-for-ip p (frame-instruction-pointer frame))
- '())))
+ (program-bindings-for-ip p (frame-instruction-pointer frame))))
(define (frame-lookup-binding frame var)
(let lp ((bindings (frame-bindings frame)))
@@ -72,15 +67,6 @@
;;; Pretty printing
;;;
-(define (frame-next-source frame)
- (let ((proc (frame-procedure frame)))
- (if (program? proc)
- (program-source proc
- (frame-instruction-pointer frame)
- (program-sources-pre-retire proc))
- '())))
-
-
;; Basically there are two cases to deal with here:
;;
;; 1. We've already parsed the arguments, and bound them to local
@@ -118,7 +104,7 @@
(opt (or (assq-ref arguments 'optional) '()))
(key (or (assq-ref arguments 'keyword) '()))
(rest (or (assq-ref arguments 'rest) #f))
- (i 0))
+ (i 1))
(cond
((pair? req)
(cons (binding-ref (car req) i)
@@ -138,7 +124,8 @@
;; case 2
(map (lambda (i)
(frame-local-ref frame i))
- (iota (frame-num-locals frame))))))))
+ ;; Cdr past the 0th local, which is the procedure.
+ (cdr (iota (frame-num-locals frame)))))))))
@@ -158,12 +145,3 @@
(define (frame-object-name frame obj)
(cond ((frame-object-binding frame obj) => binding:name)
(else #f)))
-
-;; Nota bene, only if frame is in a return context (i.e. in a
-;; pop-continuation hook dispatch).
-(define (frame-return-values frame)
- (let* ((len (frame-num-locals frame))
- (nvalues (frame-local-ref frame (1- len))))
- (map (lambda (i)
- (frame-local-ref frame (+ (- len nvalues 1) i)))
- (iota nvalues))))
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))))
diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm
deleted file mode 100644
index 287e47293..000000000
--- a/module/system/vm/instruction.scm
+++ /dev/null
@@ -1,28 +0,0 @@
-;;; Guile VM instructions
-
-;; Copyright (C) 2001, 2010 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 instruction)
- #:export (instruction-list
- instruction? instruction-length
- instruction-pops instruction-pushes
- instruction->opcode opcode->instruction))
-
-(load-extension (string-append "libguile-" (effective-version))
- "scm_init_instructions")
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
new file mode 100644
index 000000000..5449e8634
--- /dev/null
+++ b/module/system/vm/linker.scm
@@ -0,0 +1,668 @@
+;;; Guile ELF linker
+
+;; Copyright (C) 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 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
+
+;;; Commentary:
+;;;
+;;; A linker combines several linker objects into an executable or a
+;;; loadable library.
+;;;
+;;; There are several common formats for libraries out there. Since
+;;; Guile includes its own linker and loader, we are free to choose any
+;;; format, or make up our own.
+;;;
+;;; There are essentially two requirements for a linker format:
+;;; libraries should be able to be loaded with the minimal amount of
+;;; work; and they should support introspection in some way, in order to
+;;; enable good debugging.
+;;;
+;;; These requirements are somewhat at odds, as loading should not have
+;;; to stumble over features related to introspection. It so happens
+;;; that a lot of smart people have thought about this situation, and
+;;; the ELF format embodies the outcome of their thinking. Guile uses
+;;; ELF as its format, regardless of the platform's native library
+;;; format. It's not inconceivable that Guile could interoperate with
+;;; the native dynamic loader at some point, but it's not a near-term
+;;; goal.
+;;;
+;;; Guile's linker takes a list of objects, sorts them according to
+;;; similarity from the perspective of the loader, then writes them out
+;;; into one big bytevector in ELF format.
+;;;
+;;; It is often the case that different parts of a library need to refer
+;;; to each other. For example, program text may need to refer to a
+;;; constant from writable memory. When the linker places sections
+;;; (linker objects) into specific locations in the linked bytevector,
+;;; it needs to fix up those references. This process is called
+;;; /relocation/. References needing relocations are recorded in
+;;; "linker-reloc" objects, and collected in a list in each
+;;; "linker-object". The actual definitions of the references are
+;;; stored in "linker-symbol" objects, also collected in a list in each
+;;; "linker-object".
+;;;
+;;; By default, the ELF files created by the linker include some padding
+;;; so that different parts of the file can be loaded in with different
+;;; permissions. For example, some parts of the file are read-only and
+;;; thus can be shared between processes. Some parts of the file don't
+;;; need to be loaded at all. However this padding can be too much for
+;;; interactive compilation, when the code is never written out to disk;
+;;; in that case, pass #:page-aligned? #f to `link-elf'.
+;;;
+;;; Code:
+
+(define-module (system vm linker)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module ((srfi srfi-1) #:select (append-map))
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (system vm elf)
+ #:export (make-linker-reloc
+ make-linker-symbol
+
+ make-linker-object
+ linker-object?
+ linker-object-section
+ linker-object-bv
+ linker-object-relocs
+ (linker-object-symbols* . linker-object-symbols)
+
+ make-string-table
+ string-table-intern!
+ link-string-table!
+
+ link-elf))
+
+(define-syntax fold-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ proc list seed ...)
+ (with-syntax (((s ...) (generate-temporaries #'(seed ...))))
+ #'(let ((p proc))
+ (let lp ((l list) (s seed) ...)
+ (match l
+ (() (values s ...))
+ ((elt . l)
+ (call-with-values (lambda () (p elt s ...))
+ (lambda (s ...) (lp l s ...))))))))))))
+
+;; A relocation records a reference to a symbol. When the symbol is
+;; resolved to an address, the reloc location will be updated to point
+;; to the address.
+;;
+;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
+;; Rel32/4 is a relative signed offset in 32-bit units. Either can have
+;; an arbitrary addend as well.
+;;
+(define-record-type <linker-reloc>
+ (make-linker-reloc type loc addend symbol)
+ linker-reloc?
+ (type linker-reloc-type) ;; rel32/4, abs32/1, abs64/1
+ (loc linker-reloc-loc)
+ (addend linker-reloc-addend)
+ (symbol linker-reloc-symbol))
+
+;; A symbol is an association between a name and an address. The
+;; address is always in regard to some particular address space. When
+;; objects come into the linker, their symbols live in the object
+;; address space. When the objects are allocated into ELF segments, the
+;; symbols will be relocated into memory address space, corresponding to
+;; the position the ELF will be loaded at.
+;;
+(define-record-type <linker-symbol>
+ (make-linker-symbol name address)
+ linker-symbol?
+ (name linker-symbol-name)
+ (address linker-symbol-address))
+
+(define-record-type <linker-object>
+ (%make-linker-object section bv relocs symbols)
+ linker-object?
+ (section linker-object-section)
+ (bv linker-object-bv)
+ (relocs linker-object-relocs)
+ (symbols linker-object-symbols))
+
+(define (make-linker-object section bv relocs symbols)
+ "Create a linker object with the @code{<elf-section>} header
+@var{section}, bytevector contents @var{bv}, list of linker relocations
+@var{relocs}, and list of linker symbols @var{symbols}."
+ (%make-linker-object section bv relocs
+ ;; Hide a symbol to the beginning of the section
+ ;; in the symbols.
+ (cons (make-linker-symbol (gensym "*section*") 0)
+ symbols)))
+(define (linker-object-section-symbol object)
+ "Return the linker symbol corresponding to the start of this section."
+ (car (linker-object-symbols object)))
+(define (linker-object-symbols* object)
+ "Return the linker symbols defined by the user for this this section."
+ (cdr (linker-object-symbols object)))
+
+(define-record-type <string-table>
+ (%make-string-table strings linked?)
+ string-table?
+ (strings string-table-strings set-string-table-strings!)
+ (linked? string-table-linked? set-string-table-linked?!))
+
+(define (make-string-table)
+ "Return a string table with one entry: the empty string."
+ (%make-string-table '(("" 0 #vu8())) #f))
+
+(define (string-table-length strings)
+ "Return the number of bytes needed for the @var{strings}."
+ (match strings
+ (((str pos bytes) . _)
+ ;; The + 1 is for the trailing NUL byte.
+ (+ pos (bytevector-length bytes) 1))))
+
+(define (string-table-intern! table str)
+ "Ensure that @var{str} is present in the string table @var{table}.
+Returns the byte index of the string in that table."
+ (match table
+ (($ <string-table> strings linked?)
+ (match (assoc str strings)
+ ((_ pos _) pos)
+ (#f
+ (let ((next (string-table-length strings)))
+ (when linked?
+ (error "string table already linked, can't intern" table str))
+ (set-string-table-strings! table
+ (cons (list str next (string->utf8 str))
+ strings))
+ next))))))
+
+(define (link-string-table! table)
+ "Link the functional string table @var{table} into a sequence of
+bytes, suitable for use as the contents of an ELF string table section."
+ (match table
+ (($ <string-table> strings #f)
+ (let ((out (make-bytevector (string-table-length strings) 0)))
+ (for-each
+ (match-lambda
+ ((_ pos bytes)
+ (bytevector-copy! bytes 0 out pos (bytevector-length bytes))))
+ strings)
+ (set-string-table-linked?! table #t)
+ out))))
+
+(define (segment-kind section)
+ "Return the type of segment needed to store @var{section}, as a pair.
+The car is the @code{PT_} segment type, or @code{#f} if the section
+doesn't need to be present in a loadable segment. The cdr is a bitfield
+of associated @code{PF_} permissions."
+ (let ((flags (elf-section-flags section)))
+ (cons (cond
+ ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
+ ;; Sections without SHF_ALLOC don't go in segments.
+ ((zero? flags) #f)
+ (else PT_LOAD))
+ (logior (if (zero? (logand SHF_ALLOC flags))
+ 0
+ PF_R)
+ (if (zero? (logand SHF_EXECINSTR flags))
+ 0
+ PF_X)
+ (if (zero? (logand SHF_WRITE flags))
+ 0
+ PF_W)))))
+
+(define (count-segments objects)
+ "Return the total number of segments needed to represent the linker
+objects in @var{objects}, including the segment needed for the ELF
+header and segment table."
+ (length
+ (fold-values (lambda (object kinds)
+ (let ((kind (segment-kind (linker-object-section object))))
+ (if (and (car kind) (not (member kind kinds)))
+ (cons kind kinds)
+ kinds)))
+ objects
+ ;; We know there will be at least one segment,
+ ;; containing at least the header and segment table.
+ (list (cons PT_LOAD PF_R)))))
+
+(define (group-by-cars ls)
+ (let lp ((ls ls) (k #f) (group #f) (out '()))
+ (match ls
+ (()
+ (reverse!
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))
+ (((k* . v) . ls)
+ (if (and group (equal? k k*))
+ (lp ls k (cons v group) out)
+ (lp ls k* (list v)
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))))))
+
+(define (collate-objects-into-segments objects)
+ "Given the list of linker objects @var{objects}, group them into
+contiguous ELF segments of the same type and flags. The result is an
+alist that maps segment types to lists of linker objects. See
+@code{segment-type} for a description of segment types. Within a
+segment, the order of the linker objects is preserved."
+ (group-by-cars
+ (stable-sort!
+ (map (lambda (o)
+ (cons (segment-kind (linker-object-section o)) o))
+ objects)
+ (lambda (x y)
+ (let* ((x-kind (car x)) (y-kind (car y))
+ (x-type (car x-kind)) (y-type (car y-kind))
+ (x-flags (cdr x-kind)) (y-flags (cdr y-kind))
+ (x-section (linker-object-section (cdr x)))
+ (y-section (linker-object-section (cdr y))))
+ (cond
+ ((not (equal? x-kind y-kind))
+ (cond
+ ((and x-type y-type)
+ (cond
+ ((not (equal? x-flags y-flags))
+ (< x-flags y-flags))
+ (else
+ (< x-type y-type))))
+ (else
+ (not y-type))))
+ ((not (equal? (elf-section-type x-section)
+ (elf-section-type y-section)))
+ (cond
+ ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
+ ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
+ (else (< (elf-section-type x-section)
+ (elf-section-type y-section)))))
+ (else
+ ;; Leave them in the initial order. This allows us to ensure
+ ;; that the ELF header is written first.
+ #f)))))))
+
+(define (align address alignment)
+ (if (zero? alignment)
+ address
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment))))
+
+(define (relocate-section-header sec offset)
+ "Return a new section header, just like @var{sec} but with its
+@code{offset} (and @code{addr} if it is loadable) set to @var{offset}."
+ (make-elf-section #:index (elf-section-index sec)
+ #:name (elf-section-name sec)
+ #:type (elf-section-type sec)
+ #:flags (elf-section-flags sec)
+ #:addr (if (zero? (logand SHF_ALLOC
+ (elf-section-flags sec)))
+ 0
+ offset)
+ #:offset offset
+ #:size (elf-section-size sec)
+ #:link (elf-section-link sec)
+ #:info (elf-section-info sec)
+ #:addralign (elf-section-addralign sec)
+ #:entsize (elf-section-entsize sec)))
+
+(define *page-size* 4096)
+
+(define (add-symbols symbols offset symtab)
+ "Add @var{symbols} to the symbol table @var{symtab}, relocating them
+from object address space to memory address space. Returns a new symbol
+table."
+ (fold-values
+ (lambda (symbol symtab)
+ (let ((name (linker-symbol-name symbol))
+ (addr (linker-symbol-address symbol)))
+ (when (vhash-assq name symtab)
+ (error "duplicate symbol" name))
+ (vhash-consq name (make-linker-symbol name (+ addr offset)) symtab)))
+ symbols
+ symtab))
+
+(define (allocate-segment write-segment-header!
+ phidx type flags objects addr symtab alignment)
+ "Given a list of linker objects that should go in a segment, the type
+and flags that the segment should have, and the address at which the
+segment should start, compute the positions that each object should have
+in the segment.
+
+Returns three values: the address of the next byte after the segment, a
+list of relocated objects, and the symbol table. The symbol table is
+the same as @var{symtab}, augmented with the symbols defined in
+@var{objects}, relocated to their positions in the image.
+
+In what is something of a quirky interface, this routine also patches up
+the segment table using @code{write-segment-header!}."
+ (let* ((alignment (fold-values (lambda (o alignment)
+ (lcm (elf-section-addralign
+ (linker-object-section o))
+ alignment))
+ objects
+ alignment))
+ (addr (align addr alignment)))
+ (receive (objects endaddr symtab)
+ (fold-values
+ (lambda (o out addr symtab)
+ (let* ((section (linker-object-section o))
+ (addr (align addr (elf-section-addralign section))))
+ (values
+ (cons (make-linker-object
+ (relocate-section-header section addr)
+ (linker-object-bv o)
+ (linker-object-relocs o)
+ (linker-object-symbols o))
+ out)
+ (+ addr (elf-section-size section))
+ (add-symbols (linker-object-symbols o) addr symtab))))
+ objects
+ '() addr symtab)
+ (when type
+ (write-segment-header!
+ (make-elf-segment #:index phidx #:type type
+ #:offset addr #:vaddr addr
+ #:filesz (- endaddr addr) #:memsz (- endaddr addr)
+ #:flags flags #:align alignment)))
+ (values endaddr
+ (reverse objects)
+ symtab))))
+
+(define (process-reloc reloc bv section-offset symtab endianness)
+ "Process a relocation. Given that a section containing @var{reloc}
+was just written into the image @var{bv} at offset @var{section-offset},
+fix it up so that its reference points to the correct position of its
+symbol, as present in @var{symtab}."
+ (match (vhash-assq (linker-reloc-symbol reloc) symtab)
+ (#f
+ (error "Undefined symbol" (linker-reloc-symbol reloc)))
+ ((name . symbol)
+ ;; The reloc was written at LOC bytes after SECTION-OFFSET.
+ (let* ((offset (+ (linker-reloc-loc reloc) section-offset))
+ (target (linker-symbol-address symbol)))
+ (case (linker-reloc-type reloc)
+ ((rel32/4)
+ (let ((diff (- target offset)))
+ (unless (zero? (modulo diff 4))
+ (error "Bad offset" reloc symbol offset))
+ (bytevector-s32-set! bv offset
+ (+ (/ diff 4) (linker-reloc-addend reloc))
+ endianness)))
+ ((abs32/1)
+ (bytevector-u32-set! bv offset target endianness))
+ ((abs64/1)
+ (bytevector-u64-set! bv offset target endianness))
+ (else
+ (error "bad reloc type" reloc)))))))
+
+(define (write-linker-object bv o symtab endianness)
+ "Write the bytevector for the section wrapped by the linker object
+@var{o} into the image @var{bv}. The section header in @var{o} should
+already be relocated its final position in the image. Any relocations
+in the section will be processed to point to the correct symbol
+locations, as given in @var{symtab}."
+ (let* ((section (linker-object-section o))
+ (offset (elf-section-offset section))
+ (len (elf-section-size section))
+ (bytes (linker-object-bv o))
+ (relocs (linker-object-relocs o)))
+ (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
+ (unless (zero? (elf-section-addr section))
+ (error "non-loadable section has non-zero addr" section))
+ (unless (= offset (elf-section-addr section))
+ (error "loadable section has offset != addr" section)))
+ (if (not (= (elf-section-type section) SHT_NOBITS))
+ (begin
+ (if (not (= len (bytevector-length bytes)))
+ (error "unexpected length" section bytes))
+ (bytevector-copy! bytes 0 bv offset len)
+ (for-each (lambda (reloc)
+ (process-reloc reloc bv offset symtab endianness))
+ relocs)))))
+
+(define (find-shstrndx objects)
+ "Find the section name string table in @var{objects}, and return its
+section index."
+ (or-map (lambda (object)
+ (let* ((section (linker-object-section object))
+ (bv (linker-object-bv object))
+ (name (elf-section-name section)))
+ (and (= (elf-section-type section) SHT_STRTAB)
+ (equal? (false-if-exception (string-table-ref bv name))
+ ".shstrtab")
+ (elf-section-index section))))
+ objects))
+
+(define (add-elf-objects objects endianness word-size)
+ "Given the list of linker objects supplied by the user, add linker
+objects corresponding to parts of the ELF file: the null object, the ELF
+header, and the section table.
+
+Both of these internal objects include relocs, allowing their
+inter-object references to be patched up when the final image allocation
+is known. There is special support for patching up the segment table,
+however. Because the segment table needs to know the segment sizes,
+which is the difference between two symbols in image space, and there is
+no reloc kind that is the difference between two symbols, we make a hack
+and return a closure that patches up segment table entries. It seems to
+work.
+
+Returns two values: the procedure to patch the segment table, and the
+list of objects, augmented with objects for the special ELF sections."
+ (define phoff (elf-header-len word-size))
+ (define phentsize (elf-program-header-len word-size))
+ (define shentsize (elf-section-header-len word-size))
+ (define shnum (+ (length objects) 3))
+ (define reloc-kind
+ (case word-size
+ ((4) 'abs32/1)
+ ((8) 'abs64/1)
+ (else (error "bad word size" word-size))))
+
+ ;; ELF requires that the first entry in the section table be of type
+ ;; SHT_NULL.
+ ;;
+ (define (make-null-section)
+ (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
+ #:flags 0 #:addralign 0)
+ #vu8() '() '()))
+
+ ;; The ELF header and the segment table.
+ ;;
+ (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 shentsize
+ #:shstrndx (or (find-shstrndx objects) SHN_UNDEF)))
+ (shoff-reloc (make-linker-reloc reloc-kind
+ (elf-header-shoff-offset word-size)
+ 0
+ shoff-label))
+ (size (+ phoff (* phnum phentsize)))
+ (bv (make-bytevector size 0)))
+ (write-elf-header bv header)
+ ;; Leave the segment table uninitialized; it will be filled in
+ ;; later by calls to the write-segment-header! closure.
+ (make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS
+ #:flags SHF_ALLOC #:size size)
+ bv
+ (list shoff-reloc)
+ '())))
+
+ ;; The section table.
+ ;;
+ (define (make-footer objects shoff-label)
+ (let* ((size (* shentsize shnum))
+ (bv (make-bytevector size 0))
+ (section-table (make-elf-section #:index (length objects)
+ #:type SHT_PROGBITS
+ #:flags 0
+ #:size size)))
+ (define (write-and-reloc section-label section relocs)
+ (let ((offset (* shentsize (elf-section-index section))))
+ (write-elf-section-header bv offset endianness word-size section)
+ (if (= (elf-section-type section) SHT_NULL)
+ relocs
+ (let ((relocs
+ (cons (make-linker-reloc
+ reloc-kind
+ (+ offset
+ (elf-section-header-offset-offset word-size))
+ 0
+ section-label)
+ relocs)))
+ (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
+ relocs
+ (cons (make-linker-reloc
+ reloc-kind
+ (+ offset
+ (elf-section-header-addr-offset word-size))
+ 0
+ section-label)
+ relocs))))))
+ (let ((relocs (fold-values
+ (lambda (object relocs)
+ (write-and-reloc
+ (linker-symbol-name
+ (linker-object-section-symbol object))
+ (linker-object-section object)
+ relocs))
+ objects
+ (write-and-reloc shoff-label section-table '()))))
+ (%make-linker-object section-table bv relocs
+ (list (make-linker-symbol shoff-label 0))))))
+
+ (let* ((null-section (make-null-section))
+ (objects (cons null-section objects))
+
+ (shoff (gensym "*section-table*"))
+ (header (make-header (count-segments objects) (length objects) shoff))
+ (objects (cons header objects))
+
+ (footer (make-footer objects shoff))
+ (objects (cons footer objects)))
+
+ ;; The header includes the segment table, which needs offsets and
+ ;; sizes of the segments. Normally we would use relocs to rewrite
+ ;; these values, but there is no reloc type that would allow us to
+ ;; compute size. Such a reloc would need to take the difference
+ ;; between two symbols, and it's probably a bad idea architecturally
+ ;; to create one.
+ ;;
+ ;; So instead we return a closure to patch up the segment table.
+ ;; Normally we'd shy away from such destructive interfaces, but it's
+ ;; OK as we create the header section ourselves.
+ ;;
+ (define (write-segment-header! segment)
+ (let ((bv (linker-object-bv header))
+ (offset (+ phoff (* (elf-segment-index segment) phentsize))))
+ (write-elf-program-header bv offset endianness word-size segment)))
+
+ (values write-segment-header! objects)))
+
+(define (allocate-elf objects page-aligned? endianness word-size)
+ "Lay out @var{objects} into an ELF image, computing the size of the
+file, the positions of the objects, and the global symbol table.
+
+If @var{page-aligned?} is true, read-only and writable data are
+separated so that only those writable parts of the image need be mapped
+with writable permissions. This makes the resulting image larger. It
+is more suitable to situations where you would write a file out to disk
+and read it in with mmap. Otherwise if @var{page-aligned?} is false,
+sections default to 8-byte alignment.
+
+Returns three values: the total image size, a list of objects with
+relocated headers, and the global symbol table."
+ (receive (write-segment-header! objects)
+ (add-elf-objects objects endianness word-size)
+ (let lp ((seglists (collate-objects-into-segments objects))
+ (objects '())
+ (phidx 0)
+ (addr 0)
+ (symtab vlist-null)
+ (prev-flags 0))
+ (match seglists
+ ((((type . flags) objs-in ...) seglists ...)
+ (receive (addr objs-out symtab)
+ (allocate-segment
+ write-segment-header!
+ phidx type flags objs-in addr symtab
+ (if (and page-aligned?
+ (not (= flags prev-flags))
+ ;; Allow sections that are not in
+ ;; loadable segments to share pages
+ ;; with PF_R segments.
+ (not (and (not type) (= PF_R prev-flags))))
+ *page-size*
+ 8))
+ (lp seglists
+ (fold-values cons objs-out objects)
+ (if type (1+ phidx) phidx)
+ addr
+ symtab
+ flags)))
+ (()
+ (values addr
+ (reverse objects)
+ symtab))))))
+
+(define (check-section-numbers objects)
+ "Verify that taken as a whole, that all objects have distinct,
+contiguous section numbers, starting from 1. (Section 0 is the null
+section.)"
+ (let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section.
+ (sections (make-vector nsections #f)))
+ (for-each (lambda (object)
+ (let ((n (elf-section-index (linker-object-section object))))
+ (cond
+ ((< n 1)
+ (error "Invalid section number" object))
+ ((>= n nsections)
+ (error "Invalid section number" object))
+ ((vector-ref sections n)
+ (error "Duplicate section" (vector-ref sections n) object))
+ (else
+ (vector-set! sections n object)))))
+ objects)))
+
+;; Given a list of linker objects, collate the objects into segments,
+;; allocate the segments, allocate the ELF bytevector, and write the
+;; segments into the bytevector, relocating as we go.
+;;
+(define* (link-elf objects #:key
+ (page-aligned? #t)
+ (endianness (target-endianness))
+ (word-size (target-word-size)))
+ "Create an ELF image from the linker objects, @var{objects}.
+
+If @var{page-aligned?} is true, read-only and writable data are
+separated so that only those writable parts of the image need be mapped
+with writable permissions. This is suitable for situations where you
+would write a file out to disk and read it in with @code{mmap}.
+Otherwise if @var{page-aligned?} is false, sections default to 8-byte
+alignment.
+
+Returns a bytevector."
+ (check-section-numbers objects)
+ (receive (size objects symtab)
+ (allocate-elf objects page-aligned? endianness word-size)
+ (let ((bv (make-bytevector size 0)))
+ (for-each
+ (lambda (object)
+ (write-linker-object bv object symtab endianness))
+ objects)
+ bv)))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/loader.scm
index 966f34585..186bcc3c9 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/loader.scm
@@ -1,6 +1,6 @@
;;; Guile VM object code
-;; Copyright (C) 2001, 2010 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
@@ -18,11 +18,10 @@
;;; Code:
-(define-module (system vm objcode)
- #:export (objcode? objcode-meta
- bytecode->objcode objcode->bytecode
- load-objcode write-objcode
- word-size byte-order))
+(define-module (system vm loader)
+ #:export (load-thunk-from-file
+ load-thunk-from-memory
+ find-mapped-elf-image all-mapped-elf-images))
(load-extension (string-append "libguile-" (effective-version))
- "scm_init_objcodes")
+ "scm_init_loader")
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 1d0100180..a2d774dcd 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -19,31 +19,28 @@
;;; Code:
(define-module (system vm program)
- #:use-module (system base pmatch)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
+ #:use-module (ice-9 match)
+ #:use-module (system vm debug)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
- #:export (make-program
-
- make-binding binding:name binding:boxed? binding:index
+ #:export (make-binding binding:name binding:boxed? binding:index
binding:start binding:end
source:addr source:line source:column source:file
source:line-for-user
program-sources program-sources-pre-retire program-source
- program-bindings program-bindings-by-index program-bindings-for-ip
+ program-bindings-for-ip
+
program-arities program-arity arity:start arity:end
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
- program-arguments-alist program-lambda-list
+ program-arguments-alist program-arguments-alists
+ program-lambda-list
- program-meta
- program-objcode program? program-objects
- program-module program-base
+ program? program-code
program-free-variables
program-num-free-variables
program-free-variable-ref program-free-variable-set!))
@@ -51,6 +48,17 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
+;; These procedures are called by programs.c.
+(define (program-name program)
+ (and=> (find-program-debug-info (program-code program))
+ program-debug-info-name))
+(define (program-documentation program)
+ (find-program-docstring (program-code program)))
+(define (program-minimum-arity program)
+ (find-program-minimum-arity (program-code program)))
+(define (program-properties program)
+ (find-program-properties (program-code program)))
+
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
@@ -74,28 +82,31 @@
(define (source:line-for-user source)
(1+ (source:line source)))
-;; FIXME: pull this definition from elsewhere.
-(define *bytecode-header-len* 8)
-
-;; We could decompile the program to get this, but that seems like a
-;; waste.
-(define (bytecode-instruction-length bytecode ip)
- (let* ((idx (+ ip *bytecode-header-len*))
- (inst (opcode->instruction (bytevector-u8-ref bytecode idx))))
- ;; 1+ for the instruction itself.
- (1+ (cond
- ((eq? inst 'load-program)
- (+ (bytevector-u32-native-ref bytecode (+ idx 1))
- (bytevector-u32-native-ref bytecode (+ idx 5))))
- ((< (instruction-length inst) 0)
- ;; variable length instruction -- the length is encoded in the
- ;; instruction stream.
- (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16)
- (ash (bytevector-u8-ref bytecode (+ idx 2)) 8)
- (bytevector-u8-ref bytecode (+ idx 3))))
- (else
- ;; fixed length
- (instruction-length inst))))))
+(define (source-for-addr addr)
+ (and=> (find-source-for-addr addr)
+ (lambda (source)
+ ;; FIXME: absolute or relative address?
+ (cons* 0
+ (source-file source)
+ (source-line source)
+ (source-column source)))))
+
+(define (program-sources proc)
+ (map (lambda (source)
+ (cons* (- (source-post-pc source) (program-code proc))
+ (source-file source)
+ (source-line source)
+ (source-column source)))
+ (find-program-sources (program-code proc))))
+
+(define* (program-source proc ip #:optional (sources (program-sources proc)))
+ (let lp ((source #f) (sources sources))
+ (match sources
+ (() source)
+ (((and s (pc . _)) . sources)
+ (if (<= pc ip)
+ (lp s sources)
+ source)))))
;; Source information could in theory be correlated with the ip of the
;; instruction, or the ip just after the instruction is retired. Guile
@@ -108,25 +119,12 @@
;; pre-retire addresses.
;;
(define (program-sources-pre-retire proc)
- (let ((bv (objcode->bytecode (program-objcode proc))))
- (let lp ((in (program-sources proc))
- (out '())
- (ip 0))
- (cond
- ((null? in)
- (reverse out))
- (else
- (pmatch (car in)
- ((,post-ip . ,source)
- (let lp2 ((ip ip)
- (next ip))
- (if (< next post-ip)
- (lp2 next (+ next (bytecode-instruction-length bv next)))
- (lp (cdr in)
- (acons ip source out)
- next))))
- (else
- (error "unexpected"))))))))
+ (map (lambda (source)
+ (cons* (- (source-pre-pc source) (program-code proc))
+ (source-file source)
+ (source-line source)
+ (source-column source)))
+ (find-program-sources (program-code proc))))
(define (collapse-locals locs)
(let lp ((ret '()) (locs locs))
@@ -146,8 +144,8 @@
;; returns list of list of bindings
;; (list-ref ret N) == bindings bound to the Nth local slot
(define (program-bindings-by-index prog)
- (cond ((program-bindings prog) => collapse-locals)
- (else '())))
+ ;; FIXME!
+ '())
(define (program-bindings-for-ip prog ip)
(let lp ((in (program-bindings-by-index prog)) (out '()))
@@ -163,19 +161,19 @@
(else (inner (cdr binds)))))))))
(define (arity:start a)
- (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
+ (match a ((start end . _) start) (_ (error "bad arity" a))))
(define (arity:end a)
- (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
+ (match a ((start end . _) end) (_ (error "bad arity" a))))
(define (arity:nreq a)
- (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
+ (match a ((_ _ nreq . _) nreq) (_ 0)))
(define (arity:nopt a)
- (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
+ (match a ((_ _ nreq nopt . _) nopt) (_ 0)))
(define (arity:rest? a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+ (match a ((_ _ nreq nopt rest? . _) rest?) (_ #f)))
(define (arity:kw a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+ (match a ((_ _ nreq nopt rest? (_ . kw)) kw) (_ '())))
(define (arity:allow-other-keys? a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+ (match a ((_ _ nreq nopt rest? (aok . kw)) aok) (_ #f)))
(define (program-arity prog ip)
(let ((arities (program-arities prog)))
@@ -189,15 +187,15 @@
(else (lp (cdr arities))))))))
(define (arglist->arguments-alist arglist)
- (pmatch arglist
- ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+ (match arglist
+ ((req opt keyword allow-other-keys? rest . extents)
`((required . ,req)
(optional . ,opt)
(keyword . ,keyword)
(allow-other-keys? . ,allow-other-keys?)
(rest . ,rest)
(extents . ,extents)))
- (else #f)))
+ (_ #f)))
(define* (arity->arguments-alist prog arity
#:optional
@@ -239,9 +237,28 @@
;; the name "program-arguments" is taken by features.c...
(define* (program-arguments-alist prog #:optional ip)
"Returns the signature of the given procedure in the form of an association list."
- (let ((arity (program-arity prog ip)))
- (and arity
- (arity->arguments-alist prog arity))))
+ (cond
+ ((primitive? prog)
+ (match (procedure-minimum-arity prog)
+ (#f #f)
+ ((nreq nopt rest?)
+ (let ((start (primitive-call-ip prog)))
+ ;; Assume that there is only one IP for the call.
+ (and (or (not ip) (= start ip))
+ (arity->arguments-alist
+ prog
+ (list 0 0 nreq nopt rest? '(#f . ()))))))))
+ ((program? prog)
+ (or-map (lambda (arity)
+ (and (or (not ip)
+ (and (<= (arity-low-pc arity) ip)
+ (< ip (arity-high-pc arity))))
+ (arity-arguments-alist arity)))
+ (or (find-program-arities (program-code prog)) '())))
+ (else
+ (let ((arity (program-arity prog ip)))
+ (and arity
+ (arity->arguments-alist prog arity))))))
(define* (program-lambda-list prog #:optional ip)
"Returns the signature of the given procedure in the form of an argument list."
@@ -266,25 +283,48 @@
1+
0)))
+(define (program-arguments-alists prog)
+ "Returns all arities of the given procedure, as a list of association
+lists."
+ (define (fallback)
+ (match (procedure-minimum-arity prog)
+ (#f '())
+ ((nreq nopt rest?)
+ (list
+ (arity->arguments-alist
+ prog
+ (list 0 0 nreq nopt rest? '(#f . ())))))))
+ (cond
+ ((primitive? prog) (fallback))
+ ((program? prog)
+ (let ((arities (find-program-arities (program-code prog))))
+ (if arities
+ (map arity-arguments-alist arities)
+ (fallback))))
+ (else (error "expected a program" prog))))
+
(define (write-program prog port)
- (format port "#<procedure ~a~a>"
- (or (procedure-name prog)
- (and=> (program-source prog 0)
- (lambda (s)
- (format #f "~a at ~a:~a:~a"
- (number->string (object-address prog) 16)
- (or (source:file s)
- (if s "<current input>" "<unknown port>"))
- (source:line-for-user s) (source:column s))))
- (number->string (object-address prog) 16))
- (let ((arities (program-arities prog)))
- (if (or (not arities) (null? arities))
- ""
- (string-append
- " " (string-join (map (lambda (a)
- (object->string
- (arguments-alist->lambda-list
- (arity->arguments-alist prog a))))
- arities)
- " | "))))))
+ (define (program-identity-string)
+ (or (procedure-name prog)
+ (and=> (program-source prog 0)
+ (lambda (s)
+ (format #f "~a at ~a:~a:~a"
+ (number->string (object-address prog) 16)
+ (or (source:file s)
+ (if s "<current input>" "<unknown port>"))
+ (source:line-for-user s) (source:column s))))
+ (number->string (object-address prog) 16)))
+ (define (program-formals-string)
+ (let ((arguments (program-arguments-alists prog)))
+ (if (null? arguments)
+ ""
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments-alist->lambda-list a)))
+ arguments)
+ " | ")))))
+
+ (format port "#<procedure ~a~a>"
+ (program-identity-string) (program-formals-string)))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index e27dc3784..77191b7b9 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -1,6 +1,6 @@
;;; Guile VM tracer
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014 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,19 +23,14 @@
#:use-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:use-module (system vm objcode)
#:use-module (system vm traps)
#:use-module (rnrs bytevectors)
- #:use-module (system vm instruction)
#:use-module (ice-9 format)
#:export (trace-calls-in-procedure
trace-calls-to-procedure
trace-instructions-in-procedure
call-with-trace))
-;; FIXME: this constant needs to go in system vm objcode
-(define *objcode-header-len* 8)
-
(define (build-prefix prefix depth infix numeric-format max-indent)
(let lp ((indent "") (n 0))
(cond
@@ -53,80 +48,73 @@
width
(frame-call-representation frame))))
-(define* (print-return frame depth width prefix max-indent)
- (let* ((len (frame-num-locals frame))
- (nvalues (frame-local-ref frame (1- len)))
- (prefix (build-prefix prefix depth "| " "~d< "max-indent)))
- (case nvalues
+(define (print-return depth width prefix max-indent values)
+ (let ((prefix (build-prefix prefix depth "| " "~d< "max-indent)))
+ (case (length values)
((0)
(format (current-error-port) "~ano values\n" prefix))
((1)
(format (current-error-port) "~a~v:@y\n"
prefix
width
- (frame-local-ref frame (- len 2))))
+ (car values)))
(else
;; this should work, but there appears to be a bug
;; "~a~d values:~:{ ~v:@y~}\n"
(format (current-error-port) "~a~d values:~{ ~a~}\n"
- prefix nvalues
+ prefix (length values)
(map (lambda (val)
(format #f "~v:@y" width val))
- (frame-return-values frame)))))))
-
-(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
+ values))))))
+
+(define* (trace-calls-to-procedure proc #:key (width 80)
(prefix "trace: ")
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
- (define (return-handler frame depth)
- (print-return frame depth width prefix max-indent))
- (trap-calls-to-procedure proc apply-handler return-handler
- #:vm vm))
+ (define (return-handler frame depth . values)
+ (print-return depth width prefix max-indent values))
+ (trap-calls-to-procedure proc apply-handler return-handler))
-(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-calls-in-procedure proc #:key (width 80)
(prefix "trace: ")
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
- (define (return-handler frame depth)
- (print-return frame depth width prefix max-indent))
- (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:vm vm))
+ (define (return-handler frame depth . values)
+ (print-return depth width prefix max-indent values))
+ (trap-calls-in-dynamic-extent proc apply-handler return-handler))
-(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-instructions-in-procedure proc #:key (width 80)
(max-indent (- width 40)))
(define (trace-next frame)
- (let* ((ip (frame-instruction-pointer frame))
- (objcode (program-objcode (frame-procedure frame)))
- (opcode (bytevector-u8-ref (objcode->bytecode objcode)
- (+ ip *objcode-header-len*))))
- (format #t "~8d: ~a\n" ip (opcode->instruction opcode))))
+ ;; FIXME: We could disassemble this instruction here.
+ (let ((ip (frame-instruction-pointer frame)))
+ (format #t "0x~x\n" ip)))
- (trap-instructions-in-dynamic-extent proc trace-next
- #:vm vm))
+ (trap-instructions-in-dynamic-extent proc trace-next))
;; Note that because this procedure manipulates the VM trace level
;; directly, it doesn't compose well with traps at the REPL.
;;
(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
- (width 80) (vm (the-vm)) (max-indent (- width 40)))
+ (width 80) (max-indent (- width 40)))
(let ((call-trap #f)
(inst-trap #f))
(dynamic-wind
(lambda ()
(if calls?
(set! call-trap
- (trace-calls-in-procedure thunk #:vm vm #:width width
+ (trace-calls-in-procedure thunk #:width width
#:max-indent max-indent)))
(if instructions?
(set! inst-trap
- (trace-instructions-in-procedure thunk #:vm vm #:width width
+ (trace-instructions-in-procedure thunk #:width width
#:max-indent max-indent)))
- (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
+ (set-vm-trace-level! (1+ (vm-trace-level))))
thunk
(lambda ()
- (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+ (set-vm-trace-level! (1- (vm-trace-level)))
(if call-trap (call-trap))
(if inst-trap (inst-trap))
(set! call-trap #f)
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 82d4e0ef4..464740bcd 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -1,6 +1,6 @@
;;; trap-state.scm: a set of traps
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -146,19 +146,19 @@
;;;
-;;; VM-local trap states
+;;; Per-thread trap states
;;;
-(define *trap-states* (make-weak-key-hash-table))
+;; FIXME: This should be thread-local -- not something you can inherit
+;; from a dynamic state.
-(define (trap-state-for-vm vm)
- (or (hashq-ref *trap-states* vm)
- (let ((ts (make-trap-state)))
- (hashq-set! *trap-states* vm ts)
- (trap-state-for-vm vm))))
+(define %trap-state (make-parameter #f))
(define (the-trap-state)
- (trap-state-for-vm (the-vm)))
+ (or (%trap-state)
+ (let ((ts (make-trap-state)))
+ (%trap-state ts)
+ ts)))
@@ -173,11 +173,11 @@
(lambda ()
;; Don't enable hooks if the handler is #f.
(if handler
- (set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state))))
+ (set-vm-trace-level! (trap-state->trace-level trap-state))))
thunk
(lambda ()
(if handler
- (set-vm-trace-level! (the-vm) 0))))))
+ (set-vm-trace-level! 0))))))
(define* (list-traps #:optional (trap-state (the-trap-state)))
(map trap-wrapper-index (trap-state-wrappers trap-state)))
@@ -275,13 +275,13 @@
(and (<= (frame-address f) fp)
(predicate f))))))
- (let* ((source (frame-next-source frame))
+ (let* ((source (frame-source frame))
(idx (next-ephemeral-index! trap-state))
(trap (trap-matching-instructions
(wrap-predicate-according-to-into
(if instruction?
(lambda (f) #t)
- (lambda (f) (not (equal? (frame-next-source f) source)))))
+ (lambda (f) (not (equal? (frame-source f) source)))))
(ephemeral-handler-for-index trap-state idx handler))))
(add-trap-wrapper!
trap-state
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index b65e03464..77823e1aa 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -1,6 +1,6 @@
;;; Traps: stepping, breakpoints, and such.
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012, 2013, 2014 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
@@ -57,10 +57,9 @@
(define-module (system vm traps)
#:use-module (system base pmatch)
#:use-module (system vm vm)
+ #:use-module (system vm debug)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:use-module (system vm objcode)
- #:use-module (system vm instruction)
#:use-module (system xref)
#:use-module (rnrs bytevectors)
#:export (trap-at-procedure-call
@@ -84,7 +83,7 @@
(if (not (predicate? arg))
(error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
-(define (new-disabled-trap vm enable disable)
+(define (new-disabled-trap enable disable)
(let ((enabled? #f))
(define-syntax disabled?
(identifier-syntax
@@ -105,27 +104,32 @@
enable-trap))
-(define (new-enabled-trap vm frame enable disable)
- ((new-disabled-trap vm enable disable) frame))
+(define (new-enabled-trap frame enable disable)
+ ((new-disabled-trap enable disable) frame))
-(define (frame-matcher proc match-objcode?)
+;; Returns an absolute IP.
+(define (program-last-ip prog)
+ (let ((pdi (find-program-debug-info (program-code prog))))
+ (and pdi (program-debug-info-size pdi))))
+
+(define (frame-matcher proc match-code?)
(let ((proc (if (struct? proc)
(procedure proc)
proc)))
- (if match-objcode?
- (lambda (frame)
- (let ((frame-proc (frame-procedure frame)))
- (or (eq? frame-proc proc)
- (and (program? frame-proc)
- (eq? (program-objcode frame-proc)
- (program-objcode proc))))))
+ (if match-code?
+ (if (program? proc)
+ (let ((start (program-code proc))
+ (end (program-last-ip proc)))
+ (lambda (frame)
+ (let ((ip (frame-instruction-pointer frame)))
+ (and (<= start ip) (< ip end)))))
+ (lambda (frame) #f))
(lambda (frame)
(eq? (frame-procedure frame) proc)))))
;; A basic trap, fires when a procedure is called.
;;
-(define* (trap-at-procedure-call proc handler #:key (vm (the-vm))
- (closure? #f)
+(define* (trap-at-procedure-call proc handler #:key (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check handler procedure?)
@@ -135,11 +139,11 @@
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook))
+ (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
- (remove-hook! (vm-apply-hook vm) apply-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)))))
;; A more complicated trap, traps when control enters a procedure.
;;
@@ -156,8 +160,7 @@
;; * An abort.
;;
(define* (trap-in-procedure proc enter-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
@@ -187,48 +190,39 @@
(if in-proc?
(exit-proc frame)))
- (define (pop-cont-hook frame)
- (if in-proc?
- (exit-proc frame))
- (if (our-frame? (frame-previous frame))
- (enter-proc (frame-previous frame))))
-
- (define (abort-hook frame)
+ (define (pop-cont-hook frame . values)
(if in-proc?
(exit-proc frame))
(if (our-frame? frame)
(enter-proc frame)))
- (define (restore-hook frame)
+ (define (abort-hook frame . values)
(if in-proc?
(exit-proc frame))
(if (our-frame? frame)
(enter-proc frame)))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook)
- (add-hook! (vm-push-continuation-hook vm) push-cont-hook)
- (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (add-hook! (vm-abort-continuation-hook vm) abort-hook)
- (add-hook! (vm-restore-continuation-hook vm) restore-hook)
+ (add-hook! (vm-apply-hook) apply-hook)
+ (add-hook! (vm-push-continuation-hook) push-cont-hook)
+ (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (add-hook! (vm-abort-continuation-hook) abort-hook)
(if (and frame (our-frame? frame))
(enter-proc frame)))
(lambda (frame)
(if in-proc?
(exit-proc frame))
- (remove-hook! (vm-apply-hook vm) apply-hook)
- (remove-hook! (vm-push-continuation-hook vm) push-cont-hook)
- (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
- (remove-hook! (vm-restore-continuation-hook vm) restore-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)
+ (remove-hook! (vm-push-continuation-hook) push-cont-hook)
+ (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
;;
(define* (trap-instructions-in-procedure proc next-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -240,15 +234,15 @@
(next-handler frame)))
(define (enter frame)
- (add-hook! (vm-next-hook vm) next-hook)
+ (add-hook! (vm-next-hook) next-hook)
(if frame (next-hook frame)))
(define (exit frame)
(exit-handler frame)
- (remove-hook! (vm-next-hook vm) next-hook))
+ (remove-hook! (vm-next-hook) next-hook))
(trap-in-procedure proc enter exit
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
(define (non-negative-integer? x)
@@ -275,8 +269,7 @@
;; trap-at-procedure-ip-in-range.
;;
(define* (trap-at-procedure-ip-in-range proc range handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -309,44 +302,44 @@
(set! fp-stack (cdr fp-stack))))
(trap-instructions-in-procedure proc next-handler exit-handler
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
-;; FIXME: define this in objcode somehow. We are reffing the first
-;; uint32 in the objcode, which is the length of the program (without
-;; the meta).
-(define (program-last-ip prog)
- (bytevector-u32-native-ref (objcode->bytecode (program-objcode prog)) 0))
-
(define (program-sources-by-line proc file)
- (let lp ((sources (program-sources-pre-retire proc))
- (out '()))
- (if (pair? sources)
- (lp (cdr sources)
- (pmatch (car sources)
- ((,start-ip ,start-file ,start-line . ,start-col)
- (if (equal? start-file file)
- (cons (cons start-line
- (if (pair? (cdr sources))
- (pmatch (cadr sources)
- ((,end-ip . _)
- (cons start-ip end-ip))
- (else (error "unexpected")))
- (cons start-ip (program-last-ip proc))))
- out)
- out))
- (else (error "unexpected"))))
- (let ((alist '()))
- (for-each
- (lambda (pair)
- (set! alist
- (assv-set! alist (car pair)
- (cons (cdr pair)
- (or (assv-ref alist (car pair))
- '())))))
- out)
- (sort! alist (lambda (x y) (< (car x) (car y))))
- alist))))
+ (cond
+ ((program? proc)
+ (let ((code (program-code proc)))
+ (let lp ((sources (program-sources proc))
+ (out '()))
+ (if (pair? sources)
+ (lp (cdr sources)
+ (pmatch (car sources)
+ ((,start-ip ,start-file ,start-line . ,start-col)
+ (if (equal? start-file file)
+ (acons start-line
+ (if (pair? (cdr sources))
+ (pmatch (cadr sources)
+ ((,end-ip . _)
+ (cons (+ start-ip code)
+ (+ end-ip code)))
+ (else (error "unexpected")))
+ (cons (+ start-ip code)
+ (program-last-ip proc)))
+ out)
+ out))
+ (else (error "unexpected"))))
+ (let ((alist '()))
+ (for-each
+ (lambda (pair)
+ (set! alist
+ (assv-set! alist (car pair)
+ (cons (cdr pair)
+ (or (assv-ref alist (car pair))
+ '())))))
+ out)
+ (sort! alist (lambda (x y) (< (car x) (car y))))
+ alist)))))
+ (else '())))
(define (source->ip-range proc file line)
(or (or-map (lambda (line-and-ranges)
@@ -373,8 +366,7 @@
;; trap-at-source-location. The parameter `user-line' is one-indexed, as
;; a user counts lines, instead of zero-indexed, as Guile counts lines.
;;
-(define* (trap-at-source-location file user-line handler
- #:key current-frame (vm (the-vm)))
+(define* (trap-at-source-location file user-line handler #:key current-frame)
(arg-check file string?)
(arg-check user-line positive-integer?)
(arg-check handler procedure?)
@@ -383,7 +375,7 @@
(lambda () (source-closures-or-procedures file (1- user-line)))
(lambda (procs closures?)
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
(set! traps
(map
@@ -391,7 +383,6 @@
(let ((range (source->ip-range proc file (1- user-line))))
(trap-at-procedure-ip-in-range proc range handler
#:current-frame current-frame
- #:vm vm
#:closure? closures?)))
procs))
(if (null? traps)
@@ -406,56 +397,52 @@
;; do useful things during the dynamic extent of a procedure's
;; application. First, a trap for when a frame returns.
;;
-(define* (trap-frame-finish frame return-handler abort-handler
- #:key (vm (the-vm)))
+(define (trap-frame-finish frame return-handler abort-handler)
(arg-check frame frame?)
(arg-check return-handler procedure?)
(arg-check abort-handler procedure?)
(let ((fp (frame-address frame)))
- (define (pop-cont-hook frame)
- (if (and fp (eq? (frame-address frame) fp))
+ (define (pop-cont-hook frame . values)
+ (if (and fp (< (frame-address frame) fp))
(begin
(set! fp #f)
- (return-handler frame))))
+ (apply return-handler frame values))))
- (define (abort-hook frame)
+ (define (abort-hook frame . values)
(if (and fp (< (frame-address frame) fp))
(begin
(set! fp #f)
- (abort-handler frame))))
+ (apply abort-handler frame values))))
(new-enabled-trap
- vm frame
+ frame
(lambda (frame)
(if (not fp)
(error "return-or-abort traps may only be enabled once"))
- (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (add-hook! (vm-abort-continuation-hook vm) abort-hook)
- (add-hook! (vm-restore-continuation-hook vm) abort-hook))
+ (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (add-hook! (vm-abort-continuation-hook) abort-hook))
(lambda (frame)
(set! fp #f)
- (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
- (remove-hook! (vm-restore-continuation-hook vm) abort-hook)))))
+ (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
;; A more traditional dynamic-wind trap. Perhaps this should not be
;; based on the above trap-frame-finish?
;;
(define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
(arg-check return-handler procedure?)
(arg-check abort-handler procedure?)
(let ((exit-trap #f))
- (define (return-hook frame)
+ (define (return-hook frame . values)
(exit-trap frame) ; disable the return/abort trap.
(set! exit-trap #f)
(return-handler frame))
- (define (abort-hook frame)
+ (define (abort-hook frame . values)
(exit-trap frame) ; disable the return/abort trap.
(set! exit-trap #f)
(abort-handler frame))
@@ -465,25 +452,23 @@
(begin
(enter-handler frame)
(set! exit-trap
- (trap-frame-finish frame return-hook abort-hook
- #:vm vm)))))
+ (trap-frame-finish frame return-hook abort-hook)))))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook))
+ (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
(if exit-trap
(abort-hook frame))
(set! exit-trap #f)
- (remove-hook! (vm-apply-hook vm) apply-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)))))
;; Trapping all procedure calls within a dynamic extent, recording the
;; depth of the call stack relative to the original procedure.
;;
(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -493,8 +478,8 @@
(define (trace-push frame)
(set! *call-depth* (1+ *call-depth*)))
- (define (trace-pop frame)
- (return-handler frame *call-depth*)
+ (define (trace-pop frame . values)
+ (apply return-handler frame *call-depth* values)
(set! *call-depth* (1- *call-depth*)))
(define (trace-apply frame)
@@ -503,14 +488,14 @@
;; FIXME: recalc depth on abort
(define (enter frame)
- (add-hook! (vm-push-continuation-hook vm) trace-push)
- (add-hook! (vm-pop-continuation-hook vm) trace-pop)
- (add-hook! (vm-apply-hook vm) trace-apply))
+ (add-hook! (vm-push-continuation-hook) trace-push)
+ (add-hook! (vm-pop-continuation-hook) trace-pop)
+ (add-hook! (vm-apply-hook) trace-apply))
(define (leave frame)
- (remove-hook! (vm-push-continuation-hook vm) trace-push)
- (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
- (remove-hook! (vm-apply-hook vm) trace-apply))
+ (remove-hook! (vm-push-continuation-hook) trace-push)
+ (remove-hook! (vm-pop-continuation-hook) trace-pop)
+ (remove-hook! (vm-apply-hook) trace-apply))
(define (return frame)
(leave frame))
@@ -519,14 +504,13 @@
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Trapping all retired intructions within a dynamic extent.
;;
(define* (trap-instructions-in-dynamic-extent proc next-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -536,10 +520,10 @@
(next-handler frame))
(define (enter frame)
- (add-hook! (vm-next-hook vm) trace-next))
+ (add-hook! (vm-next-hook) trace-next))
(define (leave frame)
- (remove-hook! (vm-next-hook vm) trace-next))
+ (remove-hook! (vm-next-hook) trace-next))
(define (return frame)
(leave frame))
@@ -548,13 +532,12 @@
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Traps calls and returns for a given procedure, keeping track of the call depth.
;;
-(define* (trap-calls-to-procedure proc apply-handler return-handler
- #:key (vm (the-vm)))
+(define (trap-calls-to-procedure proc apply-handler return-handler)
(arg-check proc procedure?)
(arg-check apply-handler procedure?)
(arg-check return-handler procedure?)
@@ -565,7 +548,7 @@
(apply-handler frame depth)
- (if (not (eq? (frame-address frame) last-fp))
+ (if (not (eqv? (frame-address frame) last-fp))
(let ((finish-trap #f))
(define (frame-finished frame)
(finish-trap frame) ;; disables the trap.
@@ -573,16 +556,16 @@
(delq finish-trap pending-finish-traps))
(set! finish-trap #f))
- (define (return-hook frame)
+ (define (return-hook frame . values)
(frame-finished frame)
- (return-handler frame depth))
+ (apply return-handler frame depth values))
;; FIXME: abort handler?
- (define (abort-hook frame)
+ (define (abort-hook frame . values)
(frame-finished frame))
(set! finish-trap
- (trap-frame-finish frame return-hook abort-hook #:vm vm))
+ (trap-frame-finish frame return-hook abort-hook))
(set! pending-finish-traps
(cons finish-trap pending-finish-traps))))))
@@ -611,12 +594,11 @@
(with-pending-finish-enablers (trap frame))))
(with-pending-finish-disablers
- (trap-at-procedure-call proc apply-hook #:vm vm))))
+ (trap-at-procedure-call proc apply-hook))))
;; Trap when the source location changes.
;;
-(define* (trap-matching-instructions frame-pred handler
- #:key (vm (the-vm)))
+(define (trap-matching-instructions frame-pred handler)
(arg-check frame-pred procedure?)
(arg-check handler procedure?)
(let ()
@@ -625,8 +607,8 @@
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
- (add-hook! (vm-next-hook vm) next-hook))
+ (add-hook! (vm-next-hook) next-hook))
(lambda (frame)
- (remove-hook! (vm-next-hook vm) next-hook)))))
+ (remove-hook! (vm-next-hook) next-hook)))))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index 0d6f5ccac..33bcbf126 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -1,6 +1,6 @@
;;; Guile VM core
-;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;; 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
@@ -19,16 +19,13 @@
;;; Code:
(define-module (system vm vm)
- #:export (vm?
- make-vm the-vm call-with-vm
- vm:ip vm:sp vm:fp
-
+ #:export (call-with-vm
vm-trace-level set-vm-trace-level!
vm-engine set-vm-engine! set-default-vm-engine!
vm-push-continuation-hook vm-pop-continuation-hook
vm-apply-hook
vm-next-hook
- vm-abort-continuation-hook vm-restore-continuation-hook))
+ vm-abort-continuation-hook))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_vm")
diff --git a/module/system/xref.scm b/module/system/xref.scm
index 922d17fa9..2b943fdd9 100644
--- a/module/system/xref.scm
+++ b/module/system/xref.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 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
@@ -17,9 +17,10 @@
(define-module (system xref)
- #:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system vm program)
+ #:use-module (system vm disassembler)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (*xref-ignored-modules*
procedure-callees
@@ -31,55 +32,50 @@
;;; The cross-reference database: who calls whom.
;;;
+(define (nested-procedures prog)
+ (define (cons-uniq x y)
+ (if (memq x y) y (cons x y)))
+ (if (program? prog)
+ (reverse
+ (fold-program-code (lambda (elt out)
+ (match elt
+ (('static-ref dst proc)
+ (if (program? proc)
+ (fold cons-uniq
+ (cons proc out)
+ (nested-procedures prog))
+ out))
+ (_ out)))
+ (list prog)
+ prog))
+ (list prog)))
+
(define (program-callee-rev-vars prog)
(define (cons-uniq x y)
(if (memq x y) y (cons x y)))
- (cond
- ((program-objects prog)
- => (lambda (objects)
- (let ((n (vector-length objects))
- (progv (make-vector (vector-length objects) #f))
- (asm (decompile (program-objcode prog) #:to 'assembly)))
- (pmatch asm
- ((load-program ,labels ,len . ,body)
- (for-each
- (lambda (x)
- (pmatch x
- ((toplevel-ref ,n) (vector-set! progv n #t))
- ((toplevel-set ,n) (vector-set! progv n #t))))
- body)))
- (let lp ((i 0) (out '()))
- (cond
- ((= i n) out)
- ((program? (vector-ref objects i))
- (lp (1+ i)
- (fold cons-uniq out
- (program-callee-rev-vars (vector-ref objects i)))))
- ((vector-ref progv i)
- (let ((obj (vector-ref objects i)))
- (if (variable? obj)
- (lp (1+ i) (cons-uniq obj out))
- ;; otherwise it's an unmemoized binding
- (pmatch obj
- (,sym (guard (symbol? sym))
- (let ((v (module-variable (or (program-module prog)
- the-root-module)
- sym)))
- (lp (1+ i) (if v (cons-uniq v out) out))))
- ((,mod ,sym ,public?)
- ;; hm, hacky.
- (let* ((m (nested-ref-module (resolve-module '() #f)
- mod))
- (v (and m
- (module-variable
- (if public?
- (module-public-interface m)
- m)
- sym))))
- (lp (1+ i)
- (if v (cons-uniq v out) out))))))))
- (else (lp (1+ i) out)))))))
- (else '())))
+ (fold (lambda (prog out)
+ (fold-program-code
+ (lambda (elt out)
+ (match elt
+ (('toplevel-box dst var mod sym bound?)
+ (let ((var (or var (and mod (module-variable mod sym)))))
+ (if var
+ (cons-uniq var out)
+ out)))
+ (('module-box dst var public? mod-name sym bound?)
+ (let ((var (or var
+ (module-variable (if public?
+ (resolve-interface mod-name)
+ (resolve-module mod-name))
+ sym))))
+ (if var
+ (cons-uniq var out)
+ out)))
+ (_ out)))
+ out
+ prog))
+ '()
+ (nested-procedures prog)))
(define (procedure-callee-rev-vars proc)
(cond
@@ -186,10 +182,10 @@ pair of the form (module-name . variable-name), "
(let ((v (cond ((variable? var) var)
((symbol? var) (module-variable (current-module) var))
(else
- (pmatch var
- ((,modname . ,sym)
+ (match var
+ ((modname . sym)
(module-variable (resolve-module modname) sym))
- (else
+ (_
(error "expected a variable, symbol, or (modname . sym)" var)))))))
(untaint-modules)
(hashq-ref *callers-db* v '())))
@@ -254,39 +250,32 @@ pair of the form (module-name . variable-name), "
sources)
;; Actually add the source entries.
(for-each (lambda (source)
- (pmatch source
- ((,ip ,file ,line . ,col)
+ (match source
+ ((ip file line . col)
(add-source proc file line db))
- (else (error "unexpected source format" source))))
+ (_ (error "unexpected source format" source))))
sources)))
;; Add source entries for nested procedures.
(for-each (lambda (obj)
- (if (procedure? obj)
- (add-sources obj mod-name *closure-sources-db*)))
- (or (and (program? proc)
- (and=> (program-objects proc) vector->list))
- '()))))
+ (add-sources obj mod-name *closure-sources-db*))
+ (cdr (nested-procedures proc)))))
(define (forget-sources proc mod-name db)
(let ((mod-table (hash-ref *module-sources-db* mod-name)))
- (if mod-table
- (begin
- ;; Forget source entries.
- (for-each (lambda (source)
- (pmatch source
- ((,ip ,file ,line . ,col)
- (forget-source proc file line db))
- (else (error "unexpected source format" source))))
- (hashq-ref mod-table proc '()))
- ;; Forget the proc.
- (hashq-remove! mod-table proc)
- ;; Forget source entries for nested procedures.
- (for-each (lambda (obj)
- (if (procedure? obj)
- (forget-sources obj mod-name *closure-sources-db*)))
- (or (and (program? proc)
- (and=> (program-objects proc) vector->list))
- '()))))))
+ (when mod-table
+ ;; Forget source entries.
+ (for-each (lambda (source)
+ (match source
+ ((ip file line . col)
+ (forget-source proc file line db))
+ (_ (error "unexpected source format" source))))
+ (hashq-ref mod-table proc '()))
+ ;; Forget the proc.
+ (hashq-remove! mod-table proc)
+ ;; Forget source entries for nested procedures.
+ (for-each (lambda (obj)
+ (forget-sources obj mod-name *closure-sources-db*))
+ (cdr (nested-procedures proc))))))
(define (untaint-sources)
(define (untaint m)