diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-09 16:02:13 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-09 16:02:13 +0100 |
commit | d8595af55502d8e8fd8f48c0ef38201788ea9d60 (patch) | |
tree | 92603174eded2b90b52cf21893fb4977fbf86f3e | |
parent | 695e6b75515f87ec7ddca03d3d437bd8bf93130a (diff) | |
download | guile-d8595af55502d8e8fd8f48c0ef38201788ea9d60.tar.gz |
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.
-rw-r--r-- | module/system/vm/assembler.scm | 26 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 35 |
2 files changed, 36 insertions, 25 deletions
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 9f40221c0..b15a89307 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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 diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 17131b5e5..ce7950a91 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -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) |