From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 11 Dec 2009 01:54:49 +0000 (-0500)
Subject: Find structure field default value procedures by index, not by name.
X-Git-Tag: 20100708-Gtk~215
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fc1e7c672026c6ffeeac763163fa6ad030cf4e09;p=mit-scheme.git

Find structure field default value procedures by index, not by name.

Otherwise, every constructor generated by DEFINE-STRUCTURE performs
lookups by name for every field with a default initializer, every
time you call the constructor.

This is a backward-compatible change, in the sense that .bin and .com
files generated with the old definition of DEFINE-STRUCTURE can still
be loaded into images with the new definition of DEFINE-STRUCTURE and
its corresponding run-time support.  However, .bin and .com files
generated with the new definition cannot be loaded into images with
the old run-time support, which lacks procedures needed by the new
definition for lookup by index.

Note: For the full benefit of this change, run at least a two-stage
build so that the runtime will include the new definition and be
compiled with the new definition.
---

diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index 21362245a..35ebaca77 100644
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -697,8 +697,8 @@ differences:
 			(optional (map name->slot optional))
 			(rest (and rest (name->slot rest))))
 		    (map (lambda (slot)
-			   (let* ((name (slot/name slot))
-				  (dv (default-value-expr structure name)))
+			   (let ((name (slot/name slot))
+				 (dv (default-value-expr structure slot)))
 			     (cond ((or (memq slot required)
 					(eq? slot rest))
 				    name)
@@ -706,7 +706,7 @@ differences:
 				    `(IF (DEFAULT-OBJECT? ,name) ,dv ,name))
 				   (else dv))))
 			 (structure/slots structure)))))))))))
-
+
 (define (make-constructor structure name lambda-list generate-body)
   (let* ((context (structure/context structure))
 	(tag-expression (close (structure/tag-expression structure) context)))
@@ -722,14 +722,25 @@ differences:
 	`(DEFINE (,name ,@lambda-list)
 	   ,(generate-body tag-expression)))))
 
-(define (default-value-expr structure name)
-  (let ((context (structure/context structure)))
-    `(,(absolute (if (structure/record-type? structure)
-		     'RECORD-TYPE-DEFAULT-VALUE
-		     'DEFINE-STRUCTURE/DEFAULT-VALUE)
-		 context)
-      ,(close (structure/type-descriptor structure) context)
-      ',name)))
+(define (default-value-expr structure slot)
+  (let ((expression (slot/default slot)))
+    ;; Scheme spends a remarkable amount of time fetching and calling
+    ;; the default value procedures.  This hack eliminates that time
+    ;; for many uses of DEFINE-STRUCTURE.
+    (if (not (pair? (strip-syntactic-closures expression)))
+	expression
+	(let ((record? (structure/record-type? structure))
+	      (context (structure/context structure)))
+	  `(,(absolute (if record?
+			   'RECORD-TYPE-DEFAULT-VALUE-BY-INDEX
+			   'DEFINE-STRUCTURE/DEFAULT-VALUE-BY-INDEX)
+		       context)
+	    ,(close (structure/type-descriptor structure) context)
+	    ,(- (slot/index slot)
+		(if record?
+		    0
+		    (+ (structure/offset structure)
+		       (if (structure/tagged? structure) 1 0)))))))))
 
 (define (copier-definitions structure)
   (let ((copier-name (structure/copier structure)))
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 78301dfd4..8114b417a 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -227,8 +227,13 @@ USA.
 	(vector-set! v i (car values))))))
 
 (define (record-type-default-value record-type field-name)
+  (record-type-default-value-by-index
+   record-type
+   (record-type-field-index record-type field-name #t)))
+
+(define (record-type-default-value-by-index record-type field-name-index)
   ((vector-ref (%record-type-default-inits record-type)
-	       (fix:- (record-type-field-index record-type field-name #t) 1))))
+	       (fix:- field-name-index 1))))
 
 (define set-record-type-unparser-method!
   (named-lambda (set-record-type-unparser-method!/booting record-type method)
@@ -540,8 +545,12 @@ USA.
 	      (structure-type/field-name-index type field-name)))
 
 (define-integrable (structure-type/default-init type field-name)
-  (vector-ref (structure-type/default-inits type)
-	      (structure-type/field-name-index type field-name)))
+  (structure-type/default-init-by-index
+   type
+   (structure-type/field-name-index type field-name)))
+
+(define-integrable (structure-type/default-init-by-index type field-name-index)
+  (vector-ref (structure-type/default-inits type) field-name-index))
 
 (define (structure-type/field-name-index type field-name)
   (let ((names (structure-type/field-names type)))
@@ -592,6 +601,9 @@ USA.
 (define (define-structure/default-value type field-name)
   ((structure-type/default-init type field-name)))
 
+(define (define-structure/default-value-by-index type field-name-index)
+  ((structure-type/default-init-by-index type field-name-index)))
+
 (define (define-structure/keyword-constructor type)
   (let ((names (structure-type/field-names type))
 	(indexes (structure-type/field-indexes type))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 3e23fa262..34ff33188 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3047,6 +3047,7 @@ USA.
 	  %record?
 	  copy-record
 	  define-structure/default-value
+	  define-structure/default-value-by-index
 	  define-structure/keyword-constructor
 	  define-structure/list-accessor
 	  define-structure/list-modifier
@@ -3072,6 +3073,7 @@ USA.
 	  record-predicate
 	  record-type-default-inits
 	  record-type-default-value
+	  record-type-default-value-by-index
 	  record-type-descriptor
 	  record-type-dispatch-tag
 	  record-type-extension