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 "#" (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 "#" 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 "#" 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))) -- 1.7.0.4