diff options
Diffstat (limited to 'module/system/vm')
-rw-r--r-- | module/system/vm/assembler.scm | 2850 | ||||
-rw-r--r-- | module/system/vm/coverage.scm | 350 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 767 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 643 | ||||
-rw-r--r-- | module/system/vm/dwarf.scm | 1852 | ||||
-rw-r--r-- | module/system/vm/elf.scm | 1042 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 463 | ||||
-rw-r--r-- | module/system/vm/inspect.scm | 188 | ||||
-rw-r--r-- | module/system/vm/linker.scm | 733 | ||||
-rw-r--r-- | module/system/vm/loader.scm | 27 | ||||
-rw-r--r-- | module/system/vm/program.scm | 313 | ||||
-rw-r--r-- | module/system/vm/trace.scm | 122 | ||||
-rw-r--r-- | module/system/vm/trap-state.scm | 302 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 623 | ||||
-rw-r--r-- | module/system/vm/vm.scm | 32 |
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") |