mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
eb2bc00fb3
* libguile/procprop.c (scm_i_procedure_arity): Allow RTL programs to
dispatch to scm_i_program_arity.
* libguile/programs.c (scm_i_program_print): Refactor reference to
write-program.
(scm_i_rtl_program_minimum_arity): New procedure, dispatches to
Scheme.
(scm_i_program_arity): Dispatch to scm_i_rtl_program_minimum_arity if
appropriate.
* module/system/vm/debug.scm (program-minimum-arity): New export.
* module/system/vm/program.scm (rtl-program-minimum-arity): New internal
function.
(program-arguments-alists): New helper, implemented also for RTL
procedures.
(write-program): Refactor a bit, and call program-arguments-alists.
* test-suite/tests/rtl.test ("simply procedure arity"): Add tests that
arities make it all the way to cold ELF and back to warm Guile.
334 lines
13 KiB
Scheme
334 lines
13 KiB
Scheme
;;; 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 RTL 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 objcode)
|
|
#:use-module (system foreign)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-9)
|
|
#:export (debug-context-image
|
|
debug-context-base
|
|
|
|
program-debug-info-name
|
|
program-debug-info-context
|
|
program-debug-info-image
|
|
program-debug-info-offset
|
|
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?
|
|
|
|
find-debug-context
|
|
find-program-debug-info
|
|
arity-arguments-alist
|
|
find-program-arities
|
|
program-minimum-arity))
|
|
|
|
;;; 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)))
|
|
|
|
;;; 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 (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."
|
|
(let* ((bv (find-mapped-elf-image addr))
|
|
(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 (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 ((len (elf-symbol-table-len symtab))
|
|
(strtab (elf-section elf (elf-section-link symtab))))
|
|
;; The symbols should be sorted, but maybe somehow that fails
|
|
;; (for example if multiple objects are relinked together). So,
|
|
;; a modicum of tolerance.
|
|
(define (bisect)
|
|
;; FIXME: Implement.
|
|
#f)
|
|
(define (linear-search)
|
|
(let lp ((n 0))
|
|
(and (< n len)
|
|
(let ((sym (elf-symbol-table-ref elf symtab n strtab)))
|
|
(if (and (<= (elf-symbol-value sym) text-offset)
|
|
(< text-offset (+ (elf-symbol-value sym)
|
|
(elf-symbol-size sym))))
|
|
sym
|
|
(lp (1+ n)))))))
|
|
(or (bisect) (linear-search))))))
|
|
|
|
(define* (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
|
|
((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?
|
|
|
|
(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 (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-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))
|
|
(rest . ,(and (has-rest? flags) (load-symbol (+ 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))))))
|
|
|
|
(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)))
|
|
(headers-start (+ base arities-prefix-len))
|
|
(headers-end (+ base (bytevector-u32-native-ref bv base))))
|
|
;; FIXME: This is linear search. Change to binary search.
|
|
(let lp ((pos headers-start))
|
|
(cond
|
|
((>= pos headers-end) #f)
|
|
((< text-offset (arity-low-pc* bv pos))
|
|
(lp (+ pos arity-header-len)))
|
|
((< (arity-high-pc* bv pos) text-offset)
|
|
#f)
|
|
(else
|
|
(make-arity context base pos))))))
|
|
|
|
(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=>
|
|
(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)))
|
|
;; FIXME: Handle case-lambda arities.
|
|
(cond
|
|
((not first) '())
|
|
((arity-is-case-lambda? first)
|
|
(read-sub-arities context base (arity-header-offset first)))
|
|
(else (list first)))))))
|
|
|
|
(define* (program-minimum-arity addr #:optional
|
|
(context (find-debug-context addr)))
|
|
(and=>
|
|
(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)
|
|
(list 0 0 #t) ;; FIXME: be more precise.
|
|
(list (arity-nreq first)
|
|
(arity-nopt first)
|
|
(arity-has-rest? first)))))))
|