mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
Finding a procedure's arity uses binary search
* module/system/vm/assembler.scm (pack-arity-flags): (write-arity-headers): Add a flag to indicate that an arity is part of a case-lambda, so that we can use binary search to find arities. * module/system/vm/debug.scm (is-in-case-lambda?) (arity-is-in-case-lambda?, find-first-arity): Use binary search.
This commit is contained in:
parent
695e6b7551
commit
d8595af555
2 changed files with 36 additions and 25 deletions
|
@ -1322,6 +1322,7 @@ it will be added to the GC roots at runtime."
|
|||
;;; #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
|
||||
|
@ -1341,10 +1342,10 @@ it will be added to the GC roots at runtime."
|
|||
;;; 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. 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.
|
||||
;;; 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)
|
||||
|
@ -1356,11 +1357,13 @@ it will be added to the GC roots at runtime."
|
|||
(define arity-header-offset-offset (* 2 4))
|
||||
|
||||
(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
|
||||
has-keyword-args? is-case-lambda?)
|
||||
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-case-lambda? (ash 1 3) 0)
|
||||
(if is-in-case-lambda? (ash 1 4) 0)))
|
||||
|
||||
(define (meta-arities-size meta)
|
||||
(define (lambda-size arity)
|
||||
|
@ -1387,13 +1390,14 @@ it will be added to the GC roots at runtime."
|
|||
(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)
|
||||
(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)
|
||||
#f
|
||||
in-case-lambda?)
|
||||
(length (arity-req arity))
|
||||
(length (arity-opt arity))))
|
||||
(let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
|
||||
|
@ -1406,7 +1410,7 @@ it will be added to the GC roots at runtime."
|
|||
(match (meta-arities meta)
|
||||
(() (lp metas pos offsets))
|
||||
((arity)
|
||||
(write-arity-header pos arity)
|
||||
(write-arity-header pos arity #f)
|
||||
(lp metas
|
||||
(+ pos arity-header-len)
|
||||
(acons arity (+ pos arity-header-offset-offset) offsets)))
|
||||
|
@ -1414,13 +1418,13 @@ it will be added to the GC roots at runtime."
|
|||
;; 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) 0 0)
|
||||
(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)
|
||||
(write-arity-header pos arity #t)
|
||||
(lp* arities
|
||||
(+ pos arity-header-len)
|
||||
(acons arity
|
||||
|
|
|
@ -272,11 +272,13 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
|||
;;; #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)))
|
||||
|
@ -308,6 +310,7 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
|||
(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))))
|
||||
|
@ -358,19 +361,24 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
|||
(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))
|
||||
#f)
|
||||
((<= (arity-high-pc* bv pos) text-offset)
|
||||
(lp (+ pos arity-header-len)))
|
||||
(else
|
||||
(make-arity context base pos))))))
|
||||
(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)))
|
||||
|
@ -391,7 +399,6 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}."
|
|||
(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)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue