[PATCH] Performance improvement for R6RS records

[PATCH] Performance improvement for R6RS records

[Julian Graham]

[-- Attachment #1: Type: text/plain, Size: 1059 bytes --]

Hi Guilers,

I've been a bit quiet recently since, while waiting for 2.0, I've been
rewriting one of my old Guile module projects (SDOM) as an R6RS
library.  Among other things, this has gotten me pretty familiar with
the performance profile of Guile's R6RS records code.  My initial
implementation had every record be a distinct struct type identified
by its own vtable, in which the first two slots were used to store the
record's type descriptor and a pointer to a parent type; this meant
that simple type predicates and mutability checks required (expensive)
examination of the vtable layout.

The attached patched changes the way record data is laid out, such
that all records are of the same struct type, which holds the type
descriptor and parent pointer, as well as a reference to the field
data, which now lives in its own struct.  Some naive profiling, in the
context of the test suite for SDOM (which makes extensive use of
records), indicates a speedup of around 40%.

Any questions?  Would someone care to review before I push?


Regards,
Julian

[-- Attachment #2: 0001-Improve-performance-of-R6RS-records-implementation.patch --]
[-- Type: text/x-diff, Size: 8165 bytes --]

From be1b360fdcfa6c96ea9b0c64a7a19c05fa1650a5 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian.graham@aya.yale.edu>
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 "#<r6rs:record:~A>"
+                                  (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 "#<r6rs:record-type:~A>"
 				  (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 "#<r6rs:record:~A>" name))))
+		     (simple-format port "#<r6rs:record-fields:~A>" 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

Re: [PATCH] Performance improvement for R6RS records

[Andy Wingo]

Hi Julian,

On Sun 19 Sep 2010 02:20, Julian Graham <joolean@gmail.com> writes:

>    (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)))

Is it possible to keep the current flat record layout, and change this
check to be:

  (define (record-internal? obj)
    (and (struct? obj)
         (eq? (struct-vtable (struct-vtable obj))
              record-type-vtable)))

What kind of performance do you get there?

Andy
-- 
http://wingolog.org/

Re: [PATCH] Performance improvement for R6RS records

[Julian Graham]

Hey Andy,


> Is it possible to keep the current flat record layout, and change this
> check to be:
>
>  (define (record-internal? obj)
>    (and (struct? obj)
>         (eq? (struct-vtable (struct-vtable obj))
>              record-type-vtable)))
>
> What kind of performance do you get there?

I'm probably misunderstanding things, but this code doesn't work for
me -- I think there are some other modifications that'd be necessary.
I'm guessing you're proposing something along the lines of using
Vtable Vtables, as described in manual section 5.6.9.4?


Regards,
Julian

Re: [PATCH] Performance improvement for R6RS records

[Andy Wingo]

On Sun 19 Sep 2010 17:28, Julian Graham <joolean@gmail.com> writes:

>> Is it possible to keep the current flat record layout, and change this
>> check to be:
>>
>>  (define (record-internal? obj)
>>    (and (struct? obj)
>>         (eq? (struct-vtable (struct-vtable obj))
>>              record-type-vtable)))
>>
>> What kind of performance do you get there?
>
> I'm probably misunderstanding things, but this code doesn't work for
> me -- I think there are some other modifications that'd be necessary.
> I'm guessing you're proposing something along the lines of using
> Vtable Vtables, as described in manual section 5.6.9.4?

No not really; just that record-types should be instances of
record-type-vtable, which itself is a normal vtable (not a
vtable-vtable).

Will elaborate later, have to run out the door :)

A
-- 
http://wingolog.org/

Re: [PATCH] Performance improvement for R6RS records

[Andy Wingo]

On Mon 20 Sep 2010 09:20, Andy Wingo <wingo@pobox.com> writes:

> Will elaborate later, have to run out the door :)

Do you still need some help here? I can try to work up some code to make
an example.

Andy
-- 
http://wingolog.org/

Re: [PATCH] Performance improvement for R6RS records

[Julian Graham]

Hi Andy,


> Do you still need some help here? I can try to work up some code to make
> an example.

Um, yes?  If you've got the time.  (Sorry for the way-late reply --
I've been distracted with apartment hunting / moving.)


Thanks,
Julian

Re: [PATCH] Performance improvement for R6RS records

[Andy Wingo]

Hello :)

;; First, get the set of required fields in a vtable. There should be a
;; better way for this, but there isn't.
;;
(define vtable-base-layout
  (symbol->string (struct-layout (make-vtable ""))))

;; Now make the vtable for record-types. It has the base layout, plus
;; one more field to hold the list of fields in its instances.
;;
(define record-type-vtable
  (let ((rtv (make-vtable (string-append vtable-base-layout "pr")
                          (lambda (x port)
                            (format port "<record-type ~a ~x>"
                                    (struct-vtable-name x)
                                    (object-address x))))))
    (set-struct-vtable-name! rtv 'record-type)
    rtv))

;; Each field of a record will be writable. Obviously here we could do
;; "pr" fields instead.
;;
;; fields := NAME...
;;
(define (fields->layout fields)
  (apply symbol-append (map (lambda (x) 'pw) fields)))

;; A function to allow us to make new record types. They will be
;; instances of record-type-vtable. They themselves will be vtables.
;;
(define (make-record-type name fields)
  (let ((rt (make-struct/no-tail record-type-vtable
                         (fields->layout fields) ; layout
                         record-printer          ; printer
                         fields)))               ; fields, the 'pr slot
                                                 ; from above
    (set-struct-vtable-name! rt name)
    rt))

;; Since fields and names are stored in the vtable, we can access them
;; from a printer.
;;
(define (record-type-name rt)
  (struct-vtable-name rt))
(define (record-type-fields rt)
  (struct-ref rt vtable-offset-user))
(define (record-printer x port)
  (define fields (record-type-fields (struct-vtable x)))
  (format port "<~a ~x"
          (record-type-name (struct-vtable x))
          (object-address x))
  (for-each (lambda (f i)
              (format port " ~a: ~a" f (struct-ref x i)))
            fields (iota (length fields)))
  (format port ">"))

;; Record types are instances of record-type-vtable.
;;
(define (record-type? x)
  (and (struct? x) (eq? (struct-vtable x) record-type-vtable)))

;; Records are instances of record types. Obviously you could inline
;; record-type? here.
;;
(define (record? x)
  (and (struct? x) (record-type? (struct-vtable x))))

;; A little syntax, just to try things out.
(define-syntax define-record-type
  (syntax-rules ()
    ((_ (name make) field ...)
     (begin
       (define name (make-record-type 'name '(field ...)))
       (define (make field ...)
         (make-struct/no-tail name field ...))))))

(define-record-type (foo make-foo)
  bar baz)

(make-foo 'a 'b)
=> <foo 1ea1a40 bar: a baz: b>

Hope that helps,

Andy
-- 
http://wingolog.org/

Re: [PATCH] Performance improvement for R6RS records

[Julian Graham]

[-- 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