From 8714a2a0e5713a57e292cd03f2ef91be167c6ef6 Mon Sep 17 00:00:00 2001 From: Julian Graham
Date: Sun, 10 Oct 2010 01:35:26 -0400 Subject: [PATCH] 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. --- 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 "#