summaryrefslogtreecommitdiff
path: root/module/rnrs/records
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-10-10 01:35:26 -0400
committerJulian Graham <julian.graham@aya.yale.edu>2010-10-22 14:34:49 -0400
commitfe15364988b8098e0a35838f13c1cb778cb0d9d9 (patch)
tree3168f693ce03d19a78e653cdf39cbf09acc917ed /module/rnrs/records
parent3a1a883b632f51bf316195a8a180e2e6c52a3363 (diff)
downloadguile-fe15364988b8098e0a35838f13c1cb778cb0d9d9.tar.gz
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.
Diffstat (limited to 'module/rnrs/records')
-rw-r--r--module/rnrs/records/inspection.scm22
-rw-r--r--module/rnrs/records/procedural.scm131
2 files changed, 81 insertions, 72 deletions
diff --git a/module/rnrs/records/inspection.scm b/module/rnrs/records/inspection.scm
index a142d7cdd..315ef0cb6 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 bd1d0d151..6976eebdd 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)))