[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-12-gfe
From: |
Julian Graham |
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-12-gfe15364 |
Date: |
Fri, 22 Oct 2010 18:48:49 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=fe15364988b8098e0a35838f13c1cb778cb0d9d9
The branch, master has been updated
via fe15364988b8098e0a35838f13c1cb778cb0d9d9 (commit)
from 3a1a883b632f51bf316195a8a180e2e6c52a3363 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit fe15364988b8098e0a35838f13c1cb778cb0d9d9
Author: Julian Graham <address@hidden>
Date: Sun Oct 10 01:35:26 2010 -0400
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.
-----------------------------------------------------------------------
Summary of changes:
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)))
hooks/post-receive
--
GNU Guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-12-gfe15364,
Julian Graham <=