guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-383-g0561107


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-383-g0561107
Date: Sat, 09 Nov 2013 15:30:45 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=056110754ead55733879b0c8a5c0d773f576d5c6

The branch, master has been updated
       via  056110754ead55733879b0c8a5c0d773f576d5c6 (commit)
       via  463469cce7cbbc1e63306dbce6b92229a7c9aee9 (commit)
       via  d81658a7ecccfadeaef3118b311aeec1f6124808 (commit)
       via  d8595af55502d8e8fd8f48c0ef38201788ea9d60 (commit)
       via  695e6b75515f87ec7ddca03d3d437bd8bf93130a (commit)
      from  1b00f4c709016e6026e8baccf9d66f87d259c7a7 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 056110754ead55733879b0c8a5c0d773f576d5c6
Author: Andy Wingo <address@hidden>
Date:   Sat Nov 9 16:25:12 2013 +0100

    Binary search to find procedure properties.
    
    * module/system/vm/debug.scm (find-program-properties): Use binary
      search.

commit 463469cce7cbbc1e63306dbce6b92229a7c9aee9
Author: Andy Wingo <address@hidden>
Date:   Sat Nov 9 16:23:35 2013 +0100

    Fix RTL linking of procedure properties.
    
    * module/system/vm/assembler.scm (link-procprops): Fix procedure
      property embedding in bytecode.

commit d81658a7ecccfadeaef3118b311aeec1f6124808
Author: Andy Wingo <address@hidden>
Date:   Sat Nov 9 16:15:12 2013 +0100

    Binary search to find docstrings.
    
    * module/system/vm/debug.scm (find-program-docstring): Use binary
      search.

commit d8595af55502d8e8fd8f48c0ef38201788ea9d60
Author: Andy Wingo <address@hidden>
Date:   Sat Nov 9 16:02:13 2013 +0100

    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.

commit 695e6b75515f87ec7ddca03d3d437bd8bf93130a
Author: Andy Wingo <address@hidden>
Date:   Sat Nov 9 15:51:54 2013 +0100

    Use binary search in find-elf-symbol
    
    * module/system/vm/debug.scm (binary-search): New helper.
      (find-elf-symbol): Use binary search.

-----------------------------------------------------------------------

Summary of changes:
 module/system/vm/assembler.scm |   28 +++++----
 module/system/vm/debug.scm     |  141 ++++++++++++++++++++++------------------
 2 files changed, 94 insertions(+), 75 deletions(-)

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 9f40221..b2db73e 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
@@ -1575,7 +1579,7 @@ it will be added to the GC roots at runtime."
     (filter-map (lambda (meta)
                   (let ((props (props-without-name-or-docstring meta)))
                     (and (pair? props)
-                         (cons (meta-low-pc meta) props))))
+                         (cons (* 4 (meta-low-pc meta)) props))))
                 (reverse (asm-meta asm))))
   (let* ((endianness (asm-endianness asm))
          (procprops (find-procprops))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index ca6fe07..252c69c 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -180,6 +180,17 @@ to have an ELF image if the program was defined in as a 
stub in C."
   (and=> (find-mapped-elf-image addr)
          debug-context-from-image))
 
+(define-inlinable (binary-search start end inc try failure)
+  (let lp ((start start) (end end))
+    (if (eqv? start end)
+        (failure)
+        (let ((mid (+ start (* inc (floor/ (- end start) (* 2 inc))))))
+          (try mid
+               (lambda ()
+                 (lp start mid))
+               (lambda ()
+                 (lp (+ mid inc) end)))))))
+
 (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
@@ -187,24 +198,19 @@ 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))))))
+     (let ((strtab (elf-section elf (elf-section-link symtab))))
+       (binary-search
+        0 (elf-symbol-table-len symtab) 1
+        (lambda (n continue-before continue-after)
+          (let* ((sym (elf-symbol-table-ref elf symtab n strtab))
+                 (val (elf-symbol-value sym))
+                 (size (elf-symbol-size sym)))
+            (cond
+             ((< text-offset val) (continue-before))
+             ((<= (+ val size) text-offset) (continue-after))
+             (else sym))))
+        (lambda ()
+          #f))))))
 
 (define* (find-program-debug-info addr #:optional
                                   (context (find-debug-context addr)))
@@ -266,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)))
@@ -302,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))))
@@ -352,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)))
@@ -385,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)
@@ -426,25 +439,27 @@ section of the ELF image.  Returns an ELF symbol, or 
@code{#f}."
      ;;   uint32_t pc;
      ;;   uint32_t str;
      ;; }
-     (define docstr-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))))
-       ;; FIXME: This is linear search.  Change to binary search.
-       (let lp ((pos start))
-         (cond
-          ((>= pos end) #f)
-          ((< (bytevector-u32-native-ref bv pos) text-offset)
-           (lp (+ pos docstr-len)))
-          ((= text-offset (bytevector-u32-native-ref bv pos))
-           (let ((strtab (elf-section (debug-context-elf context)
-                                      (elf-section-link sec)))
-                 (idx (bytevector-u32-native-ref bv (+ pos 4))))
-             (string-table-ref bv (+ (elf-section-offset strtab) idx))))
-          (else #f)))))))
+     (let ((start (elf-section-offset sec))
+           (bv (elf-bytes (debug-context-elf context)))
+           (text-offset (- addr
+                           (debug-context-text-base context)
+                           (debug-context-base context))))
+       (binary-search
+        start
+        (+ start (elf-section-size sec))
+        8
+        (lambda (pos continue-before continue-after)
+          (let ((pc (bytevector-u32-native-ref bv pos)))
+            (cond
+             ((< text-offset pc) (continue-before))
+             ((< pc text-offset) (continue-after))
+             (else
+              (let ((strtab (elf-section (debug-context-elf context)
+                                         (elf-section-link sec)))
+                    (idx (bytevector-u32-native-ref bv (+ pos 4))))
+                (string-table-ref bv (+ (elf-section-offset strtab) idx)))))))
+        (lambda ()
+          #f))))))
 
 (define* (find-program-properties addr #:optional
                                   (context (find-debug-context addr)))
@@ -467,7 +482,6 @@ section of the ELF image.  Returns an ELF symbol, or 
@code{#f}."
           ;; }
           (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)
@@ -476,17 +490,18 @@ section of the ELF image.  Returns an ELF symbol, or 
@code{#f}."
               (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)))))))))
+            (binary-search
+             start (+ start (elf-section-size sec)) 8
+             (lambda (pos continue-before continue-after)
+               (let ((pc (bytevector-u32-native-ref bv pos)))
+                 (cond
+                  ((< text-offset pc) (continue-before))
+                  ((< pc text-offset) (continue-after))
+                  (else
+                   (load-non-immediate
+                    (bytevector-u32-native-ref bv (+ pos 4)))))))
+             (lambda ()
+               '())))))
     (else '()))))
 
 (define-record-type <source>


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]