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 "#" + (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 "#" (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 "#" name)))) + (simple-format port "#" 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