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
From be1b360fdcfa6c96ea9b0c64a7a19c05fa1650a5 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian.gra...@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
