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 21362245a39f232c7423621d2380284fcfbc96d2..35ebaca77720434b6ae241adc5a3470f82797f29 100644 (file)
--- 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)))))))))))
-
+\f
 (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)))))))))
 \f
 (define (copier-definitions structure)
   (let ((copier-name (structure/copier structure)))

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 78301dfd418085530fba6c5c791b2ecdb4302527..8114b417a6adf8e66717e0b4c008f690cc456020 100644 (file)
--- 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)))
+\f
 (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 3e23fa26223488e546f3c5cc22f4ab2799edd929..34ff3318896ec07b7965fa1a0af47362bd5d9c27 100644 (file)
--- 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