summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
Diffstat (limited to 'module/system')
-rw-r--r--module/system/vm/assembler.scm65
-rw-r--r--module/system/vm/debug.scm45
-rw-r--r--module/system/vm/program.scm10
3 files changed, 112 insertions, 8 deletions
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 51777287f..556f58920 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1411,8 +1411,69 @@ it will be added to the GC roots at runtime."
(linker-object-section strtab)))
strtab))))
+;;;
+;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
+;;; values. Pc and addr are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; addr is the address of the associated properties alist, relative to
+;;; the start of the ELF image.
+;;;
+;;; Since procedure properties are stored in the data sections, we need
+;;; to link the procedures property section first. (Note that this
+;;; constraint does not apply to the arities section, which may
+;;; reference the data sections via the kw-indices literal, because
+;;; assembling the text section already makes sure that the kw-indices
+;;; are interned.)
+;;;
+
+;; The size of a procprops entry, in bytes.
+(define procprops-size 8)
+
+(define (link-procprops asm)
+ (define (assoc-remove-one alist key value-pred)
+ (match alist
+ (() '())
+ ((((? (lambda (x) (eq? x key))) . value) . alist)
+ (if (value-pred value)
+ alist
+ (acons key value alist)))
+ (((k . v) . alist)
+ (acons k v (assoc-remove-one alist key value-pred)))))
+ (define (props-without-name-or-docstring meta)
+ (assoc-remove-one
+ (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
+ 'documentation
+ string?))
+ (define (find-procprops)
+ (filter-map (lambda (meta)
+ (let ((props (props-without-name-or-docstring meta)))
+ (and (pair? props)
+ (cons (meta-low-pc meta) props))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (procprops (find-procprops))
+ (bv (make-bytevector (* (length procprops) procprops-size) 0)))
+ (let lp ((procprops procprops) (pos 0) (relocs '()))
+ (match procprops
+ (()
+ (make-object asm '.guile.procprops
+ bv
+ relocs '()
+ #:type SHT_PROGBITS #:flags 0))
+ (((pc . props) . procprops)
+ (bytevector-u32-set! bv pos pc endianness)
+ (lp procprops
+ (+ pos procprops-size)
+ (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
+ (intern-constant asm props))
+ relocs)))))))
+
(define (link-objects asm)
- (let*-values (((ro rw rw-init) (link-constants 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))
@@ -1425,7 +1486,7 @@ it will be added to the GC roots at runtime."
((shstrtab) (link-shstrtab asm)))
(filter identity
(list text ro rw dt symtab strtab arities arities-strtab
- docstrs docstrs-strtab shstrtab))))
+ docstrs docstrs-strtab procprops shstrtab))))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index cee0892c7..c70f7c5b1 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -58,7 +58,9 @@
find-program-arities
program-minimum-arity
- find-program-docstring))
+ find-program-docstring
+
+ find-program-properties))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -364,3 +366,44 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(elf-section-link sec)))
(idx (bytevector-u32-native-ref bv (+ pos 4))))
(string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
+
+(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
+ ((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))
+ (end (+ start (elf-section-size 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)))
+ ;; FIXME: This is linear search. Change to binary search.
+ (let lp ((pos start))
+ (cond
+ ((>= pos end) '())
+ ((< text-offset (bytevector-u32-native-ref bv pos))
+ (lp (+ pos procprop-len)))
+ ((> text-offset (bytevector-u32-native-ref bv pos))
+ '())
+ (else
+ (load-non-immediate
+ (bytevector-u32-native-ref bv (+ pos 4))))))))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index d719e954c..267e373c5 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -54,24 +54,24 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
-;; This procedure is called by programs.c.
+;; These procedures are called by programs.c.
(define (rtl-program-name program)
(unless (rtl-program? program)
(error "shouldn't get here"))
(and=> (find-program-debug-info (rtl-program-code program))
program-debug-info-name))
-
-;; This procedure is called by programs.c.
(define (rtl-program-documentation program)
(unless (rtl-program? program)
(error "shouldn't get here"))
(find-program-docstring (rtl-program-code program)))
-
-;; This procedure is called by programs.c.
(define (rtl-program-minimum-arity program)
(unless (rtl-program? program)
(error "shouldn't get here"))
(program-minimum-arity (rtl-program-code program)))
+(define (rtl-program-properties program)
+ (unless (rtl-program? program)
+ (error "shouldn't get here"))
+ (find-program-properties (rtl-program-code program)))
(define (make-binding name boxed? index start end)
(list name boxed? index start end))