From aa0c555c70a9ce14a70949a16183d2d77b9ba0f5 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 10 Feb 2020 10:33:27 -0700
Subject: [PATCH] Add support for record types with anonymous fields

Avoid saving a list of per-field vector descriptions when
field names are not going to be relevant and the rest of
the description is easily computed from information that is
alerady available.

original commit: a20e3f305cee3b4a386582dd50cda344a49174c3
---
 csug/objects.stex       |  43 +++++++
 makefiles/Mf-install.in |   2 +-
 s/cmacros.ss            |  10 +-
 s/cp0.ss                | 202 ++++++++++++++++++++++---------
 s/cpcheck.ss            |  31 +++--
 s/cpletrec.ss           |  16 ++-
 s/fasl.ss               |  44 ++++---
 s/inspect.ss            |  63 +++++++---
 s/layout.ss             |   9 +-
 s/primdata.ss           |   5 +
 s/print.ss              |   2 +-
 s/read.ss               |   4 +-
 s/record.ss             | 256 ++++++++++++++++++++++++++++++----------
 13 files changed, 504 insertions(+), 183 deletions(-)

diff --git a/csug/objects.stex b/csug/objects.stex
index 905c12d2cd..d0b66dcd69 100644
--- a/csug/objects.stex
+++ b/csug/objects.stex
@@ -4105,6 +4105,17 @@ The field names are symbols.
 (record-type-field-names (type-descriptor triple)) ;=> (x1 x2 x3)
 \endschemedisplay
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{record-type-field-names}{\categoryprocedure}{(record-type-field-indices \var{rtd})}
+\returns a list of field indicies of the type represented by \var{rtd}
+\listlibraries
+\endentryheader
+
+\noindent
+\var{rtd} must be a record-type descriptor.
+The field indices are fixnums.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{record-type-field-decls}{\categoryprocedure}{(record-type-field-decls \var{rtd})}
@@ -4187,6 +4198,38 @@ rtd ;=> #<record type frob>
 (eq? (record-type-descriptor x) rtd) ;=> \var{unspecified}
 \endschemedisplay
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{make-record-type-descriptor*}{\categoryprocedure}{(make-record-type-descriptor* \var{name} \var{parent} \var{uid} \var{s?} \var{o?} \var{fields} \var{mutability})}
+\returns a record-type descriptor for a new record type
+\listlibraries
+\endentryheader
+
+\noindent
+This variant of \scheme{make-record-type-descriptor} accepts a field
+count and mutability mask in place of a vector of field descriptions,
+which results in a record type with anonymous fields. The \var{fields}
+argument must be a non-negative fixnum for the field count, and it is
+added to any fields present in \var{parent} to determine the record
+type's total numnber of fields. The \var{mutability} argument must be
+an exact non-negative integer that is treated as a bit array; a
+\scheme{1} bit indicates the the corresponding field among
+\var{fields} is mutable.
+
+If \var{parent} is a record type descriptor, it must also have
+anonymous fields. The resulting anonynmous-field record type can only
+be the parent of a record type with anonymous fields.
+
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{record-type-named-fields?}{\categoryprocedure}{(record-type-named-fields? \var{rtd})}
+\returns a boolean indicating whether \var{rts} has named fields
+\listlibraries
+\endentryheader
+
+\noindent
+\var{rtd} must be a record-type descriptor.
+
 
 \section{Procedures}
 
diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in
index 7d28a8c41a..33cfca5147 100644
--- a/makefiles/Mf-install.in
+++ b/makefiles/Mf-install.in
@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.19
+Version=csv9.5.3.20
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot
diff --git a/s/cmacros.ss b/s/cmacros.ss
index 5dbb0b2a58..c80e2a8aa3 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -328,7 +328,7 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x09050313)
+(define-constant scheme-version #x09050314)
 
 (define-syntax define-machine-types
   (lambda (x)
@@ -1461,11 +1461,11 @@
 (define-primitive-structure-disps record-type type-typed-object
   ([ptr type]
    [ptr parent]
-   [ptr size]
-   [ptr pm]
-   [ptr mpm]
+   [ptr size]  ; total record size in bytes, including type tag
+   [ptr pm]    ; pointer mask, where low bit corresponds to type tag
+   [ptr mpm]   ; mutable-pointer mask, where low bit for type is always 0
    [ptr name]
-   [ptr flds]
+   [ptr flds]  ; either a list of `fld` vectors or a fixnum count
    [ptr flags]
    [ptr uid]
    [ptr counts]))
diff --git a/s/cp0.ss b/s/cp0.ss
index 9808b2a72d..7b642f0266 100644
--- a/s/cp0.ss
+++ b/s/cp0.ss
@@ -123,6 +123,7 @@
   (define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent))
   (define rtd-size (csv7:record-field-accessor #!base-rtd 'size))
   (define rtd-pm (csv7:record-field-accessor #!base-rtd 'pm))
+  (define rtd-mpm (csv7:record-field-accessor #!base-rtd 'mpm))
 
   ; compile-time rtds (ctrtds)
   (define ctrtd-opaque-known #b0000001)
@@ -142,6 +143,39 @@
       (or (not (ctrtd? rtd))
           (fxlogtest (ctrtd-flags rtd) ctrtd-opaque-known))))
 
+  (define rtd-all-immutable?
+    (lambda (rtd)
+      (let ([flds (rtd-flds rtd)])
+        (cond
+         [(fixnum? flds) (eqv? 0 (rtd-mpm rtd))]
+         [else
+          (andmap (lambda (fld) (not (fld-mutable? fld))) flds)]))))
+
+  (define rtd-all-immutable-scheme-objects?
+    (lambda (rtd)
+      (let ([flds (rtd-flds rtd)])
+        (cond
+         [(fixnum? flds)
+          (eqv? 0 (rtd-mpm rtd))]
+         [else
+          (andmap (lambda (fld)
+                    (and (not (fld-mutable? fld))
+                         (eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
+                  flds)]))))
+
+  (define rtd-immutable-field?
+    (lambda (rtd index)
+      (let ([flds (rtd-flds rtd)])
+        (cond
+         [(fixnum? flds)
+          (not (bitwise-bit-set? (rtd-mpm rtd) (fx+ index 1)))]
+         [else
+          (not (fld-mutable? (list-ref flds index)))]))))
+
+  (define rtd-make-fld
+    (lambda (rtd index)
+      (make-fld 'unknown (bitwise-bit-set? (rtd-mpm rtd) (fx+ index 1)) 'scheme-object 0)))
+
   (with-output-language (Lsrc Expr)
     (define void-rec `(quote ,(void)))
     (define true-rec `(quote #t))
@@ -551,17 +585,20 @@
             ; from a rhs.
             [(record ,rtd ,rtd-expr ,e* ...)
              (let-values ([(liftmt* liftme* e*)
-                           (let ([fld* (rtd-flds rtd)])
-                             (let f ([e* e*] [fld* fld*])
+                           (let ([fld* (rtd-flds rtd)]
+                                 [mpm (rtd-mpm rtd)])
+                             (let f ([e* e*] [fld* (and (not (fixnum? fld*)) fld*)] [idx 0])
                                (if (null? e*)
                                    (values '() '() '())
                                    (let ([e (car e*)])
-                                     (let-values ([(liftmt* liftme* e*) (f (cdr e*) (cdr fld*))])
+                                     (let-values ([(liftmt* liftme* e*) (f (cdr e*) (and fld* (cdr fld*)) (fx+ idx 1))])
                                        (if (nanopass-case (Lsrc Expr) e
                                              [(ref ,maybe-src ,x) #f]
                                              [(quote ,d) #f]
                                              [,pr #f]
-                                             [else (not (fld-mutable? (car fld*)))])
+                                             [else (not (if fld*
+                                                            (fld-mutable? (car fld*))
+                                                            (bitwise-bit-set? mpm (fx+ idx 1))))])
                                            (let ([t (cp0-make-temp #f)])
                                              (values (cons t liftmt*) (cons e liftme*) (cons (build-ref t) e*)))
                                            (values liftmt* liftme* (cons e e*))))))))])
@@ -1053,10 +1090,7 @@
               [(record-ref ,rtd ,type ,index ,e) #f]
               [(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
               [(record ,rtd ,rtd-expr ,e* ...)
-               (and (andmap (lambda (fld)
-                              (and (not (fld-mutable? fld))
-                                   (eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
-                      (rtd-flds rtd))
+               (and (rtd-all-immutable-scheme-objects? rtd)
                     (memoize (and (pure1? rtd-expr) (andmap pure1? e*))))]
               [(set! ,maybe-src ,x ,e) #f]
               [(record-cd ,rcd ,rtd-expr ,e) (memoize (pure1? e))]
@@ -1115,12 +1149,12 @@
               [(seq ,e1 ,e2) (memoize (and (ivory? e1) (ivory? e2)))]
               [(record-ref ,rtd ,type ,index ,e) 
                ; here ivory? differs from pure?
-               (and (not (fld-mutable? (list-ref (rtd-flds rtd) index)))
+               (and (rtd-immutable-field? rtd index)
                     (memoize (ivory1? e)))]
               [(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
               [(record ,rtd ,rtd-expr ,e* ...)
                ; here ivory? differs from pure?
-               (and (andmap (lambda (fld) (not (fld-mutable? fld))) (rtd-flds rtd))
+               (and (rtd-all-immutable? rtd)
                     (memoize (and (ivory1? rtd-expr) (andmap ivory1? e*))))]
               [(set! ,maybe-src ,x ,e) #f]
               [(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory1? e))]
@@ -2998,6 +3032,13 @@
           (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?fields))
             [(quote ,d) (k d)]
             [else #f]))
+        (define (get-mutability-mask ?mutability-mask k)
+          (cond
+           [(not ?mutability-mask) (k #f)]
+           [else
+            (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?mutability-mask))
+              [(quote ,d) (k d)]
+              [else #f])]))
         (define (get-sealed x)
           (nanopass-case (Lsrc Expr) (if x (result-exp (value-visit-operand! x)) false-rec)
             [(quote ,d) (values (if d #t #f) ctrtd-sealed-known)]
@@ -3061,7 +3102,7 @@
              (mrt ?parent ?name ?fields ?sealed ?opaque ctxt level $make-record-type '$make-record-type
                (list* ?base-id ?parent ?name ?fields ?sealed ?opaque ?extras))]))
         (let ()
-          (define (mrtd ?parent ?uid ?fields ?sealed ?opaque ctxt level prim primname opnd*)
+          (define (mrtd ?parent ?uid ?fields ?mutability-mask ?sealed ?opaque ctxt level prim primname opnd*)
             (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?uid))
                   [(quote ,d)
                    (and d
@@ -3077,32 +3118,49 @@
                   (lambda (prtd)
                     (get-fields ?fields
                       (lambda (fields)
-                        (let-values ([(sealed? sealed-flag) (get-sealed ?sealed)]
-                                     [(opaque? opaque-flag) (get-opaque ?opaque prtd)])
-                          (cond
-                            [(guard (c [#t #f])
-                               ($make-record-type-descriptor base-ctrtd 'tmp prtd #f
-                                 sealed? opaque? fields 'cp0 (fxlogor sealed-flag opaque-flag))) =>
-                             (lambda (rtd)
-                               (residualize-seq opnd* '() ctxt)
-                               `(record-type ,rtd
-                                  ; can't use level 3 unconditionally because we're missing checks for
-                                  ; ?base-rtd, ?name, ?uid, ?who, and ?extras
-                                  ,(build-primcall (app-preinfo ctxt) level primname
-                                     (value-visit-operands! opnd*))))]
-                            [else #f]))))))))
+                        (get-mutability-mask ?mutability-mask
+                          (lambda (mutability-mask)
+                            (let-values ([(sealed? sealed-flag) (get-sealed ?sealed)]
+                                         [(opaque? opaque-flag) (get-opaque ?opaque prtd)])
+                              (cond
+                                [(guard (c [#t #f])
+                                   (if ?mutability-mask
+                                       ($make-record-type-descriptor* base-ctrtd 'tmp prtd #f
+                                         sealed? opaque? fields mutability-mask 'cp0 (fxlogor sealed-flag opaque-flag))
+                                       ($make-record-type-descriptor base-ctrtd 'tmp prtd #f
+                                         sealed? opaque? fields 'cp0 (fxlogor sealed-flag opaque-flag)))) =>
+                                 (lambda (rtd)
+                                   (residualize-seq opnd* '() ctxt)
+                                   `(record-type ,rtd
+                                      ; can't use level 3 unconditionally because we're missing checks for
+                                      ; ?base-rtd, ?name, ?uid, ?who, and ?extras
+                                      ,(build-primcall (app-preinfo ctxt) level primname
+                                         (value-visit-operands! opnd*))))]
+                                [else #f]))))))))))
 
           (define-inline 2 make-record-type-descriptor
             [(?name ?parent ?uid ?sealed ?opaque ?fields)
-             (mrtd ?parent ?uid ?fields ?sealed ?opaque ctxt level
+             (mrtd ?parent ?uid ?fields #f ?sealed ?opaque ctxt level
                make-record-type-descriptor 'make-record-type-descriptor
                (list ?name ?parent ?uid ?sealed ?opaque ?fields))])
 
+          (define-inline 2 make-record-type-descriptor*
+            [(?name ?parent ?uid ?sealed ?opaque ?fields ?mutability-mask)
+             (mrtd ?parent ?uid ?fields ?mutability-mask ?sealed ?opaque ctxt level
+               make-record-type-descriptor* 'make-record-type-descriptor*
+               (list ?name ?parent ?uid ?sealed ?opaque ?fields ?mutability-mask))])
+
           (define-inline 2 $make-record-type-descriptor
             [(?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?who . ?extras)
-             (mrtd ?parent ?uid ?fields ?sealed ?opaque ctxt level
+             (mrtd ?parent ?uid ?fields #f ?sealed ?opaque ctxt level
                $make-record-type-descriptor '$make-record-type-descriptor
-               (list* ?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?who ?extras))])))
+               (list* ?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?who ?extras))])
+
+          (define-inline 2 $make-record-type-descriptor*
+            [(?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?mutability-mask ?who . ?extras)
+             (mrtd ?parent ?uid ?fields ?mutability-mask ?sealed ?opaque ctxt level
+               $make-record-type-descriptor* '$make-record-type-descriptor*
+               (list* ?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?mutability-mask ?who ?extras))])))
       (let ()
         ; if you update this, also update duplicate in record.ss
         (define-record-type rcd
@@ -3282,7 +3340,14 @@
 
           (let ()
             (define (go safe? rtd rtd-e ctxt)
-              (let* ([fld* (rtd-flds rtd)]
+              (let* ([fld* (let ([flds (rtd-flds rtd)])
+                             (cond
+                              [(fixnum? flds)
+                               (let loop ([i flds])
+                                 (if (fx= i 0)
+                                     '()
+                                     (cons (rtd-make-fld rtd i) (loop (fx- i 1)))))]
+                              [else flds]))]
                      [t* (map (lambda (x) (cp0-make-temp #t)) fld*)]
                      [check* (if safe?
                                  (fold-right
@@ -3370,7 +3435,7 @@
                                        (let f ([ctprcd (ctrcd-ctprcd ctrcd)] [crtd rtd] [prtd prtd] [vars '()])
                                          (let ([pp-args (cp0-make-temp #f)]
                                                [new-vars (map (lambda (x) (cp0-make-temp #f))
-                                                           (vector->list (record-type-field-names crtd)))])
+                                                           (vector->list (record-type-field-indices crtd)))])
                                            (set-prelex-immutable-value! pp-args #t)
                                            `(case-lambda ,(make-preinfo-lambda)
                                               (clause (,pp-args) -1
@@ -3393,14 +3458,14 @@
                                                                        (f (ctrcd-ctprcd ctprcd) prtd pprtd vars))]
                                                                     [else
                                                                      (let ([new-vars (map (lambda (x) (cp0-make-temp #f))
-                                                                                       (csv7:record-type-field-names prtd))])
+                                                                                       (csv7:record-type-field-indices prtd))])
                                                                        (build-lambda new-vars
                                                                          `(call ,(app-preinfo ctxt) ,(go (< level 3) rtd rtd-e ctxt)
                                                                             ,(map build-ref (append new-vars vars))
                                                                             ...)))])))]
                                                            [else
                                                             (let ([new-vars (map (lambda (x) (cp0-make-temp #f))
-                                                                              (csv7:record-type-field-names prtd))])
+                                                                              (csv7:record-type-field-indices prtd))])
                                                               (build-lambda new-vars
                                                                 `(call ,(app-preinfo ctxt) ,(go (< level 3) rtd rtd-e ctxt)
                                                                    ,(map build-ref (append new-vars vars)) ...)))])
@@ -3440,7 +3505,7 @@
               (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?field))
                 [(quote ,d)
                  (cond
-                   [(symbol? d)
+                   [(and (symbol? d) (not (fixnum? (rtd-flds rtd))))
                     ; reverse order to check child's fields first
                     (let loop ([flds (reverse (rtd-flds rtd))] [index (length (rtd-flds rtd))])
                       (let ([index (fx- index 1)])
@@ -3451,8 +3516,13 @@
                                    (loop (cdr flds) index))))))]
                    [(fixnum? d)
                     (let ((flds (rtd-flds rtd)))
-                      (and ($fxu< d (length flds))
-                           (k rtd-e rtd (list-ref flds d) d)))]
+                      (cond
+                       [(fixnum? flds)
+                        (and ($fxu< d flds)
+                             (k rtd-e rtd (rtd-make-fld rtd d) d))]
+                       [else
+                        (and ($fxu< d (length flds))
+                             (k rtd-e rtd (list-ref flds d) d))]))]
                    [else #f])]
                 [else #f]))
 
@@ -3460,9 +3530,15 @@
               (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?field))
                 [(quote ,d)
                  (let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)])
-                   (let ([index (if prtd (+ d (length (rtd-flds prtd))) d)])
-                     (and ($fxu< index (length flds))
-                          (k rtd-e rtd (list-ref flds index) index))))]
+                   (let ([p-flds (and prtd (rtd-flds prtd))])
+                     (let ([index (if prtd (+ d (if (fixnum? p-flds) p-flds (length p-flds))) d)])
+                       (cond
+                        [(fixnum? flds)
+                         (and ($fxu< index flds)
+                              (k rtd-e rtd (rtd-make-fld rtd index) index))]
+                        [else
+                         (and ($fxu< index (length flds))
+                              (k rtd-e rtd (list-ref flds index) index))]))))]
                 [else #f]))
 
             (define (find-rtd-and-field ?rtd ?field find-fld k)
@@ -3746,21 +3822,32 @@
                               (list xval rtdval)))))))
              (define obviously-incompatible?
                (lambda (instance-rtd rtd)
-                 (let f ([ls1 (rtd-flds instance-rtd)] [ls2 (rtd-flds rtd)])
-                   (if (null? ls2)
-                       (if (record-type-parent instance-rtd)
-                           ; could work harder here, though it gets trickier (so not obvious)...
-                           #f
-                           ; instance has no parent, so rtds are compatible only if they are the same modulo incomplete info if one or both are ctrtds
-                           (or (not (null? ls1))
-                               (and (record-type-parent rtd) #t)
-                               (and (and (record-type-sealed-known? rtd) (record-type-sealed-known? instance-rtd))
-                                    (not (eq? (record-type-sealed? instance-rtd) (record-type-sealed? rtd))))
-                               (and (and (record-type-opaque-known? rtd) (record-type-opaque-known? instance-rtd))
-                                    (not (eq? (record-type-opaque? instance-rtd) (record-type-opaque? rtd))))))
-                       (or (null? ls1)
-                           (not (equal? (car ls1) (car ls2)))
-                           (f (cdr ls1) (cdr ls2)))))))
+                 (let ([flds1 (rtd-flds instance-rtd)]
+                       [flds2 (rtd-flds rtd)])
+                   (cond
+                    [(or (fixnum? flds1) (fixnum? flds2))
+                     (or (not (fixnum? flds1))
+                         (not (fixnum? flds2))
+                         (fx< flds1 flds2)
+                         (not (= (rtd-mpm instance-rtd)
+                                 (bitwise-and (rtd-mpm rtd)
+                                              (sub1 (bitwise-arithmetic-shift-left 1 (fx+ flds1 1)))))))]
+                    [else
+                     (let f ([ls1 flds1] [ls2 flds2])
+                       (if (null? ls2)
+                           (if (record-type-parent instance-rtd)
+                               ; could work harder here, though it gets trickier (so not obvious)...
+                               #f
+                               ; instance has no parent, so rtds are compatible only if they are the same modulo incomplete info if one or both are ctrtds
+                               (or (not (null? ls1))
+                                   (and (record-type-parent rtd) #t)
+                                   (and (and (record-type-sealed-known? rtd) (record-type-sealed-known? instance-rtd))
+                                        (not (eq? (record-type-sealed? instance-rtd) (record-type-sealed? rtd))))
+                                   (and (and (record-type-opaque-known? rtd) (record-type-opaque-known? instance-rtd))
+                                        (not (eq? (record-type-opaque? instance-rtd) (record-type-opaque? rtd))))))
+                           (or (null? ls1)
+                               (not (equal? (car ls1) (car ls2)))
+                               (f (cdr ls1) (cdr ls2)))))]))))
              (nanopass-case (Lsrc Expr) (result-exp rtdval)
                [(quote ,d0)
                 (and (record-type-descriptor? d0)
@@ -3898,7 +3985,7 @@
            (nanopass-case (Lsrc Expr) (result-exp rtd-expr)
              [(quote ,d)
               (and (record-type-descriptor? d)
-                   (if (andmap (lambda (fld) (not (fld-mutable? fld))) (rtd-flds d))
+                   (if (rtd-all-immutable? d)
                        (let ([e* (objs-if-constant (value-visit-operands! ?e*))])
                          (and e*
                               (begin
@@ -5063,10 +5150,7 @@
             (or (nanopass-case (Lsrc Expr) (result-exp rtd-expr)
                   [(quote ,d)
                    (and (record-type-descriptor? d)
-                        (andmap (lambda (fld)
-                                  (and (not (fld-mutable? fld))
-                                       (eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
-                          (rtd-flds d))
+                        (rtd-all-immutable-scheme-objects? d)
                         (let ([d* (objs-if-constant e*)])
                           (and d*
                                (make-1seq ctxt
@@ -5110,7 +5194,7 @@
                 (nanopass-case (Lsrc Expr) (result-exp/indirect-ref e0)
                   [(record ,rtd1 ,rtd-expr ,e* ...)
                    (and (> (length e*) index)
-                        (not (fld-mutable? (list-ref (rtd-flds rtd) index)))
+                        (rtd-immutable-field? rtd index)
                         (let ([e (list-ref e* index)])
                           (and (nanopass-case (Lsrc Expr) e
                                  [(quote ,d) #t]
diff --git a/s/cpcheck.ss b/s/cpcheck.ss
index 407b244f42..91d88598ba 100644
--- a/s/cpcheck.ss
+++ b/s/cpcheck.ss
@@ -44,8 +44,11 @@
 
   (define record-field-offset
     (lambda (rtd index)
-      (let ([rtd (maybe-remake-rtd rtd)])
-        (fld-byte (list-ref (rtd-flds rtd) index)))))
+      (let* ([rtd (maybe-remake-rtd rtd)]
+             [flds (rtd-flds rtd)])
+        (if (fixnum? flds)
+            (fx+ (constant record-data-disp) (fxsll index (constant log2-ptr-bytes)))
+            (fld-byte (list-ref flds index))))))
 
   (define-pass cpcheck : Lsrc (ir) -> Lsrc ()
     (definitions
@@ -185,17 +188,19 @@
       [(record ,rtd ,[rtd-expr #f -> rtd-expr] ,[e* #f -> e*] ...)
        (let ([rtd (maybe-remake-rtd rtd)])
          (let ([fld* (rtd-flds rtd)] [rec-t (make-prelex*)])
-           (safe-assert (fx= (length e*) (length fld*)))
-           (let ([filler* (fold-right
-                            (lambda (fld e filler*)
-                              (let ([type (fld-type fld)])
-                                (if (eq? (filter-foreign-type type) 'scheme-object)
-                                    filler*
-                                    (cons
-                                      `(call ,(make-preinfo-call) ,(lookup-primref 3 '$object-set!)
-                                         (quote ,type) (ref #f ,rec-t) (quote ,(fld-byte fld)) ,e)
-                                      filler*))))
-                            '() fld* e*)])
+           (safe-assert (fx= (length e*) (if (fixnum? fld*) fld* (length fld*))))
+           (let ([filler* (if (fixnum? fld*)
+                              '()
+                              (fold-right
+                               (lambda (fld e filler*)
+                                 (let ([type (fld-type fld)])
+                                   (if (eq? (filter-foreign-type type) 'scheme-object)
+                                       filler*
+                                       (cons
+                                        `(call ,(make-preinfo-call) ,(lookup-primref 3 '$object-set!)
+                                               (quote ,type) (ref #f ,rec-t) (quote ,(fld-byte fld)) ,e)
+                                        filler*))))
+                               '() fld* e*))])
              (if (null? filler*)
                  `(call ,(make-preinfo-call) ,(lookup-primref 3 '$record) ,rtd-expr ,e* ...)
                  (begin
diff --git a/s/cpletrec.ss b/s/cpletrec.ss
index ad9b2fcdf1..2bb04998a8 100644
--- a/s/cpletrec.ss
+++ b/s/cpletrec.ss
@@ -56,6 +56,7 @@ Handling letrec and letrec*
   (include "base-lang.ss")
 
   (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
+  (define rtd-mpm (csv7:record-field-accessor #!base-rtd 'mpm))
 
   (define-pass lift-profile-forms : Lsrc (ir) -> Lsrc ()
     (definitions
@@ -370,11 +371,16 @@ Handling letrec and letrec*
          (values
            `(record ,rtd ,rtd-expr ,e* ...)
            (and (and rtd-pure? pure?)
-                (andmap
-                  (lambda (fld)
-                    (and (not (fld-mutable? fld))
-                         (eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
-                  (rtd-flds rtd)))))]
+                (let ([flds (rtd-flds rtd)])
+                  (cond
+                   [(fixnum? flds)
+                    (eqv? 0 (rtd-mpm rtd))]
+                   [else
+                    (andmap
+                      (lambda (fld)
+                        (and (not (fld-mutable? fld))
+                             (eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
+                      flds)])))))]
       [(record-type ,rtd ,e) (Expr e)]
       [(record-cd ,rcd ,rtd-expr ,e) (Expr e)]
       [(immutable-list (,[e* pure?*] ...) ,[e pure?])
diff --git a/s/fasl.ss b/s/fasl.ss
index 7e5575770d..fcaf9eb2ad 100644
--- a/s/fasl.ss
+++ b/s/fasl.ss
@@ -85,10 +85,16 @@
   (lambda (x t a? d)
     (let ([rtd ($record-type-descriptor x)])
       (bld rtd t a? d)
-      (do ([flds (rtd-flds rtd) (cdr flds)] [i 0 (+ i 1)])
-        ((null? flds))
-        (when (memq (fld-type (car flds)) '(scheme-object ptr))
-          (bld ((csv7:record-field-accessor rtd i) x) t a? d))))))
+      (let ([flds (rtd-flds rtd)])
+        (if (fixnum? flds)
+            (let loop ([i 0])
+              (unless (fx= i flds)
+                (bld ($record-ref x i) t a? d)
+                (loop (fx+ i 1))))
+            (do ([flds flds (cdr flds)] [i 0 (+ i 1)])
+              ((null? flds))
+              (when (memq (fld-type (car flds)) '(scheme-object ptr))
+                (bld ((csv7:record-field-accessor rtd i) x) t a? d))))))))
 
 (define bld-ht
   (lambda (x t a? d)
@@ -385,7 +391,7 @@
                         [else ($oops 'fasl-write "unexpected difference in filtered foreign type ~s for unfiltered type ~s" filtered-type type)])
                 ($oops 'fasl-write "host value ~s for type ~s is too big for target" val type))))))
       (define put-field
-        (lambda (target-fld pad val)
+        (lambda (field-type field-addr pad val)
           (define put-i64
             (lambda (p val)
               (constant-case ptr-bits
@@ -395,7 +401,7 @@
             (syntax-rules ()
               [(_ fasl-fld-type)
                (put-u8 p (fxlogor (fxsll pad 4) (constant fasl-fld-type)))]))
-          (let ([type (fld-type target-fld)] [addr (fld-byte target-fld)])
+          (let ([type field-type] [addr field-addr])
             ; using filter-foreign-type to get target filtering
             (case (filter-foreign-type type)
               [(scheme-object) (put-padty fasl-fld-ptr) (wrf val p t a?) (constant ptr-bytes)]
@@ -433,17 +439,23 @@
              [target-rtd (maybe-remake-rtd host-rtd)]
              [target-fld* (rtd-flds target-rtd)])
         (put-uptr p (rtd-size target-rtd))
-        (put-uptr p (length target-fld*))
+        (put-uptr p (if (fixnum? target-fld*) target-fld* (length target-fld*)))
         (wrf host-rtd p t a?)
-        (fold-left
-          (lambda (last-target-addr host-fld target-fld)
-            (let ([val (get-field host-fld)])
-              (check-field target-fld val)
-              (let ([target-addr (fld-byte target-fld)])
-                (fx+ target-addr (put-field host-fld (fx- target-addr last-target-addr) val)))))
-          (constant record-data-disp)
-          (rtd-flds host-rtd)
-          target-fld*))))
+        (if (fixnum? target-fld*)
+            (let loop ([i 0] [addr (constant record-data-disp)])
+              (unless (fx= i target-fld*)
+                (let ([sz (put-field 'scheme-object addr 0 ($record-ref x i))])
+                  (loop (fx+ i 1) (fx+ addr sz)))))
+            (fold-left
+              (lambda (last-target-addr host-fld target-fld)
+                (let ([val (get-field host-fld)])
+                  (check-field target-fld val)
+                  (let ([target-addr (fld-byte target-fld)])
+                    (fx+ target-addr (put-field (fld-type host-fld) (fld-byte host-fld)
+                                                (fx- target-addr last-target-addr) val)))))
+              (constant record-data-disp)
+              (rtd-flds host-rtd)
+              target-fld*)))))
 
   (define wrf-record
     (lambda (x p t a?)
diff --git a/s/inspect.ss b/s/inspect.ss
index b97b698f01..f81620f428 100644
--- a/s/inspect.ss
+++ b/s/inspect.ss
@@ -2061,7 +2061,9 @@
     (define make-record-object
       (lambda (x)
         (let* ((rtd ($record-type-descriptor x))
-               (fields (csv7:record-type-field-names rtd)))
+               (fields (if (record-type-named-fields? rtd)
+                           (csv7:record-type-field-names rtd)
+                           (csv7:record-type-field-indices rtd))))
           (define check-field
             (lambda (f)
               (unless (or (and (symbol? f) (memq f fields))
@@ -2644,12 +2646,21 @@
                     ((fx= i n) size)))]
                [($record? x)
                 (let ([rtd ($record-type-descriptor x)])
-                  (fold-left (lambda (size fld)
-                               (if (eq? (fld-type fld) 'scheme-object)
-                                   (fx+ size (compute-size ($object-ref 'scheme-object x (fld-byte fld))))
-                                   size))
-                    (fx+ (align (rtd-size rtd)) (compute-size rtd))
-                    (rtd-flds rtd)))]
+                  (let ([flds (rtd-flds rtd)])
+                    (cond
+                     [(fixnum? flds)
+                      (let loop ([i 0] [size 0])
+                        (cond
+                         [(fx= i flds) size]
+                         [else (loop (fx+ i 1)
+                                     (fx+ size (compute-size ($record-ref x i))))]))]
+                     [else
+                      (fold-left (lambda (size fld)
+                                   (if (eq? (fld-type fld) 'scheme-object)
+                                       (fx+ size (compute-size ($object-ref 'scheme-object x (fld-byte fld))))
+                                       size))
+                        (fx+ (align (rtd-size rtd)) (compute-size rtd))
+                        flds)])))]
                [(string? x) (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes))))]
                [(box? x) (fx+ (constant size-box) (compute-size (unbox x)))]
                [(flonum? x) (constant size-flonum)]
@@ -2838,10 +2849,18 @@
                        (set-cdr! p (fx+ (cdr p) size)))
                      (eq-hashtable-set! rtd-ht rtd (cons 1 size))))
                (compute-composition! rtd)
-               (for-each (lambda (fld)
-                           (when (eq? (fld-type fld) 'scheme-object)
-                             (compute-composition! ($object-ref 'scheme-object x (fld-byte fld)))))
-                 (rtd-flds rtd)))]
+               (let ([flds (rtd-flds rtd)])
+                 (cond
+                  [(fixnum? flds)
+                   (let loop ([i 0])
+                     (unless (fx= i flds)
+                       (compute-composition! ($record-ref x i))
+                       (loop (fx+ i 1))))]
+                  [else
+                   (for-each (lambda (fld)
+                               (when (eq? (fld-type fld) 'scheme-object)
+                                 (compute-composition! ($object-ref 'scheme-object x (fld-byte fld)))))
+                     (rtd-flds rtd))])))]
             [(string? x) (incr! string (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes)))))]
             [(box? x)
              (incr! box (constant size-box))
@@ -2990,13 +3009,21 @@
                       [($record? x)
                        (let ([rtd ($record-type-descriptor x)])
                          (construct-proc rtd
-                           (let f ([flds (rtd-flds rtd)])
-                             (if (null? flds)
-                                 next-proc
-                                 (let ([fld (car flds)])
-                                   (if (eq? (fld-type fld) 'scheme-object)
-                                       (construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds)))
-                                       (f (cdr flds))))))))]
+                           (let ([flds (rtd-flds rtd)])
+                             (cond
+                              [(fixnum? flds)
+                               (let loop ([i 0])
+                                 (if (fx= i flds)
+                                     next-proc
+                                     (construct-proc ($record-ref x i) (loop (fx+ i 1)))))]
+                              [else
+                               (let f ([flds (rtd-flds rtd)])
+                                 (if (null? flds)
+                                     next-proc
+                                     (let ([fld (car flds)])
+                                       (if (eq? (fld-type fld) 'scheme-object)
+                                           (construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds)))
+                                           (f (cdr flds))))))]))))]
                       [(or (fxvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x)
                            ($inexactnum? x) ($rtd-counts? x) (phantom-bytevector? x))
                        next-proc]
diff --git a/s/layout.ss b/s/layout.ss
index a46b552c54..c32f61b7d3 100644
--- a/s/layout.ss
+++ b/s/layout.ss
@@ -16,7 +16,11 @@
 (define compute-field-offsets
  ; type-disp is the offset from the ptr to the object's true address
  ; ls is a list of field descriptors
-  (lambda (who type-disp ls)
+  (case-lambda
+   [(who type-disp n mpm)
+    ;; Simple case: all pointers, mutability mask given
+    (values -1 mpm n (fx* n (constant ptr-bytes)))]
+   [(who type-disp ls)
     (define parse-field
       (lambda (f)
         (define supported-type
@@ -107,5 +111,4 @@
             (if (= (- (ash 1 (quotient (+ size -1 (constant ptr-bytes)) (constant ptr-bytes))) 1) m)
                 -1
                 m)))
-        (values (sanitize-mask pm size) mpm flds size)))))
-
+        (values (sanitize-mask pm size) mpm flds size)))]))
diff --git a/s/primdata.ss b/s/primdata.ss
index f645b9bde0..917ab8de8d 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -845,6 +845,7 @@
   ((csv7: record-type-descriptor) [sig [(record) -> (rtd)]] [flags pure mifoldable discard true cp02])
   ((csv7: record-type-field-decls) [sig [(rtd) -> (list)]] [flags pure mifoldable discard true cp02])
   ((csv7: record-type-field-names) [sig [(rtd) -> (list)]] [flags pure mifoldable discard true cp02])
+  ((csv7: record-type-field-indices) [sig [(rtd) -> (list)]] [flags pure mifoldable discard true])
   ((csv7: record-type-name) [sig [(rtd) -> (string)]] [flags pure mifoldable discard true cp02])
   ((csv7: record-type-symbol) [sig [(rtd) -> (symbol)]] [flags pure mifoldable discard true cp02])
 )
@@ -1476,6 +1477,7 @@
   (make-phantom-bytevector [sig [(uptr) -> (phantom-bytevector)]] [flags true])
   (make-pseudo-random-generator [sig [() -> (pseudo-random-generator)]] [flags true])
   (make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (rtd)]] [flags pure alloc cp02])
+  (make-record-type-descriptor* [sig [(symbol maybe-rtd maybe-symbol ptr ptr fixnum exact-integer) -> (rtd)]] [flags pure alloc cp02])
   (make-source-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
   (make-source-file-descriptor [sig [(string binary-input-port) (string binary-input-port ptr) (string binary-input-port ptr ptr) -> (sfd)]] [flags true])
   (make-source-object [sig [(sfd uint uint) (sfd uint uint uint uint) -> (source-object)]] [flags pure true mifoldable discard])
@@ -1588,6 +1590,8 @@
   (record-reader [sig [(sub-ptr) -> (ptr)] [(sub-ptr sub-ptr) -> (void)]] [flags])
   (record-type-equal-procedure [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags])
   (record-type-hash-procedure [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags])
+  (record-type-field-indices [sig [(rtd) -> (vector)]] [flags])
+  (record-type-named-fields? [sig [(rtd) -> (boolean)]] [flags])
   (record-writer [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags])
   (register-signal-handler [sig [(sint procedure) -> (void)]] [flags])
   (remove-foreign-entry [sig [(string) -> (void)]] [flags true])
@@ -2170,6 +2174,7 @@
   ($make-recompile-condition [flags single-valued])
   ($make-record-constructor-descriptor [flags single-valued pure true cp02])
   ($make-record-type-descriptor [flags single-valued pure alloc cp02])
+  ($make-record-type-descriptor* [flags single-valued pure alloc cp02])
   ($make-record-type [sig [(rtd maybe-rtd sub-ptr sub-list ptr ptr ptr ...) -> (rtd)]] [flags pure alloc cp02])
   ($make-relocation-table! [flags single-valued])
   ($make-rnrs-libraries [flags single-valued])
diff --git a/s/print.ss b/s/print.ss
index f7c735efb3..09758ee691 100644
--- a/s/print.ss
+++ b/s/print.ss
@@ -49,7 +49,7 @@
                ; we use write instead of wr here so that the field doesn't get
                ; a reference (#n#) when print-graph is true.
                 (write (or (record-reader rtd) (record-type-uid rtd)) p)
-                (do ([flds (csv7:record-type-field-names rtd) (cdr flds)]
+                (do ([flds (csv7:record-type-field-indices rtd) (cdr flds)]
                      [i 0 (+ i 1)])
                     ((null? flds))
                   (write-char #\space p)
diff --git a/s/read.ss b/s/read.ss
index a3e6629d40..af2f7221da 100644
--- a/s/read.ss
+++ b/s/read.ss
@@ -1110,7 +1110,7 @@
              (rd-fix-graph (vector-ref x m) rd-set-vector-tail! x m))))]
       [($record? x)
        (let ((d ($record-type-descriptor x)))
-         (do ([fields (csv7:record-type-field-names d) (cdr fields)]
+         (do ([fields (csv7:record-type-field-indices d) (cdr fields)]
               [i 0 (+ i 1)])
              ((null? fields))
            (when (csv7:record-field-accessible? d i)
@@ -1134,7 +1134,7 @@
           (let* ((dr (car wl))
                  (rtd (delayed-record-rtd dr))
                  (vals (delayed-record-vals dr))
-                 (fields (csv7:record-type-field-names rtd)))
+                 (fields (csv7:record-type-field-indices rtd)))
             (if (andmap
                   (lambda (f v)
                     (or (not (delayed-record? v))
diff --git a/s/record.ss b/s/record.ss
index c3019a6752..335b4eb6aa 100644
--- a/s/record.ss
+++ b/s/record.ss
@@ -38,9 +38,19 @@
   (define (child-flds rtd)
     (let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)])
       (if prtd
-          (list-tail flds (length (rtd-flds prtd)))
+          (let ([p-flds (rtd-flds prtd)])
+            (if (fixnum? flds)
+                (fx- flds p-flds)
+                (list-tail flds (length p-flds))))
           flds)))
 
+  ;; assumes anonymous fields
+  (define (parent-flds rtd)
+    (let ([prtd (rtd-parent rtd)])
+      (if prtd
+          (rtd-flds prtd)
+          0)))
+
   ; $record is hand-coded and is defined in prims.ss
 
   (let ([addr? (constant-case ptr-bits
@@ -403,21 +413,41 @@
             (constant rtd-opaque)
             0)
         (if sealed? (constant rtd-sealed) 0)))
-    (define ($mrt who base-rtd name parent uid flags fields extras)
+    (define ($mrt who base-rtd name parent uid flags fields mutability-mask extras)
       (include "layout.ss")
-      (when (and parent (record-type-sealed? parent))
-        ($oops who "cannot extend sealed record type ~s" parent))
-      (let ([parent-fields (if (not parent) '() (csv7:record-type-field-decls parent))]
-            [uid (or uid ((current-generate-id) name))])
+      (when parent
+        (when (record-type-sealed? parent)
+          ($oops who "cannot extend sealed record type ~s" parent))
+        (if (fixnum? fields)
+            (unless (fixnum? (rtd-flds parent))
+              ($oops who "cannot make anonymous-field record type ~s from named-field parent record type ~s" name parent))
+            (when (fixnum? (rtd-flds parent))
+              ($oops who "cannot make named-field record type ~s from anonymous-field parent record type ~s" name parent))))
+      (let ([uid (or uid ((current-generate-id) name))])
        ; start base offset at rtd field
        ; synchronize with syntax.ss and front.ss
         (let-values ([(pm mpm flds size)
-                      (compute-field-offsets who
-                        (constant record-type-disp)
-                       ; rtd must be immutable if we are ever to store records
-                       ; in space pure
-                        (cons `(immutable scheme-object ,uid)
-                              (append parent-fields fields)))])
+                      (if (fixnum? fields)
+                          (let ([parent-n (if parent
+                                              (let ([p-flds (rtd-flds parent)])
+                                                (if (fixnum? p-flds)
+                                                    p-flds
+                                                    (length p-flds)))
+                                              0)])
+                            (unless (< (+ fields parent-n 1) (fxsrl (most-positive-fixnum) (constant log2-ptr-bytes)))
+                              ($oops who "cannot make record type with ~s fields" (+ fields parent-n)))
+                            (compute-field-offsets who
+                              (constant record-type-disp)
+                              (fx+ parent-n fields 1)
+                              (+ (bitwise-arithmetic-shift-left mutability-mask (fx+ parent-n 1))
+                                 (if parent (rtd-mpm parent) 0))))
+                          (let ([parent-fields (if (not parent) '() (csv7:record-type-field-decls parent))])
+                            (compute-field-offsets who
+                              (constant record-type-disp)
+                              ; rtd must be immutable if we are ever to store records
+                              ; in space pure
+                              (cons `(immutable scheme-object ,uid)
+                                    (append parent-fields fields)))))])
           (cond
             [(and (not (fxlogtest flags (constant rtd-generative)))
                   (let ([x ($sgetprop uid '*rtd* #f)])
@@ -436,21 +466,23 @@
                            ; following is paranoid; overall size
                            ; check should suffice
                             #;(= (fld-byte fld1) (fld-byte fld2)))))
-                   (and (= (length flds1) (length flds2))
-                        (andmap same-field? flds1 flds2))))
+                   (or (and (fixnum? flds1) (fixnum? flds2) (fx= flds1 flds2))
+                       (and (not (fixnum? flds1)) (not (fixnum? flds2))
+                            (fx= (length flds1) (length flds2))
+                            (andmap same-field? flds1 flds2)))))
               ; following assumes extras match
                (let ()
                  (define (squawk what) ($oops who "incompatible record type ~s - ~a" name what))
                  (unless (eq? ($record-type-descriptor rtd) base-rtd) (squawk "different base rtd"))
                  (unless (eq? (rtd-parent rtd) parent) (squawk "different parent"))
-                 (unless (same-fields? (rtd-flds rtd) (cdr flds)) (squawk "different fields"))
+                 (unless (same-fields? (rtd-flds rtd) (if (pair? flds) (cdr flds) (fx- flds 1))) (squawk "different fields"))
                  (unless (= (rtd-mpm rtd) mpm) (squawk "different mutability"))
                  (unless (fx= (rtd-flags rtd) flags) (squawk "different flags"))
                  (unless (eq? (rtd-size rtd) size) (squawk "different size")))
                rtd)]
             [else
              (let ([rtd (apply #%$record base-rtd parent size pm mpm name
-                          (cdr flds) flags uid #f extras)])
+                          (if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f extras)])
                (with-tc-mutex ($sputprop uid '*rtd* rtd))
                rtd)]))))
 
@@ -463,12 +495,18 @@
                     [parent (rtd-parent rtd)]
                     [name (rtd-name rtd)]
                     [flags (rtd-flags rtd)]
-                    [fields (csv7:record-type-field-decls rtd)])
+                    [flds (rtd-flds rtd)])
                 (let-values ([(pm mpm flds size)
-                              (compute-field-offsets who
-                                (constant record-type-disp)
-                                (cons `(immutable scheme-object ,uid) fields))])
-                  (let ([rtd (apply #%$record base-rtd parent size pm mpm name (cdr flds) flags uid #f
+                              (if (fixnum? flds)
+                                  (compute-field-offsets who
+                                    (constant record-type-disp)
+                                    (fx+ flds 1) (rtd-mpm rtd))
+                                  (let ([fields (csv7:record-type-field-decls rtd)])
+                                    (compute-field-offsets who
+                                      (constant record-type-disp)
+                                      (cons `(immutable scheme-object ,uid) fields))))])
+                  (let ([rtd (apply #%$record base-rtd parent size pm mpm name
+                               (if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f
                                (let* ([n (length (rtd-flds ($record-type-descriptor base-rtd)))]
                                       [ls (list-tail (rtd-flds base-rtd) n)])
                                  (let f ([n n] [ls ls])
@@ -486,12 +524,12 @@
            ($mrt 'make-record-type base-rtd
              (string->symbol (symbol->string name)) parent name
              (make-flags name sealed? opaque? parent)
-             fields extras)]
+             fields 0 extras)]
           [(string? name)
            ($mrt 'make-record-type base-rtd
              (string->symbol name) parent #f
              (make-flags #f sealed? opaque? parent)
-             fields extras)]
+             fields 0 extras)]
           [else ($oops 'make-record-type "invalid record name ~s" name)]))
 
       (set-who! make-record-type
@@ -522,41 +560,67 @@
           (mrt base-rtd parent name fields sealed? opaque? extras))))
 
     (let ()
-      (define (mrtd base-rtd name parent uid sealed? opaque? fields who extras)
+      (define (mrtd base-rtd name parent uid sealed? opaque? fields mutability-mask? mutability-mask who extras)
         (unless (symbol? name)
           ($oops who "invalid record name ~s" name))
         (unless (or (not parent) (record-type-descriptor? parent))
           ($oops who "invalid parent ~s" parent))
         (unless (or (not uid) (symbol? uid))
           ($oops who "invalid uid ~s" uid))
-        (unless (vector? fields)
-          ($oops who "invalid field vector ~s" fields))
+        (cond
+         [mutability-mask?
+          (unless (and (fixnum? fields)
+                       (fx>= fields 0))
+            ($oops who "invalid field count ~s" fields))
+          (unless (and (or (fixnum? mutability-mask) (bignum? mutability-mask))
+                       (eqv? 0 (bitwise-arithmetic-shift-right mutability-mask fields)))
+            ($oops who "invalid mutability mask ~s for field count ~s" mutability-mask fields))]
+         [else
+          (unless (vector? fields)
+            ($oops who "invalid field vector ~s" fields))])
         ($mrt who base-rtd name parent uid
           (make-flags uid sealed? opaque? parent)
-          (let ([n (vector-length fields)])
-            (let f ([i 0])
-              (if (fx= i n)
-                  '()
-                  (let ([x (vector-ref fields i)])
-                    (unless (and (pair? x)
-                                 (memq (car x) '(mutable immutable))
-                                 (let ([x (cdr x)])
-                                   (and (pair? x)
-                                        (symbol? (car x))
-                                        (null? (cdr x)))))
-                      ($oops who "invalid field specifier ~s" x))
-                    (cons x (f (fx+ i 1)))))))
+          (if mutability-mask?
+              fields
+              (let ([n (vector-length fields)])
+                (let f ([i 0])
+                  (if (fx= i n)
+                      '()
+                      (let ([x (vector-ref fields i)])
+                        (unless (and (pair? x)
+                                     (memq (car x) '(mutable immutable))
+                                     (let ([x (cdr x)])
+                                       (and (pair? x)
+                                            (symbol? (car x))
+                                            (null? (cdr x)))))
+                          ($oops who "invalid field specifier ~s" x))
+                        (cons x (f (fx+ i 1))))))))
+          mutability-mask
           extras))
 
       (set! $make-record-type-descriptor
-        (lambda (base-rtd name parent uid sealed? opaque? fields who . extras)
+        (case-lambda
+         [(base-rtd name parent uid sealed? opaque? fields who . extras)
           (unless (record-type-descriptor? base-rtd)
             ($oops who "invalid base rtd ~s" base-rtd))
-          (mrtd base-rtd name parent uid sealed? opaque? fields who extras)))
+          (mrtd base-rtd name parent uid sealed? opaque? fields #f 0 who extras)]))
+
+      (set! $make-record-type-descriptor*
+        (case-lambda
+         [(base-rtd name parent uid sealed? opaque? fields mutability-mask who . extras)
+          (unless (record-type-descriptor? base-rtd)
+            ($oops who "invalid base rtd ~s" base-rtd))
+          (mrtd base-rtd name parent uid sealed? opaque? fields #t mutability-mask who extras)]))
 
       (set-who! make-record-type-descriptor
-        (lambda (name parent uid sealed? opaque? fields)
-          (mrtd base-rtd name parent uid sealed? opaque? fields who '()))))
+        (case-lambda
+         [(name parent uid sealed? opaque? fields)
+          (mrtd base-rtd name parent uid sealed? opaque? fields #f 0 who '())]))
+
+      (set-who! make-record-type-descriptor*
+        (case-lambda
+         [(name parent uid sealed? opaque? fields mutability-mask)
+          (mrtd base-rtd name parent uid sealed? opaque? fields #t mutability-mask who '())])))
 
     (set! record-type-descriptor?
       (lambda (x)
@@ -605,33 +669,79 @@
         ($oops who "~s is not a record type descriptor" rtd))
       (rtd-uid rtd)))
 
+  (set-who! record-type-named-fields?
+    (lambda (rtd)
+      (unless (record-type-descriptor? rtd)
+        ($oops who "~s is not a record type descriptor" rtd))
+      (not (fixnum? (rtd-flds rtd)))))
+
   (set-who! #(csv7: record-type-field-names)
     (lambda (rtd)
       (unless (record-type-descriptor? rtd)
         ($oops who "~s is not a record type descriptor" rtd))
-      (map (lambda (x) (fld-name x)) (rtd-flds rtd))))
+      (let ([flds (rtd-flds rtd)])
+        (if (fixnum? flds)
+            ($oops who "~s is a record type descriptor with anonymous fields" rtd)
+            (map (lambda (x) (fld-name x)) flds)))))
 
   (set-who! record-type-field-names
     (lambda (rtd)
       (unless (record-type-descriptor? rtd)
         ($oops who "~s is not a record type descriptor" rtd))
-      (list->vector (map (lambda (x) (fld-name x)) (child-flds rtd)))))
+      (let ([flds (child-flds rtd)])
+        (if (fixnum? flds)
+            ($oops who "~s is a record type descriptor with anonymous fields" rtd)
+            (list->vector (map (lambda (x) (fld-name x)) flds))))))
+
+  (set-who! #(csv7: record-type-field-indices)
+    (lambda (rtd)
+      (unless (record-type-descriptor? rtd)
+        ($oops who "~s is not a record type descriptor" rtd))
+      (let* ([flds (rtd-flds rtd)]
+             [n-flds (if (fixnum? flds)
+                         flds
+                         (length flds))])
+        (iota n-flds))))
+
+  (set-who! record-type-field-indices
+    (lambda (rtd)
+      (unless (record-type-descriptor? rtd)
+        ($oops who "~s is not a record type descriptor" rtd))
+      (let* ([flds (rtd-flds rtd)]
+             [n-flds (let ([prtd (rtd-parent rtd)])
+                       (if (fixnum? flds)
+                           (fx- flds (if prtd (rtd-flds prtd) 0))
+                           (fx- (length flds) (if prtd (length (rtd-flds prtd)) 0))))])
+        (list->vector (iota n-flds)))))
 
   (set-who! #(csv7: record-type-field-decls)
     (lambda (rtd)
       (unless (record-type-descriptor? rtd)
         ($oops who "~s is not a record type descriptor" rtd))
-      (map (lambda (x)
-             `(,(if (fld-mutable? x) 'mutable 'immutable)
-                ,(fld-type x)
-                ,(fld-name x)))
-           (rtd-flds rtd))))
+      (let ([flds (rtd-flds rtd)])
+        (if (fixnum? flds)
+            (let loop ([flds flds])
+              (if (fx= 0 flds)
+                  '()
+                  (cons '(mutable scheme-object unknown) (loop (fx- flds 1)))))
+            (map (lambda (x)
+                   `(,(if (fld-mutable? x) 'mutable 'immutable)
+                     ,(fld-type x)
+                     ,(fld-name x)))
+                 flds)))))
 
   (set! $record-type-field-offsets
     (lambda (rtd)
       (unless (record-type-descriptor? rtd)
         ($oops '$record-type-field-offsets "~s is not a record type descriptor" rtd))
-      (map (lambda (x) (fld-byte x)) (rtd-flds rtd))))
+      (let ([flds (rtd-flds rtd)])
+        (if (fixnum? flds)
+            (let loop ([i flds])
+              (if (fx= i flds)
+                  '()
+                  (cons (fx+ (constant record-data-disp) (fx* i (constant ptr-bytes)))
+                        (loop (fx+ i 1)))))
+            (map (lambda (x) (fld-byte x)) (rtd-flds rtd))))))
 
   (set! record-type-opaque?
     (lambda (rtd)
@@ -652,13 +762,21 @@
       (#3%record-type-generative? rtd)))
 
   (let ()
+    (define (make-default-fld field-spec mpm)
+      (make-fld 'unknown
+                (bitwise-bit-set? mpm (fx+ field-spec 1))
+                'scheme-object
+                (fx+ (constant record-data-disp) (fx* field-spec (constant ptr-bytes)))))
     (define (find-fld who rtd field-spec)
       (unless (record-type-descriptor? rtd)
         ($oops who "~s is not a record type descriptor" rtd))
       (cond
         [(symbol? field-spec)
         ; reverse order to check child's fields first
-         (let loop ((flds (reverse (rtd-flds rtd))))
+         (let loop ((flds (let ([flds (rtd-flds rtd)])
+                            (if (fixnum? flds)
+                                '()
+                                (reverse flds)))))
            (when (null? flds)
              ($oops who "unrecognized field name ~s for type ~s"
                field-spec rtd))
@@ -667,11 +785,14 @@
                  fld
                  (loop (cdr flds)))))]
         [(and (fixnum? field-spec) (fx>= field-spec 0))
-         (let ((flds (rtd-flds rtd)))
-           (when (fx>= field-spec (length flds))
+         (let* ((flds (rtd-flds rtd))
+                (n-flds (if (fixnum? flds) flds (length flds))))
+           (when (fx>= field-spec n-flds)
              ($oops who "invalid field ordinal ~s for type ~s"
                field-spec rtd))
-           (list-ref flds field-spec))]
+           (if (fixnum? flds)
+               (make-default-fld field-spec (rtd-mpm rtd))
+               (list-ref flds field-spec)))]
         [else ($oops who "invalid field specifier ~s" field-spec)]))
 
     (define (r6rs:find-fld who rtd field-spec)
@@ -679,11 +800,14 @@
         ($oops who "~s is not a record type descriptor" rtd))
       (cond
         [(and (fixnum? field-spec) (fx>= field-spec 0))
-         (let ((flds (child-flds rtd)))
-           (when (fx>= field-spec (length flds))
+         (let* ((flds (child-flds rtd))
+                (n-flds (if (fixnum? flds) flds (length flds))))
+           (when (fx>= field-spec n-flds)
              ($oops who "invalid field index ~s for type ~s"
                field-spec rtd))
-           (list-ref flds field-spec))]
+           (if (fixnum? flds)
+               (make-default-fld (fx+ field-spec (parent-flds rtd)) (rtd-mpm rtd))
+               (list-ref flds field-spec)))]
         [else ($oops who "invalid field specifier ~s" field-spec)]))
 
     (let ()
@@ -747,7 +871,18 @@
 
     (set-who! #(csv7: record-field-mutable?)
       (lambda (rtd field-spec)
-        (fld-mutable? (find-fld who rtd field-spec))))
+        (cond
+         [(and (fixnum? field-spec)
+               (record-type-descriptor? rtd))
+          ;; Try fast path
+          (let ([flds (rtd-flds rtd)])
+            (cond
+             [(and (fixnum? flds)
+                   ($fxu< field-spec flds))
+              (bitwise-bit-set? (rtd-mpm rtd) (fx+ field-spec 1))]
+             [else
+              (fld-mutable? (find-fld who rtd field-spec))]))]
+         [else (fld-mutable? (find-fld who rtd field-spec))])))
 
     (set-who! record-field-mutable?
       (lambda (rtd field-spec)
@@ -804,7 +939,7 @@
                 (syntax-rules () ((_ type bytes pred) 'pred)))
               (record-datatype cases ty ->pred
                 ($oops 'record-constructor "unrecognized type ~s" ty))))
-          (let* ((flds (rtd-flds rtd)) (nflds (length flds)))
+          (let* ((flds (rtd-flds rtd)) (nflds (if (fixnum? flds) flds (length flds))))
             (if (eqv? (rtd-pm rtd) -1) ; all pointers?
                 (let ()
                   (define-syntax nlambda
@@ -832,6 +967,7 @@
                                  ($oops #f "incorrect number of arguments to ~s" constructor))
                                (apply $record rtd xr))
                              (ash 1 nflds)))]))
+                ;; In this case, `flds` will be a list
                 (let* ([args (make-record-call-args flds (rtd-size rtd)
                                (map (lambda (x) 0) flds))]
                        [nargs (length args)]