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 f97016b8b635b6ac85b5796dd11f98fa7f6917e7..b20ca698ed6729b045c8f2b3018ef6d4809d09c9 100644 (file)
--- a/src/runtime/boot.scm
+++ b/src/runtime/boot.scm
@@ -503,6 +503,41 @@ USA.
          (list '(evaluated) (promise-value promise))
          (list '(unevaluated))))))
 \f
+;;;; Multiple values
+
+(define <multi-values>
+  (list '<multi-values>))
+
+(define (make-multi-values objects)
+  (cons <multi-values> objects))
+
+(define (multi-values? object)
+  (and (pair? object)
+       (eq? <multi-values> (car object))))
+
+(define (multi-values-list mv)
+  (cdr mv))
+
+(defer-boot-action 'make-record-type
+  (lambda ()
+    (set! <multi-values> (make-record-type '<multi-values> '(list)))
+    (set! make-multi-values (record-constructor <multi-values>))
+    (set! multi-values? (record-predicate <multi-values>))
+    (set! multi-values-list (record-accessor <multi-values> '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 4b6d817d0e28823b0557745724622540f368e04d..72f4f7e1dab99cb175c7a535b46bfd54496710e3 100644 (file)
--- 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 '() <bundle>)))
 
-(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 <bundle>
-  (make-record-type '<bundle> '(alist)))
-(set-record-type-applicator! <bundle> %bundle-applicator)
+  (make-record-type '<bundle> '(alist)
+                   'applicator
+                   (lambda (bundle name . args)
+                     (apply (bundle-ref bundle name) args))))
 
 (define bundle?
   (record-predicate <bundle>))

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 95cba4129dcb1dc99f8498c203531c161657bbd0..b2cf32546d94049c549d8ad7e0eba8463eddfc71 100644 (file)
--- 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 <multi-values>
-    (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 ab9fb90cdcbe2420d4ac9e4a63b4c46b30ac2285..3d400d2d559d0d7c0cdcc3b15d8522db7e86d455 100644 (file)
--- 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 a1370b6cb4fc4ba8f917f50a312cff80efe87079..dce24dbc5cb85c08120c9bfc87fe408cc344b2e1 100644 (file)
--- 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 431df79632737c5614310ca5525c4f30ec79e421..545c88abd3c53de1fa8f4524ea76df681a5986d7 100644 (file)
--- a/src/runtime/pathname.scm
+++ b/src/runtime/pathname.scm
@@ -97,18 +97,19 @@ these rules:
 
 |#
 \f
-(define-record-type <pathname>
-    (%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! <pathname> record-type-proxy:pathname)
-
-(define-guarantee pathname "pathname")
+(define <pathname>
+  (make-record-type '<pathname>
+                   '(host device directory name type version)
+                   'instance-marker record-type-proxy:pathname))
+
+(define %make-pathname (record-constructor <pathname>))
+(define pathname? (record-predicate <pathname>))
+(define %pathname-host (record-accessor <pathname> 'host))
+(define %pathname-device (record-accessor <pathname> 'device))
+(define %pathname-directory (record-accessor <pathname> 'directory))
+(define %pathname-name (record-accessor <pathname> 'name))
+(define %pathname-type (record-accessor <pathname> 'type))
+(define %pathname-version (record-accessor <pathname> '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 <host>
-    (%make-host type-index name)
-    host?
-  (type-index host/type-index)
-  (name host/name))
-(set-record-type-fasdumpable! <host> record-type-proxy:host)
+(define <host>
+  (make-record-type '<host>
+                   '(type-index name)
+                   'instance-marker record-type-proxy:host))
+
+(define %make-host (record-constructor <host>))
+(define host? (record-predicate <host>))
+(define host/type-index (record-accessor <host> 'type-index))
+(define host/name (record-accessor <host> '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 7a3e9e02f55717bc1f979e6d340ae6db91283efc..bf679b3e84d9155d22472d9d07527c10c659bfe0 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -36,14 +36,25 @@ USA.
 (define-primitives
   (vector-cons 2))
 \f
-(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))))
 \f
-(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)))
-\f
-(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))
 \f
-(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)))
+\f
 (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)
                        symbol<?
                        field-name
@@ -255,11 +297,14 @@ USA.
       (%record-type-field-by-index record-type
                                   (error:no-such-slot record-type index))))
 
-(define-integrable (%record-type-field-by-index-no-error record-type index)
+(define (%record-type-field-by-index-no-error record-type index)
   (vector-binary-search (%record-type-fields-by-index record-type)
                        fix:<
                        field-index
                        index))
+
+(define (%record-type-fasdumpable? type)
+  (%record-type-proxy? (%record-type-instance-marker type)))
 \f
 (define (record-type-name record-type)
   (guarantee record-type? record-type 'record-type-name)
@@ -313,17 +358,7 @@ USA.
     (if (not applicator)
        (error:not-a applicable-record? record 'record-applicator))
     applicator))
-
-(define (set-record-type-applicator! record-type applicator)
-  (guarantee record-type? record-type 'set-record-type-applicator!)
-  (if (%record-type-parent record-type)
-      (error:bad-range-argument record-type 'set-record-type-applicator!))
-  (guarantee procedure? applicator 'set-record-type-applicator!)
-  (%set-record-type-applicator! record-type applicator))
 \f
-(define (%record-type-fasdumpable? type)
-  (%record-type-proxy? (%record-type-instance-marker type)))
-
 (define (%record-type-proxy? object)
   (and (object-type? (ucode-type constant) object)
        (let ((v (object-new-type (ucode-type fixnum) object)))
@@ -331,27 +366,6 @@ USA.
              (fix:< v #x200)))))
 (register-predicate! %record-type-proxy? 'record-type-proxy)
 
-(define (set-record-type-fasdumpable! type proxy)
-  (defer-boot-action 'record-procedures
-    (lambda ()
-      (set-record-type-fasdumpable! type proxy))))
-
-(defer-boot-action 'record-procedures
-  (lambda ()
-    (set! set-record-type-fasdumpable!
-         (named-lambda (set-record-type-fasdumpable! type proxy)
-           (guarantee record-type? type 'set-record-type-fasdumpable!)
-           (guarantee %record-type-proxy? proxy 'set-record-type-fasdumpable!)
-           (without-interrupts
-            (lambda ()
-              (if (%record-type-fasdumpable? type)
-                  (error "Record type already fasdumpable:" type))
-              (if (%proxy->record-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))
-\f
+
 (define (record? object)
   (and (%record? object)
        (%record->root-type object)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index de96e95beb35b714e0d62578833557abb9a079b1..b5395fac2a865b8d000ed503d24f11f89e64c021 100644 (file)
--- 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)
          <hook-list>
          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)