summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/vm/debug.scm174
1 files changed, 173 insertions, 1 deletions
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 9522d622f..6f241087d 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -42,8 +42,20 @@
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))
+ find-program-debug-info
+ arity-arguments-alist
+ find-program-arities))
;;; A compiled procedure comes from a specific loaded ELF image. A
;;; debug context identifies that image.
@@ -159,3 +171,163 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
(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)))))))