unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [PATCH] Performance improvement for R6RS records
@ 2010-09-19  0:20 Julian Graham
  2010-09-19 10:39 ` Andy Wingo
  0 siblings, 1 reply; 8+ messages in thread
From: Julian Graham @ 2010-09-19  0:20 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 1059 bytes --]

Hi Guilers,

I've been a bit quiet recently since, while waiting for 2.0, I've been
rewriting one of my old Guile module projects (SDOM) as an R6RS
library.  Among other things, this has gotten me pretty familiar with
the performance profile of Guile's R6RS records code.  My initial
implementation had every record be a distinct struct type identified
by its own vtable, in which the first two slots were used to store the
record's type descriptor and a pointer to a parent type; this meant
that simple type predicates and mutability checks required (expensive)
examination of the vtable layout.

The attached patched changes the way record data is laid out, such
that all records are of the same struct type, which holds the type
descriptor and parent pointer, as well as a reference to the field
data, which now lives in its own struct.  Some naive profiling, in the
context of the test suite for SDOM (which makes extensive use of
records), indicates a speedup of around 40%.

Any questions?  Would someone care to review before I push?


Regards,
Julian

[-- Attachment #2: 0001-Improve-performance-of-R6RS-records-implementation.patch --]
[-- Type: text/x-diff, Size: 8165 bytes --]

From be1b360fdcfa6c96ea9b0c64a7a19c05fa1650a5 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian.graham@aya.yale.edu>
Date: Sat, 18 Sep 2010 19:59:33 -0400
Subject: [PATCH] Improve performance of R6RS records implementation

Store field layout and other record type metadata in a struct type that
sits in front of the actual field data, which saves us an expensive
inspection of the vtable layout string.

* 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 an
  `eq?' check against `record-vtable'.
  (record-vtable): New struct type with fields for parent, record-type
  descriptor, and field data.
  (make-record-type-descriptor): In addition to field struct vtable, build
  up a mutability bit field to use for fast mutability checks.
  (record-accessor, record-mutator): Use field struct and mutability bit
  field.
---
 module/rnrs/records/inspection.scm |   10 ++--
 module/rnrs/records/procedural.scm |   89 +++++++++++++++++++++++-------------
 2 files changed, 62 insertions(+), 37 deletions(-)

diff --git a/module/rnrs/records/inspection.scm b/module/rnrs/records/inspection.scm
index a142d7c..0bd6399 100644
--- a/module/rnrs/records/inspection.scm
+++ b/module/rnrs/records/inspection.scm
@@ -28,7 +28,8 @@
 	  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))
@@ -45,6 +46,8 @@
   (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-bit-field
+    (@@ (rnrs records procedural) rtd-index-field-bit-field))
   (define rtd-index-field-vtable 
     (@@ (rnrs records procedural) rtd-index-field-vtable))
 
@@ -76,8 +79,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..c49f0cb 100644
--- a/module/rnrs/records/procedural.scm
+++ b/module/rnrs/records/procedural.scm
@@ -28,7 +28,11 @@
 	  record-mutator)
 	  
   (import (rnrs base (6))
-          (only (guile) and=>
+          (only (guile) logand 
+                        logior
+                        ash
+
+                        and=>
 			throw
 			display
 		        make-struct 
@@ -52,16 +56,11 @@
 	  (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)))))))
+    (and (struct? obj) (eq? (struct-vtable obj) record-vtable)))
 
   (define record-index-parent 0)
   (define record-index-rtd 1)
+  (define record-index-fields 2)
 
   (define rtd-index-name 0)
   (define rtd-index-uid 1)
@@ -71,14 +70,22 @@
   (define rtd-index-predicate 5)
   (define rtd-index-field-names 6)
   (define rtd-index-field-vtable 7)
-  (define rtd-index-field-binder 8)
+  (define rtd-index-field-bit-field 8)
+  (define rtd-index-field-binder 9)
 
   (define rctd-index-rtd 0)
   (define rctd-index-parent 1)
   (define rctd-index-protocol 2)
 
+  (define record-vtable
+    (make-vtable "prprpr"
+                 (lambda (obj port)
+                   (simple-format port "#<r6rs:record:~A>"
+                                  (struct-ref (struct-ref obj record-index-rtd)
+                                              rtd-index-name)))))
+
   (define record-type-vtable 
-    (make-vtable "prprprprprprprprpr" 
+    (make-vtable "prprprprprprprprprpr" 
 		 (lambda (obj port) 
 		   (simple-format port "#<r6rs:record-type:~A>"
 				  (struct-ref obj rtd-index-name)))))
@@ -93,14 +100,33 @@
   (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))
+    (define fields-pair
+      (let loop ((field-list (vector->list fields))
+                 (layout-str "")
+                 (layout-bit-field 0)
+                 (counter 0))
+        (if (null? field-list)
+            (cons layout-str layout-bit-field)
+            (case (caar field-list)
+              ((immutable) 
+               (loop (cdr field-list)
+                     (string-append layout-str "pr") 
+                     layout-bit-field 
+                     (+ counter 1)))
+              ((mutable)
+               (loop (cdr field-list)
+                     (string-append layout-str "pw")
+                     (logior layout-bit-field (ash 1 counter))
+                     (+ counter 1)))
+              (else (r6rs-raise (make-assertion-violation)))))))
+
+    (define fields-vtable 
+      (make-vtable (car fields-pair)
 		   (lambda (obj port)
-		     (simple-format port "#<r6rs:record:~A>" name))))
+		     (simple-format port "#<r6rs:record-fields:~A>" name))))
+
+    (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)       
@@ -111,10 +137,9 @@
 			private-record-predicate)))))
 
     (define (field-binder parent-struct . args)
-      (apply make-struct (append (list fields-vtable 0 
-				       parent-struct 
-				       late-rtd) 
-				 args)))
+      (make-struct record-vtable 0 parent-struct late-rtd 
+                   (apply make-struct (append (list fields-vtable 0) args))))
+
     (if (and parent (struct-ref parent rtd-index-sealed?))
 	(r6rs-raise (make-assertion-violation)))
 
@@ -150,6 +175,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 +226,23 @@
 
   (define (record-accessor rtd k)
     (define (record-accessor-inner 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)))
+	  (struct-ref (struct-ref obj record-index-fields) k)
+          (and=> (struct-ref obj record-index-parent) record-accessor-inner)))
+    (lambda (obj) 
+      (if (not (record-internal? obj))
+          (r6rs-raise (make-assertion-violation)))
+      (record-accessor-inner obj)))
 
   (define (record-mutator rtd k)
     (define (record-mutator-inner obj val)
-      (and obj 
+      (and obj
 	   (or (and (eq? (struct-ref obj record-index-rtd) rtd) 
-		    (struct-set! obj (+ k 2) val))
+		    (struct-set! (struct-ref obj record-index-fields) k 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))
+    (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)))
 
-- 
1.7.0.4


^ permalink raw reply related	[flat|nested] 8+ messages in thread

end of thread, other threads:[~2010-10-10  5:46 UTC | newest]

Thread overview: 8+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-09-19  0:20 [PATCH] Performance improvement for R6RS records Julian Graham
2010-09-19 10:39 ` Andy Wingo
2010-09-19 15:28   ` Julian Graham
2010-09-20  7:20     ` Andy Wingo
2010-09-27 20:05       ` Andy Wingo
2010-10-04 13:48         ` Julian Graham
2010-10-04 19:09           ` Andy Wingo
2010-10-10  5:46             ` Julian Graham

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).