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

@@ -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 
+  (define rtd-index-field-bit-field
-    (@@ (rnrs records procedural) rtd-index-field-vtable))
+    (@@ (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)))))
+	 (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)))
+    (bitwise-bit-set? (struct-ref rtd rtd-index-field-bit-field) k))
-      (eqv? (string-ref (symbol->string (struct-ref vt vtable-index-layout))
-			(+ (* 2 (+ k 2)) 1))
-	    #\w)))
 )

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)
+    (and (struct? obj) (record-type-descriptor? (struct-vtable 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 rtd-index-name 8)
-  (define record-index-rtd 1)
+  (define rtd-index-uid 9)
-
+  (define rtd-index-parent 10)
-  (define rtd-index-name 0)
+  (define rtd-index-sealed? 11)
-  (define rtd-index-uid 1)
+  (define rtd-index-opaque? 12)
-  (define rtd-index-parent 2)
+  (define rtd-index-predicate 13)
-  (define rtd-index-sealed? 3)
+  (define rtd-index-field-names 14)
-  (define rtd-index-opaque? 4)
+  (define rtd-index-field-bit-field 15)
-  (define rtd-index-predicate 5)
+  (define rtd-index-field-binder 16)
-  (define rtd-index-field-names 6)
-  (define rtd-index-field-vtable 7)
-  (define rtd-index-field-binder 8)
 
   (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
+    (define fields-pair
-      (make-vtable (fold (lambda (x p) 
+      (let loop ((field-list (vector->list fields))
-			   (string-append p (case (car x)
+                 (layout-sym 'pr)
-					      ((immutable) "pr")
+                 (layout-bit-field 0)
-					      ((mutable) "pw"))))
+                 (counter 0))
-			 "prpr" (vector->list fields))
+        (if (null? field-list)
-		   (lambda (obj port)
+            (cons layout-sym layout-bit-field)
-		     (simple-format port "#<r6rs:record:~A>" name))))
+            (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-vtable obj) late-rtd)
-	     (or (eq? (struct-ref rtd rtd-index-field-vtable) fields-vtable)
+               (and=> (struct-ref obj 0) private-record-predicate))))
-		 (and=> (struct-ref obj record-index-parent)
-			private-record-predicate)))))
 
     (define (field-binder parent-struct . args)
-      (apply make-struct (append (list fields-vtable 0 
+      (apply make-struct (cons* late-rtd 0 parent-struct args)))
-				       parent-struct 
+
-				       late-rtd) 
-				 args)))
     (if (and parent (struct-ref parent rtd-index-sealed?))
 	(r6rs-raise (make-assertion-violation)))
 
@@ -127,20 +139,24 @@
 			    sealed? 
 			    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 
+                            (struct-ref matching-rtd 
-						    rtd-index-field-vtable)
+                                        rtd-index-field-bit-field)))
-					vtable-index-layout)))
 	      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
 				  parent 
@@ -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)))
+          (r6rs-raise (make-assertion-violation)))
-      (if (eq? (struct-ref obj record-index-rtd) rtd)
+      (record-accessor-inner obj)))
-	  (struct-ref obj (+ k 2))
-	  (record-accessor-inner (struct-ref obj record-index-parent))))
-    (lambda (obj) (record-accessor-inner obj)))
 
   (define (record-mutator rtd k)
     (define (record-mutator-inner obj val)
-      (and obj 
+      (and obj (or (and (eq? (struct-vtable obj) rtd)
-	   (or (and (eq? (struct-ref obj record-index-rtd) rtd) 
+                        (struct-set! obj (+ k 1) val))
-		    (struct-set! obj (+ k 2) val))
+                   (record-mutator-inner (struct-ref obj 0) val))))
-	       (record-mutator-inner (struct-ref obj record-index-parent) 
+    (let ((bit-field (struct-ref rtd rtd-index-field-bit-field)))
-				     val))))
+      (if (zero? (logand bit-field (ash 1 k)))
-    (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))
 	  (r6rs-raise (make-assertion-violation))))
     (lambda (obj val) (record-mutator-inner obj val)))