diff options
author | Julian Graham <julian.graham@aya.yale.edu> | 2010-10-10 01:35:26 -0400 |
---|---|---|
committer | Julian Graham <julian.graham@aya.yale.edu> | 2010-10-22 14:34:49 -0400 |
commit | fe15364988b8098e0a35838f13c1cb778cb0d9d9 (patch) | |
tree | 3168f693ce03d19a78e653cdf39cbf09acc917ed /module/rnrs/records | |
parent | 3a1a883b632f51bf316195a8a180e2e6c52a3363 (diff) | |
download | guile-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.scm | 22 | ||||
-rw-r--r-- | 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 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))) |