From: Chris Hanson Date: Tue, 24 Sep 2019 07:35:38 +0000 (-0700) Subject: Change record types to be immutable. X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~41 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=33e3a188ffb8e332db58af2a4942b8fa044034f2;p=mit-scheme.git Change record types to be immutable. The primary reason for this is to make the predicates slightly faster, eliminating the need to look up the type markers in the predicates. Additionally, make-record-type now accepts these additional options using a keyword list. The define-record-type macro has not been updated to support these new options, but that will come soon. Consequently the files using these options have been modified to use make-record-type directly. Finally, a small tweak was needed so that multiple values are available earlier in the cold load. --- diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index f97016b8b..b20ca698e 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -503,6 +503,41 @@ USA. (list '(evaluated) (promise-value promise)) (list '(unevaluated)))))) +;;;; Multiple values + +(define + (list ')) + +(define (make-multi-values objects) + (cons objects)) + +(define (multi-values? object) + (and (pair? object) + (eq? (car object)))) + +(define (multi-values-list mv) + (cdr mv)) + +(defer-boot-action 'make-record-type + (lambda () + (set! (make-record-type ' '(list))) + (set! make-multi-values (record-constructor )) + (set! multi-values? (record-predicate )) + (set! multi-values-list (record-accessor 'list)) + unspecific)) + +(define (values . objects) + (if (and (pair? objects) + (null? (cdr objects))) + (car objects) + (make-multi-values objects))) + +(define (call-with-values thunk receiver) + (let ((v (thunk))) + (if (multi-values? v) + (apply receiver (multi-values-list v)) + (receiver v)))) + ;;;; Miscellany (define (object-constant? object) diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm index 4b6d817d0..72f4f7e1d 100644 --- a/src/runtime/bundle.scm +++ b/src/runtime/bundle.scm @@ -39,9 +39,6 @@ USA. (define (make-bundle-predicate name) (record-predicate (make-record-type name '() ))) -(define (%bundle-applicator bundle name . args) - (apply (bundle-ref bundle name) args)) - (define-integrable (%predicate->record-type predicate) (predicate->dispatch-tag predicate)) @@ -79,8 +76,10 @@ USA. object))) (define - (make-record-type ' '(alist))) -(set-record-type-applicator! %bundle-applicator) + (make-record-type ' '(alist) + 'applicator + (lambda (bundle name . args) + (apply (bundle-ref bundle name) args)))) (define bundle? (record-predicate )) diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 95cba4129..b2cf32546 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -128,23 +128,6 @@ USA. (define bind-cell-contents! (object-component-binder cell-contents set-cell-contents!)) -(define-record-type - (make-multi-values list) - multi-values? - (list multi-values-list)) - -(define (values . objects) - (if (and (pair? objects) - (null? (cdr objects))) - (car objects) - (make-multi-values objects))) - -(define (call-with-values thunk receiver) - (let ((v (thunk))) - (if (multi-values? v) - (apply receiver (multi-values-list v)) - (receiver v)))) - (define (write-to-string object #!optional max) (if (or (default-object? max) (not max)) (call-with-output-string diff --git a/src/runtime/list.scm b/src/runtime/list.scm index ab9fb90cd..3d400d2d5 100644 --- a/src/runtime/list.scm +++ b/src/runtime/list.scm @@ -1303,8 +1303,10 @@ USA. keyword-option-specs)))) (define (keyword-option-spec? object) - (and (list? object) - (memv (length object) '(2 3)) + (and (let ((n (list?->length object))) + (and n + (or (fix:= 2 n) + (fix:= 3 n)))) (interned-symbol? (car object)) (or (and (unary-procedure? (cadr object)) (or (null? (cddr object)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index a1370b6cb..dce24dbc5 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -486,7 +486,6 @@ USA. (runtime continuation-parser) (runtime program-copier) ;; Finish records - ((runtime record) initialize-record-procedures!) ((package) finalize-package-record-type!) ((runtime random-number) finalize-random-state-type!) ;; Condition System diff --git a/src/runtime/pathname.scm b/src/runtime/pathname.scm index 431df7963..545c88abd 100644 --- a/src/runtime/pathname.scm +++ b/src/runtime/pathname.scm @@ -97,18 +97,19 @@ these rules: |# -(define-record-type - (%make-pathname host device directory name type version) - pathname? - (host %pathname-host) - (device %pathname-device) - (directory %pathname-directory) - (name %pathname-name) - (type %pathname-type) - (version %pathname-version)) -(set-record-type-fasdumpable! record-type-proxy:pathname) - -(define-guarantee pathname "pathname") +(define + (make-record-type ' + '(host device directory name type version) + 'instance-marker record-type-proxy:pathname)) + +(define %make-pathname (record-constructor )) +(define pathname? (record-predicate )) +(define %pathname-host (record-accessor 'host)) +(define %pathname-device (record-accessor 'device)) +(define %pathname-directory (record-accessor 'directory)) +(define %pathname-name (record-accessor 'name)) +(define %pathname-type (record-accessor 'type)) +(define %pathname-version (record-accessor 'version)) (define-print-method pathname? (standard-print-method 'pathname @@ -561,12 +562,15 @@ these rules: (operation/init-file-pathname #f read-only #t) (operation/pathname-simplify #f read-only #t)) -(define-record-type - (%make-host type-index name) - host? - (type-index host/type-index) - (name host/name)) -(set-record-type-fasdumpable! record-type-proxy:host) +(define + (make-record-type ' + '(type-index name) + 'instance-marker record-type-proxy:host)) + +(define %make-host (record-constructor )) +(define host? (record-predicate )) +(define host/type-index (record-accessor 'type-index)) +(define host/name (record-accessor 'name)) (define (make-host type name) (%make-host (host-type/index type) name)) diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 7a3e9e02f..bf679b3e8 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -36,14 +36,25 @@ USA. (define-primitives (vector-cons 2)) -(define (make-record-type type-name field-specs #!optional parent-type) +(define (make-record-type type-name field-specs . options) (guarantee valid-field-specs? field-specs 'make-record-type) (let ((type-name (->type-name type-name 'make-record-type))) - (if (default-object? parent-type) - (%make-record-type type-name field-specs #f) - (begin - (guarantee record-type? parent-type 'make-record-type) - (%make-record-type type-name field-specs parent-type))))) + (receive (parent-type applicator instance-marker) + (make-record-type-options (if (and (pair? options) + (null? (cdr options))) + ;; SRFI 131 compatibility + (cons 'parent-type options) + options) + 'make-record-type) + (if parent-type + (begin + (if applicator + (error:bad-range-argument applicator 'make-record-type)) + (if (and instance-marker + (not (%record-type-fasdumpable? parent-type))) + (error:bad-range-argument instance-marker 'make-record-type)))) + (%make-record-type type-name field-specs parent-type + applicator instance-marker)))) (define (valid-field-specs? object) (and (list? object) @@ -71,100 +82,74 @@ USA. (if (pair? spec) (cadr spec) #f)) (define (%valid-default-init? object) - (declare (ignore object)) - #t) + (or (not object) + (thunk? object))) -(defer-boot-action 'record-procedures - (lambda () - (set! %valid-default-init? - (named-lambda (%valid-default-init? object) - (or (not object) - (thunk? object)))) - unspecific)) - -(define (initialize-record-procedures!) - (run-deferred-boot-actions 'record-procedures)) +(define %record-metatag) +(define record-type?) +(define %%make-record-type) +(define make-record-type-options) +(add-boot-init! + (lambda () + (set! %record-metatag (make-dispatch-metatag 'record-tag)) + (set! record-type? (dispatch-tag->predicate %record-metatag)) + (set! %%make-record-type + (dispatch-metatag-constructor %record-metatag 'make-record-type)) + (set! make-record-type-options + (keyword-option-parser + (list (list 'parent-type record-type? (lambda () #f)) + (list 'applicator procedure? (lambda () #f)) + (list 'instance-marker %record-type-proxy? (lambda () #f))))) + (run-deferred-boot-actions 'make-record-type))) (define (->type-name object caller) (cond ((string? object) (string->symbol object)) ((symbol? object) object) (else (error:wrong-type-argument object "type name" caller)))) -(define (%make-record-type type-name field-specs parent-type) +(define (%make-record-type type-name field-specs parent-type + applicator instance-marker) (let* ((start-index (if parent-type (%record-type-end-index parent-type) 0)) - (end-index (+ start-index 1 (length field-specs))) - (partial-fields - (list->vector - (map (lambda (spec index) - (make-field (field-spec-name spec) - (field-spec-init spec) - index)) - field-specs - (iota (length field-specs) (+ start-index 1))))) - (fields-by-index - (if parent-type - (vector-append (%record-type-fields-by-index parent-type) - partial-fields) - partial-fields))) - - (letrec* - ((predicate - (case (count-ancestors parent-type) - ((0) - (lambda (object) - (and (%record? object) - (check-marker type object 0)))) - ((1) - (lambda (object) - (and (%record? object) - (fix:>= (%record-length object) end-index) - (check-marker type object start-index) - (check-marker parent-type object 0)))) - ((2) - (let ((parent-start (%record-type-start-index parent-type)) - (grandparent-type (%record-type-parent parent-type))) - (lambda (object) - (and (%record? object) - (fix:>= (%record-length object) end-index) - (check-marker type object start-index) - (check-marker parent-type object parent-start) - (check-marker grandparent-type object 0))))) - (else - (lambda (object) - (and (%record? object) - (fix:>= (%record-length object) end-index) - (check-marker type object start-index) - (let loop ((t parent-type)) - (and (check-marker t object (%record-type-start-index t)) - (if (%record-type-parent t) - (loop (%record-type-parent t)) - #t)))))))) - (type - (%%make-record-type type-name - predicate - start-index - end-index - fields-by-index - (generate-fields-by-name fields-by-index) - parent-type - #f - #f))) - (%set-record-type-instance-marker! type type) - (set-predicate<=! predicate + (end-index (+ start-index 1 (length field-specs)))) + + (define (make-type predicate) + (let ((fields-by-index + (generate-fields-by-index field-specs parent-type start-index))) + (%%make-record-type type-name + predicate + start-index + end-index + fields-by-index + (generate-fields-by-name fields-by-index) + parent-type + applicator + instance-marker))) + + (let ((type + (if instance-marker + (%make-marked-type start-index end-index parent-type + instance-marker make-type) + (%make-normal-type start-index end-index parent-type + make-type)))) + (set-predicate<=! (record-predicate type) (if parent-type (record-predicate parent-type) record?)) type))) - -(define (count-ancestors parent-type) - (let loop ((type parent-type) (n 0)) - (if type - (loop (%record-type-parent type) (+ n 1)) - n))) -(define-integrable (check-marker type object index) - (eq? (%record-type-instance-marker type) - (%record-ref object index))) +(define (generate-fields-by-index field-specs parent-type start-index) + (let ((partial-fields + (list->vector + (map (lambda (spec index) + (make-field (field-spec-name spec) + (field-spec-init spec) + index)) + field-specs + (iota (length field-specs) (+ start-index 1)))))) + (if parent-type + (vector-append (%record-type-fields-by-index parent-type) + partial-fields) + partial-fields))) (define (generate-fields-by-name fields-by-index) (let loop ((fields (reverse (vector->list fields-by-index))) (filtered '())) @@ -195,17 +180,77 @@ USA. (define-integrable (field-index field) (vector-ref field 2)) -(define %record-metatag) -(define record-type?) -(define %%make-record-type) -(add-boot-init! - (lambda () - (set! %record-metatag (make-dispatch-metatag 'record-tag)) - (set! record-type? (dispatch-tag->predicate %record-metatag)) - (set! %%make-record-type - (dispatch-metatag-constructor %record-metatag 'make-record-type)) - unspecific)) +(define (%make-marked-type start-index end-index parent-type instance-marker + make-type) + (make-type + (cond ((not parent-type) + (lambda (object) + (%pred=0 instance-marker object))) + ((not (%record-type-parent parent-type)) + (let ((marker2 (%record-type-instance-marker parent-type))) + (lambda (object) + (%pred=1 start-index end-index instance-marker marker2 object)))) + (else + (let ((index2 (%record-type-start-index parent-type)) + (marker2 (%record-type-instance-marker parent-type)) + (type3 (%record-type-parent parent-type))) + (let ((marker3 (%record-type-instance-marker type3))) + (lambda (object) + (%pred>1 start-index end-index instance-marker index2 marker2 + marker3 type3 object)))))))) + +(define (%make-normal-type start-index end-index parent-type make-type) + (letrec + ((type + (make-type + (cond ((not parent-type) + (lambda (object) + (%pred=0 type object))) + ((not (%record-type-parent parent-type)) + (let ((marker2 (%record-type-instance-marker parent-type))) + (lambda (object) + (%pred=1 start-index end-index type marker2 object)))) + (else + (let ((index2 (%record-type-start-index parent-type)) + (marker2 (%record-type-instance-marker parent-type)) + (type3 (%record-type-parent parent-type))) + (let ((marker3 (%record-type-instance-marker type3))) + (lambda (object) + (%pred>1 start-index end-index type index2 marker2 + marker3 type3 object))))))))) + (%set-record-type-instance-marker! type type) + type)) + +(define-integrable (%pred=0 marker1 object) + (and (%record? object) + (%pred-check-marker 0 marker1 object))) + +(define-integrable (%pred=1 start-index end-index marker1 marker2 object) + (and (%pred-prefix end-index object) + (%pred-check-marker start-index marker1 object) + (%pred-check-marker 0 marker2 object))) + +(define-integrable (%pred>1 start-index end-index marker1 start2 marker2 + marker3 type3 object) + (and (%pred-prefix end-index object) + (%pred-check-marker start-index marker1 object) + (%pred-check-marker start2 marker2 object) + (%pred-check-marker 0 marker3 object) + (let loop ((type (%record-type-parent type3))) + (if type + (and (check-type (%record-type-start-index type) + (%record-type-instance-marker type) + object) + (loop (%record-type-parent type))) + #t)))) + +(define-integrable (%pred-prefix end-index object) + (and (%record? object) + (fix:>= (%record-length object) end-index))) +(define-integrable (%pred-check-marker index marker object) + (eq? marker (%record-ref object index))) + (define-integrable (%record-type-start-index record-type) (%dispatch-tag-extra-ref record-type 0)) @@ -221,30 +266,27 @@ USA. (define-integrable (%record-type-parent record-type) (%dispatch-tag-extra-ref record-type 4)) -(define-integrable (%record-type-instance-marker record-type) - (%dispatch-tag-extra-ref record-type 5)) - -(define-integrable (%set-record-type-instance-marker! record-type marker) - (%dispatch-tag-extra-set! record-type 5 marker)) - (define-integrable (%record-type-applicator record-type) - (%dispatch-tag-extra-ref record-type 6)) - -(define-integrable (%set-record-type-applicator! record-type applicator) - (%dispatch-tag-extra-set! record-type 6 applicator)) + (%dispatch-tag-extra-ref record-type 5)) (defer-boot-action 'fixed-objects (lambda () (set-fixed-objects-item! 'record-dispatch-tag %record-metatag) (set-fixed-objects-item! 'record-applicator-index - (%dispatch-tag-extra-index 6)))) + (%dispatch-tag-extra-index 5)))) + +(define-integrable (%record-type-instance-marker record-type) + (%dispatch-tag-extra-ref record-type 6)) + +(define (%set-record-type-instance-marker! record-type marker) + (%dispatch-tag-extra-set! record-type 6 marker)) (define (%record-type-field-by-name record-type name) (or (%record-type-field-by-name-no-error record-type name) (%record-type-field-by-name record-type (error:no-such-slot record-type name)))) -(define-integrable (%record-type-field-by-name-no-error record-type name) +(define (%record-type-field-by-name-no-error record-type name) (vector-binary-search (%record-type-fields-by-name record-type) symbolrecord-type proxy) - (error "Record-type proxy already in use:" proxy)) - (%set-proxied-record-type! proxy type) - (%set-record-type-instance-marker! type proxy))))) - unspecific)) - (define-integrable (%record-type-proxy->index marker) (fix:- (object-new-type (ucode-type fixnum) marker) #x100)) @@ -382,7 +396,7 @@ USA. (cdr form) (iota (length (cdr form))))))))) (enumerate-proxies pathname host)) - + (define (record? object) (and (%record? object) (%record->root-type object) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index de96e95be..b5395fac2 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -146,6 +146,7 @@ USA. (define-unparser-method define-print-method) (simple-unparser-method standard-print-method) (standard-unparser-method bracketed-print-method) + (with-values call-with-values) without-interrupts) (export () %false->weak-false @@ -166,6 +167,7 @@ USA. %weak-set-car! bracketed-print-method bytes-per-object + call-with-values default-object default-object? define-pp-describer @@ -204,6 +206,7 @@ USA. simple-parser-method standard-print-method target-bytes-per-object + values weak-car weak-cdr weak-cons @@ -552,15 +555,13 @@ USA. (parent (runtime)) (export deprecated () (%exit exit) - (quit suspend) - (with-values call-with-values)) + (quit suspend)) (export () (*the-non-printing-object* unspecific) append-hook-to-list apply bind-cell-contents! - call-with-values cd cell-contents cell? @@ -661,7 +662,6 @@ USA. unspecific user-initial-environment user-initial-prompt - values wait-interval with-history-disabled with-interrupt-mask @@ -3959,13 +3959,11 @@ USA. record-type-name record-type-parent record-type? - record? - set-record-type-applicator!) + record?) (export (runtime) error:no-such-slot error:uninitialized-slot - record-type-field-index - set-record-type-fasdumpable!) + record-type-field-index) (export (runtime pathname) record-type-proxy:host record-type-proxy:pathname)