From: Julian Graham <joolean@gmail.com>
To: Andy Wingo <wingo@pobox.com>
Cc: guile-devel <guile-devel@gnu.org>
Subject: Re: [PATCH] Performance improvement for R6RS records
Date: Sun, 10 Oct 2010 01:46:30 -0400 [thread overview]
Message-ID: <AANLkTi=FuGs4L1W7EzYMWC=LK4BcavLjsvx1iYrHm-q1@mail.gmail.com> (raw)
In-Reply-To: <m3y6adhj16.fsf@unquote.localdomain>
[-- Attachment #1: Type: text/plain, Size: 619 bytes --]
Hey Andy,
> Hope that helps,
It does, thanks! (It took me a while to internalize the practical
implications of struct / vtable equality, although I'd read and
re-read the relevant bits of the manual...)
Find attached a revised version of my original patch, which I hope
reflects what you were getting at (flat record layouts, record-type
descriptor data stored in the vtable). This version seems to perform
a bit better than the first one; my profiling (still fairly naive)
indicates a performance improvement of around 50% for the SDOM test
suite.
As usual, thanks for your help and patience.
Regards,
Julian
[-- Attachment #2: 0001-Improve-performance-of-R6RS-records-implementation.patch --]
[-- Type: text/x-diff, Size: 10965 bytes --]
From 8714a2a0e5713a57e292cd03f2ef91be167c6ef6 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian.graham@aya.yale.edu>
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 "#<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)))
--
1.7.0.4
prev parent reply other threads:[~2010-10-10 5:46 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2010-09-19 0:20 [PATCH] Performance improvement for R6RS records Julian Graham
2010-09-19 10:39 ` Andy Wingo
2010-09-19 15:28 ` Julian Graham
2010-09-20 7:20 ` Andy Wingo
2010-09-27 20:05 ` Andy Wingo
2010-10-04 13:48 ` Julian Graham
2010-10-04 19:09 ` Andy Wingo
2010-10-10 5:46 ` Julian Graham [this message]
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to='AANLkTi=FuGs4L1W7EzYMWC=LK4BcavLjsvx1iYrHm-q1@mail.gmail.com' \
--to=joolean@gmail.com \
--cc=guile-devel@gnu.org \
--cc=wingo@pobox.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).