summaryrefslogtreecommitdiff
path: root/module/system/vm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm')
-rw-r--r--module/system/vm/assembler.scm2850
-rw-r--r--module/system/vm/coverage.scm350
-rw-r--r--module/system/vm/debug.scm767
-rw-r--r--module/system/vm/disassembler.scm643
-rw-r--r--module/system/vm/dwarf.scm1852
-rw-r--r--module/system/vm/elf.scm1042
-rw-r--r--module/system/vm/frame.scm463
-rw-r--r--module/system/vm/inspect.scm188
-rw-r--r--module/system/vm/linker.scm733
-rw-r--r--module/system/vm/loader.scm27
-rw-r--r--module/system/vm/program.scm313
-rw-r--r--module/system/vm/trace.scm122
-rw-r--r--module/system/vm/trap-state.scm302
-rw-r--r--module/system/vm/traps.scm623
-rw-r--r--module/system/vm/vm.scm32
15 files changed, 10307 insertions, 0 deletions
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
new file mode 100644
index 000000000..f3682f7e8
--- /dev/null
+++ b/module/system/vm/assembler.scm
@@ -0,0 +1,2850 @@
+;;; Guile bytecode assembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015, 2017, 2018 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 base types internal)
+ #:use-module (system vm dwarf)
+ #:use-module (system vm elf)
+ #:use-module (system vm linker)
+ #:use-module (system syntax internal)
+ #: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-receive* . emit-receive)
+ (emit-mov* . emit-mov)
+ (emit-fmov* . emit-fmov)
+
+ emit-u64=?
+ emit-u64<?
+ emit-u64-imm<?
+ emit-imm-u64<?
+ emit-s64-imm=?
+ emit-s64<?
+ emit-s64-imm<?
+ emit-imm-s64<?
+ emit-f64=?
+ emit-f64<?
+ emit-=?
+ emit-<?
+ emit-arguments<=?
+ emit-positional-arguments<=?
+ emit-immediate-tag=?
+ emit-heap-tag=?
+ emit-eq?
+ emit-heap-numbers-equal?
+ emit-j
+ emit-jl
+ emit-je
+ emit-jnl
+ emit-jne
+ emit-jge
+ emit-jnge
+
+ emit-fixnum?
+ emit-heap-object?
+ emit-char?
+ emit-eq-null?
+ emit-eq-nil?
+ emit-eq-false?
+ emit-eq-true?
+ emit-unspecified?
+ emit-undefined?
+ emit-eof-object?
+
+ emit-untag-fixnum
+ emit-tag-fixnum
+ emit-untag-char
+ emit-tag-char
+
+ emit-throw
+ (emit-throw/value* . emit-throw/value)
+ (emit-throw/value+data* . emit-throw/value+data)
+
+ emit-pair?
+ emit-struct?
+ emit-symbol?
+ emit-variable?
+ emit-vector?
+ emit-mutable-vector?
+ emit-immutable-vector?
+ emit-weak-vector?
+ emit-string?
+ emit-heap-number?
+ emit-hash-table?
+ emit-pointer?
+ emit-fluid?
+ emit-stringbuf?
+ emit-dynamic-state?
+ emit-frame?
+ emit-keyword?
+ emit-syntax?
+ emit-program?
+ emit-vm-continuation?
+ emit-bytevector?
+ emit-weak-set?
+ emit-weak-table?
+ emit-array?
+ emit-bitvector?
+ emit-port?
+ emit-smob?
+ emit-bignum?
+ emit-flonum?
+ emit-compnum?
+ emit-fracnum?
+
+ emit-allocate-words
+ emit-allocate-words/immediate
+
+ emit-scm-ref
+ emit-scm-set!
+ emit-scm-ref/tag
+ emit-scm-set!/tag
+ emit-scm-ref/immediate
+ emit-scm-set!/immediate
+
+ emit-word-ref
+ emit-word-set!
+ emit-word-ref/immediate
+ emit-word-set!/immediate
+
+ emit-pointer-ref/immediate
+ emit-pointer-set!/immediate
+ emit-tail-pointer-ref/immediate
+
+ emit-u8-ref
+ emit-s8-ref
+ emit-u16-ref
+ emit-s16-ref
+ emit-u32-ref
+ emit-s32-ref
+ emit-u64-ref
+ emit-s64-ref
+ emit-f32-ref
+ emit-f64-ref
+ emit-u8-set!
+ emit-s8-set!
+ emit-u16-set!
+ emit-s16-set!
+ emit-u32-set!
+ emit-s32-set!
+ emit-u64-set!
+ emit-s64-set!
+ emit-f32-set!
+ emit-f64-set!
+
+ emit-atomic-scm-ref/immediate
+ emit-atomic-scm-set!/immediate
+ emit-atomic-scm-swap!/immediate
+ emit-atomic-scm-compare-and-swap!/immediate
+
+ ;; Intrinsics.
+ emit-add
+ emit-add/immediate
+ emit-sub
+ emit-sub/immediate
+ emit-mul
+ emit-div
+ emit-quo
+ emit-rem
+ emit-mod
+ emit-logand
+ emit-logior
+ emit-logxor
+ emit-logsub
+ emit-string-set!
+ emit-string->number
+ emit-string->symbol
+ emit-symbol->keyword
+ emit-class-of
+ emit-scm->f64
+ emit-scm->u64
+ emit-scm->u64/truncate
+ emit-scm->s64
+ emit-u64->scm
+ emit-s64->scm
+ emit-wind
+ emit-unwind
+ emit-push-fluid
+ emit-pop-fluid
+ emit-fluid-ref
+ emit-fluid-set!
+ emit-push-dynamic-state
+ emit-pop-dynamic-state
+ emit-lsh
+ emit-rsh
+ emit-lsh/immediate
+ emit-rsh/immediate
+ emit-resolve-module
+ emit-lookup
+ emit-define!
+ emit-current-module
+
+ emit-cache-ref
+ emit-cache-set!
+
+ emit-call
+ emit-call-label
+ emit-tail-call
+ emit-tail-call-label
+ (emit-instrument-entry* . emit-instrument-entry)
+ (emit-instrument-loop* . emit-instrument-loop)
+ emit-receive-values
+ emit-return-values
+ emit-call/cc
+ emit-abort
+ emit-builtin-ref
+ emit-assert-nargs-ee
+ emit-assert-nargs-ge
+ emit-assert-nargs-le
+ emit-alloc-frame
+ emit-reset-frame
+ emit-assert-nargs-ee/locals
+ emit-bind-kwargs
+ emit-bind-rest
+ emit-load-label
+ emit-resolve
+ emit-prompt
+ emit-current-thread
+ emit-fadd
+ emit-fsub
+ emit-fmul
+ emit-fdiv
+ emit-uadd
+ emit-usub
+ emit-umul
+ emit-uadd/immediate
+ emit-usub/immediate
+ emit-umul/immediate
+ emit-ulogand
+ emit-ulogior
+ emit-ulogxor
+ emit-ulogsub
+ emit-ursh
+ emit-srsh
+ emit-ulsh
+ emit-ursh/immediate
+ emit-srsh/immediate
+ emit-ulsh/immediate
+ emit-make-array
+ emit-load-f64
+ emit-load-u64
+ emit-load-s64
+ emit-handle-interrupts
+
+ emit-text
+ link-assembly))
+
+
+
+
+;; Like define-inlinable, but only for first-order uses of the defined
+;; routine. Should residualize less code.
+(eval-when (expand)
+ (define-syntax define-inline
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name arg ...) body ...)
+ (with-syntax (((temp ...) (generate-temporaries #'(arg ...))))
+ #`(eval-when (expand)
+ (define-syntax-rule (name temp ...)
+ (let ((arg temp) ...)
+ body ...)))))))))
+
+;;; Bytecode consists of 32-bit units, often subdivided in some way.
+;;; These helpers create one 32-bit unit from multiple components.
+
+(define-inline (check-urange x mask)
+ (unless (and (exact-integer? x) (= x (logand x mask)))
+ (error "out of range" x))
+ x)
+
+(define-inline (check-srange x mask)
+ (let ((x* (logand x mask)))
+ (unless (if (negative? x)
+ (= (+ x mask 1) x*)
+ (= x x*))
+ (error "out of range" x))
+ x*))
+
+(define-inline (pack-u8-u24 x y)
+ (let ((x (check-urange x #xff))
+ (y (check-urange y #xffffff)))
+ (logior x (ash y 8))))
+
+(define-inline (pack-u8-s24 x y)
+ (let ((x (check-urange x #xff))
+ (y (check-srange y #xffffff)))
+ (logior x (ash y 8))))
+
+(define-inline (pack-u16-u16 x y)
+ (let ((x (check-urange x #xffff))
+ (y (check-urange y #xffff)))
+ (logior x (ash y 16))))
+
+(define-inline (pack-u1-u7-u24 x y z)
+ (let ((x (check-urange x #x1))
+ (y (check-urange y #x7f))
+ (z (check-urange z #xffffff)))
+ (logior x (ash y 1) (ash z 8))))
+
+(define-inline (pack-u8-u12-u12 x y z)
+ (let ((x (check-urange x #xff))
+ (y (check-urange y #xfff))
+ (z (check-urange z #xfff)))
+ (logior x (ash y 8) (ash z 20))))
+
+(define-inline (pack-u8-u12-s12 x y z)
+ (let ((x (check-urange x #xff))
+ (y (check-urange y #xfff))
+ (z (check-srange z #xfff)))
+ (logior x (ash y 8) (ash z 20))))
+
+(define-inline (pack-u8-u8-u16 x y z)
+ (let ((x (check-urange x #xff))
+ (y (check-urange y #xff))
+ (z (check-urange z #xffff)))
+ (logior x (ash y 8) (ash z 16))))
+
+(define-inline (pack-u8-u8-u8-u8 x y z w)
+ (let ((x (check-urange x #xff))
+ (y (check-urange y #xff))
+ (z (check-urange z #xff))
+ (w (check-urange w #xff)))
+ (logior x (ash y 8) (ash z 16) (ash w 24))))
+
+(eval-when (expand)
+ (define-syntax pack-flags
+ (syntax-rules ()
+ ;; Add clauses as needed.
+ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
+ (if f2 (ash 1 1) 0))))))
+
+
+(define-syntax-rule (define-byte-order-swapper name size ref set)
+ (define* (name buf #:optional (start 0) (end (bytevector-length buf)))
+ "Patch up the text buffer @var{buf}, swapping the endianness of each
+N-byte unit."
+ (unless (zero? (modulo (- end start) size))
+ (error "unexpected length"))
+ (let lp ((pos start))
+ (when (< pos end)
+ (set buf pos (ref buf pos (endianness big)) (endianness little))
+ (lp (+ pos size))))))
+
+(define-byte-order-swapper byte-swap/2!
+ 2 bytevector-u16-ref bytevector-u16-set!)
+(define-byte-order-swapper byte-swap/4!
+ 4 bytevector-u32-ref bytevector-u32-set!)
+(define-byte-order-swapper byte-swap/8!
+ 8 bytevector-u64-ref bytevector-u64-set!)
+
+
+
+;;; A <meta> entry collects metadata for one procedure. Procedures are
+;;; written as contiguous ranges of bytecode.
+;;;
+(eval-when (expand)
+ (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 <jit-data>
+ (make-jit-data low-pc high-pc)
+ jit-data?
+ (low-pc jit-data-low-pc)
+ (high-pc jit-data-high-pc))
+
+(define-record-type <meta>
+ (%make-meta label properties low-pc high-pc arities jit-data-label)
+ 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!)
+ (jit-data-label meta-jit-data-label))
+
+(define (make-meta label properties low-pc)
+ (assert-match label (or (? exact-integer?) (? symbol?)) "symbol")
+ (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
+ (%make-meta label properties low-pc #f '() (gensym "jit-data")))
+
+(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 definitions)
+ 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!)
+ (definitions arity-definitions set-arity-definitions!))
+
+;;; 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 buf pos start
+ labels relocs
+ word-size endianness
+ constants inits
+ shstrtab next-section-number
+ meta sources
+ slot-maps)
+ asm?
+
+ ;; We write bytecode into a bytevector, growing the bytevector as
+ ;; needed. asm-cur is that bytevector, and asm-pos is the byte offset
+ ;; into the vector at which the next word should be written.
+ ;;
+ (buf asm-buf set-asm-buf!)
+ (pos asm-pos set-asm-pos!)
+
+ ;; asm-start is an absolute position, indicating the byte offset of
+ ;; the beginning of an instruction. 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!)
+
+ ;; 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 textual
+ ;; 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 . slot-map) pairs, indicating slot maps. POS is
+ ;; relative to the beginning of the text section. SLOT-MAP is a
+ ;; bitfield describing the stack at call sites, as an integer.
+ ;;
+ (slot-maps asm-slot-maps set-asm-slot-maps!))
+
+(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 (make-u32vector 1000) 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 (grow-buffer! asm)
+ "Grow the code buffer of the asm."
+ (let* ((buf (asm-buf asm))
+ (len (bytevector-length buf))
+ (new (make-u32vector (ash len -1) 0)))
+ (bytevector-copy! buf 0 new 0 len)
+ (set-asm-buf! asm new)
+ #f))
+
+(define-inline (emit asm u32)
+ "Emit one 32-bit word into the instruction stream. Assumes that there
+is space for the word."
+ (bytevector-u32-native-set! (asm-buf asm) (asm-pos asm) u32)
+ (set-asm-pos! asm (+ (asm-pos asm) 4)))
+
+(define-inline (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-inline (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)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+
+ (define-syntax encoder
+ (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
+ ((X32)
+ (emit asm opcode))
+ ((X8_S24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((X8_F24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((X8_C24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((X8_L24 label)
+ (record-label-reference asm label)
+ (emit asm opcode))
+ ((X8_S8_I16 a imm)
+ (emit asm (pack-u8-u8-u16 opcode a (immediate-bits asm imm))))
+ ((X8_S12_S12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((X8_S12_C12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((X8_S12_Z12 a b)
+ (emit asm (pack-u8-u12-s12 opcode a b)))
+ ((X8_C12_C12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((X8_F12_F12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((X8_S8_S8_S8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c)))
+ ((X8_S8_S8_C8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c)))
+ ((X8_S8_C8_S8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
+
+ (define (pack-tail-word asm type)
+ (op-case
+ asm type
+ ((C32 a)
+ (emit asm a))
+ ((I32 imm)
+ (let ((val (immediate-bits asm imm)))
+ (emit asm val)))
+ ((A32 imm)
+ (unless (= (asm-word-size asm) 8)
+ (error "make-long-immediate unavailable for this target"))
+ (let ((bits (immediate-bits asm imm)))
+ (emit asm (ash bits -32))
+ (emit asm (logand bits (1- (ash 1 32))))))
+ ((AF32 f64)
+ (let ((u64 (u64vector-ref (f64vector f64) 0)))
+ (emit asm (ash u64 -32))
+ (emit asm (logand u64 (1- (ash 1 32))))))
+ ((AU32 u64)
+ (emit asm (ash u64 -32))
+ (emit asm (logand u64 (1- (ash 1 32)))))
+ ((AS32 s64)
+ (let ((u64 (u64vector-ref (s64vector s64) 0)))
+ (emit asm (ash u64 -32))
+ (emit asm (logand u64 (1- (ash 1 32))))))
+ ((B32))
+ ((BU32))
+ ((BS32))
+ ((BF32))
+ ((N32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((R32 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)))
+ (emit asm 0))
+ ((C8_C24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((C8_S24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((C16_C16 a b)
+ (emit asm (pack-u16-u16 a b)))
+ ((B1_X7_L24 a label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_C7_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_S24 a b)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))
+ ((B1_X7_F24 a b)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))
+ ((B1_X7_C24 a b)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))
+ ((X8_S24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_F24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_C24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_L24 label)
+ (record-label-reference asm label)
+ (emit asm 0))))
+
+ (syntax-case x ()
+ ((_ word0 word* ...)
+ (with-syntax ((((formal0 ...)
+ code0 ...)
+ (pack-first-word #'asm #'opcode
+ (syntax->datum #'word0)))
+ ((((formal* ...)
+ code* ...) ...)
+ (map (lambda (word) (pack-tail-word #'asm word))
+ (syntax->datum #'(word* ...)))))
+ ;; The opcode is the last argument, so that assemblers don't
+ ;; have to shuffle their arguments before tail-calling an
+ ;; encoder.
+ #'(lambda (asm formal0 ... formal* ... ... opcode)
+ (let lp ()
+ (let ((words (length '(word0 word* ...))))
+ (unless (<= (+ (asm-pos asm) (* 4 words))
+ (bytevector-length (asm-buf asm)))
+ (grow-buffer! asm)
+ (lp))))
+ code0 ...
+ code* ... ...
+ (reset-asm-start! asm)))))))
+
+ (define (encoder-name operands)
+ (let lp ((operands operands) (out #'encode))
+ (syntax-case operands ()
+ (() out)
+ ((operand . operands)
+ (lp #'operands
+ (id-append #'operand (id-append out out #'-) #'operand))))))
+
+ (define-syntax define-encoder
+ (lambda (x)
+ (syntax-case x ()
+ ((_ operand ...)
+ (with-syntax ((encode (encoder-name #'(operand ...))))
+ #'(define encode (encoder operand ...)))))))
+
+ (define-syntax visit-instruction-kinds
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-instruction-kinds macro arg ...)
+ (with-syntax (((operands ...)
+ (delete-duplicates
+ (map (match-lambda
+ ((name opcode kind . operands)
+ (datum->syntax #'macro operands)))
+ (instruction-list)))))
+ #'(begin
+ (macro arg ... . operands)
+ ...)))))))
+
+(visit-instruction-kinds define-encoder)
+
+;; In Guile's VM, locals are usually addressed via the stack pointer
+;; (SP). There can be up to 2^24 slots for local variables in a
+;; frame. Some instructions encode their operands using a restricted
+;; subset of the full 24-bit local address space, in order to make the
+;; bytecode more dense in the usual case that a function needs few
+;; local slots. To allow these instructions to be used when there are
+;; many local slots, we can temporarily push the values on the stack,
+;; operate on them there, and then store back any result as we pop the
+;; SP to its original position.
+;;
+;; We implement this shuffling via wrapper encoders that have the same
+;; arity as the encoder they wrap, e.g. encode-X8_S12_S12/shuffle that
+;; wraps encode-X8_S12_S12. We make the emit-cons public interface
+;; use the shuffling encoder. That way we solve the problem fully and
+;; in just one place.
+
+(define (encode-X8_S12_S12!/shuffle asm a b opcode)
+ (cond
+ ((< (logior a b) (ash 1 12))
+ (encode-X8_S12_S12 asm a b opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm (1+ b))
+ (encode-X8_S12_S12 asm 1 0 opcode)
+ (emit-drop asm 2))))
+(define (encode-X8_S12_S12<-/shuffle asm dst a opcode)
+ (cond
+ ((< (logior dst a) (ash 1 12))
+ (encode-X8_S12_S12 asm dst a opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S12_S12 asm 0 0 opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S12_C12!/shuffle asm a const opcode)
+ (cond
+ ((< a (ash 1 12))
+ (encode-X8_S12_C12 asm a const opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S12_C12 asm 0 const opcode)
+ (emit-drop asm 1))))
+(define (encode-X8_S12_C12<-/shuffle asm dst const opcode)
+ (cond
+ ((< dst (ash 1 12))
+ (encode-X8_S12_C12 asm dst const opcode))
+ (else
+ ;; Push garbage value to make space for dst.
+ (emit-push asm dst)
+ (encode-X8_S12_C12 asm 0 const opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S12_Z12!/shuffle asm a const opcode)
+ (cond
+ ((< a (ash 1 12))
+ (encode-X8_S12_Z12 asm a const opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S12_Z12 asm 0 const opcode)
+ (emit-drop asm 1))))
+(define (encode-X8_S8_I16<-/shuffle asm dst imm opcode)
+ (cond
+ ((< dst (ash 1 8))
+ (encode-X8_S8_I16 asm dst imm opcode))
+ (else
+ ;; Push garbage value to make space for dst.
+ (emit-push asm dst)
+ (encode-X8_S8_I16 asm 0 imm opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S8_S8_S8!/shuffle asm a b c opcode)
+ (cond
+ ((< (logior a b c) (ash 1 8))
+ (encode-X8_S8_S8_S8 asm a b c opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm (+ b 1))
+ (emit-push asm (+ c 2))
+ (encode-X8_S8_S8_S8 asm 2 1 0 opcode)
+ (emit-drop asm 3))))
+(define (encode-X8_S8_S8_S8<-/shuffle asm dst a b opcode)
+ (cond
+ ((< (logior dst a b) (ash 1 8))
+ (encode-X8_S8_S8_S8 asm dst a b opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm (1+ b))
+ (encode-X8_S8_S8_S8 asm 1 1 0 opcode)
+ (emit-drop asm 1)
+ (emit-pop asm dst))))
+(define (encode-X8_S8_S8_C8<-/shuffle asm dst a const opcode)
+ (cond
+ ((< (logior dst a) (ash 1 8))
+ (encode-X8_S8_S8_C8 asm dst a const opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S8_S8_C8 asm 0 0 const opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S8_C8_S8!/shuffle asm a const b opcode)
+ (cond
+ ((< (logior a b) (ash 1 8))
+ (encode-X8_S8_C8_S8 asm a const b opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm (1+ b))
+ (encode-X8_S8_C8_S8 asm 1 const 0 opcode)
+ (emit-drop asm 2))))
+(define (encode-X8_S8_C8_S8<-/shuffle asm dst const a opcode)
+ (cond
+ ((< (logior dst a) (ash 1 8))
+ (encode-X8_S8_C8_S8 asm dst const a opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S8_C8_S8 asm 0 const 0 opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S8_S8_S8-C32<-/shuffle asm dst a b c32 opcode)
+ (cond
+ ((< (logior dst a b) (ash 1 8))
+ (encode-X8_S8_S8_S8-C32 asm dst a b c32 opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm (1+ b))
+ (encode-X8_S8_S8_S8-C32 asm 1 1 0 c32 opcode)
+ (emit-drop asm 1)
+ (emit-pop asm dst))))
+(define (encode-X8_S8_S8_C8-C32<-/shuffle asm dst a const c32 opcode)
+ (cond
+ ((< (logior dst a) (ash 1 8))
+ (encode-X8_S8_S8_C8-C32 asm dst a const c32 opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S8_S8_C8-C32 asm 0 0 const c32 opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S8_S8_S8-C32!/shuffle asm a b c c32 opcode)
+ (cond
+ ((< (logior a b c) (ash 1 8))
+ (encode-X8_S8_S8_S8-C32 asm a b c c32 opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm (+ b 1))
+ (emit-push asm (+ c 2))
+ (encode-X8_S8_S8_S8-C32 asm 2 1 0 c32 opcode)
+ (emit-drop asm 3))))
+(define (encode-X8_S12_S12-C32<-/shuffle asm dst src c32 opcode)
+ (cond
+ ((< (logior dst src) (ash 1 12))
+ (encode-X8_S12_S12-C32 asm dst src c32 opcode))
+ (else
+ (emit-push asm src)
+ (encode-X8_S12_S12-C32 asm 0 0 c32 opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S12_S12-C32!/shuffle asm a b c32 opcode)
+ (cond
+ ((< (logior a b) (ash 1 12))
+ (encode-X8_S12_S12-C32 asm a b c32 opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm b)
+ (encode-X8_S12_S12-C32 asm 1 0 c32 opcode)
+ (emit-drop asm 2))))
+
+(eval-when (expand)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+
+ (define (shuffling-encoder-name kind operands)
+ (match (cons (syntax->datum kind) (syntax->datum operands))
+ (('! 'X8_S12_S12) #'encode-X8_S12_S12!/shuffle)
+ (('<- 'X8_S12_S12) #'encode-X8_S12_S12<-/shuffle)
+ (('! 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24!/shuffle)
+ (('<- 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24<-/shuffle)
+ (('! 'X8_S12_C12) #'encode-X8_S12_C12!/shuffle)
+ (('<- 'X8_S12_C12) #'encode-X8_S12_C12<-/shuffle)
+ (('! 'X8_S12_Z12) #'encode-X8_S12_Z12!/shuffle)
+ (('<- 'X8_S8_I16) #'encode-X8_S8_I16<-/shuffle)
+ (('! 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8!/shuffle)
+ (('<- 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8<-/shuffle)
+ (('<- 'X8_S8_S8_C8) #'encode-X8_S8_S8_C8<-/shuffle)
+ (('<- 'X8_S8_S8_S8 'C32) #'encode-X8_S8_S8_S8-C32<-/shuffle)
+ (('<- 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32<-/shuffle)
+ (('! 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32!/shuffle)
+ (('<- 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32<-/shuffle)
+ (('! 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32!/shuffle)
+ (('! 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8!/shuffle)
+ (('<- 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8<-/shuffle)
+ (else (encoder-name operands))))
+
+ (define-syntax assembler
+ (lambda (x)
+ (define (word-args word)
+ (match word
+ ('C32 #'(a))
+ ('I32 #'(imm))
+ ('A32 #'(imm))
+ ('AF32 #'(f64))
+ ('AU32 #'(u64))
+ ('AS32 #'(s64))
+ ('B32 #'())
+ ('BU32 #'())
+ ('BS32 #'())
+ ('BF32 #'())
+ ('N32 #'(label))
+ ('R32 #'(label))
+ ('L32 #'(label))
+ ('LO32 #'(label offset))
+ ('C8_C24 #'(a b))
+ ('C8_S24 #'(a b))
+ ('C16_C16 #'(a b))
+ ('B1_X7_L24 #'(a label))
+ ('B1_C7_L24 #'(a b label))
+ ('B1_X31 #'(a))
+ ('B1_X7_S24 #'(a b))
+ ('B1_X7_F24 #'(a b))
+ ('B1_X7_C24 #'(a b))
+ ('X8_S24 #'(arg))
+ ('X8_F24 #'(arg))
+ ('X8_C24 #'(arg))
+ ('X8_L24 #'(label))
+ ('X8_S8_I16 #'(a imm))
+ ('X8_S12_S12 #'(a b))
+ ('X8_S12_C12 #'(a b))
+ ('X8_S12_Z12 #'(a b))
+ ('X8_C12_C12 #'(a b))
+ ('X8_F12_F12 #'(a b))
+ ('X8_S8_S8_S8 #'(a b c))
+ ('X8_S8_S8_C8 #'(a b c))
+ ('X8_S8_C8_S8 #'(a b c))
+ ('X32 #'())))
+
+ (syntax-case x ()
+ ((_ name opcode kind word ...)
+ (with-syntax (((formal ...)
+ (generate-temporaries
+ (append-map word-args (syntax->datum #'(word ...)))))
+ (encode (shuffling-encoder-name #'kind #'(word ...))))
+ #'(lambda (asm formal ...)
+ (encode asm formal ... opcode))))))))
+
+(define assemblers (make-hash-table))
+
+(eval-when (expand)
+ (define-syntax define-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(define emit
+ (let ((emit (assembler name opcode kind arg ...)))
+ (hashq-set! assemblers 'name emit)
+ 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)
+
+;; Shuffling is a general mechanism to get around address space
+;; limitations for SP-relative variable references. FP-relative
+;; variables need special support. Also, some instructions like `mov'
+;; have multiple variations with different addressing limits.
+
+(define (emit-mov* asm dst src)
+ (if (and (< dst (ash 1 12)) (< src (ash 1 12)))
+ (emit-mov asm dst src)
+ (emit-long-mov asm dst src)))
+
+(define (emit-fmov* asm dst src)
+ (emit-long-fmov asm dst src))
+
+(define (emit-receive* asm dst proc nlocals)
+ (if (and (< dst (ash 1 12)) (< proc (ash 1 12)))
+ (emit-receive asm dst proc nlocals)
+ (begin
+ (emit-receive-values asm proc #t 1)
+ (emit-fmov* asm dst (1+ proc))
+ (emit-reset-frame asm nlocals))))
+
+(define (emit-throw/value* asm val param)
+ (emit-throw/value asm val (intern-non-immediate asm param)))
+
+(define (emit-throw/value+data* asm val param)
+ (emit-throw/value+data asm val (intern-non-immediate asm param)))
+
+(define (emit-instrument-entry* asm)
+ (let ((meta (car (asm-meta asm))))
+ (emit-instrument-entry asm (meta-jit-data-label meta))))
+
+(define (emit-instrument-loop* asm)
+ (let ((meta (car (asm-meta asm))))
+ (emit-instrument-loop asm (meta-jit-data-label meta))))
+
+(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 (immediate-bits asm x)
+ "Return the bit pattern to write into the buffer if @var{x} is
+immediate, and @code{#f} otherwise."
+ (define tc2-int 2)
+ (if (exact-integer? x)
+ ;; Object is an immediate if it is a fixnum on the target.
+ (call-with-values (lambda ()
+ (case (asm-word-size asm)
+ ((4) (values (- #x20000000)
+ #x1fffffff))
+ ((8) (values (- #x2000000000000000)
+ #x1fffffffFFFFFFFF))
+ (else (error "unexpected word size"))))
+ (lambda (fixnum-min fixnum-max)
+ (and (<= fixnum-min x fixnum-max)
+ (let ((fixnum-bits (if (negative? x)
+ (+ fixnum-max 1 (logand x fixnum-max))
+ x)))
+ (logior (ash fixnum-bits 2) tc2-int)))))
+ ;; Otherwise, the object will be immediate on the target if and
+ ;; only if it is immediate on the host. Except for integers,
+ ;; which we handle specially above, any immediate value is an
+ ;; immediate on both 32-bit and 64-bit targets.
+ (let ((bits (object-address x)))
+ (and (not (zero? (logand bits 6)))
+ bits))))
+
+(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 key)
+ cache-cell?
+ (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))
+ (match (array-shape obj)
+ (((0 n)) #t)
+ (else #f))))
+
+(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) (syntax? 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))))
+ ((syntax? obj)
+ (append (field label 1 (syntax-expression obj))
+ (field label 2 (syntax-wrap obj))
+ (field label 3 (syntax-module obj))))
+ ((stringbuf? obj) '())
+ ((static-procedure? obj)
+ `((static-patch! ,label 1 ,(static-procedure-code obj))))
+ ((cache-cell? obj) '())
+ ((symbol? obj)
+ (unless (symbol-interned? obj)
+ (error "uninterned symbol cannot be saved to object file" 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)
+ (let ((width (case (array-type obj)
+ ((vu8 u8 s8) 1)
+ ((u16 s16) 2)
+ ;; Bitvectors are addressed in 32-bit units.
+ ;; Although a complex number is 8 or 16 bytes wide,
+ ;; it should be byteswapped in 4 or 8 byte units.
+ ((u32 s32 f32 c32 b) 4)
+ ((u64 s64 f64 c64) 8)
+ (else
+ (error "unhandled array type" obj)))))
+ `((static-patch! ,label 2
+ ,(recur (make-uniform-vector-backing-store
+ (uniform-array->bytevector obj)
+ width))))))
+ ((array? obj)
+ `((static-patch! ,label 1 ,(recur (shared-array-root obj)))))
+ (else
+ (error "don't know how to intern" obj))))
+ (cond
+ ((immediate-bits asm obj) #f)
+ ((vhash-assoc obj (asm-constants asm)) => cdr)
+ (else
+ ;; Note that calling intern may mutate asm-constants and asm-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-bits asm obj)
+ (error "expected a non-immediate" obj))
+ (intern-constant asm obj))
+
+(define (intern-cache-cell asm 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 key)))
+
+
+
+
+;;;
+;;; Macro assemblers bridge the gap between primitive instructions and
+;;; some higher-level operations.
+;;;
+
+(eval-when (expand)
+ (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-bits asm obj)
+ => (lambda (bits)
+ (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-immediate-tag=?-macro-assembler name pred mask tag)
+ (define-macro-assembler (pred asm slot)
+ (emit-immediate-tag=? asm slot mask tag)))
+
+(visit-immediate-tags define-immediate-tag=?-macro-assembler)
+
+(define-syntax-rule (define-heap-tag=?-macro-assembler name pred mask tag)
+ (define-macro-assembler (pred asm slot)
+ (emit-heap-tag=? asm slot mask tag)))
+
+(visit-heap-tags define-heap-tag=?-macro-assembler)
+
+(define-syntax-rule (define-scm<-scm-scm-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-scm asm dst a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-uimm-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-uimm asm dst a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm-sz-u32-intrinsic name)
+ (define-macro-assembler (name asm a b c)
+ (emit-call-scm-sz-u32 asm a b c (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-scm<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-f64<-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-f64<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-u64<-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-u64<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-s64<-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-s64<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-u64-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-scm<-u64 asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-s64-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-scm<-s64 asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-thread-intrinsic name)
+ (define-macro-assembler (name asm)
+ (emit-call-thread asm (intrinsic-name->index 'name))))
+(define-syntax-rule (define-thread-scm-intrinsic name)
+ (define-macro-assembler (name asm a)
+ (emit-call-thread-scm asm a (intrinsic-name->index 'name))))
+(define-syntax-rule (define-thread-scm-scm-intrinsic name)
+ (define-macro-assembler (name asm a b)
+ (emit-call-thread-scm-scm asm a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-thread-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-scm<-thread-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-u64-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-u64 asm dst a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-bool-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-uimm asm dst a (if b 1 0) (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-thread-intrinsic name)
+ (define-macro-assembler (name asm dst)
+ (emit-call-scm<-thread asm dst (intrinsic-name->index 'name))))
+
+(define-scm<-scm-scm-intrinsic add)
+(define-scm<-scm-uimm-intrinsic add/immediate)
+(define-scm<-scm-scm-intrinsic sub)
+(define-scm<-scm-uimm-intrinsic sub/immediate)
+(define-scm<-scm-scm-intrinsic mul)
+(define-scm<-scm-scm-intrinsic div)
+(define-scm<-scm-scm-intrinsic quo)
+(define-scm<-scm-scm-intrinsic rem)
+(define-scm<-scm-scm-intrinsic mod)
+(define-scm<-scm-scm-intrinsic logand)
+(define-scm<-scm-scm-intrinsic logior)
+(define-scm<-scm-scm-intrinsic logxor)
+(define-scm<-scm-scm-intrinsic logsub)
+(define-scm-sz-u32-intrinsic string-set!)
+(define-scm<-scm-intrinsic string->number)
+(define-scm<-scm-intrinsic string->symbol)
+(define-scm<-scm-intrinsic symbol->keyword)
+(define-scm<-scm-intrinsic class-of)
+(define-f64<-scm-intrinsic scm->f64)
+(define-u64<-scm-intrinsic scm->u64)
+(define-u64<-scm-intrinsic scm->u64/truncate)
+(define-s64<-scm-intrinsic scm->s64)
+(define-scm<-u64-intrinsic u64->scm)
+(define-scm<-s64-intrinsic s64->scm)
+(define-thread-scm-scm-intrinsic wind)
+(define-thread-intrinsic unwind)
+(define-thread-scm-scm-intrinsic push-fluid)
+(define-thread-intrinsic pop-fluid)
+(define-scm<-thread-scm-intrinsic fluid-ref)
+(define-thread-scm-scm-intrinsic fluid-set!)
+(define-thread-scm-intrinsic push-dynamic-state)
+(define-thread-intrinsic pop-dynamic-state)
+(define-scm<-scm-u64-intrinsic lsh)
+(define-scm<-scm-u64-intrinsic rsh)
+(define-scm<-scm-uimm-intrinsic lsh/immediate)
+(define-scm<-scm-uimm-intrinsic rsh/immediate)
+(define-scm<-scm-bool-intrinsic resolve-module)
+(define-scm<-scm-scm-intrinsic lookup)
+(define-scm<-scm-scm-intrinsic define!)
+(define-scm<-thread-intrinsic current-module)
+
+(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))))
+ (emit-instrument-entry* 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)))
+ (set-asm-constants!
+ asm
+ (vhash-cons (make-jit-data (meta-low-pc meta) (meta-high-pc meta))
+ (meta-jit-data-label meta)
+ (asm-constants asm)))))
+
+(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 (? exact-integer?) (? symbol?)) "#f or symbol")
+ (let* ((meta (car (asm-meta asm)))
+ (arity (make-arity req opt rest kw-indices allow-other-keys?
+ ;; Include the initial instrument-entry in
+ ;; the first arity.
+ (if (null? (meta-arities meta))
+ (meta-low-pc meta)
+ (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-definitions! arity (reverse (arity-definitions arity)))
+ (set-arity-high-pc! arity (asm-start asm))))
+
+(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
+ (cond
+ (alternate
+ (emit-arguments<=? asm nreq)
+ (emit-jne asm 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
+ (begin
+ (emit-arguments<=? asm nreq)
+ (emit-jl asm alternate))
+ (emit-assert-nargs-ge asm nreq))
+ (cond
+ (rest?
+ (emit-bind-rest asm (+ nreq nopt)))
+ (alternate
+ (emit-arguments<=? asm (+ nreq nopt))
+ ;; The arguments<=? instruction sets NONE to indicate greater-than,
+ ;; whereas for <, NONE usually indicates greater-than-or-equal,
+ ;; hence the name jge. Perhaps we just need to rename jge to
+ ;; br-if-none.
+ (emit-jge asm 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-arguments<=? asm nreq)
+ (emit-jl asm alternate)
+ (unless rest?
+ (emit-positional-arguments<=? asm nreq (+ nreq nopt))
+ (emit-jge asm 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 (definition asm name slot representation)
+ (let* ((arity (car (meta-arities (car (asm-meta asm)))))
+ (def (vector name slot representation
+ (- (asm-start asm) (arity-low-pc arity)))))
+ (set-arity-definitions! arity (cons def (arity-definitions arity)))))
+
+(define-macro-assembler (cache-ref asm dst key)
+ (emit-static-ref asm dst (intern-cache-cell asm key)))
+
+(define-macro-assembler (cache-set! asm key val)
+ (emit-static-set! asm val (intern-cache-cell asm key) 0))
+
+(define-macro-assembler (slot-map asm proc-slot slot-map)
+ (unless (zero? slot-map)
+ (set-asm-slot-maps! asm (cons
+ (cons* (asm-start asm) proc-slot slot-map)
+ (asm-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 (symbol->string name)
+ (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 bits)
+ (let ((endianness (asm-endianness asm)))
+ (case (asm-word-size asm)
+ ((4) (bytevector-u32-set! buf pos bits endianness))
+ ((8) (bytevector-u64-set! buf pos bits endianness))
+ (else (error "bad word size" asm)))))
+
+(define (write-placeholder asm buf pos)
+ (write-immediate asm buf pos (immediate-bits asm #f)))
+
+(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)
+ (reset-frame 1)
+ (load-constant 0 ,*unspecified*)
+ (return-values)
+ (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 #x0d)
+ (define vector-immutable-flag #x80)
+
+ (define tc7-string #x15)
+ (define string-read-only-flag #x200)
+
+ (define tc7-stringbuf #x27)
+ (define stringbuf-wide-flag #x400)
+
+ (define tc7-syntax #x3d)
+
+ (define tc7-program #x45)
+
+ (define tc7-bytevector #x4d)
+ ;; This flag is intended to be left-shifted by 7 bits.
+ (define bytevector-immutable-flag #x200)
+
+ (define tc7-array #x5d)
+
+ (define tc7-bitvector #x5f)
+ (define bitvector-immutable-flag #x80)
+
+ (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))
+ ((syntax? x)
+ (* 4 word-size))
+ ((jit-data? x)
+ (case word-size
+ ((4) (+ word-size (* 4 3)))
+ ((8) (+ word-size (* 4 4))) ;; One additional uint32_t for padding.
+ (else (error word-size))))
+ ((simple-uniform-vector? x)
+ (* 4 word-size))
+ ((uniform-vector-backing-store? x)
+ (bytevector-length (uniform-vector-backing-store-bytes x)))
+ ((array? x)
+ (* word-size (+ 3 (* 3 (array-rank x)))))
+ (else
+ word-size)))
+
+ (define (write-constant-reference buf pos x)
+ (let ((bits (immediate-bits asm x)))
+ (if bits
+ (write-immediate asm buf pos bits)
+ ;; The asm-inits will fix up any reference to a
+ ;; non-immediate.
+ (write-placeholder asm buf pos))))
+
+ (define (write buf pos obj)
+ (cond
+ ((stringbuf? obj)
+ (let* ((x (stringbuf-string obj))
+ (len (string-length x))
+ (tag (logior tc7-stringbuf
+ (if (= (string-bytes-per-char x) 1)
+ 0
+ stringbuf-wide-flag))))
+ (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-placeholder asm buf pos))
+
+ ((jit-data? obj)
+ ;; Default initialization of 0.
+ (values))
+
+ ((string? obj)
+ (let ((tag (logior tc7-string string-read-only-flag)))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tag endianness)
+ (write-placeholder asm buf (+ pos 4)) ; 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 tag endianness)
+ (write-placeholder asm buf (+ pos 8)) ; 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 vector-immutable-flag (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-placeholder asm buf pos))
+
+ ((keyword? obj)
+ (write-placeholder asm buf pos))
+
+ ((syntax? obj)
+ (case word-size
+ ((4) (bytevector-u32-set! buf pos tc7-syntax endianness))
+ ((8) (bytevector-u64-set! buf pos tc7-syntax endianness))
+ (else (error "bad word size")))
+ (write-constant-reference buf (+ pos (* 1 word-size))
+ (syntax-expression obj))
+ (write-constant-reference buf (+ pos (* 2 word-size))
+ (syntax-wrap obj))
+ (write-constant-reference buf (+ pos (* 3 word-size))
+ (syntax-module obj)))
+
+ ((number? obj)
+ (write-placeholder asm buf pos))
+
+ ((simple-uniform-vector? obj)
+ (let ((tag (if (bitvector? obj)
+ (logior tc7-bitvector
+ bitvector-immutable-flag)
+ (logior tc7-bytevector
+ ;; Bytevector immutable flag also shifted
+ ;; left.
+ (ash (logior bytevector-immutable-flag
+ (array-type-code obj))
+ 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-placeholder asm buf (+ pos 12))) ; 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-placeholder asm buf (+ pos 24))) ; 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 (eq? endianness (native-endianness))
+ (case (uniform-vector-backing-store-element-size obj)
+ ((1) #f) ;; Nothing to do.
+ ((2) (byte-swap/2! buf pos (+ pos (bytevector-length bv))))
+ ((4) (byte-swap/4! buf pos (+ pos (bytevector-length bv))))
+ ((8) (byte-swap/8! buf pos (+ pos (bytevector-length bv))))
+ (else (error "FIXME: Implement byte order swap"))))))
+
+ ((array? obj)
+ (let-values
+ ;; array tag + rank + contp flag: see libguile/arrays.h .
+ (((tag) (logior tc7-array (ash (array-rank obj) 17) (ash 1 16)))
+ ((bv-set! bvs-set!)
+ (case word-size
+ ((4) (values bytevector-u32-set! bytevector-s32-set!))
+ ((8) (values bytevector-u64-set! bytevector-s64-set!))
+ (else (error "bad word size")))))
+ (bv-set! buf pos tag endianness)
+ (write-placeholder asm buf (+ pos word-size)) ; root vector (fixed later)
+ (bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base
+ (let lp ((pos (+ pos (* word-size 3)))
+ (bounds (array-shape obj))
+ (incs (shared-array-increments obj)))
+ (when (pair? bounds)
+ (bvs-set! buf pos (first (first bounds)) endianness)
+ (bvs-set! buf (+ pos word-size) (second (first bounds)) endianness)
+ (bvs-set! buf (+ pos (* word-size 2)) (first incs) endianness)
+ (lp (+ pos (* 3 word-size)) (cdr bounds) (cdr incs))))))
+
+ (else
+ (error "unrecognized object" obj))))
+
+ (define (add-relocs obj pos relocs)
+ (match obj
+ (($ <jit-data> low-pc high-pc)
+ ;; Patch "start" and "end" fields of "struct jit_data".
+ (cons* (make-linker-reloc 'rel32/1 (+ pos word-size 4)
+ (+ low-pc word-size 4)
+ '.rtl-text)
+ (make-linker-reloc 'rel32/1 (+ pos word-size 8)
+ (+ high-pc word-size 8)
+ '.rtl-text)
+ relocs))
+ (_ relocs)))
+
+ (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) (relocs '()) (symbols '()))
+ (if (< i (vlist-length data))
+ (match (vlist-ref data i)
+ ((obj . obj-label)
+ (write buf pos obj)
+ (lp (1+ i)
+ (align (+ (byte-length obj) pos) 8)
+ (add-relocs obj pos relocs)
+ (cons (make-linker-symbol obj-label pos) symbols))))
+ (make-object asm name buf relocs 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-bits asm (car x)) (immediate-bits asm (cdr x))))
+ ((simple-vector? x)
+ (let lp ((i 0))
+ (or (= i (vector-length x))
+ (and (immediate-bits asm (vector-ref x i))
+ (lp (1+ i))))))
+ ((uniform-vector-backing-store? x) #t)
+ (else #f)))
+ (let* ((init-constants (emit-init-constants asm))
+ (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)
+ init-constants)
+ (match (vlist-ref constants i)
+ ((obj . label)
+ (if (shareable? obj)
+ (lp (1+ i) (vhash-consq obj label ro) rw)
+ (lp (1+ i) ro (vhash-consq obj label 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 offset)
+ (let ((abs (hashq-ref labels label))
+ (dst (+ base offset)))
+ (case type
+ ((s32)
+ (if abs
+ (let ((rel (- abs base)))
+ (unless (zero? (logand rel #x3))
+ (error "reloc not in 32-bit units!"))
+ (bytevector-s32-native-set! buf dst (ash rel -2))
+ tail)
+ (cons (make-linker-reloc 'rel32/4 dst offset label)
+ tail)))
+ ((x8-s24)
+ (unless abs
+ (error "unbound near relocation" reloc))
+ (let ((rel (- abs base))
+ (u32 (bytevector-u32-native-ref buf dst)))
+ (unless (zero? (logand rel #x3))
+ (error "reloc not in 32-bit units!"))
+ (bytevector-u32-native-set! buf dst
+ (pack-u8-s24 (logand u32 #xff)
+ (ash rel -2)))
+ 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))
+ labels))
+
+(define (link-text-object asm)
+ "Link the .rtl-text section, swapping the endianness of the bytes if
+needed."
+ (let ((buf (make-bytevector (asm-pos asm))))
+ (bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf))
+ (unless (eq? (asm-endianness asm) (native-endianness))
+ (byte-swap/4! buf))
+ (make-object asm '.rtl-text
+ buf
+ (process-relocs buf (asm-relocs asm)
+ (asm-labels asm))
+ (process-labels (asm-labels asm)))))
+
+
+
+
+;;;
+;;; 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 (* 2 (- 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 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-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* #x0300)
+(define *bytecode-minor-version* 1)
+
+(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 (meta-low-pc meta)
+ #:size (- (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;
+;;; uint32_t nlocals;
+;;; }
+;;;
+;;; 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.
+;;;
+;;; If the arity has keyword arguments -- if has-keyword-args? is set in
+;;; the flags -- the first uint32 pointed to by offset encodes a link to
+;;; the "keyword indices" literal, in the data section. Then follow the
+;;; names for all locals, in order, as uleb128 values. The required
+;;; arguments will be the first locals, followed by the optionals,
+;;; followed by the rest argument if if has-rest? is set. The names
+;;; point into the associated string table section.
+;;;
+;;; 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 (* 7 4))
+
+;; Some helpers.
+(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-inline (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 (write-arities asm metas headers names-port strtab)
+ (define (write-header pos low-pc high-pc offset flags nreq nopt nlocals)
+ (unless (<= (+ nreq nopt) nlocals)
+ (error "forgot to emit definition instructions?"))
+ (bytevector-u32-set! headers pos low-pc (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 4) high-pc (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 20) nopt (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 24) nlocals (asm-endianness asm)))
+ (define (write-kw-indices kw-indices relocs)
+ ;; FIXME: Assert that kw-indices is already interned.
+ (if (pair? kw-indices)
+ (let ((pos (+ (bytevector-length headers)
+ (port-position names-port)))
+ (label (intern-constant asm kw-indices)))
+ (put-bytevector names-port #vu8(0 0 0 0))
+ (cons (make-linker-reloc 'abs32/1 pos 0 label) relocs))
+ relocs))
+ (define (write-arity pos arity in-case-lambda? relocs)
+ (write-header pos (arity-low-pc arity)
+ (arity-high-pc arity)
+ ;; FIXME: Seems silly to add on bytevector-length of
+ ;; headers, given the arities-prefix.
+ (+ (bytevector-length headers) (port-position names-port))
+ (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))
+ (length (arity-definitions arity)))
+ (let ((relocs (write-kw-indices (arity-kw-indices arity) relocs)))
+ ;; Write local names.
+ (let lp ((definitions (arity-definitions arity)))
+ (match definitions
+ (() relocs)
+ ((#(name slot representation def) . definitions)
+ (let ((sym (if (symbol? name)
+ (string-table-intern! strtab (symbol->string name))
+ 0)))
+ (put-uleb128 names-port sym)
+ (lp definitions)))))
+ ;; Now write their definitions.
+ (let lp ((definitions (arity-definitions arity)))
+ (match definitions
+ (() relocs)
+ ((#(name slot representation def) . definitions)
+ (put-uleb128 names-port def)
+ (let ((tag (case representation
+ ((scm) 0)
+ ((f64) 1)
+ ((u64) 2)
+ ((s64) 3)
+ ((ptr) 4)
+ (else (error "what!" representation)))))
+ (put-uleb128 names-port (logior (ash slot 3) tag)))
+ (lp definitions))))))
+ (let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
+ (match metas
+ (()
+ (unless (= pos (bytevector-length headers))
+ (error "expected to fully fill the bytevector"
+ pos (bytevector-length headers)))
+ relocs)
+ ((meta . metas)
+ (match (meta-arities meta)
+ (() (lp metas pos relocs))
+ ((arity)
+ (lp metas
+ (+ pos arity-header-len)
+ (write-arity pos arity #f relocs)))
+ (arities
+ ;; Write a case-lambda header, then individual arities.
+ ;; The case-lambda header's offset link is 0.
+ (write-header pos (meta-low-pc meta) (meta-high-pc meta) 0
+ (pack-arity-flags #f #f #f #t #f) 0 0 0)
+ (let lp* ((arities arities) (pos (+ pos arity-header-len))
+ (relocs relocs))
+ (match arities
+ (() (lp metas pos relocs))
+ ((arity . arities)
+ (lp* arities
+ (+ pos arity-header-len)
+ (write-arity pos arity #t relocs)))))))))))
+
+(define (link-arities asm)
+ (define (meta-arities-header-size meta)
+ (define (lambda-size arity)
+ arity-header-len)
+ (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 (bytevector-append a b)
+ (let ((out (make-bytevector (+ (bytevector-length a)
+ (bytevector-length b)))))
+ (bytevector-copy! a 0 out 0 (bytevector-length a))
+ (bytevector-copy! b 0 out (bytevector-length a) (bytevector-length b))
+ out))
+
+ (let* ((endianness (asm-endianness asm))
+ (metas (reverse (asm-meta asm)))
+ (header-size (fold (lambda (meta size)
+ (+ size (meta-arities-header-size meta)))
+ arities-prefix-len
+ metas))
+ (strtab (make-string-table))
+ (headers (make-bytevector header-size 0)))
+ (bytevector-u32-set! headers 0 (bytevector-length headers) endianness)
+ (let-values (((names-port get-name-bv) (open-bytevector-output-port)))
+ (let* ((relocs (write-arities asm metas headers names-port strtab))
+ (strtab (make-object asm '.guile.arities.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.arities
+ (bytevector-append headers (get-name-bv))
+ 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 (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 (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 (meta->subprogram-die meta)
+ `(subprogram
+ (@ ,@(cond
+ ((meta-name meta)
+ => (lambda (name) `((name ,(symbol->string name)))))
+ (else
+ '()))
+ (low-pc ,(meta-label meta))
+ (high-pc ,(- (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 ,(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)
+ (define min-inc 4) ; Minimum PC increment.
+
+ (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.
+ (if (and line col)
+ (cons (list pc
+ (if (string? file) (intern-file file) 0)
+ (1+ line)
+ (1+ col))
+ out)
+ 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 min-inc) ; 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) min-inc)))
+ (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 min-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) min-inc))
+ line-inc))
+ (else
+ (put-u8 line-port 2) ; advance-pc
+ (put-uleb128 line-port (/ pc-inc min-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 (choose-form attr val code)
+ (cond
+ ((string? val) 'strp)
+ ((eq? attr 'stmt-list) 'sec-offset)
+ ((eq? attr 'low-pc) 'addr)
+ ((exact-integer? code)
+ (cond
+ ((< code 0) 'sleb128)
+ ((<= code #xff) 'data1)
+ ((<= code #xffff) 'data2)
+ ((<= code #xffffffff) 'data4)
+ ((<= code #xffffffffffffffff) 'data8)
+ (else 'uleb128)))
+ (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
new file mode 100644
index 000000000..0d51e261a
--- /dev/null
+++ b/module/system/vm/coverage.scm
@@ -0,0 +1,350 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010, 2013, 2018 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
+
+(define-module (system vm coverage)
+ #: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
+ instrumented/executed-lines
+ line-execution-counts
+ procedure-execution-count
+ coverage-data->lcov))
+
+;;; Author: Ludovic Courtès
+;;;
+;;; Commentary:
+;;;
+;;; This module provides support to gather code coverage data by instrumenting
+;;; the VM.
+;;;
+;;; Code:
+
+
+;;;
+;;; Gathering coverage data.
+;;;
+
+(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 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)))
+ (dynamic-wind
+ (lambda ()
+ (set-vm-trace-level! (+ level 1))
+ (vm-add-next-hook! collect!))
+ (lambda ()
+ (call-with-vm thunk))
+ (lambda ()
+ (set-vm-trace-level! level)
+ (vm-remove-next-hook! collect!)))))
+ (lambda 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)))))
+
+
+;;;
+;;; Coverage data summary.
+;;;
+
+(define-record-type <coverage-data>
+ (%make-coverage-data ip-counts
+ sources
+ file->procedures
+ file->line-counts)
+ coverage-data?
+
+ ;; 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)
+
+ ;; 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 ip-counts)
+ ;; Return a `coverage-data' object based on the coverage data available in
+ ;; 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 all-counts
+ all-sources
+ file->procedures
+ file->line-counts)))
+
+ (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.
+ (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. 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
+FILE according to DATA."
+ (define instr+exec
+ (and=> (hash-ref (data-file->line-counts data) file)
+ (lambda (line-counts)
+ (hash-fold (lambda (line count instr+exec)
+ (let ((instr (car instr+exec))
+ (exec (cdr instr+exec)))
+ (cons (+ 1 instr)
+ (if (> count 0)
+ (+ 1 exec)
+ exec))))
+ '(0 . 0)
+ line-counts))))
+
+ (values (car instr+exec) (cdr instr+exec)))
+
+(define (line-execution-counts data file)
+ "Return a list of line number/execution count pairs for FILE, or #f if FILE
+is not among the files covered by DATA."
+ (and=> (hash-ref (data-file->line-counts data) file)
+ (lambda (line-counts)
+ (hash-fold alist-cons '() line-counts))))
+
+(define (instrumented-source-files data)
+ "Return the list of `instrumented' source files, i.e., source files whose code
+was loaded at the time DATA was collected."
+ (hash-fold (lambda (file counts files)
+ (cons file files))
+ '()
+ (data-file->line-counts data)))
+
+
+;;;
+;;; LCOV output.
+;;;
+
+(define* (coverage-data->lcov data port)
+ "Traverse code coverage information DATA, as obtained with
+`with-code-coverage', and write coverage information in the LCOV format to PORT.
+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 (or (program? proc))
+ (let ((sources (program-sources* data proc)))
+ (and (pair? sources)
+ (let* ((line (source:line-for-user (car sources)))
+ (name (or (procedure-name proc)
+ (format #f "anonymous-l~a" line))))
+ (format port "FN:~A,~A~%" line name)
+ (and=> (procedure-execution-count data proc)
+ (lambda (count)
+ (format port "FNDA:~A,~A~%" count name))))))))
+
+ ;; Output per-file coverage data.
+ (format port "TN:~%")
+ (for-each (lambda (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))
+ (count (cdr line+count)))
+ (format port "DA:~A,~A~%"
+ (+ 1 line) count)))
+ (line-execution-counts data file))
+ (let-values (((instr exec)
+ (instrumented/executed-lines data file)))
+ (format port "LH: ~A~%" exec)
+ (format port "LF: ~A~%" instr))
+ (format port "end_of_record~%"))
+ (begin
+ (format (current-error-port)
+ "skipping unknown source file: ~a~%"
+ file)))))
+ (instrumented-source-files data)))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
new file mode 100644
index 000000000..c3b27697c
--- /dev/null
+++ b/module/system/vm/debug.scm
@@ -0,0 +1,767 @@
+;;; Guile runtime debug information
+
+;;; Copyright (C) 2013, 2014, 2015, 2018 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 split-at))
+ #: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-nlocals
+ arity-has-rest?
+ arity-allow-other-keys?
+ arity-has-keyword-args?
+ arity-keyword-args
+ arity-is-case-lambda?
+ arity-definitions
+ arity-code
+
+ 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-arity
+ 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 (* 7 4))
+
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; uint32_t nlocals;
+;;; }
+
+(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))))
+(define (arity-nlocals* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 6 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-nlocals arity)
+ (arity-nlocals* (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-keyword-args arity)
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (if (arity-has-keyword-args? arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (offset (bytevector-u32-native-ref bv link)))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset)))
+ '()))
+
+(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-definitions arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (nlocals (arity-nlocals* bv header))
+ (flags (arity-flags* bv header))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity)
+ link-offset
+ (if (has-keyword-args? flags) 4 0))))
+ (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 (load-definitions pos names)
+ (let lp ((pos pos) (names names))
+ (match names
+ (() '())
+ ((name . names)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (def-offset pos)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (slot+representation pos)
+ (let ((slot (ash slot+representation -3))
+ (representation (case (logand slot+representation #x7)
+ ((0) 'scm)
+ ((1) 'f64)
+ ((2) 'u64)
+ ((3) 's64)
+ ((4) 'ptr)
+ (else 'unknown))))
+ (cons (vector name def-offset slot representation)
+ (lp pos names)))))))))))
+ (define (load-symbols pos)
+ (let lp ((pos pos) (n nlocals) (out '()))
+ (if (zero? n)
+ (load-definitions pos (reverse out))
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (strtab-offset pos)
+ strtab-offset
+ (lp pos
+ (1- n)
+ (cons (if (zero? strtab-offset)
+ #f
+ (load-symbol strtab-offset))
+ out)))))))
+ (when (is-case-lambda? flags)
+ (error "invalid request for definitions of case-lambda wrapper arity"))
+ (load-symbols link)))
+
+(define (arity-code arity)
+ (let* ((ctx (arity-context arity))
+ (bv (elf-bytes (debug-context-elf ctx)))
+ (header (arity-header-offset arity))
+ (base-addr (+ (debug-context-base ctx) (debug-context-text-base ctx)))
+ (low-pc (+ base-addr (arity-low-pc* bv header)))
+ (high-pc (+ base-addr (arity-high-pc* bv header))))
+ ;; FIXME: We should be able to use a sub-bytevector operation here;
+ ;; it would be safer.
+ (pointer->bytevector (make-pointer low-pc) (- high-pc low-pc))))
+
+(define* (arity-locals arity #:optional nlocals)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (nlocals (if nlocals
+ (if (<= 0 nlocals (arity-nlocals* bv header))
+ nlocals
+ (error "request for too many locals"))
+ (arity-nlocals* bv header)))
+ (flags (arity-flags* bv header))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity)
+ link-offset
+ (if (has-keyword-args? flags) 4 0))))
+ (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 (load-symbols pos n)
+ (let lp ((pos pos) (n n) (out '()))
+ (if (zero? n)
+ (reverse out)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (strtab-offset pos)
+ strtab-offset
+ (lp pos
+ (1- n)
+ (cons (if (zero? strtab-offset)
+ #f
+ (load-symbol strtab-offset))
+ out)))))))
+ (when (is-case-lambda? flags)
+ (error "invalid request for locals of case-lambda wrapper arity"))
+ (load-symbols link nlocals)))
+
+(define (arity-arguments-alist arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (header (arity-header-offset arity))
+ (flags (arity-flags* bv header))
+ (nreq (arity-nreq* bv header))
+ (nopt (arity-nopt* bv header))
+ (nargs (+ nreq nopt (if (has-rest? flags) 1 0)))
+ (nargs+closure (1+ nargs)))
+ (when (is-case-lambda? flags)
+ (error "invalid request for locals of case-lambda wrapper arity"))
+ (match (arity-locals arity nargs+closure)
+ ((closure . args)
+ (call-with-values (lambda () (split-at args nreq))
+ (lambda (req args)
+ (call-with-values (lambda () (split-at args nopt))
+ (lambda (opt args)
+ `((required . ,req)
+ (optional . ,opt)
+ (keyword . ,(arity-keyword-args arity))
+ (allow-other-keys? . ,(allow-other-keys? flags))
+ (rest . ,(and (has-rest? flags) (car args))))))))))))
+
+(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-arity addr #:optional
+ (context (find-debug-context addr)))
+ (let lp ((arities (or (find-program-arities addr context) '())))
+ (match arities
+ (() #f)
+ ((arity . arities)
+ (if (and (<= (arity-low-pc arity) addr)
+ (< addr (arity-high-pc arity)))
+ arity
+ (lp arities))))))
+
+(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)
+ (and (source-line 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..83499333c
--- /dev/null
+++ b/module/system/vm/disassembler.scm
@@ -0,0 +1,643 @@
+;;; Guile bytecode disassembler
+
+;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2018 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 base types internal)
+ #: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
+
+ instruction-length
+ instruction-has-fallthrough?
+ instruction-relative-jump-targets
+ instruction-stack-size-after
+ instruction-slot-clobbers))
+
+(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-s12 s)
+ (if (zero? (logand s (ash 1 11)))
+ s
+ (- s (ash 1 12))))
+
+(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
+ ((X32)
+ #'())
+ ((X8_S24 X8_F24 X8_C24)
+ #'((ash word -8)))
+ ((X8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((X8_S8_I16)
+ #'((logand (ash word -8) #xff)
+ (ash word -16)))
+ ((X8_S12_S12
+ X8_S12_C12
+ X8_C12_C12
+ X8_F12_F12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((X8_S12_Z12)
+ #'((logand (ash word -8) #xfff)
+ (unpack-s12 (ash word -20))))
+ ((X8_S8_S8_S8
+ X8_S8_S8_C8
+ X8_S8_C8_S8)
+ #'((logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ (else
+ (error "bad head kind" type)))))
+
+ (define (parse-tail-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32)
+ #'(word))
+ ((N32 R32 L32 LO32)
+ #'((unpack-s32 word)))
+ ((C8_C24 C8_S24)
+ #'((logand word #xff)
+ (ash word -8)))
+ ((C16_C16)
+ #'((logand word #xffff)
+ (ash word -16)))
+ ((B1_C7_L24)
+ #'((not (zero? (logand word #x1)))
+ (logand (ash word -1) #x7f)
+ (unpack-s24 (ash word -8))))
+ ((B1_X7_S24 B1_X7_F24 B1_X7_C24)
+ #'((not (zero? (logand word #x1)))
+ (ash word -8)))
+ ((B1_X7_L24)
+ #'((not (zero? (logand word #x1)))
+ (unpack-s24 (ash word -8))))
+ ((B1_X31)
+ #'((not (zero? (logand word #x1)))))
+ ((X8_S24 X8_F24 X8_C24)
+ #'((ash word -8)))
+ ((X8_L24)
+ #'((unpack-s24 (ash word -8))))
+ (else
+ (error "bad tail 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 immediate-tag-annotations '())
+(define-syntax-rule (define-immediate-tag-annotation name pred mask tag)
+ (set! immediate-tag-annotations
+ (cons `((,mask ,tag) ,(symbol->string 'pred)) immediate-tag-annotations)))
+(visit-immediate-tags define-immediate-tag-annotation)
+
+(define heap-tag-annotations '())
+(define-syntax-rule (define-heap-tag-annotation name pred mask tag)
+ (set! heap-tag-annotations
+ (cons `((,mask ,tag) ,(symbol->string 'pred)) heap-tag-annotations)))
+
+(visit-heap-tags define-heap-tag-annotation)
+
+(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 'j 'je 'jl 'jge 'jne 'jnl 'jnge) target)
+ (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+ (('immediate-tag=? _ mask tag)
+ (assoc-ref immediate-tag-annotations (list mask tag)))
+ (('heap-tag=? _ mask tag)
+ (assoc-ref heap-tag-annotations (list mask tag)))
+ (('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 slot~:p (~a arg~:p)" (+ locals nargs) (1- nargs)))
+ (('alloc-frame nlocals)
+ (list "~a slot~:p" nlocals))
+ (('reset-frame nlocals)
+ (list "~a slot~:p" nlocals))
+ (('bind-rest dst)
+ (list "~a slot~:p" (1+ dst)))
+ (('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)))
+ (('load-label dst src)
+ (let* ((addr (u32-offset->addr (+ offset src) 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" name addr)))
+ (('call-label closure nlocals target)
+ (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" name addr)))
+ (('tail-call-label target)
+ (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" name addr)))
+ (('make-non-immediate dst target)
+ (let ((val (reference-scm target)))
+ (when (program? val)
+ (push-addr! (program-code val) val))
+ (list "~@Y" val)))
+ (((or 'throw/value 'throw/value+data) dst target)
+ (list "~@Y" (reference-scm target)))
+ (('builtin-ref dst idx)
+ (list "~A" (builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) _ target)
+ (list "~@Y" (dereference-scm target)))
+ (('resolve-module dst name public)
+ (list "~a" (if (zero? public) "private" "public")))
+ (('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
+ ((j je jl jge jne jnl jnge)
+ (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 #:optional (seen (make-hash-table)))
+ (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 (hashv-ref seen addr)
+ (hashv-set! seen addr #t)
+ (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 seen)))
+ 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))
+ (('load-label dst src)
+ `(load-label ,dst ,(u32-offset->addr (+ offset src) context)))
+ (('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)))
+ (_ 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)))
+
+(define-syntax instruction-lengths-vector
+ (lambda (x)
+ (syntax-case x ()
+ ((_)
+ (let ((lengths (make-vector 256 #f)))
+ (for-each (match-lambda
+ ((name opcode kind words ...)
+ (vector-set! lengths opcode (* 4 (length words)))))
+ (instruction-list))
+ (datum->syntax x lengths))))))
+
+(define (instruction-length code pos)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ (or (vector-ref (instruction-lengths-vector) opcode)
+ (error "Unknown opcode" opcode))))
+
+(define-syntax static-opcode-set
+ (lambda (x)
+ (define (instruction-opcode inst)
+ (cond
+ ((assq inst (instruction-list))
+ => (match-lambda ((name opcode . _) opcode)))
+ (else
+ (error "unknown instruction" inst))))
+
+ (syntax-case x ()
+ ((static-opcode-set inst ...)
+ (let ((bv (make-bitvector 256 #f)))
+ (for-each (lambda (inst)
+ (bitvector-set! bv (instruction-opcode inst) #t))
+ (syntax->datum #'(inst ...)))
+ (datum->syntax #'static-opcode-set bv))))))
+
+(define (instruction-has-fallthrough? code pos)
+ (define non-fallthrough-set
+ (static-opcode-set halt
+ throw throw/value throw/value+data
+ tail-call tail-call-label
+ return-values
+ subr-call foreign-call continuation-call
+ j))
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ (not (bitvector-ref non-fallthrough-set opcode))))
+
+(define-syntax define-jump-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind word0 word* ...)
+ (let ((symname (syntax->datum #'name)))
+ (if (memq symname '(prompt j je jl jge jne jnl jnge))
+ (let ((offset (* 4 (length #'(word* ...)))))
+ #`(vector-set!
+ jump-parsers
+ opcode
+ (lambda (code pos)
+ (let ((target
+ (bytevector-s32-native-ref code (+ pos #,offset))))
+ ;; Assume that the target is in the last word, as
+ ;; an L24 in the high bits.
+ (list (* 4 (ash target -8)))))))
+ #'(begin)))))))
+
+(define jump-parsers (make-vector 256 (lambda (code pos) '())))
+(visit-opcodes define-jump-parser)
+
+(define (instruction-relative-jump-targets code pos)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ ((vector-ref jump-parsers opcode) code pos)))
+
+(define-syntax define-stack-effect-parser
+ (lambda (x)
+ (define (stack-effect-parser name)
+ (case name
+ ((push)
+ #'(lambda (code pos size) (and size (+ size 1))))
+ ((pop)
+ #'(lambda (code pos size) (and size (- size 1))))
+ ((drop)
+ #'(lambda (code pos size)
+ (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
+ (and size (- size count)))))
+ ((alloc-frame reset-frame)
+ #'(lambda (code pos size)
+ (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
+ nlocals)))
+ ((receive)
+ #'(lambda (code pos size)
+ (let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4))
+ -8)))
+ nlocals)))
+ ((bind-kwargs)
+ #'(lambda (code pos size)
+ (let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8)))
+ ntotal)))
+ ((bind-rest)
+ #'(lambda (code pos size)
+ (let ((dst (ash (bytevector-u32-native-ref code pos) -8)))
+ (+ dst 1))))
+ ((assert-nargs-ee/locals)
+ #'(lambda (code pos size)
+ (let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8)
+ #xfff))
+ (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
+ (+ nargs nlocals))))
+ ((call call-label tail-call tail-call-label expand-apply-argument)
+ #'(lambda (code pos size) #f))
+ ((shuffle-down)
+ #'(lambda (code pos size)
+ (let ((from (logand (ash (bytevector-u32-native-ref code pos) -8)
+ #xfff))
+ (to (ash (bytevector-u32-native-ref code pos) -20)))
+ (and size (- size (- from to))))))
+ (else
+ #f)))
+ (syntax-case x ()
+ ((_ name opcode kind word0 word* ...)
+ (let ((parser (stack-effect-parser (syntax->datum #'name))))
+ (if parser
+ #`(vector-set! stack-effect-parsers opcode #,parser)
+ #'(begin)))))))
+
+(define stack-effect-parsers (make-vector 256 (lambda (code pos size) size)))
+(visit-opcodes define-stack-effect-parser)
+
+(define (instruction-stack-size-after code pos size)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ ((vector-ref stack-effect-parsers opcode) code pos size)))
+
+(define-syntax define-clobber-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg0 arg* ...)
+ (case (syntax->datum #'kind)
+ ((!)
+ (case (syntax->datum #'name)
+ ((call call-label)
+ #'(let ((parse (lambda (code pos nslots-in nslots-out)
+ (call-with-values
+ (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (define frame-size 3)
+ (match elt
+ ((_ proc . _)
+ (let lp ((slot (- proc frame-size)))
+ (if (and nslots-in (< slot nslots-in))
+ (cons slot (lp (1+ slot)))
+ '())))))))))
+ (vector-set! clobber-parsers opcode parse)))
+ (else
+ #'(begin))))
+ ((<-)
+ #`(let ((parse (lambda (code pos nslots-in nslots-out)
+ (call-with-values
+ (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (match elt
+ ((_ dst . _)
+ #,(case (syntax->datum #'arg0)
+ ((X8_F24 X8_F12_F12)
+ #'(list dst))
+ (else
+ #'(if nslots-out
+ (list (- nslots-out 1 dst))
+ '()))))))))))
+ (vector-set! clobber-parsers opcode parse)))
+ (else (error "unexpected instruction kind" #'kind)))))))
+
+(define clobber-parsers
+ (make-vector 256 (lambda (code pos nslots-in nslots-out) '())))
+(visit-opcodes define-clobber-parser)
+
+(define (instruction-slot-clobbers code pos nslots-in nslots-out)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ ((vector-ref clobber-parsers opcode) code pos nslots-in nslots-out)))
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..6ee62f129
--- /dev/null
+++ b/module/system/vm/elf.scm
@@ -0,0 +1,1042 @@
+;;; Guile ELF reader and writer
+
+;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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
+
+ ELFOSABI_NONE ELFOSABI_HPUX ELFOSABI_NETBSD ELFOSABI_GNU
+ ELFOSABI_SOLARIS ELFOSABI_AIX ELFOSABI_IRIX ELFOSABI_FREEBSD
+ ELFOSABI_TRU64 ELFOSABI_MODESTO ELFOSABI_OPENBSD
+ ELFOSABI_ARM_AEABI ELFOSABI_ARM ELFOSABI_STANDALONE
+
+ ET_NONE ET_REL ET_EXEC ET_DYN ET_CORE
+
+ EM_NONE EM_SPARC EM_386 EM_MIPS EM_PPC EM_PPC64 EM_ARM EM_SH
+ EM_SPARCV9 EM_IA_64 EM_X86_64
+
+ 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 elf-symbol-value-offset 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_NONE 0) ; UNIX System V ABI */
+(define ELFOSABI_HPUX 1) ; HP-UX
+(define ELFOSABI_NETBSD 2) ; NetBSD.
+(define ELFOSABI_GNU 3) ; Object uses GNU ELF extensions.
+(define ELFOSABI_SOLARIS 6) ; Sun Solaris.
+(define ELFOSABI_AIX 7) ; IBM AIX.
+(define ELFOSABI_IRIX 8) ; SGI Irix.
+(define ELFOSABI_FREEBSD 9) ; FreeBSD.
+(define ELFOSABI_TRU64 10) ; Compaq TRU64 UNIX.
+(define ELFOSABI_MODESTO 11) ; Novell Modesto.
+(define ELFOSABI_OPENBSD 12) ; OpenBSD.
+(define ELFOSABI_ARM_AEABI 64) ; ARM EABI
+(define ELFOSABI_ARM 97) ; ARM
+(define ELFOSABI_STANDALONE 255) ; Standalone (embedded) application
+
+(define ET_NONE 0) ; No file type
+(define ET_REL 1) ; Relocatable file
+(define ET_EXEC 2) ; Executable file
+(define ET_DYN 3) ; Shared object file
+(define ET_CORE 4) ; Core 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")))
+ n
+ (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 (elf-symbol-value-offset word-size)
+ (case word-size
+ ((4) 4)
+ ((8) 8)
+ (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
new file mode 100644
index 000000000..2b55ce4f6
--- /dev/null
+++ b/module/system/vm/frame.scm
@@ -0,0 +1,463 @@
+;;; Guile VM frame functions
+
+;;; Copyright (C) 2001, 2005, 2009-2016, 2018 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 frame)
+ #:use-module (system base pmatch)
+ #:use-module (system foreign)
+ #:use-module (system vm program)
+ #:use-module (system vm debug)
+ #:use-module (system vm disassembler)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:export (binding-index
+ binding-name
+ binding-slot
+ binding-representation
+
+ frame-bindings
+ frame-lookup-binding
+ binding-ref binding-set!
+
+ frame-call-representation
+ frame-return-values
+ frame-environment
+ frame-object-binding frame-object-name))
+
+(eval-when (expand compile load eval)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_frames_builtins"))
+
+(define-record-type <binding>
+ (make-binding frame idx name slot representation)
+ binding?
+ (frame binding-frame)
+ (idx binding-index)
+ (name binding-name)
+ (slot binding-slot)
+ (representation binding-representation))
+
+(define (parse-code code)
+ (let ((len (bytevector-length code)))
+ (let lp ((pos 0) (out '()))
+ (cond
+ ((< pos len)
+ (let* ((inst-len (instruction-length code pos))
+ (pos (+ pos inst-len)))
+ (unless (<= pos len)
+ (error "Failed to parse codestream"))
+ (lp pos (cons inst-len out))))
+ (else
+ (list->vector (reverse out)))))))
+
+(define (compute-predecessors code parsed)
+ (let ((preds (make-vector (vector-length parsed) '())))
+ (define (add-pred! from target)
+ (let lp ((to from) (target target))
+ (cond
+ ((negative? target)
+ (lp (1- to) (+ target (vector-ref parsed (1- to)))))
+ ((positive? target)
+ (lp (1+ to) (- target (vector-ref parsed to))))
+ ((= to (vector-length preds))
+ ;; This can happen when an arity fails to match. Just ignore
+ ;; this case.
+ #t)
+ (else
+ (vector-set! preds to (cons from (vector-ref preds to)))))))
+ (let lp ((n 0) (pos 0))
+ (when (< n (vector-length preds))
+ (when (instruction-has-fallthrough? code pos)
+ (add-pred! n (vector-ref parsed n)))
+ (for-each (lambda (target)
+ (add-pred! n target))
+ (instruction-relative-jump-targets code pos))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ preds))
+
+(define (compute-frame-sizes code parsed initial-size)
+ (let ((in-sizes (make-vector (vector-length parsed) #f))
+ (out-sizes (make-vector (vector-length parsed) #f)))
+ ;; This only computes all possible valid stack sizes if the bytecode
+ ;; is sorted topologically. Guiles' compiler does this currently,
+ ;; but if that changes we should do a proper pre-order visit. Of
+ ;; course the bytecode has to be valid too.
+ (define (find-idx n diff)
+ (let lp ((n n) (diff diff))
+ (cond
+ ((= n (vector-length parsed))
+ ;; Possible for jumps to alternate arities.
+ #f)
+ ((negative? diff)
+ (lp (1- n) (+ diff (vector-ref parsed (1- n)))))
+ ((positive? diff)
+ (lp (1+ n) (- diff (vector-ref parsed n))))
+ (else n))))
+ (vector-set! in-sizes 0 initial-size)
+ (let lp ((n 0) (pos 0))
+ (define (offset->idx target)
+ (call-with-values (lambda ()
+ (if (>= target pos)
+ (values n pos)
+ (values 0 0)))
+ (lambda (n pos)
+ (let lp ((n n) (pos pos))
+ (cond
+ ((= pos target) n)
+ ((< pos target) (lp (1+ n) (+ pos (vector-ref parsed n))))
+ (else (error "bad target" target)))))))
+ (when (< n (vector-length parsed))
+ (let* ((in (vector-ref in-sizes n))
+ (out (instruction-stack-size-after code pos in)))
+ (vector-set! out-sizes n out)
+ (when out
+ (when (instruction-has-fallthrough? code pos)
+ (vector-set! in-sizes (1+ n) out))
+ (for-each (lambda (target)
+ (let ((idx (find-idx n target)))
+ (when idx
+ (vector-set! in-sizes idx out))))
+ (instruction-relative-jump-targets code pos))))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ (values in-sizes out-sizes)))
+
+(define (compute-genv parsed defs)
+ (let ((genv (make-vector (vector-length parsed) '())))
+ (define (add-def! pos var)
+ (vector-set! genv pos (cons var (vector-ref genv pos))))
+ (let lp ((var 0) (pos 0) (pc-offset 0))
+ (when (< var (vector-length defs))
+ (match (vector-ref defs var)
+ (#(name offset slot representation)
+ (when (< offset pc-offset)
+ (error "mismatch between def offsets and parsed code"))
+ (cond
+ ((< pc-offset offset)
+ (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos))))
+ (else
+ (add-def! pos var)
+ (lp (1+ var) pos pc-offset)))))))
+ genv))
+
+(define (compute-defs-by-slot defs)
+ (let* ((nslots (match defs
+ (#(#(_ _ slot _) ...) (1+ (apply max slot)))))
+ (by-slot (make-vector nslots #f)))
+ (let lp ((n 0))
+ (when (< n nslots)
+ (vector-set! by-slot n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+ (let lp ((n 0))
+ (when (< n (vector-length defs))
+ (match (vector-ref defs n)
+ (#(_ _ slot _)
+ (bitvector-set! (vector-ref by-slot slot) n #t)
+ (lp (1+ n))))))
+ by-slot))
+
+(define (compute-killv code parsed defs)
+ (let*-values (((defs-by-slot) (compute-defs-by-slot defs))
+ ((initial-frame-size) (vector-length defs-by-slot))
+ ((in-sizes out-sizes)
+ (compute-frame-sizes code parsed initial-frame-size))
+ ((killv) (make-vector (vector-length parsed) #f)))
+ (define (kill-slot! n slot)
+ (bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t))
+ (let lp ((n 0))
+ (when (< n (vector-length killv))
+ (vector-set! killv n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+ ;; Some defs get into place without explicit instructions -- this is
+ ;; the case if no shuffling need occur, for example. In any case,
+ ;; mark them as killing any previous definitions at that slot.
+ (let lp ((var 0) (pos 0) (pc-offset 0))
+ (when (< var (vector-length defs))
+ (match (vector-ref defs var)
+ (#(name offset slot representation)
+ (when (< offset pc-offset)
+ (error "mismatch between def offsets and parsed code"))
+ (cond
+ ((< pc-offset offset)
+ (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos))))
+ (else
+ (kill-slot! pos slot)
+ (lp (1+ var) pos pc-offset)))))))
+ (let lp ((n 0) (pos 0))
+ (when (< n (vector-length parsed))
+ (for-each (lambda (slot)
+ (when (< slot (vector-length defs-by-slot))
+ (kill-slot! n slot)))
+ (let ((in (vector-ref in-sizes n))
+ (out (vector-ref out-sizes n)))
+ (instruction-slot-clobbers code pos in out)))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ killv))
+
+(define (available-bindings frame arity ip top-frame?)
+ (let* ((defs (list->vector (arity-definitions arity)))
+ (code (arity-code arity))
+ (parsed (parse-code code))
+ (len (vector-length parsed))
+ (preds (compute-predecessors code parsed))
+ (genv (compute-genv parsed defs))
+ (killv (compute-killv code parsed defs))
+ (inv (make-vector len #f))
+ (outv (make-vector len #f))
+ (tmp (make-bitvector (vector-length defs) #f)))
+ (define (bitvector-copy! dst src)
+ (bitvector-fill! dst #f)
+ (bit-set*! dst src #t))
+ (define (bitvector-meet! accum src)
+ (bitvector-copy! tmp src)
+ (bit-invert! tmp)
+ (bit-set*! accum tmp #f))
+
+ (let lp ((n 0))
+ (when (< n len)
+ (vector-set! inv n (make-bitvector (vector-length defs) #f))
+ (vector-set! outv n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+
+ (let lp ((n 0) (first? #t) (changed? #f))
+ (cond
+ ((< n len)
+ (let ((in (vector-ref inv n))
+ (out (vector-ref outv n))
+ (kill (vector-ref killv n))
+ (gen (vector-ref genv n)))
+ (let ((out-count (or changed? (bit-count #t out))))
+ (bitvector-fill! in (not (zero? n)))
+ (let lp ((preds (vector-ref preds n)))
+ (match preds
+ (() #t)
+ ((pred . preds)
+ (unless (and first? (<= n pred))
+ (bitvector-meet! in (vector-ref outv pred)))
+ (lp preds))))
+ (bitvector-copy! out in)
+ (bit-set*! out kill #f)
+ (for-each (lambda (def)
+ (bitvector-set! out def #t))
+ gen)
+ (lp (1+ n) first?
+ (or changed? (not (eqv? out-count (bit-count #t out))))))))
+ ((or changed? first?)
+ (lp 0 #f #f))))
+
+ (let lp ((n 0) (offset (- ip (arity-low-pc arity))))
+ (when (< offset 0)
+ (error "ip did not correspond to an instruction boundary?"))
+ (if (zero? offset)
+ ;; It shouldn't be the case that both OFFSET and N are zero
+ ;; but TOP-FRAME? is false. Still, it could happen, as is
+ ;; currently the case in frame-arguments.
+ (let ((live (if (or top-frame? (zero? n))
+ (vector-ref inv n)
+ ;; If we're not at a top frame, the IP points
+ ;; to the continuation -- but we haven't
+ ;; returned and defined its values yet. The
+ ;; set of live variables is the set that was
+ ;; live going into the call, minus the set
+ ;; killed by the call, but not including
+ ;; values defined by the call.
+ (begin
+ (bitvector-copy! tmp (vector-ref inv (1- n)))
+ (bit-set*! tmp (vector-ref killv (1- n)) #f)
+ tmp))))
+ (let lp ((n 0))
+ (let ((n (bit-position #t live n)))
+ (if n
+ (match (vector-ref defs n)
+ (#(name def-offset slot representation)
+ (cons (make-binding frame n name slot representation)
+ (lp (1+ n)))))
+ '()))))
+ (lp (1+ n) (- offset (vector-ref parsed n)))))))
+
+(define* (frame-bindings frame #:optional top-frame?)
+ (let ((ip (frame-instruction-pointer frame)))
+ (cond
+ ((find-program-arity ip)
+ => (lambda (arity)
+ (available-bindings frame arity ip top-frame?)))
+ (else '()))))
+
+(define (frame-lookup-binding frame var)
+ (let lp ((bindings (frame-bindings frame)))
+ (cond ((null? bindings)
+ #f)
+ ((eq? (binding-name (car bindings)) var)
+ (car bindings))
+ (else
+ (lp (cdr bindings))))))
+
+(define (binding-ref binding)
+ (frame-local-ref (or (binding-frame binding)
+ (error "binding has no frame" binding))
+ (binding-slot binding)
+ (binding-representation binding)))
+
+(define (binding-set! binding val)
+ (frame-local-set! (or (binding-frame binding)
+ (error "binding has no frame" binding))
+ (binding-slot binding)
+ val
+ (binding-representation binding)))
+
+(define* (frame-procedure-name frame #:key
+ (info (find-program-debug-info
+ (frame-instruction-pointer frame))))
+ (if info
+ (program-debug-info-name info)
+ (primitive-code-name (frame-instruction-pointer frame))))
+
+;; This function is always called to get some sort of representation of the
+;; frame to present to the user, so let's do the logical thing and dispatch to
+;; frame-call-representation.
+(define (frame-arguments frame)
+ (cdr (frame-call-representation frame)))
+
+
+;;;
+;;; Pretty printing
+;;;
+
+;; Basically there are three cases to deal with here:
+;;
+;; 1. We've already parsed the arguments, and bound them to local
+;; variables. In a standard (lambda (a b c) ...) call, this doesn't
+;; involve any argument shuffling; but with rest, optional, or
+;; keyword arguments, the arguments as given to the procedure may
+;; not correspond to what's on the stack. We reconstruct the
+;; arguments using e.g. for the case above: `(,a ,b ,c). This works
+;; for rest arguments too: (a b . c) => `(,a ,b . ,c)
+;;
+;; 2. We have failed to parse the arguments. Perhaps it's the wrong
+;; number of arguments, or perhaps we're doing a typed dispatch and
+;; the types don't match. In that case the arguments are all on the
+;; stack, and nothing else is on the stack.
+;;
+;; 3. Alternately it's possible that we're between a primitive call
+;; and its associated return. In that case, we won't be able to
+;; say anything at all.
+
+(define* (frame-call-representation frame #:key top-frame?)
+ (let* ((ip (frame-instruction-pointer frame))
+ (info (find-program-debug-info ip))
+ (nlocals (frame-num-locals frame)))
+ (define (find-slot i bindings)
+ (match bindings
+ (() #f)
+ (((and binding ($ <binding> frame idx name slot)) . bindings)
+ (if (< idx i)
+ (find-slot i bindings)
+ (and (= idx i) binding)))))
+ (define (local-ref i bindings)
+ (cond
+ ((not bindings)
+ ;; This case is only hit for primitives and application
+ ;; arguments.
+ (frame-local-ref frame i 'scm))
+ ((find-slot i bindings)
+ => (lambda (binding)
+ (let ((val (frame-local-ref frame (binding-slot binding)
+ (binding-representation binding))))
+ ;; It could be that there's a value that isn't clobbered
+ ;; by a call but that isn't live after a call either. In
+ ;; that case, if GC runs during the call, the value will
+ ;; be collected, and on the stack it will be replaced
+ ;; with the unspecified value. Assume that clobbering
+ ;; values is more likely than passing the unspecified
+ ;; value as an argument, and replace unspecified with _,
+ ;; as if the binding were not available.
+ (if (unspecified? val) '_ val))))
+ (else
+ '_)))
+ (define (application-arguments)
+ ;; Case 1.
+ (map (lambda (local) (local-ref local #f))
+ ;; Cdr past the 0th local, which is the procedure.
+ (cdr (iota nlocals))))
+ (define (reconstruct-arguments bindings nreq nopt kw has-rest? local)
+ ;; Case 2.
+ (cond
+ ((positive? nreq)
+ (cons (local-ref local bindings)
+ (reconstruct-arguments bindings
+ (1- nreq) nopt kw has-rest? (1+ local))))
+ ((positive? nopt)
+ (cons (local-ref local bindings)
+ (reconstruct-arguments bindings
+ nreq (1- nopt) kw has-rest? (1+ local))))
+ ((pair? kw)
+ (cons* (caar kw) (local-ref (cdar kw) bindings)
+ (reconstruct-arguments bindings
+ nreq nopt (cdr kw) has-rest? (1+ local))))
+ (has-rest?
+ (local-ref local bindings))
+ (else
+ '())))
+ (cons
+ (or (frame-procedure-name frame #:info info) '_)
+ (cond
+ ((find-program-arity ip)
+ => (lambda (arity)
+ (if (and top-frame? (eqv? ip (arity-low-pc arity)))
+ (application-arguments)
+ (reconstruct-arguments
+ (available-bindings frame arity ip top-frame?)
+ (arity-nreq arity)
+ (arity-nopt arity)
+ (arity-keyword-args arity)
+ (arity-has-rest? arity)
+ 1))))
+ ((and (primitive-code? ip)
+ (program-arguments-alist (frame-local-ref frame 0 'scm) ip))
+ => (lambda (args)
+ (match args
+ ((('required . req)
+ ('optional . opt)
+ ('keyword . kw)
+ ('allow-other-keys? . _)
+ ('rest . rest))
+ (reconstruct-arguments #f
+ (length req) (length opt) kw rest 1)))))
+ (else
+ (application-arguments))))))
+
+
+
+;;; Misc
+;;;
+
+(define (frame-environment frame)
+ (map (lambda (binding)
+ (cons (binding-name binding) (binding-ref binding)))
+ (frame-bindings frame)))
+
+(define (frame-object-binding frame obj)
+ (do ((bs (frame-bindings frame) (cdr bs)))
+ ((or (null? bs) (eq? obj (binding-ref (car bs))))
+ (and (pair? bs) (car bs)))))
+
+(define (frame-object-name frame obj)
+ (cond ((frame-object-binding frame obj) => binding-name)
+ (else #f)))
diff --git a/module/system/vm/inspect.scm b/module/system/vm/inspect.scm
new file mode 100644
index 000000000..1f6d99d19
--- /dev/null
+++ b/module/system/vm/inspect.scm
@@ -0,0 +1,188 @@
+;;; Guile VM debugging facilities
+
+;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm inspect)
+ #:use-module (system base pmatch)
+ #:use-module (system base syntax)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (system vm disassembler)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 format)
+ #:use-module (system vm program)
+ #:export (inspect))
+
+
+(define (reverse-hashq h)
+ (let ((ret (make-hash-table)))
+ (hash-for-each
+ (lambda (k v)
+ (hashq-set! ret v (cons k (hashq-ref ret v '()))))
+ h)
+ ret))
+
+(define (catch-bad-arguments thunk bad-args-thunk)
+ (catch 'wrong-number-of-args
+ (lambda ()
+ (catch 'keyword-argument-error
+ thunk
+ (lambda (k . args)
+ (bad-args-thunk))))
+ (lambda (k . args)
+ (bad-args-thunk))))
+
+(define (read-args prompt)
+ (define (read* reader)
+ (repl-reader prompt reader))
+ (define (next)
+ (read* read-char))
+ (define (cmd chr)
+ (cond
+ ((eof-object? chr) (list chr))
+ ((char=? chr #\newline) (cmd (next)))
+ ((char-whitespace? chr) (cmd (next)))
+ (else
+ (unread-char chr)
+ (let ((tok (read* read)))
+ (args (list tok) (next))))))
+ (define (args out chr)
+ (cond
+ ((eof-object? chr) (reverse out))
+ ((char=? chr #\newline) (reverse out))
+ ((char-whitespace? chr) (args out (next)))
+ (else
+ (unread-char chr)
+ (let ((tok (read* read)))
+ (args (cons tok out) (next))))))
+ (cmd (next)))
+
+
+;;;
+;;; Inspector
+;;;
+
+(define (inspect x)
+ (define-syntax-rule (define-command ((mod cname alias ...) . args)
+ body ...)
+ (define cname
+ (let ((c (lambda* args body ...)))
+ (set-procedure-property! c 'name 'cname)
+ (module-define! mod 'cname c)
+ (module-add! mod 'alias (module-local-variable mod 'cname))
+ ...
+ c)))
+
+ (let ((commands (make-module)))
+ (define (prompt)
+ (format #f "~20@y inspect> " x))
+
+ (define-command ((commands quit q continue cont c))
+ "Quit the inspector."
+ (throw 'quit))
+
+ (define-command ((commands print p))
+ "Print the current object using `pretty-print'."
+ (pretty-print x))
+
+ (define-command ((commands write w))
+ "Print the current object using `write'."
+ (write x))
+
+ (define-command ((commands display d))
+ "Print the current object using `display'."
+ (display x))
+
+ (define-command ((commands disassemble x))
+ "Disassemble the current object, which should be a procedure."
+ (catch #t
+ (lambda ()
+ (disassemble-program x))
+ (lambda args
+ (format #t "Error disassembling object: ~a\n" args))))
+
+ (define-command ((commands help h ?) #:optional cmd)
+ "Show this help message."
+ (let ((rhash (reverse-hashq (module-obarray commands))))
+ (define (help-cmd cmd)
+ (let* ((v (module-local-variable commands cmd))
+ (p (variable-ref v))
+ (canonical-name (procedure-name p)))
+ ;; la la la
+ (format #t "~a~{ ~:@(~a~)~}~?~%~a~&~%"
+ canonical-name (program-lambda-list p)
+ "~#[~:;~40t(aliases: ~@{~a~^, ~})~]"
+ (delq canonical-name (hashq-ref rhash v))
+ (procedure-documentation p))))
+ (cond
+ (cmd
+ (cond
+ ((and (symbol? cmd) (module-local-variable commands cmd))
+ (help-cmd cmd))
+ (else
+ (format #t "Invalid command ~s.~%" cmd)
+ (format #t "Try `help' for a list of commands~%"))))
+ (else
+ (let ((names (sort
+ (hash-map->list
+ (lambda (k v)
+ (procedure-name (variable-ref k)))
+ rhash)
+ (lambda (x y)
+ (string<? (symbol->string x)
+ (symbol->string y))))))
+ (format #t "Available commands:~%~%")
+ (for-each help-cmd names))))))
+
+ (define (handle cmd . args)
+ (cond
+ ((and (symbol? cmd)
+ (module-local-variable commands cmd))
+ => (lambda (var)
+ (let ((proc (variable-ref var)))
+ (catch-bad-arguments
+ (lambda ()
+ (apply (variable-ref var) args))
+ (lambda ()
+ (format (current-error-port)
+ "Invalid arguments to ~a. Try `help ~a'.~%"
+ (procedure-name proc) (procedure-name proc)))))))
+ ; ((and (integer? cmd) (exact? cmd))
+ ; (nth cmd))
+ ((eof-object? cmd)
+ (newline)
+ (throw 'quit))
+ (else
+ (format (current-error-port)
+ "~&Unknown command: ~a. Try `help'.~%" cmd)
+ *unspecified*)))
+
+ (catch 'quit
+ (lambda ()
+ (let loop ()
+ (apply
+ handle
+ (save-module-excursion
+ (lambda ()
+ (set-current-module commands)
+ (read-args prompt))))
+ (loop)))
+ (lambda (k . args)
+ (apply values args)))))
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
new file mode 100644
index 000000000..ac1da6ecb
--- /dev/null
+++ b/module/system/vm/linker.scm
@@ -0,0 +1,733 @@
+;;; Guile ELF linker
+
+;; Copyright (C) 2011, 2012, 2013, 2014, 2018 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-name
+ 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/1 and Rel32/1 are relative signed offsets, in 8-bit or 32-bit
+;; units, respectively. 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/1, 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 name section bv relocs symbols)
+ linker-object?
+ (name linker-object-name)
+ (section linker-object-section)
+ (bv linker-object-bv)
+ (relocs linker-object-relocs)
+ (symbols linker-object-symbols))
+
+(define (make-linker-object name section bv relocs symbols)
+ "Create a linker object named @var{name} (a string, or #f for no name),
+@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 name 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)))
+ ;; Sections without SHF_ALLOC don't go in segments.
+ (cons (if (zero? flags) #f PT_LOAD)
+ (logior (if (logtest SHF_ALLOC flags) PF_R 0)
+ (if (logtest SHF_EXECINSTR flags) PF_X 0)
+ (if (logtest SHF_WRITE flags) PF_W 0)))))
+
+(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."
+ (define (adjoin x xs)
+ (if (member x xs) xs (cons x xs)))
+ (length
+ (fold-values (lambda (object kinds)
+ (let ((kind (segment-kind (linker-object-section object))))
+ (if (= (elf-section-type (linker-object-section object))
+ SHT_DYNAMIC)
+ ;; The dynamic section is part of a loadable
+ ;; segment, and also gets the additional
+ ;; PT_DYNAMIC segment header.
+ (cons (cons PT_DYNAMIC (cdr kind))
+ (adjoin kind kinds))
+ (if (car kind) (adjoin 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)))
+
+
+;; We assume that 64K is a multiple of the page size. A
+;; least-common-multiple, if you will.
+;;
+;; It would be possible to choose smaller, target-specific page sizes.
+;; This is still a little tricky; on amd64 for example, systems commonly
+;; have 4KB pages, but they are allowed by the ABI to have any
+;; multiple-of-2 page size up to 64 KB. On Cygwin, pages are 4kB but
+;; they can only be allocated 16 at a time. MIPS and ARM64 can use 64K
+;; pages too and that's not uncommon.
+;;
+;; At the current time, in Guile we would like to reduce the number of
+;; binaries we ship to the existing 32-or-64-bit and
+;; big-or-little-endian variants, if possible. It would seem that with
+;; the least-common-multiple of 64 KB pages, we can do that.
+;;
+;; See https://github.com/golang/go/issues/10180 for a discussion of
+;; this issue in the Go context.
+;;
+;; Using 64KB instead of the more usual 4KB will increase the size of
+;; our .go files, but not the prebuilt/ part of the tarball as that part
+;; of the file will be zeroes and compress well. Additionally on a
+;; system with 4KB pages, the extra padding will never be paged in, nor
+;; read from disk (though it causes more seeking etc so on spinning
+;; metal it's a bit of a lose).
+;;
+;; By way of comparison, on many 64-bit platforms, binutils currently
+;; defaults to aligning segments on 2MB boundaries. It does so by
+;; making the file and the memory images not the same: the pages are all
+;; together on disk, but then when loading, the loader will mmap a
+;; region "memsz" large which might be greater than the file size, then
+;; map segments into that region. We can avoid this complication for
+;; now. We can consider adding it in the future in a compatible way in
+;; 2.2 if it is important.
+;;
+(define *lcm-page-size* (ash 1 16))
+
+(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
+ (linker-object-name o)
+ (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 #:paddr 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) (linker-reloc-addend reloc))))
+ (unless (zero? (modulo diff 4))
+ (error "Bad offset" reloc symbol offset))
+ (bytevector-s32-set! bv offset (/ diff 4) endianness)))
+ ((rel32/1)
+ (let ((diff (- target offset)))
+ (bytevector-s32-set! bv offset
+ (+ diff (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)
+ (and (equal? (linker-object-name object) ".shstrtab")
+ (elf-section-index (linker-object-section object))))
+ objects))
+
+(define (add-elf-objects objects endianness word-size abi type machine-type)
+ "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
+ #:abi abi #:type type #:machine-type machine-type
+ #: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 #f
+ (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 #f 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 (record-special-segments write-segment-header! phidx all-objects)
+ (let lp ((phidx phidx) (objects all-objects))
+ (match objects
+ (() #t)
+ ((object . objects)
+ (let ((section (linker-object-section object)))
+ (cond
+ ((eqv? (elf-section-type section) SHT_DYNAMIC)
+ (let ((addr (elf-section-offset section))
+ (size (elf-section-size section))
+ (align (elf-section-addralign section))
+ (flags (cdr (segment-kind section))))
+ (write-segment-header!
+ (make-elf-segment #:index phidx #:type PT_DYNAMIC
+ #:offset addr #:vaddr addr #:paddr addr
+ #:filesz size #:memsz size
+ #:flags flags #:align align))
+ (lp (1+ phidx) objects)))
+ (else
+ (lp phidx objects))))))))
+
+(define (allocate-elf objects page-aligned? endianness word-size
+ abi type machine-type)
+ "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 abi type machine-type)
+ (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))))
+ *lcm-page-size*
+ 8))
+ (lp seglists
+ (fold-values cons objs-out objects)
+ (if type (1+ phidx) phidx)
+ addr
+ symtab
+ flags)))
+ (()
+ (record-special-segments write-segment-header! phidx objects)
+ (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))
+ (abi ELFOSABI_STANDALONE)
+ (type ET_DYN)
+ (machine-type EM_NONE))
+ "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
+ abi type machine-type)
+ (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/loader.scm b/module/system/vm/loader.scm
new file mode 100644
index 000000000..186bcc3c9
--- /dev/null
+++ b/module/system/vm/loader.scm
@@ -0,0 +1,27 @@
+;;; Guile VM object code
+
+;; 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
+;;; 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 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_loader")
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
new file mode 100644
index 000000000..e5dbcc089
--- /dev/null
+++ b/module/system/vm/program.scm
@@ -0,0 +1,313 @@
+;;; Guile VM program functions
+
+;;; Copyright (C) 2001, 2009, 2010, 2013, 2014, 2018 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 program)
+ #: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 (source:addr source:line source:column source:file
+ source:line-for-user
+ program-sources program-sources-pre-retire program-source
+
+ program-address-range
+
+ program-arities program-arity arity:start arity:end
+
+ arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
+
+ program-arguments-alist program-arguments-alists
+ program-lambda-list
+
+ program? program-code
+ program-free-variables
+ program-num-free-variables
+ program-free-variable-ref program-free-variable-set!
+
+ print-program
+
+ primitive-code?
+ primitive-code-name))
+
+(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 (source:addr source)
+ (car source))
+(define (source:file source)
+ (cadr source))
+(define (source:line source)
+ (caddr source))
+(define (source:column source)
+ (cdddr 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 (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)))))
+
+(define (program-address-range program)
+ "Return the start and end addresses of @var{program}'s code, as a pair
+of integers."
+ (let ((pdi (find-program-debug-info (program-code program))))
+ (and pdi
+ (cons (program-debug-info-addr pdi)
+ (+ (program-debug-info-addr pdi)
+ (program-debug-info-size pdi))))))
+
+;; Source information could in theory be correlated with the ip of the
+;; instruction, or the ip just after the instruction is retired. Guile
+;; does the latter, to make backtraces easy -- an error produced while
+;; running an opcode always happens after it has retired its arguments.
+;;
+;; But for breakpoints and such, we need the ip before the instruction
+;; is retired -- before it has had a chance to do anything. So here we
+;; change from the post-retire addresses given by program-sources to
+;; pre-retire addresses.
+;;
+(define (program-sources-pre-retire proc)
+ (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 (arity:start a)
+ (match a ((start end . _) start) (_ (error "bad arity" a))))
+(define (arity:end a)
+ (match a ((start end . _) end) (_ (error "bad arity" a))))
+(define (arity:nreq a)
+ (match a ((_ _ nreq . _) nreq) (_ 0)))
+(define (arity:nopt a)
+ (match a ((_ _ nreq nopt . _) nopt) (_ 0)))
+(define (arity:rest? a)
+ (match a ((_ _ nreq nopt rest? . _) rest?) (_ #f)))
+(define (arity:kw a)
+ (match a ((_ _ nreq nopt rest? (_ . kw)) kw) (_ '())))
+(define (arity:allow-other-keys? a)
+ (match a ((_ _ nreq nopt rest? (aok . kw)) aok) (_ #f)))
+
+(define (program-arity prog ip)
+ (let ((arities (program-arities prog)))
+ (and arities
+ (let lp ((arities arities))
+ (cond ((null? arities) #f)
+ ((not ip) (car arities)) ; take the first one
+ ((and (< (arity:start (car arities)) ip)
+ (<= ip (arity:end (car arities))))
+ (car arities))
+ (else (lp (cdr arities))))))))
+
+(define (arglist->arguments-alist arglist)
+ (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)))
+ (_ #f)))
+
+(define* (arity->arguments-alist prog arity
+ #:optional
+ (make-placeholder
+ (lambda (i) (string->symbol "_"))))
+ (let lp ((nreq (arity:nreq arity)) (req '())
+ (nopt (arity:nopt arity)) (opt '())
+ (rest? (arity:rest? arity)) (rest #f)
+ (n 0))
+ (cond
+ ((< 0 nreq)
+ (lp (1- nreq) (cons (make-placeholder n) req)
+ nopt opt rest? rest (1+ n)))
+ ((< 0 nopt)
+ (lp nreq req
+ (1- nopt) (cons (make-placeholder n) opt)
+ rest? rest (1+ n)))
+ (rest?
+ (lp nreq req nopt opt
+ #f (make-placeholder (+ n (length (arity:kw arity))))
+ (1+ n)))
+ (else
+ `((required . ,(reverse req))
+ (optional . ,(reverse opt))
+ (keyword . ,(arity:kw arity))
+ (allow-other-keys? . ,(arity:allow-other-keys? arity))
+ (rest . ,rest))))))
+
+;; 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 ((code (program-code prog)))
+ (cond
+ ((primitive-code? code)
+ (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) (and start (= start ip)))
+ (arity->arguments-alist
+ prog
+ (list 0 0 nreq nopt rest? '(#f . ()))))))))
+ (else
+ (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 code) '()))))))
+
+(define* (program-lambda-list prog #:optional ip)
+ "Returns the signature of the given procedure in the form of an argument list."
+ (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list))
+
+(define (arguments-alist->lambda-list arguments-alist)
+ (let ((req (or (assq-ref arguments-alist 'required) '()))
+ (opt (or (assq-ref arguments-alist 'optional) '()))
+ (key (map keyword->symbol
+ (map car (or (assq-ref arguments-alist 'keyword) '()))))
+ (rest (or (assq-ref arguments-alist 'rest) '())))
+ `(,@req
+ ,@(if (pair? opt) (cons #:optional opt) '())
+ ,@(if (pair? key) (cons #:key key) '())
+ . ,rest)))
+
+(define (program-free-variables prog)
+ "Return the list of free variables of PROG."
+ (let ((count (program-num-free-variables prog)))
+ (unfold (lambda (i) (>= i count))
+ (cut program-free-variable-ref prog <>)
+ 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 . ())))))))
+ (let* ((code (program-code prog))
+ (arities (and (not (primitive-code? code))
+ (find-program-arities code))))
+ (if arities
+ (map arity-arguments-alist arities)
+ (fallback))))
+
+(define* (print-program #:optional program (port (current-output-port))
+ #:key (addr (program-code program))
+ (always-print-addr? #f) (never-print-addr? #f)
+ (always-print-source? #f) (never-print-source? #f)
+ (name-only? #f) (print-formals? #t))
+ (let* ((pdi (find-program-debug-info addr))
+ ;; It could be the procedure had its name property set via the
+ ;; procedure property interface.
+ (name (or (and program (procedure-name program))
+ (and pdi (program-debug-info-name pdi))))
+ (source (match (find-program-sources addr)
+ (() #f)
+ ((source . _) source)))
+ (formals (if program
+ (program-arguments-alists program)
+ (let ((arities (find-program-arities addr)))
+ (if arities
+ (map arity-arguments-alist arities)
+ '())))))
+ (define (hex n)
+ (number->string n 16))
+
+ (cond
+ ((and name-only? name)
+ (format port "~a" name))
+ (else
+ (format port "#<procedure")
+ (format port " ~a"
+ (or name
+ (and program (hex (object-address program)))
+ (if never-print-addr?
+ ""
+ (string-append "@" (hex addr)))))
+ (when (and always-print-addr? (not never-print-addr?))
+ (unless (and (not name) (not program))
+ (format port " @~a" (hex addr))))
+ (when (and source (not never-print-source?)
+ (or always-print-source? (not name)))
+ (format port " at ~a:~a:~a"
+ (or (source-file source) "<unknown port>")
+ (source-line-for-user source)
+ (source-column source)))
+ (unless (or (null? formals) (not print-formals?))
+ (format port "~a"
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments-alist->lambda-list a)))
+ formals)
+ " | "))))
+ (format port ">")))))
+
+(define (write-program prog port)
+ (print-program prog port))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
new file mode 100644
index 000000000..e9f17dae8
--- /dev/null
+++ b/module/system/vm/trace.scm
@@ -0,0 +1,122 @@
+;;; Guile VM tracer
+
+;; Copyright (C) 2001,2009-2010,2012-2014,2018 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 trace)
+ #:use-module (system base syntax)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
+ #:use-module (system vm traps)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:export (trace-calls-in-procedure
+ trace-calls-to-procedure
+ trace-instructions-in-procedure
+ call-with-trace))
+
+(define (build-prefix prefix depth infix numeric-format max-indent)
+ (let lp ((indent "") (n 0))
+ (cond
+ ((= n depth)
+ (string-append prefix indent))
+ ((< (+ (string-length indent) (string-length infix)) max-indent)
+ (lp (string-append indent infix) (1+ n)))
+ (else
+ (string-append prefix indent (format #f numeric-format depth))))))
+
+(define (print-application frame depth width prefix max-indent)
+ (let ((prefix (build-prefix prefix depth "| " "~d> " max-indent)))
+ (format (current-error-port) "~a~v:@y\n"
+ prefix
+ width
+ (frame-call-representation frame #:top-frame? #t))))
+
+(define (print-return frame depth width prefix max-indent)
+ (let ((prefix (build-prefix prefix depth "| " "~d< "max-indent))
+ (values (frame-return-values frame)))
+ (case (length values)
+ ((0)
+ (format (current-error-port) "~ano values\n" prefix))
+ ((1)
+ (format (current-error-port) "~a~v:@y\n"
+ prefix
+ width
+ (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 (length values)
+ (map (lambda (val)
+ (format #f "~v:@y" width val))
+ 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 values)
+ (print-return frame depth width prefix max-indent))
+ (trap-calls-to-procedure proc apply-handler return-handler))
+
+(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))
+
+(define* (trace-instructions-in-procedure proc #:key (width 80)
+ (max-indent (- width 40)))
+ (define (trace-next frame)
+ ;; 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))
+
+;; 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) (max-indent (- width 40)))
+ (let ((call-trap #f)
+ (inst-trap #f))
+ (dynamic-wind
+ (lambda ()
+ (if calls?
+ (set! call-trap
+ (trace-calls-in-procedure thunk #:width width
+ #:max-indent max-indent)))
+ (if instructions?
+ (set! inst-trap
+ (trace-instructions-in-procedure thunk #:width width
+ #:max-indent max-indent)))
+ (set-vm-trace-level! (1+ (vm-trace-level))))
+ thunk
+ (lambda ()
+ (set-vm-trace-level! (1- (vm-trace-level)))
+ (if call-trap (call-trap))
+ (if inst-trap (inst-trap))
+ (set! call-trap #f)
+ (set! inst-trap #f)))))
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
new file mode 100644
index 000000000..464740bcd
--- /dev/null
+++ b/module/system/vm/trap-state.scm
@@ -0,0 +1,302 @@
+;;; trap-state.scm: a set of traps
+
+;; 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
+;;; 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:
+;;;
+;;; Code:
+
+(define-module (system vm trap-state)
+ #:use-module (system base syntax)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (system vm vm)
+ #:use-module (system vm traps)
+ #:use-module (system vm trace)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
+ #:export (add-trap!
+ list-traps
+ trap-enabled?
+ trap-name
+ enable-trap!
+ disable-trap!
+ delete-trap!
+
+ with-default-trap-handler
+ install-trap-handler!
+
+ add-trap-at-procedure-call!
+ add-trace-at-procedure-call!
+ add-trap-at-source-location!
+ add-ephemeral-trap-at-frame-finish!
+ add-ephemeral-stepping-trap!))
+
+(define %default-trap-handler (make-fluid))
+
+(define (default-trap-handler frame idx trap-name)
+ (let ((default-handler (fluid-ref %default-trap-handler)))
+ (if default-handler
+ (default-handler frame idx trap-name)
+ (warn "Trap with no handler installed" frame idx trap-name))))
+
+(define-record <trap-wrapper>
+ index
+ enabled?
+ trap
+ name)
+
+(define-record <trap-state>
+ (handler default-trap-handler)
+ (next-idx 0)
+ (next-ephemeral-idx -1)
+ (wrappers '()))
+
+(define (trap-wrapper<? t1 t2)
+ (< (trap-wrapper-index t1) (trap-wrapper-index t2)))
+
+;; The interface that a trap provides to the outside world is that of a
+;; procedure, which when called disables the trap, and returns a
+;; procedure to enable the trap. Perhaps this is a bit too odd and we
+;; should fix this.
+(define (enable-trap-wrapper! wrapper)
+ (if (trap-wrapper-enabled? wrapper)
+ (error "Trap already enabled" (trap-wrapper-index wrapper))
+ (let ((trap (trap-wrapper-trap wrapper)))
+ (set! (trap-wrapper-trap wrapper) (trap))
+ (set! (trap-wrapper-enabled? wrapper) #t))))
+
+(define (disable-trap-wrapper! wrapper)
+ (if (not (trap-wrapper-enabled? wrapper))
+ (error "Trap already disabled" (trap-wrapper-index wrapper))
+ (let ((trap (trap-wrapper-trap wrapper)))
+ (set! (trap-wrapper-trap wrapper) (trap))
+ (set! (trap-wrapper-enabled? wrapper) #f))))
+
+(define (add-trap-wrapper! trap-state wrapper)
+ (set! (trap-state-wrappers trap-state)
+ (append (trap-state-wrappers trap-state) (list wrapper)))
+ (trap-wrapper-index wrapper))
+
+(define (remove-trap-wrapper! trap-state wrapper)
+ (set! (trap-state-wrappers trap-state)
+ (delq wrapper (trap-state-wrappers trap-state))))
+
+(define (trap-state->trace-level trap-state)
+ (fold (lambda (wrapper level)
+ (if (trap-wrapper-enabled? wrapper)
+ (1+ level)
+ level))
+ 0
+ (trap-state-wrappers trap-state)))
+
+(define (wrapper-at-index trap-state idx)
+ (let lp ((wrappers (trap-state-wrappers trap-state)))
+ (cond
+ ((null? wrappers)
+ (warn "no wrapper found with index in trap-state" idx)
+ #f)
+ ((eqv? (trap-wrapper-index (car wrappers)) idx)
+ (car wrappers))
+ (else
+ (lp (cdr wrappers))))))
+
+(define (next-index! trap-state)
+ (let ((idx (trap-state-next-idx trap-state)))
+ (set! (trap-state-next-idx trap-state) (1+ idx))
+ idx))
+
+(define (next-ephemeral-index! trap-state)
+ (let ((idx (trap-state-next-ephemeral-idx trap-state)))
+ (set! (trap-state-next-ephemeral-idx trap-state) (1- idx))
+ idx))
+
+(define (handler-for-index trap-state idx)
+ (lambda (frame)
+ (let ((wrapper (wrapper-at-index trap-state idx))
+ (handler (trap-state-handler trap-state)))
+ (if wrapper
+ (handler frame
+ (trap-wrapper-index wrapper)
+ (trap-wrapper-name wrapper))))))
+
+(define (ephemeral-handler-for-index trap-state idx handler)
+ (lambda (frame)
+ (let ((wrapper (wrapper-at-index trap-state idx)))
+ (if wrapper
+ (begin
+ (if (trap-wrapper-enabled? wrapper)
+ (disable-trap-wrapper! wrapper))
+ (remove-trap-wrapper! trap-state wrapper)
+ (handler frame))))))
+
+
+
+;;;
+;;; Per-thread trap states
+;;;
+
+;; FIXME: This should be thread-local -- not something you can inherit
+;; from a dynamic state.
+
+(define %trap-state (make-parameter #f))
+
+(define (the-trap-state)
+ (or (%trap-state)
+ (let ((ts (make-trap-state)))
+ (%trap-state ts)
+ ts)))
+
+
+
+;;;
+;;; API
+;;;
+
+(define* (with-default-trap-handler handler thunk
+ #:optional (trap-state (the-trap-state)))
+ (with-fluids ((%default-trap-handler handler))
+ (dynamic-wind
+ (lambda ()
+ ;; Don't enable hooks if the handler is #f.
+ (if handler
+ (set-vm-trace-level! (trap-state->trace-level trap-state))))
+ thunk
+ (lambda ()
+ (if handler
+ (set-vm-trace-level! 0))))))
+
+(define* (list-traps #:optional (trap-state (the-trap-state)))
+ (map trap-wrapper-index (trap-state-wrappers trap-state)))
+
+(define* (trap-name idx #:optional (trap-state (the-trap-state)))
+ (and=> (wrapper-at-index trap-state idx)
+ trap-wrapper-name))
+
+(define* (trap-enabled? idx #:optional (trap-state (the-trap-state)))
+ (and=> (wrapper-at-index trap-state idx)
+ trap-wrapper-enabled?))
+
+(define* (enable-trap! idx #:optional (trap-state (the-trap-state)))
+ (and=> (wrapper-at-index trap-state idx)
+ enable-trap-wrapper!))
+
+(define* (disable-trap! idx #:optional (trap-state (the-trap-state)))
+ (and=> (wrapper-at-index trap-state idx)
+ disable-trap-wrapper!))
+
+(define* (delete-trap! idx #:optional (trap-state (the-trap-state)))
+ (and=> (wrapper-at-index trap-state idx)
+ (lambda (wrapper)
+ (if (trap-wrapper-enabled? wrapper)
+ (disable-trap-wrapper! wrapper))
+ (remove-trap-wrapper! trap-state wrapper))))
+
+(define* (install-trap-handler! handler #:optional (trap-state (the-trap-state)))
+ (set! (trap-state-handler trap-state) handler))
+
+(define* (add-trap-at-procedure-call! proc #:optional (trap-state (the-trap-state)))
+ (let* ((idx (next-index! trap-state))
+ (trap (trap-at-procedure-call
+ proc
+ (handler-for-index trap-state idx))))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper
+ idx #t trap
+ (format #f "Breakpoint at ~a" proc)))))
+
+(define* (add-trace-at-procedure-call! proc
+ #:optional (trap-state (the-trap-state)))
+ (let* ((idx (next-index! trap-state))
+ (trap (trace-calls-to-procedure
+ proc
+ #:prefix (format #f "Trap ~a: " idx))))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper
+ idx #t trap
+ (format #f "Tracepoint at ~a" proc)))))
+
+(define* (add-trap-at-source-location! file user-line
+ #:optional (trap-state (the-trap-state)))
+ (let* ((idx (next-index! trap-state))
+ (trap (trap-at-source-location file user-line
+ (handler-for-index trap-state idx))))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper
+ idx #t trap
+ (format #f "Breakpoint at ~a:~a" file user-line)))))
+
+;; handler := frame -> nothing
+(define* (add-ephemeral-trap-at-frame-finish! frame handler
+ #:optional (trap-state
+ (the-trap-state)))
+ (let* ((idx (next-ephemeral-index! trap-state))
+ (trap (trap-frame-finish
+ frame
+ (ephemeral-handler-for-index trap-state idx handler)
+ (lambda (frame) (delete-trap! idx trap-state)))))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper
+ idx #t trap
+ (format #f "Return from ~a" frame)))))
+
+(define (source-string source)
+ (if source
+ (format #f "~a:~a:~a" (or (source:file source) "unknown file")
+ (source:line-for-user source) (source:column source))
+ "unknown source location"))
+
+(define* (add-ephemeral-stepping-trap! frame handler
+ #:optional (trap-state
+ (the-trap-state))
+ #:key (into? #t) (instruction? #f))
+ (define (wrap-predicate-according-to-into predicate)
+ (if into?
+ predicate
+ (let ((fp (frame-address frame)))
+ (lambda (f)
+ (and (<= (frame-address f) fp)
+ (predicate f))))))
+
+ (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-source f) source)))))
+ (ephemeral-handler-for-index trap-state idx handler))))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper
+ idx #t trap
+ (if instruction?
+ (if into?
+ "Step to different instruction"
+ (format #f "Step to different instruction in ~a" frame))
+ (if into?
+ (format #f "Step into ~a" (source-string source))
+ (format #f "Step out of ~a" (source-string source))))))))
+
+(define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
+ (let* ((idx (next-index! trap-state)))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper idx #t trap name))))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
new file mode 100644
index 000000000..76be8d7d3
--- /dev/null
+++ b/module/system/vm/traps.scm
@@ -0,0 +1,623 @@
+;;; Traps: stepping, breakpoints, and such.
+
+;; Copyright (C) 2010,2012-2014,2017-2018 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 debugging capabilities come from the hooks that its VM
+;;; provides. For example, there is a hook that is fired when a function
+;;; is called, and even a hook that gets fired at every retired
+;;; instruction.
+;;;
+;;; But as the firing of these hooks is interleaved with the program
+;;; execution, if we want to debug a program, we have to write an
+;;; imperative program that mutates the state of these hooks, and to
+;;; dispatch the hooks to a more semantic context.
+;;;
+;;; For example if we have placed a breakpoint at foo.scm:38, and
+;;; determined that that location maps to the 18th instruction in
+;;; procedure `bar', then we will need per-instruction hooks within
+;;; `bar' -- but when running other procedures, we can have the
+;;; per-instruction hooks off.
+;;;
+;;; Our approach is to define "traps". The behavior of a trap is
+;;; specified when the trap is created. After creation, traps expose a
+;;; limited, uniform interface: they are either on or off.
+;;;
+;;; To take our foo.scm:38 example again, we can define a trap that
+;;; calls a function when control transfers to that source line --
+;;; trap-at-source-location below. Calling the trap-at-source-location
+;;; function adds to the VM hooks in such at way that it can do its job.
+;;; The result of calling the function is a "disable-hook" closure that,
+;;; when called, will turn off that trap.
+;;;
+;;; The result of calling the "disable-hook" closure, in turn, is an
+;;; "enable-hook" closure, which when called turns the hook back on, and
+;;; returns a "disable-hook" closure.
+;;;
+;;; It's a little confusing. The summary is, call these functions to add
+;;; a trap; and call their return value to disable the trap.
+;;;
+;;; Code:
+
+(define-module (system vm traps)
+ #:use-module (ice-9 match)
+ #:use-module (system vm vm)
+ #:use-module (system vm debug)
+ #:use-module (system vm frame)
+ #:use-module (system vm program)
+ #:use-module (system xref)
+ #:use-module (rnrs bytevectors)
+ #:export (trap-at-procedure-call
+ trap-in-procedure
+ trap-instructions-in-procedure
+ trap-at-procedure-ip-in-range
+ trap-at-source-location
+ trap-frame-finish
+ trap-in-dynamic-extent
+ trap-calls-in-dynamic-extent
+ trap-instructions-in-dynamic-extent
+ trap-calls-to-procedure
+ trap-matching-instructions))
+
+(define-syntax arg-check
+ (syntax-rules ()
+ ((_ arg predicate? message)
+ (if (not (predicate? arg))
+ (error "bad argument ~a: ~a" 'arg message)))
+ ((_ arg predicate?)
+ (if (not (predicate? arg))
+ (error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
+
+(define (new-disabled-trap enable disable)
+ (let ((enabled? #f))
+ (define-syntax disabled?
+ (identifier-syntax
+ (disabled? (not enabled?))
+ ((set! disabled? val) (set! enabled? (not val)))))
+
+ (define* (enable-trap #:optional frame)
+ (if enabled? (error "trap already enabled"))
+ (enable frame)
+ (set! enabled? #t)
+ disable-trap)
+
+ (define* (disable-trap #:optional frame)
+ (if disabled? (error "trap already disabled"))
+ (disable frame)
+ (set! disabled? #t)
+ enable-trap)
+
+ enable-trap))
+
+(define (new-enabled-trap frame enable disable)
+ ((new-disabled-trap enable disable) frame))
+
+;; Returns an absolute IP.
+(define (program-last-ip prog)
+ (let ((pdi (find-program-debug-info (program-code prog))))
+ (and pdi
+ (+ (program-debug-info-addr pdi)
+ (program-debug-info-size pdi)))))
+
+(define (frame-matcher proc)
+ (let ((proc (if (struct? proc)
+ (procedure proc)
+ proc)))
+ (cond
+ ((program? proc)
+ (let ((start (program-code proc))
+ (end (program-last-ip proc)))
+ (lambda (frame)
+ (let ((ip (frame-instruction-pointer frame)))
+ (and (<= start ip)
+ end (< ip end))))))
+ ((struct? proc)
+ (frame-matcher (procedure proc)))
+ (else
+ (error "Not a VM program" proc)))))
+
+;; A basic trap, fires when a procedure is called.
+;;
+(define* (trap-at-procedure-call proc handler #:key
+ (our-frame? (frame-matcher proc)))
+ (arg-check proc procedure?)
+ (arg-check handler procedure?)
+ (let ()
+ (define (apply-hook frame)
+ (if (our-frame? frame)
+ (handler frame)))
+
+ (new-enabled-trap
+ #f
+ (lambda (frame)
+ (vm-add-apply-hook! apply-hook))
+ (lambda (frame)
+ (vm-remove-apply-hook! apply-hook)))))
+
+;; A more complicated trap, traps when control enters a procedure.
+;;
+;; Control can enter a procedure via:
+;; * A procedure call.
+;; * A return to a procedure's frame on the stack.
+;; * A continuation returning directly to an application of this
+;; procedure.
+;;
+;; Control can leave a procedure via:
+;; * A normal return from the procedure.
+;; * An application of another procedure.
+;; * An invocation of a continuation.
+;; * An abort.
+;;
+(define* (trap-in-procedure proc enter-handler exit-handler
+ #:key current-frame
+ (our-frame? (frame-matcher proc)))
+ (arg-check proc procedure?)
+ (arg-check enter-handler procedure?)
+ (arg-check exit-handler procedure?)
+ (let ((in-proc? #f))
+ (define (enter-proc frame)
+ (if in-proc?
+ (warn "already in proc" frame)
+ (begin
+ (enter-handler frame)
+ (set! in-proc? #t))))
+
+ (define (exit-proc frame)
+ (if in-proc?
+ (begin
+ (exit-handler frame)
+ (set! in-proc? #f))
+ (warn "not in proc" frame)))
+
+ (define (apply-hook frame)
+ (if in-proc?
+ (exit-proc frame))
+ (if (our-frame? frame)
+ (enter-proc frame)))
+
+ (define (return-hook frame)
+ (if in-proc?
+ (exit-proc frame))
+ (let ((prev (frame-previous frame)))
+ (if (our-frame? prev)
+ (enter-proc prev))))
+
+ (define (abort-hook frame)
+ (if in-proc?
+ (exit-proc frame))
+ (if (our-frame? frame)
+ (enter-proc frame)))
+
+ (new-enabled-trap
+ current-frame
+ (lambda (frame)
+ (vm-add-apply-hook! apply-hook)
+ (vm-add-return-hook! return-hook)
+ (vm-add-abort-hook! abort-hook)
+ (if (and frame (our-frame? frame))
+ (enter-proc frame)))
+ (lambda (frame)
+ (if in-proc?
+ (exit-proc frame))
+ (vm-remove-apply-hook! apply-hook)
+ (vm-remove-return-hook! return-hook)
+ (vm-remove-abort-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
+ (our-frame? (frame-matcher proc)))
+ (arg-check proc procedure?)
+ (arg-check next-handler procedure?)
+ (arg-check exit-handler procedure?)
+ (let ()
+ (define (next-hook frame)
+ (if (our-frame? frame)
+ (next-handler frame)))
+
+ (define (enter frame)
+ (vm-add-next-hook! next-hook)
+ (if frame (next-hook frame)))
+
+ (define (exit frame)
+ (exit-handler frame)
+ (vm-remove-next-hook! next-hook))
+
+ (trap-in-procedure proc enter exit
+ #:current-frame current-frame
+ #:our-frame? our-frame?)))
+
+(define (non-negative-integer? x)
+ (and (number? x) (integer? x) (exact? x) (not (negative? x))))
+
+(define (positive-integer? x)
+ (and (number? x) (integer? x) (exact? x) (positive? x)))
+
+(define (range? x)
+ (and (list? x)
+ (and-map (lambda (x)
+ (and (pair? x)
+ (non-negative-integer? (car x))
+ (non-negative-integer? (cdr x))))
+ x)))
+
+(define (in-range? range i)
+ (or-map (lambda (bounds)
+ (and (<= (car bounds) i)
+ (< i (cdr bounds))))
+ range))
+
+;; Building on trap-instructions-in-procedure, we have
+;; trap-at-procedure-ip-in-range.
+;;
+(define* (trap-at-procedure-ip-in-range proc range handler
+ #:key current-frame
+ (our-frame? (frame-matcher proc)))
+ (arg-check proc procedure?)
+ (arg-check range range?)
+ (arg-check handler procedure?)
+ (let ((fp-stack '()))
+ (define (cull-frames! fp)
+ (let lp ((frames fp-stack))
+ (if (and (pair? frames) (< (car frames) fp))
+ (lp (cdr frames))
+ (set! fp-stack frames))))
+
+ (define (next-handler frame)
+ (let ((fp (frame-address frame))
+ (ip (frame-instruction-pointer frame)))
+ (cull-frames! fp)
+ (let ((now-in-range? (in-range? range ip))
+ (was-in-range? (and (pair? fp-stack) (= (car fp-stack) fp))))
+ (cond
+ (was-in-range?
+ (if (not now-in-range?)
+ (set! fp-stack (cdr fp-stack))))
+ (now-in-range?
+ (set! fp-stack (cons fp fp-stack))
+ (handler frame))))))
+
+ (define (exit-handler frame)
+ (if (and (pair? fp-stack)
+ (= (car fp-stack) (frame-address frame)))
+ (set! fp-stack (cdr fp-stack))))
+
+ (trap-instructions-in-procedure proc next-handler exit-handler
+ #:current-frame current-frame
+ #:our-frame? our-frame?)))
+
+(define (program-sources-by-line proc file)
+ (cond
+ ((program? proc)
+ (let ((code (program-code proc)))
+ (let lp ((sources (program-sources proc))
+ (out '()))
+ (match sources
+ (((start-ip start-file start-line . start-col) . sources)
+ (lp sources
+ (if (equal? start-file file)
+ (acons start-line
+ (cons (+ start-ip code)
+ (match sources
+ (((end-ip . _) . _)
+ (+ end-ip code))
+ (()
+ (program-last-ip proc))))
+ out)
+ out)))
+ (()
+ (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)
+ (cond
+ ((= (car line-and-ranges) line)
+ (cdr line-and-ranges))
+ ((> (car line-and-ranges) line)
+ (warn "no instructions found at" file ":" line
+ "; using line" (car line-and-ranges) "instead")
+ (cdr line-and-ranges))
+ (else #f)))
+ (program-sources-by-line proc file))
+ (begin
+ (warn "no instructions found for" file ":" line)
+ '())))
+
+(define (source-closures-or-procedures file line)
+ (let ((closures (source-closures file line)))
+ (if (pair? closures)
+ (values closures #t)
+ (values (source-procedures file line) #f))))
+
+;; Building on trap-on-instructions-in-procedure, we have
+;; 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)
+ (arg-check file string?)
+ (arg-check user-line positive-integer?)
+ (arg-check handler procedure?)
+ (let ((traps #f))
+ (call-with-values
+ (lambda () (source-closures-or-procedures file (1- user-line)))
+ (lambda (procs closures?)
+ (new-enabled-trap
+ current-frame
+ (lambda (frame)
+ (set! traps
+ (map
+ (lambda (proc)
+ (let ((range (source->ip-range proc file (1- user-line))))
+ (trap-at-procedure-ip-in-range proc range handler
+ #:current-frame
+ current-frame)))
+ procs))
+ (if (null? traps)
+ (error "No procedures found at ~a:~a." file user-line)))
+ (lambda (frame)
+ (for-each (lambda (trap) (trap frame)) traps)
+ (set! traps #f)))))))
+
+
+
+;; On a different tack, now we're going to build up a set of traps that
+;; 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)
+ (arg-check frame frame?)
+ (arg-check return-handler procedure?)
+ (arg-check abort-handler procedure?)
+ (let ((fp (frame-address frame)))
+ (define (return-hook frame)
+ (if (and fp (<= (frame-address frame) fp))
+ (begin
+ (set! fp #f)
+ (return-handler frame))))
+
+ (define (abort-hook frame)
+ (if (and fp (<= (frame-address frame) fp))
+ (begin
+ (set! fp #f)
+ (abort-handler frame))))
+
+ (new-enabled-trap
+ frame
+ (lambda (frame)
+ (if (not fp)
+ (error "return-or-abort traps may only be enabled once"))
+ (vm-add-return-hook! return-hook)
+ (vm-add-abort-hook! abort-hook))
+ (lambda (frame)
+ (set! fp #f)
+ (vm-remove-return-hook! return-hook)
+ (vm-remove-abort-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
+ (our-frame? (frame-matcher proc)))
+ (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)
+ (exit-trap frame) ; disable the return/abort trap.
+ (set! exit-trap #f)
+ (return-handler frame))
+
+ (define (abort-hook frame)
+ (exit-trap frame) ; disable the return/abort trap.
+ (set! exit-trap #f)
+ (abort-handler frame))
+
+ (define (apply-hook frame)
+ (if (and (not exit-trap) (our-frame? frame))
+ (begin
+ (enter-handler frame)
+ (set! exit-trap
+ (trap-frame-finish frame return-hook abort-hook)))))
+
+ (new-enabled-trap
+ current-frame
+ (lambda (frame)
+ (vm-add-apply-hook! apply-hook))
+ (lambda (frame)
+ (if exit-trap
+ (abort-hook frame))
+ (set! exit-trap #f)
+ (vm-remove-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
+ (our-frame? (frame-matcher proc)))
+ (arg-check proc procedure?)
+ (arg-check apply-handler procedure?)
+ (arg-check return-handler procedure?)
+ (let ((*stack* '()))
+ (define (trace-return frame)
+ (let ((fp* (frame-address frame)))
+ (let lp ((stack *stack*))
+ (match stack
+ (() (values))
+ ((fp . stack)
+ (cond
+ ((> fp fp*)
+ (set! *stack* stack)
+ (lp stack))
+ ((= fp fp*) (set! *stack* stack))
+ ((< fp fp*) (values)))))))
+ (return-handler frame (1+ (length *stack*))))
+
+ (define (trace-apply frame)
+ (let ((fp* (frame-address frame)))
+ (define (same-fp? fp) (= fp fp*))
+ (define (newer-fp? fp) (> fp fp*))
+ (let lp ((stack *stack*))
+ (match stack
+ (((? same-fp?) . stack)
+ ;; A tail call, nothing to do.
+ (values))
+ (((? newer-fp?) . stack)
+ ;; Unless there are continuations, we shouldn't get here.
+ (set! *stack* stack)
+ (lp stack))
+ (stack
+ (set! *stack* (cons fp* stack))))))
+ (apply-handler frame (length *stack*)))
+
+ (define (enter frame)
+ (vm-add-return-hook! trace-return)
+ (vm-add-apply-hook! trace-apply))
+
+ (define (leave frame)
+ (vm-remove-return-hook! trace-return)
+ (vm-remove-apply-hook! trace-apply))
+
+ (define (return frame)
+ (leave frame))
+
+ (define (abort frame)
+ (leave frame))
+
+ (trap-in-dynamic-extent proc enter return abort
+ #: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
+ (our-frame? (frame-matcher proc)))
+ (arg-check proc procedure?)
+ (arg-check next-handler procedure?)
+ (let ()
+ (define (trace-next frame)
+ (next-handler frame))
+
+ (define (enter frame)
+ (vm-add-next-hook! trace-next))
+
+ (define (leave frame)
+ (vm-remove-next-hook! trace-next))
+
+ (define (return frame)
+ (leave frame))
+
+ (define (abort frame)
+ (leave frame))
+
+ (trap-in-dynamic-extent proc enter return abort
+ #: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)
+ (arg-check proc procedure?)
+ (arg-check apply-handler procedure?)
+ (arg-check return-handler procedure?)
+ (let ((pending-finish-traps '())
+ (last-fp #f))
+ (define (apply-hook frame)
+ (let ((depth (length pending-finish-traps)))
+
+ (apply-handler frame depth)
+
+ (if (not (eqv? (frame-address frame) last-fp))
+ (let ((finish-trap #f))
+ (define (frame-finished frame)
+ (finish-trap frame) ;; disables the trap.
+ (set! pending-finish-traps
+ (delq finish-trap pending-finish-traps))
+ (set! finish-trap #f))
+
+ (define (return-hook frame)
+ (frame-finished frame)
+ (return-handler frame depth))
+
+ ;; FIXME: abort handler?
+ (define (abort-hook frame)
+ (frame-finished frame))
+
+ (set! finish-trap
+ (trap-frame-finish frame return-hook abort-hook))
+ (set! pending-finish-traps
+ (cons finish-trap pending-finish-traps))))))
+
+ ;; The basic idea is that we install one trap that fires for calls,
+ ;; but that each call installs its own finish trap. Those finish
+ ;; traps remove themselves as their frames finish or abort.
+ ;;
+ ;; However since to the outside world we present the interface of
+ ;; just being one trap, disabling this calls-to-procedure trap
+ ;; should take care of disabling all of the pending finish traps. We
+ ;; keep track of pending traps through the pending-finish-traps
+ ;; list.
+ ;;
+ ;; So since we know that the trap-at-procedure will be enabled, and
+ ;; thus returning a disable closure, we make sure to wrap that
+ ;; closure in something that will disable pending finish traps.
+ (define (with-pending-finish-disablers trap)
+ (define (with-pending-finish-enablers trap)
+ (lambda* (#:optional frame)
+ (with-pending-finish-disablers (trap frame))))
+
+ (lambda* (#:optional frame)
+ (for-each (lambda (disable) (disable frame))
+ pending-finish-traps)
+ (set! pending-finish-traps '())
+ (with-pending-finish-enablers (trap frame))))
+
+ (with-pending-finish-disablers
+ (trap-at-procedure-call proc apply-hook))))
+
+;; Trap when the source location changes.
+;;
+(define (trap-matching-instructions frame-pred handler)
+ (arg-check frame-pred procedure?)
+ (arg-check handler procedure?)
+ (let ()
+ (define (next-hook frame)
+ (if (frame-pred frame)
+ (handler frame)))
+
+ (new-enabled-trap
+ #f
+ (lambda (frame)
+ (vm-add-next-hook! next-hook))
+ (lambda (frame)
+ (vm-remove-next-hook! next-hook)))))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
new file mode 100644
index 000000000..91b862d20
--- /dev/null
+++ b/module/system/vm/vm.scm
@@ -0,0 +1,32 @@
+;;; Guile VM core
+
+;;; Copyright (C) 2001,2009-2010,2013-2014,2018 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 vm)
+ #:export (call-with-vm
+ call-with-stack-overflow-handler
+ vm-trace-level set-vm-trace-level!
+ vm-engine set-vm-engine! set-default-vm-engine!
+ vm-add-apply-hook! vm-add-return-hook!
+ vm-add-next-hook! vm-add-abort-hook!
+ vm-remove-apply-hook! vm-remove-return-hook!
+ vm-remove-next-hook! vm-remove-abort-hook!))
+
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_vm")