From fc1e7c672026c6ffeeac763163fa6ad030cf4e09 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Thu, 10 Dec 2009 20:54:49 -0500 Subject: [PATCH] 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. --- src/runtime/defstr.scm | 33 ++++++++++++++++++++++----------- src/runtime/record.scm | 18 +++++++++++++++--- src/runtime/runtime.pkg | 2 ++ 3 files changed, 39 insertions(+), 14 deletions(-) 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 -- 2.25.1