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