From be1b360fdcfa6c96ea9b0c64a7a19c05fa1650a5 Mon Sep 17 00:00:00 2001 From: Julian Graham
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 "#