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. release_1-9-13-12-gfe


From: Julian Graham
Subject: [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-12-gfe15364
Date: Fri, 22 Oct 2010 18:48:49 +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=fe15364988b8098e0a35838f13c1cb778cb0d9d9

The branch, master has been updated
       via  fe15364988b8098e0a35838f13c1cb778cb0d9d9 (commit)
      from  3a1a883b632f51bf316195a8a180e2e6c52a3363 (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 fe15364988b8098e0a35838f13c1cb778cb0d9d9
Author: Julian Graham <address@hidden>
Date:   Sun Oct 10 01:35:26 2010 -0400

    Improve performance of R6RS records implementation
    
    Reimplement record-type descriptors as vtables for record structs, saving
    us what was an expensive inspection of a record's vtable layout string to
    determine its type.
    
    * module/rnrs/records/inspection.scm (record-field-mutable?): Check
      mutability using the bit field stored in the record-type descriptor
      instead of the record struct's vtable.
    * module/rnrs/records/procedural.scm (record-internal?): Reimplement as a
      delegation to a check of the passed struct's vtable against
      `record-type-descriptor?'.
      (record-type-vtable): Modify to include base vtable layout as a prefix
      of the record-type-descriptor layout so that all record-type instances
      are now also vtables.
      (make-record-type-descriptor): Remove field vtable; build up a mutability
      bit field to use for fast mutability checks.
      (record-accessor, record-mutator): Use field struct and mutability bit
      field.

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

Summary of changes:
 module/rnrs/records/inspection.scm |   22 +++----
 module/rnrs/records/procedural.scm |  131 ++++++++++++++++++++----------------
 2 files changed, 81 insertions(+), 72 deletions(-)

diff --git a/module/rnrs/records/inspection.scm 
b/module/rnrs/records/inspection.scm
index a142d7c..315ef0c 100644
--- a/module/rnrs/records/inspection.scm
+++ b/module/rnrs/records/inspection.scm
@@ -28,16 +28,15 @@
          record-type-opaque? 
          record-type-field-names 
          record-field-mutable?)
-  (import (rnrs base (6))
+  (import (rnrs arithmetic bitwise (6))
+          (rnrs base (6))
          (rnrs conditions (6))
           (rnrs exceptions (6))
          (rnrs records procedural (6))
-         (only (guile) struct-ref vtable-index-layout @@))
+         (only (guile) struct-ref struct-vtable vtable-index-layout @@))
 
   (define record-internal? (@@ (rnrs records procedural) record-internal?))
 
-  (define record-index-rtd (@@ (rnrs records procedural) record-index-rtd))
-
   (define rtd-index-name (@@ (rnrs records procedural) rtd-index-name))
   (define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent))
   (define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid))
@@ -45,16 +44,16 @@
   (define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?))
   (define rtd-index-field-names 
     (@@ (rnrs records procedural) rtd-index-field-names))
-  (define rtd-index-field-vtable 
-    (@@ (rnrs records procedural) rtd-index-field-vtable))
+  (define rtd-index-field-bit-field
+    (@@ (rnrs records procedural) rtd-index-field-bit-field))
 
   (define (record? obj)
-    (and (record-internal? obj) 
-        (not (record-type-opaque? (struct-ref obj record-index-rtd)))))
+    (and (record-internal? obj)
+        (not (record-type-opaque? (struct-vtable obj)))))
 
   (define (record-rtd record)
     (or (and (record-internal? record)
-            (let ((rtd (struct-ref record record-index-rtd)))
+            (let ((rtd (struct-vtable record)))
               (and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
        (raise (make-assertion-violation))))
 
@@ -76,8 +75,5 @@
     (ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
   (define (record-field-mutable? rtd k)
     (ensure-rtd rtd)
-    (let ((vt (struct-ref rtd rtd-index-field-vtable)))
-      (eqv? (string-ref (symbol->string (struct-ref vt vtable-index-layout))
-                       (+ (* 2 (+ k 2)) 1))
-           #\w)))
+    (bitwise-bit-set? (struct-ref rtd rtd-index-field-bit-field) k))
 )
diff --git a/module/rnrs/records/procedural.scm 
b/module/rnrs/records/procedural.scm
index bd1d0d1..6976eeb 100644
--- a/module/rnrs/records/procedural.scm
+++ b/module/rnrs/records/procedural.scm
@@ -28,7 +28,12 @@
          record-mutator)
          
   (import (rnrs base (6))
-          (only (guile) and=>
+          (only (guile) cons*
+                        logand 
+                        logior
+                        ash
+
+                        and=>
                        throw
                        display
                        make-struct 
@@ -36,8 +41,10 @@
                        map
                        simple-format
                        string-append 
+                        symbol-append
                        
                        struct? 
+                        struct-layout
                        struct-ref 
                        struct-set! 
                        struct-vtable
@@ -52,33 +59,26 @@
          (only (srfi :1) fold split-at take))
 
   (define (record-internal? obj)
-    (and (struct? obj)
-        (let* ((vtable (struct-vtable obj))
-               (layout (symbol->string
-                        (struct-ref vtable vtable-index-layout))))
-          (and (>= (string-length layout) 4)
-               (let ((rtd (struct-ref obj record-index-rtd)))
-                 (and (record-type-descriptor? rtd)))))))
-
-  (define record-index-parent 0)
-  (define record-index-rtd 1)
-
-  (define rtd-index-name 0)
-  (define rtd-index-uid 1)
-  (define rtd-index-parent 2)
-  (define rtd-index-sealed? 3)
-  (define rtd-index-opaque? 4)
-  (define rtd-index-predicate 5)
-  (define rtd-index-field-names 6)
-  (define rtd-index-field-vtable 7)
-  (define rtd-index-field-binder 8)
+    (and (struct? obj) (record-type-descriptor? (struct-vtable obj))))
+
+  (define rtd-index-name 8)
+  (define rtd-index-uid 9)
+  (define rtd-index-parent 10)
+  (define rtd-index-sealed? 11)
+  (define rtd-index-opaque? 12)
+  (define rtd-index-predicate 13)
+  (define rtd-index-field-names 14)
+  (define rtd-index-field-bit-field 15)
+  (define rtd-index-field-binder 16)
 
   (define rctd-index-rtd 0)
   (define rctd-index-parent 1)
   (define rctd-index-protocol 2)
 
+  (define vtable-base-layout (symbol->string (struct-layout (make-vtable ""))))
+
   (define record-type-vtable 
-    (make-vtable "prprprprprprprprpr" 
+    (make-vtable (string-append vtable-base-layout "prprprprprprprprprpr")
                 (lambda (obj port) 
                   (simple-format port "#<r6rs:record-type:~A>"
                                  (struct-ref obj rtd-index-name)))))
@@ -93,28 +93,40 @@
   (define uid-table (make-hash-table))    
 
   (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
-    (define fields-vtable
-      (make-vtable (fold (lambda (x p) 
-                          (string-append p (case (car x)
-                                             ((immutable) "pr")
-                                             ((mutable) "pw"))))
-                        "prpr" (vector->list fields))
-                  (lambda (obj port)
-                    (simple-format port "#<r6rs:record:~A>" name))))
+    (define fields-pair
+      (let loop ((field-list (vector->list fields))
+                 (layout-sym 'pr)
+                 (layout-bit-field 0)
+                 (counter 0))
+        (if (null? field-list)
+            (cons layout-sym layout-bit-field)
+            (case (caar field-list)
+              ((immutable) 
+               (loop (cdr field-list)
+                     (symbol-append layout-sym 'pr) 
+                     layout-bit-field 
+                     (+ counter 1)))
+              ((mutable)
+               (loop (cdr field-list)
+                     (symbol-append layout-sym 'pw)
+                     (logior layout-bit-field (ash 1 counter))
+                     (+ counter 1)))
+              (else (r6rs-raise (make-assertion-violation)))))))
+
+    (define fields-layout (car fields-pair))
+    (define fields-bit-field (cdr fields-pair))
+
     (define field-names (list->vector (map cadr (vector->list fields))))
     (define late-rtd #f)
+
     (define (private-record-predicate obj)       
       (and (record-internal? obj)
-          (let ((rtd (struct-ref obj record-index-rtd)))
-            (or (eq? (struct-ref rtd rtd-index-field-vtable) fields-vtable)
-                (and=> (struct-ref obj record-index-parent)
-                       private-record-predicate)))))
+           (or (eq? (struct-vtable obj) late-rtd)
+               (and=> (struct-ref obj 0) private-record-predicate))))
 
     (define (field-binder parent-struct . args)
-      (apply make-struct (append (list fields-vtable 0 
-                                      parent-struct 
-                                      late-rtd) 
-                                args)))
+      (apply make-struct (cons* late-rtd 0 parent-struct args)))
+
     (if (and parent (struct-ref parent rtd-index-sealed?))
        (r6rs-raise (make-assertion-violation)))
 
@@ -125,21 +137,25 @@
          (if (equal? (list name 
                            parent 
                            sealed? 
-                           opaque?
+                           opaque?                            
                            field-names
-                           (struct-ref fields-vtable vtable-index-layout))
+                            fields-bit-field)
                      (list (struct-ref matching-rtd rtd-index-name)
                            (struct-ref matching-rtd rtd-index-parent)
                            (struct-ref matching-rtd rtd-index-sealed?)
                            (struct-ref matching-rtd rtd-index-opaque?)
                            (struct-ref matching-rtd rtd-index-field-names)
-                           (struct-ref (struct-ref matching-rtd 
-                                                   rtd-index-field-vtable)
-                                       vtable-index-layout)))
+                            (struct-ref matching-rtd 
+                                        rtd-index-field-bit-field)))
              matching-rtd
              (r6rs-raise (make-assertion-violation)))
-
+          
          (let ((rtd (make-struct record-type-vtable 0
+
+                                  fields-layout
+                                  (lambda (obj port)
+                                    (simple-format 
+                                     port "#<r6rs:record:~A>" name))
                                  
                                  name
                                  uid
@@ -149,7 +165,7 @@
                                  
                                  private-record-predicate
                                  field-names
-                                 fields-vtable
+                                  fields-bit-field
                                  field-binder)))
            (set! late-rtd rtd)
            (if uid (hashq-set! uid-table uid rtd))
@@ -200,24 +216,21 @@
 
   (define (record-accessor rtd k)
     (define (record-accessor-inner obj)
+      (if (eq? (struct-vtable obj) rtd)
+         (struct-ref obj (+ k 1))
+          (and=> (struct-ref obj 0) record-accessor-inner)))
+    (lambda (obj) 
       (if (not (record-internal? obj))
-         (r6rs-raise (make-assertion-violation)))
-      (if (eq? (struct-ref obj record-index-rtd) rtd)
-         (struct-ref obj (+ k 2))
-         (record-accessor-inner (struct-ref obj record-index-parent))))
-    (lambda (obj) (record-accessor-inner obj)))
+          (r6rs-raise (make-assertion-violation)))
+      (record-accessor-inner obj)))
 
   (define (record-mutator rtd k)
     (define (record-mutator-inner obj val)
-      (and obj 
-          (or (and (eq? (struct-ref obj record-index-rtd) rtd) 
-                   (struct-set! obj (+ k 2) val))
-              (record-mutator-inner (struct-ref obj record-index-parent) 
-                                    val))))
-    (let* ((rtd-vtable (struct-ref rtd rtd-index-field-vtable))
-          (field-layout (symbol->string
-                         (struct-ref rtd-vtable vtable-index-layout))))
-      (if (not (eqv? (string-ref field-layout (+ (* (+ k 2) 2) 1)) #\w))
+      (and obj (or (and (eq? (struct-vtable obj) rtd)
+                        (struct-set! obj (+ k 1) val))
+                   (record-mutator-inner (struct-ref obj 0) val))))
+    (let ((bit-field (struct-ref rtd rtd-index-field-bit-field)))
+      (if (zero? (logand bit-field (ash 1 k)))
          (r6rs-raise (make-assertion-violation))))
     (lambda (obj val) (record-mutator-inner obj val)))
 


hooks/post-receive
-- 
GNU Guile



reply via email to

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