suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add support for record types with anonymous fields

Browse Source 
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
This commit is contained in:
Matthew Flatt 2020-02-10 10:33:27 -07:00
parent 5d45d6dca2
commit aa0c555c70
13 changed files with 504 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
csug/objects.stex
View File

@ -4105,6 +4105,17 @@ The field names are symbols.
(record-type-field-names (type-descriptor triple)) ;=> (x1 x2 x3) (record-type-field-names (type-descriptor triple)) ;=> (x1 x2 x3)
\endschemedisplay \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 \entryheader
\formdef{record-type-field-decls}{\categoryprocedure}{(record-type-field-decls \var{rtd})} \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} (eq? (record-type-descriptor x) rtd) ;=> \var{unspecified}
\endschemedisplay \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} \section{Procedures}

2
makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point # # no changes should be needed below this point #
############################################################################### ###############################################################################
Version=csv9.5.3.19 Version=csv9.5.3.20
Include=boot/$m Include=boot/$m
PetiteBoot=boot/$m/petite.boot PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot SchemeBoot=boot/$m/scheme.boot

10
s/cmacros.ss
View File

@ -328,7 +328,7 @@
[(_ foo e1 e2) e1] ... [(_ foo e1 e2) e1] ...
[(_ bar e1 e2) e2]))))]))) [(_ bar e1 e2) e2]))))])))
(define-constant scheme-version #x09050313) (define-constant scheme-version #x09050314)
(define-syntax define-machine-types (define-syntax define-machine-types
(lambda (x) (lambda (x)
@ -1461,11 +1461,11 @@
(define-primitive-structure-disps record-type type-typed-object (define-primitive-structure-disps record-type type-typed-object
([ptr type] ([ptr type]
[ptr parent] [ptr parent]
[ptr size] [ptr size] ; total record size in bytes, including type tag
[ptr pm] [ptr pm] ; pointer mask, where low bit corresponds to type tag
[ptr mpm] [ptr mpm] ; mutable-pointer mask, where low bit for type is always 0
[ptr name] [ptr name]
[ptr flds] [ptr flds] ; either a list of `fld` vectors or a fixnum count
[ptr flags] [ptr flags]
[ptr uid] [ptr uid]
[ptr counts])) [ptr counts]))

202
s/cp0.ss
View File

@ -123,6 +123,7 @@
(define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent)) (define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent))
(define rtd-size (csv7:record-field-accessor #!base-rtd 'size)) (define rtd-size (csv7:record-field-accessor #!base-rtd 'size))
(define rtd-pm (csv7:record-field-accessor #!base-rtd 'pm)) (define rtd-pm (csv7:record-field-accessor #!base-rtd 'pm))
(define rtd-mpm (csv7:record-field-accessor #!base-rtd 'mpm))
; compile-time rtds (ctrtds) ; compile-time rtds (ctrtds)
(define ctrtd-opaque-known #b0000001) (define ctrtd-opaque-known #b0000001)
@ -142,6 +143,39 @@
(or (not (ctrtd? rtd)) (or (not (ctrtd? rtd))
(fxlogtest (ctrtd-flags rtd) ctrtd-opaque-known)))) (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) (with-output-language (Lsrc Expr)
(define void-rec `(quote ,(void))) (define void-rec `(quote ,(void)))
(define true-rec `(quote #t)) (define true-rec `(quote #t))
@ -551,17 +585,20 @@
; from a rhs. ; from a rhs.
[(record ,rtd ,rtd-expr ,e* ...) [(record ,rtd ,rtd-expr ,e* ...)
(let-values ([(liftmt* liftme* e*) (let-values ([(liftmt* liftme* e*)
(let ([fld* (rtd-flds rtd)]) (let ([fld* (rtd-flds rtd)]
(let f ([e* e*] [fld* fld*]) [mpm (rtd-mpm rtd)])
(let f ([e* e*] [fld* (and (not (fixnum? fld*)) fld*)] [idx 0])
(if (null? e*) (if (null? e*)
(values '() '() '()) (values '() '() '())
(let ([e (car e*)]) (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 (if (nanopass-case (Lsrc Expr) e
[(ref ,maybe-src ,x) #f] [(ref ,maybe-src ,x) #f]
[(quote ,d) #f] [(quote ,d) #f]
[,pr #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)]) (let ([t (cp0-make-temp #f)])
(values (cons t liftmt*) (cons e liftme*) (cons (build-ref t) e*))) (values (cons t liftmt*) (cons e liftme*) (cons (build-ref t) e*)))
(values liftmt* liftme* (cons e e*))))))))]) (values liftmt* liftme* (cons e e*))))))))])
@ -1053,10 +1090,7 @@
[(record-ref ,rtd ,type ,index ,e) #f] [(record-ref ,rtd ,type ,index ,e) #f]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(record ,rtd ,rtd-expr ,e* ...) [(record ,rtd ,rtd-expr ,e* ...)
(and (andmap (lambda (fld) (and (rtd-all-immutable-scheme-objects? rtd)
(and (not (fld-mutable? fld))
(eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
(rtd-flds rtd))
(memoize (and (pure1? rtd-expr) (andmap pure1? e*))))] (memoize (and (pure1? rtd-expr) (andmap pure1? e*))))]
[(set! ,maybe-src ,x ,e) #f] [(set! ,maybe-src ,x ,e) #f]
[(record-cd ,rcd ,rtd-expr ,e) (memoize (pure1? e))] [(record-cd ,rcd ,rtd-expr ,e) (memoize (pure1? e))]
@ -1115,12 +1149,12 @@
[(seq ,e1 ,e2) (memoize (and (ivory? e1) (ivory? e2)))] [(seq ,e1 ,e2) (memoize (and (ivory? e1) (ivory? e2)))]
[(record-ref ,rtd ,type ,index ,e) [(record-ref ,rtd ,type ,index ,e)
; here ivory? differs from pure? ; here ivory? differs from pure?
(and (not (fld-mutable? (list-ref (rtd-flds rtd) index))) (and (rtd-immutable-field? rtd index)
(memoize (ivory1? e)))] (memoize (ivory1? e)))]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(record ,rtd ,rtd-expr ,e* ...) [(record ,rtd ,rtd-expr ,e* ...)
; here ivory? differs from pure? ; 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*))))] (memoize (and (ivory1? rtd-expr) (andmap ivory1? e*))))]
[(set! ,maybe-src ,x ,e) #f] [(set! ,maybe-src ,x ,e) #f]
[(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory1? e))] [(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory1? e))]
@ -2998,6 +3032,13 @@
(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?fields)) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?fields))
[(quote ,d) (k d)] [(quote ,d) (k d)]
[else #f])) [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) (define (get-sealed x)
(nanopass-case (Lsrc Expr) (if x (result-exp (value-visit-operand! x)) false-rec) (nanopass-case (Lsrc Expr) (if x (result-exp (value-visit-operand! x)) false-rec)
[(quote ,d) (values (if d #t #f) ctrtd-sealed-known)] [(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 (mrt ?parent ?name ?fields ?sealed ?opaque ctxt level $make-record-type '$make-record-type
(list* ?base-id ?parent ?name ?fields ?sealed ?opaque ?extras))])) (list* ?base-id ?parent ?name ?fields ?sealed ?opaque ?extras))]))
(let () (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)) (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?uid))
[(quote ,d) [(quote ,d)
(and d (and d
@ -3077,32 +3118,49 @@
(lambda (prtd) (lambda (prtd)
(get-fields ?fields (get-fields ?fields
(lambda (fields) (lambda (fields)
(let-values ([(sealed? sealed-flag) (get-sealed ?sealed)] (get-mutability-mask ?mutability-mask
[(opaque? opaque-flag) (get-opaque ?opaque prtd)]) (lambda (mutability-mask)
(cond (let-values ([(sealed? sealed-flag) (get-sealed ?sealed)]
[(guard (c [#t #f]) [(opaque? opaque-flag) (get-opaque ?opaque prtd)])
($make-record-type-descriptor base-ctrtd 'tmp prtd #f (cond
sealed? opaque? fields 'cp0 (fxlogor sealed-flag opaque-flag))) => [(guard (c [#t #f])
(lambda (rtd) (if ?mutability-mask
(residualize-seq opnd* '() ctxt) ($make-record-type-descriptor* base-ctrtd 'tmp prtd #f
`(record-type ,rtd sealed? opaque? fields mutability-mask 'cp0 (fxlogor sealed-flag opaque-flag))
; can't use level 3 unconditionally because we're missing checks for ($make-record-type-descriptor base-ctrtd 'tmp prtd #f
; ?base-rtd, ?name, ?uid, ?who, and ?extras sealed? opaque? fields 'cp0 (fxlogor sealed-flag opaque-flag)))) =>
,(build-primcall (app-preinfo ctxt) level primname (lambda (rtd)
(value-visit-operands! opnd*))))] (residualize-seq opnd* '() ctxt)
[else #f])))))))) `(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 (define-inline 2 make-record-type-descriptor
[(?name ?parent ?uid ?sealed ?opaque ?fields) [(?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 make-record-type-descriptor 'make-record-type-descriptor
(list ?name ?parent ?uid ?sealed ?opaque ?fields))]) (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 (define-inline 2 $make-record-type-descriptor
[(?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?who . ?extras) [(?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 $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 () (let ()
; if you update this, also update duplicate in record.ss ; if you update this, also update duplicate in record.ss
(define-record-type rcd (define-record-type rcd
@ -3282,7 +3340,14 @@
(let () (let ()
(define (go safe? rtd rtd-e ctxt) (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*)] [t* (map (lambda (x) (cp0-make-temp #t)) fld*)]
[check* (if safe? [check* (if safe?
(fold-right (fold-right
@ -3370,7 +3435,7 @@
(let f ([ctprcd (ctrcd-ctprcd ctrcd)] [crtd rtd] [prtd prtd] [vars '()]) (let f ([ctprcd (ctrcd-ctprcd ctrcd)] [crtd rtd] [prtd prtd] [vars '()])
(let ([pp-args (cp0-make-temp #f)] (let ([pp-args (cp0-make-temp #f)]
[new-vars (map (lambda (x) (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) (set-prelex-immutable-value! pp-args #t)
`(case-lambda ,(make-preinfo-lambda) `(case-lambda ,(make-preinfo-lambda)
(clause (,pp-args) -1 (clause (,pp-args) -1
@ -3393,14 +3458,14 @@
(f (ctrcd-ctprcd ctprcd) prtd pprtd vars))] (f (ctrcd-ctprcd ctprcd) prtd pprtd vars))]
[else [else
(let ([new-vars (map (lambda (x) (cp0-make-temp #f)) (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 (build-lambda new-vars
`(call ,(app-preinfo ctxt) ,(go (< level 3) rtd rtd-e ctxt) `(call ,(app-preinfo ctxt) ,(go (< level 3) rtd rtd-e ctxt)
,(map build-ref (append new-vars vars)) ,(map build-ref (append new-vars vars))
...)))])))] ...)))])))]
[else [else
(let ([new-vars (map (lambda (x) (cp0-make-temp #f)) (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 (build-lambda new-vars
`(call ,(app-preinfo ctxt) ,(go (< level 3) rtd rtd-e ctxt) `(call ,(app-preinfo ctxt) ,(go (< level 3) rtd rtd-e ctxt)
,(map build-ref (append new-vars vars)) ...)))]) ,(map build-ref (append new-vars vars)) ...)))])
@ -3440,7 +3505,7 @@
(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?field)) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?field))
[(quote ,d) [(quote ,d)
(cond (cond
[(symbol? d) [(and (symbol? d) (not (fixnum? (rtd-flds rtd))))
; reverse order to check child's fields first ; reverse order to check child's fields first
(let loop ([flds (reverse (rtd-flds rtd))] [index (length (rtd-flds rtd))]) (let loop ([flds (reverse (rtd-flds rtd))] [index (length (rtd-flds rtd))])
(let ([index (fx- index 1)]) (let ([index (fx- index 1)])
@ -3451,8 +3516,13 @@
(loop (cdr flds) index))))))] (loop (cdr flds) index))))))]
[(fixnum? d) [(fixnum? d)
(let ((flds (rtd-flds rtd))) (let ((flds (rtd-flds rtd)))
(and ($fxu< d (length flds)) (cond
(k rtd-e rtd (list-ref flds d) d)))] [(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])]
[else #f])) [else #f]))
@ -3460,9 +3530,15 @@
(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?field)) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?field))
[(quote ,d) [(quote ,d)
(let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)]) (let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)])
(let ([index (if prtd (+ d (length (rtd-flds prtd))) d)]) (let ([p-flds (and prtd (rtd-flds prtd))])
(and ($fxu< index (length flds)) (let ([index (if prtd (+ d (if (fixnum? p-flds) p-flds (length p-flds))) d)])
(k rtd-e rtd (list-ref flds index) index))))] (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])) [else #f]))
(define (find-rtd-and-field ?rtd ?field find-fld k) (define (find-rtd-and-field ?rtd ?field find-fld k)
@ -3746,21 +3822,32 @@
(list xval rtdval))))))) (list xval rtdval)))))))
(define obviously-incompatible? (define obviously-incompatible?
(lambda (instance-rtd rtd) (lambda (instance-rtd rtd)
(let f ([ls1 (rtd-flds instance-rtd)] [ls2 (rtd-flds rtd)]) (let ([flds1 (rtd-flds instance-rtd)]
(if (null? ls2) [flds2 (rtd-flds rtd)])
(if (record-type-parent instance-rtd) (cond
; could work harder here, though it gets trickier (so not obvious)... [(or (fixnum? flds1) (fixnum? flds2))
#f (or (not (fixnum? flds1))
; instance has no parent, so rtds are compatible only if they are the same modulo incomplete info if one or both are ctrtds (not (fixnum? flds2))
(or (not (null? ls1)) (fx< flds1 flds2)
(and (record-type-parent rtd) #t) (not (= (rtd-mpm instance-rtd)
(and (and (record-type-sealed-known? rtd) (record-type-sealed-known? instance-rtd)) (bitwise-and (rtd-mpm rtd)
(not (eq? (record-type-sealed? instance-rtd) (record-type-sealed? rtd)))) (sub1 (bitwise-arithmetic-shift-left 1 (fx+ flds1 1)))))))]
(and (and (record-type-opaque-known? rtd) (record-type-opaque-known? instance-rtd)) [else
(not (eq? (record-type-opaque? instance-rtd) (record-type-opaque? rtd)))))) (let f ([ls1 flds1] [ls2 flds2])
(or (null? ls1) (if (null? ls2)
(not (equal? (car ls1) (car ls2))) (if (record-type-parent instance-rtd)
(f (cdr ls1) (cdr ls2))))))) ; 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) (nanopass-case (Lsrc Expr) (result-exp rtdval)
[(quote ,d0) [(quote ,d0)
(and (record-type-descriptor? d0) (and (record-type-descriptor? d0)
@ -3898,7 +3985,7 @@
(nanopass-case (Lsrc Expr) (result-exp rtd-expr) (nanopass-case (Lsrc Expr) (result-exp rtd-expr)
[(quote ,d) [(quote ,d)
(and (record-type-descriptor? 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*))]) (let ([e* (objs-if-constant (value-visit-operands! ?e*))])
(and e* (and e*
(begin (begin
@ -5063,10 +5150,7 @@
(or (nanopass-case (Lsrc Expr) (result-exp rtd-expr) (or (nanopass-case (Lsrc Expr) (result-exp rtd-expr)
[(quote ,d) [(quote ,d)
(and (record-type-descriptor? d) (and (record-type-descriptor? d)
(andmap (lambda (fld) (rtd-all-immutable-scheme-objects? d)
(and (not (fld-mutable? fld))
(eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
(rtd-flds d))
(let ([d* (objs-if-constant e*)]) (let ([d* (objs-if-constant e*)])
(and d* (and d*
(make-1seq ctxt (make-1seq ctxt
@ -5110,7 +5194,7 @@
(nanopass-case (Lsrc Expr) (result-exp/indirect-ref e0) (nanopass-case (Lsrc Expr) (result-exp/indirect-ref e0)
[(record ,rtd1 ,rtd-expr ,e* ...) [(record ,rtd1 ,rtd-expr ,e* ...)
(and (> (length e*) index) (and (> (length e*) index)
(not (fld-mutable? (list-ref (rtd-flds rtd) index))) (rtd-immutable-field? rtd index)
(let ([e (list-ref e* index)]) (let ([e (list-ref e* index)])
(and (nanopass-case (Lsrc Expr) e (and (nanopass-case (Lsrc Expr) e
[(quote ,d) #t] [(quote ,d) #t]

31
s/cpcheck.ss
View File

@ -44,8 +44,11 @@
(define record-field-offset (define record-field-offset
(lambda (rtd index) (lambda (rtd index)
(let ([rtd (maybe-remake-rtd rtd)]) (let* ([rtd (maybe-remake-rtd rtd)]
(fld-byte (list-ref (rtd-flds rtd) index))))) [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 () (define-pass cpcheck : Lsrc (ir) -> Lsrc ()
(definitions (definitions
@ -185,17 +188,19 @@
[(record ,rtd ,[rtd-expr #f -> rtd-expr] ,[e* #f -> e*] ...) [(record ,rtd ,[rtd-expr #f -> rtd-expr] ,[e* #f -> e*] ...)
(let ([rtd (maybe-remake-rtd rtd)]) (let ([rtd (maybe-remake-rtd rtd)])
(let ([fld* (rtd-flds rtd)] [rec-t (make-prelex*)]) (let ([fld* (rtd-flds rtd)] [rec-t (make-prelex*)])
(safe-assert (fx= (length e*) (length fld*))) (safe-assert (fx= (length e*) (if (fixnum? fld*) fld* (length fld*))))
(let ([filler* (fold-right (let ([filler* (if (fixnum? fld*)
(lambda (fld e filler*) '()
(let ([type (fld-type fld)]) (fold-right
(if (eq? (filter-foreign-type type) 'scheme-object) (lambda (fld e filler*)
filler* (let ([type (fld-type fld)])
(cons (if (eq? (filter-foreign-type type) 'scheme-object)
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$object-set!) filler*
(quote ,type) (ref #f ,rec-t) (quote ,(fld-byte fld)) ,e) (cons
filler*)))) `(call ,(make-preinfo-call) ,(lookup-primref 3 '$object-set!)
'() fld* e*)]) (quote ,type) (ref #f ,rec-t) (quote ,(fld-byte fld)) ,e)
filler*))))
'() fld* e*))])
(if (null? filler*) (if (null? filler*)
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$record) ,rtd-expr ,e* ...) `(call ,(make-preinfo-call) ,(lookup-primref 3 '$record) ,rtd-expr ,e* ...)
(begin (begin

16
s/cpletrec.ss
View File

@ -56,6 +56,7 @@ Handling letrec and letrec*
(include "base-lang.ss") (include "base-lang.ss")
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) (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 () (define-pass lift-profile-forms : Lsrc (ir) -> Lsrc ()
(definitions (definitions
@ -370,11 +371,16 @@ Handling letrec and letrec*
(values (values
`(record ,rtd ,rtd-expr ,e* ...) `(record ,rtd ,rtd-expr ,e* ...)
(and (and rtd-pure? pure?) (and (and rtd-pure? pure?)
(andmap (let ([flds (rtd-flds rtd)])
(lambda (fld) (cond
(and (not (fld-mutable? fld)) [(fixnum? flds)
(eq? (filter-foreign-type (fld-type fld)) 'scheme-object))) (eqv? 0 (rtd-mpm rtd))]
(rtd-flds 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-type ,rtd ,e) (Expr e)]
[(record-cd ,rcd ,rtd-expr ,e) (Expr e)] [(record-cd ,rcd ,rtd-expr ,e) (Expr e)]
[(immutable-list (,[e* pure?*] ...) ,[e pure?]) [(immutable-list (,[e* pure?*] ...) ,[e pure?])

44
s/fasl.ss
View File

@ -85,10 +85,16 @@
(lambda (x t a? d) (lambda (x t a? d)
(let ([rtd ($record-type-descriptor x)]) (let ([rtd ($record-type-descriptor x)])
(bld rtd t a? d) (bld rtd t a? d)
(do ([flds (rtd-flds rtd) (cdr flds)] [i 0 (+ i 1)]) (let ([flds (rtd-flds rtd)])
((null? flds)) (if (fixnum? flds)
(when (memq (fld-type (car flds)) '(scheme-object ptr)) (let loop ([i 0])
(bld ((csv7:record-field-accessor rtd i) x) t a? d)))))) (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 (define bld-ht
(lambda (x t a? d) (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)]) [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)))))) ($oops 'fasl-write "host value ~s for type ~s is too big for target" val type))))))
(define put-field (define put-field
(lambda (target-fld pad val) (lambda (field-type field-addr pad val)
(define put-i64 (define put-i64
(lambda (p val) (lambda (p val)
(constant-case ptr-bits (constant-case ptr-bits
@ -395,7 +401,7 @@
(syntax-rules () (syntax-rules ()
[(_ fasl-fld-type) [(_ fasl-fld-type)
(put-u8 p (fxlogor (fxsll pad 4) (constant 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 ; using filter-foreign-type to get target filtering
(case (filter-foreign-type type) (case (filter-foreign-type type)
[(scheme-object) (put-padty fasl-fld-ptr) (wrf val p t a?) (constant ptr-bytes)] [(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-rtd (maybe-remake-rtd host-rtd)]
[target-fld* (rtd-flds target-rtd)]) [target-fld* (rtd-flds target-rtd)])
(put-uptr p (rtd-size 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?) (wrf host-rtd p t a?)
(fold-left (if (fixnum? target-fld*)
(lambda (last-target-addr host-fld target-fld) (let loop ([i 0] [addr (constant record-data-disp)])
(let ([val (get-field host-fld)]) (unless (fx= i target-fld*)
(check-field target-fld val) (let ([sz (put-field 'scheme-object addr 0 ($record-ref x i))])
(let ([target-addr (fld-byte target-fld)]) (loop (fx+ i 1) (fx+ addr sz)))))
(fx+ target-addr (put-field host-fld (fx- target-addr last-target-addr) val))))) (fold-left
(constant record-data-disp) (lambda (last-target-addr host-fld target-fld)
(rtd-flds host-rtd) (let ([val (get-field host-fld)])
target-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 (define wrf-record
(lambda (x p t a?) (lambda (x p t a?)

63
s/inspect.ss
View File

@ -2061,7 +2061,9 @@
(define make-record-object (define make-record-object
(lambda (x) (lambda (x)
(let* ((rtd ($record-type-descriptor 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 (define check-field
(lambda (f) (lambda (f)
(unless (or (and (symbol? f) (memq f fields)) (unless (or (and (symbol? f) (memq f fields))
@ -2644,12 +2646,21 @@
((fx= i n) size)))] ((fx= i n) size)))]
[($record? x) [($record? x)
(let ([rtd ($record-type-descriptor x)]) (let ([rtd ($record-type-descriptor x)])
(fold-left (lambda (size fld) (let ([flds (rtd-flds rtd)])
(if (eq? (fld-type fld) 'scheme-object) (cond
(fx+ size (compute-size ($object-ref 'scheme-object x (fld-byte fld)))) [(fixnum? flds)
size)) (let loop ([i 0] [size 0])
(fx+ (align (rtd-size rtd)) (compute-size rtd)) (cond
(rtd-flds rtd)))] [(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))))] [(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)))] [(box? x) (fx+ (constant size-box) (compute-size (unbox x)))]
[(flonum? x) (constant size-flonum)] [(flonum? x) (constant size-flonum)]
@ -2838,10 +2849,18 @@
(set-cdr! p (fx+ (cdr p) size))) (set-cdr! p (fx+ (cdr p) size)))
(eq-hashtable-set! rtd-ht rtd (cons 1 size)))) (eq-hashtable-set! rtd-ht rtd (cons 1 size))))
(compute-composition! rtd) (compute-composition! rtd)
(for-each (lambda (fld) (let ([flds (rtd-flds rtd)])
(when (eq? (fld-type fld) 'scheme-object) (cond
(compute-composition! ($object-ref 'scheme-object x (fld-byte fld))))) [(fixnum? flds)
(rtd-flds rtd)))] (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)))))] [(string? x) (incr! string (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes)))))]
[(box? x) [(box? x)
(incr! box (constant size-box)) (incr! box (constant size-box))
@ -2990,13 +3009,21 @@
[($record? x) [($record? x)
(let ([rtd ($record-type-descriptor x)]) (let ([rtd ($record-type-descriptor x)])
(construct-proc rtd (construct-proc rtd
(let f ([flds (rtd-flds rtd)]) (let ([flds (rtd-flds rtd)])
(if (null? flds) (cond
next-proc [(fixnum? flds)
(let ([fld (car flds)]) (let loop ([i 0])
(if (eq? (fld-type fld) 'scheme-object) (if (fx= i flds)
(construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds))) next-proc
(f (cdr flds))))))))] (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) [(or (fxvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x)
($inexactnum? x) ($rtd-counts? x) (phantom-bytevector? x)) ($inexactnum? x) ($rtd-counts? x) (phantom-bytevector? x))
next-proc] next-proc]

9
s/layout.ss
View File

@ -16,7 +16,11 @@
(define compute-field-offsets (define compute-field-offsets
; type-disp is the offset from the ptr to the object's true address ; type-disp is the offset from the ptr to the object's true address
; ls is a list of field descriptors ; 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 (define parse-field
(lambda (f) (lambda (f)
(define supported-type (define supported-type
@ -107,5 +111,4 @@
(if (= (- (ash 1 (quotient (+ size -1 (constant ptr-bytes)) (constant ptr-bytes))) 1) m) (if (= (- (ash 1 (quotient (+ size -1 (constant ptr-bytes)) (constant ptr-bytes))) 1) m)
-1 -1
m))) m)))
(values (sanitize-mask pm size) mpm flds size))))) (values (sanitize-mask pm size) mpm flds size)))]))

5
s/primdata.ss
View File

@ -845,6 +845,7 @@
((csv7: record-type-descriptor) [sig [(record) -> (rtd)]] [flags pure mifoldable discard true cp02]) ((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-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-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-name) [sig [(rtd) -> (string)]] [flags pure mifoldable discard true cp02])
((csv7: record-type-symbol) [sig [(rtd) -> (symbol)]] [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-phantom-bytevector [sig [(uptr) -> (phantom-bytevector)]] [flags true])
(make-pseudo-random-generator [sig [() -> (pseudo-random-generator)]] [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 [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-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-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]) (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-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-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-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]) (record-writer [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags])
(register-signal-handler [sig [(sint procedure) -> (void)]] [flags]) (register-signal-handler [sig [(sint procedure) -> (void)]] [flags])
(remove-foreign-entry [sig [(string) -> (void)]] [flags true]) (remove-foreign-entry [sig [(string) -> (void)]] [flags true])
@ -2170,6 +2174,7 @@
($make-recompile-condition [flags single-valued]) ($make-recompile-condition [flags single-valued])
($make-record-constructor-descriptor [flags single-valued pure true cp02]) ($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-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-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-relocation-table! [flags single-valued])
($make-rnrs-libraries [flags single-valued]) ($make-rnrs-libraries [flags single-valued])

2
s/print.ss
View File

@ -49,7 +49,7 @@
; we use write instead of wr here so that the field doesn't get ; we use write instead of wr here so that the field doesn't get
; a reference (#n#) when print-graph is true. ; a reference (#n#) when print-graph is true.
(write (or (record-reader rtd) (record-type-uid rtd)) p) (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)]) [i 0 (+ i 1)])
((null? flds)) ((null? flds))
(write-char #\space p) (write-char #\space p)

4
s/read.ss
View File

@ -1110,7 +1110,7 @@
(rd-fix-graph (vector-ref x m) rd-set-vector-tail! x m))))] (rd-fix-graph (vector-ref x m) rd-set-vector-tail! x m))))]
[($record? x) [($record? x)
(let ((d ($record-type-descriptor 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)]) [i 0 (+ i 1)])
((null? fields)) ((null? fields))
(when (csv7:record-field-accessible? d i) (when (csv7:record-field-accessible? d i)
@ -1134,7 +1134,7 @@
(let* ((dr (car wl)) (let* ((dr (car wl))
(rtd (delayed-record-rtd dr)) (rtd (delayed-record-rtd dr))
(vals (delayed-record-vals dr)) (vals (delayed-record-vals dr))
(fields (csv7:record-type-field-names rtd))) (fields (csv7:record-type-field-indices rtd)))
(if (andmap (if (andmap
(lambda (f v) (lambda (f v)
(or (not (delayed-record? v)) (or (not (delayed-record? v))

256
s/record.ss
View File

@ -38,9 +38,19 @@
(define (child-flds rtd) (define (child-flds rtd)
(let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)]) (let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)])
(if prtd (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))) 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 ; $record is hand-coded and is defined in prims.ss
(let ([addr? (constant-case ptr-bits (let ([addr? (constant-case ptr-bits
@ -403,21 +413,41 @@
(constant rtd-opaque) (constant rtd-opaque)
0) 0)
(if sealed? (constant rtd-sealed) 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") (include "layout.ss")
(when (and parent (record-type-sealed? parent)) (when parent
($oops who "cannot extend sealed record type ~s" parent)) (when (record-type-sealed? parent)
(let ([parent-fields (if (not parent) '() (csv7:record-type-field-decls parent))] ($oops who "cannot extend sealed record type ~s" parent))
[uid (or uid ((current-generate-id) name))]) (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 ; start base offset at rtd field
; synchronize with syntax.ss and front.ss ; synchronize with syntax.ss and front.ss
(let-values ([(pm mpm flds size) (let-values ([(pm mpm flds size)
(compute-field-offsets who (if (fixnum? fields)
(constant record-type-disp) (let ([parent-n (if parent
; rtd must be immutable if we are ever to store records (let ([p-flds (rtd-flds parent)])
; in space pure (if (fixnum? p-flds)
(cons `(immutable scheme-object ,uid) p-flds
(append parent-fields fields)))]) (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 (cond
[(and (not (fxlogtest flags (constant rtd-generative))) [(and (not (fxlogtest flags (constant rtd-generative)))
(let ([x ($sgetprop uid '*rtd* #f)]) (let ([x ($sgetprop uid '*rtd* #f)])
@ -436,21 +466,23 @@
; following is paranoid; overall size ; following is paranoid; overall size
; check should suffice ; check should suffice
#;(= (fld-byte fld1) (fld-byte fld2))))) #;(= (fld-byte fld1) (fld-byte fld2)))))
(and (= (length flds1) (length flds2)) (or (and (fixnum? flds1) (fixnum? flds2) (fx= flds1 flds2))
(andmap same-field? flds1 flds2)))) (and (not (fixnum? flds1)) (not (fixnum? flds2))
(fx= (length flds1) (length flds2))
(andmap same-field? flds1 flds2)))))
; following assumes extras match ; following assumes extras match
(let () (let ()
(define (squawk what) ($oops who "incompatible record type ~s - ~a" name what)) (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? ($record-type-descriptor rtd) base-rtd) (squawk "different base rtd"))
(unless (eq? (rtd-parent rtd) parent) (squawk "different parent")) (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 (= (rtd-mpm rtd) mpm) (squawk "different mutability"))
(unless (fx= (rtd-flags rtd) flags) (squawk "different flags")) (unless (fx= (rtd-flags rtd) flags) (squawk "different flags"))
(unless (eq? (rtd-size rtd) size) (squawk "different size"))) (unless (eq? (rtd-size rtd) size) (squawk "different size")))
rtd)] rtd)]
[else [else
(let ([rtd (apply #%$record base-rtd parent size pm mpm name (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)) (with-tc-mutex ($sputprop uid '*rtd* rtd))
rtd)])))) rtd)]))))
@ -463,12 +495,18 @@
[parent (rtd-parent rtd)] [parent (rtd-parent rtd)]
[name (rtd-name rtd)] [name (rtd-name rtd)]
[flags (rtd-flags rtd)] [flags (rtd-flags rtd)]
[fields (csv7:record-type-field-decls rtd)]) [flds (rtd-flds rtd)])
(let-values ([(pm mpm flds size) (let-values ([(pm mpm flds size)
(compute-field-offsets who (if (fixnum? flds)
(constant record-type-disp) (compute-field-offsets who
(cons `(immutable scheme-object ,uid) fields))]) (constant record-type-disp)
(let ([rtd (apply #%$record base-rtd parent size pm mpm name (cdr flds) flags uid #f (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)))] (let* ([n (length (rtd-flds ($record-type-descriptor base-rtd)))]
[ls (list-tail (rtd-flds base-rtd) n)]) [ls (list-tail (rtd-flds base-rtd) n)])
(let f ([n n] [ls ls]) (let f ([n n] [ls ls])
@ -486,12 +524,12 @@
($mrt 'make-record-type base-rtd ($mrt 'make-record-type base-rtd
(string->symbol (symbol->string name)) parent name (string->symbol (symbol->string name)) parent name
(make-flags name sealed? opaque? parent) (make-flags name sealed? opaque? parent)
fields extras)] fields 0 extras)]
[(string? name) [(string? name)
($mrt 'make-record-type base-rtd ($mrt 'make-record-type base-rtd
(string->symbol name) parent #f (string->symbol name) parent #f
(make-flags #f sealed? opaque? parent) (make-flags #f sealed? opaque? parent)
fields extras)] fields 0 extras)]
[else ($oops 'make-record-type "invalid record name ~s" name)])) [else ($oops 'make-record-type "invalid record name ~s" name)]))
(set-who! make-record-type (set-who! make-record-type
@ -522,41 +560,67 @@
(mrt base-rtd parent name fields sealed? opaque? extras)))) (mrt base-rtd parent name fields sealed? opaque? extras))))
(let () (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) (unless (symbol? name)
($oops who "invalid record name ~s" name)) ($oops who "invalid record name ~s" name))
(unless (or (not parent) (record-type-descriptor? parent)) (unless (or (not parent) (record-type-descriptor? parent))
($oops who "invalid parent ~s" parent)) ($oops who "invalid parent ~s" parent))
(unless (or (not uid) (symbol? uid)) (unless (or (not uid) (symbol? uid))
($oops who "invalid uid ~s" uid)) ($oops who "invalid uid ~s" uid))
(unless (vector? fields) (cond
($oops who "invalid field vector ~s" fields)) [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 ($mrt who base-rtd name parent uid
(make-flags uid sealed? opaque? parent) (make-flags uid sealed? opaque? parent)
(let ([n (vector-length fields)]) (if mutability-mask?
(let f ([i 0]) fields
(if (fx= i n) (let ([n (vector-length fields)])
'() (let f ([i 0])
(let ([x (vector-ref fields i)]) (if (fx= i n)
(unless (and (pair? x) '()
(memq (car x) '(mutable immutable)) (let ([x (vector-ref fields i)])
(let ([x (cdr x)]) (unless (and (pair? x)
(and (pair? x) (memq (car x) '(mutable immutable))
(symbol? (car x)) (let ([x (cdr x)])
(null? (cdr x))))) (and (pair? x)
($oops who "invalid field specifier ~s" x)) (symbol? (car x))
(cons x (f (fx+ i 1))))))) (null? (cdr x)))))
($oops who "invalid field specifier ~s" x))
(cons x (f (fx+ i 1))))))))
mutability-mask
extras)) extras))
(set! $make-record-type-descriptor (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) (unless (record-type-descriptor? base-rtd)
($oops who "invalid base rtd ~s" 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 (set-who! make-record-type-descriptor
(lambda (name parent uid sealed? opaque? fields) (case-lambda
(mrtd base-rtd name parent uid sealed? opaque? fields who '())))) [(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? (set! record-type-descriptor?
(lambda (x) (lambda (x)
@ -605,33 +669,79 @@
($oops who "~s is not a record type descriptor" rtd)) ($oops who "~s is not a record type descriptor" rtd))
(rtd-uid 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) (set-who! #(csv7: record-type-field-names)
(lambda (rtd) (lambda (rtd)
(unless (record-type-descriptor? rtd) (unless (record-type-descriptor? rtd)
($oops who "~s is not a 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 (set-who! record-type-field-names
(lambda (rtd) (lambda (rtd)
(unless (record-type-descriptor? rtd) (unless (record-type-descriptor? rtd)
($oops who "~s is not a 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) (set-who! #(csv7: record-type-field-decls)
(lambda (rtd) (lambda (rtd)
(unless (record-type-descriptor? rtd) (unless (record-type-descriptor? rtd)
($oops who "~s is not a record type descriptor" rtd)) ($oops who "~s is not a record type descriptor" rtd))
(map (lambda (x) (let ([flds (rtd-flds rtd)])
`(,(if (fld-mutable? x) 'mutable 'immutable) (if (fixnum? flds)
,(fld-type x) (let loop ([flds flds])
,(fld-name x))) (if (fx= 0 flds)
(rtd-flds rtd)))) '()
(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 (set! $record-type-field-offsets
(lambda (rtd) (lambda (rtd)
(unless (record-type-descriptor? rtd) (unless (record-type-descriptor? rtd)
($oops '$record-type-field-offsets "~s is not a 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? (set! record-type-opaque?
(lambda (rtd) (lambda (rtd)
@ -652,13 +762,21 @@
(#3%record-type-generative? rtd))) (#3%record-type-generative? rtd)))
(let () (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) (define (find-fld who rtd field-spec)
(unless (record-type-descriptor? rtd) (unless (record-type-descriptor? rtd)
($oops who "~s is not a record type descriptor" rtd)) ($oops who "~s is not a record type descriptor" rtd))
(cond (cond
[(symbol? field-spec) [(symbol? field-spec)
; reverse order to check child's fields first ; 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) (when (null? flds)
($oops who "unrecognized field name ~s for type ~s" ($oops who "unrecognized field name ~s for type ~s"
field-spec rtd)) field-spec rtd))
@ -667,11 +785,14 @@
fld fld
(loop (cdr flds)))))] (loop (cdr flds)))))]
[(and (fixnum? field-spec) (fx>= field-spec 0)) [(and (fixnum? field-spec) (fx>= field-spec 0))
(let ((flds (rtd-flds rtd))) (let* ((flds (rtd-flds rtd))
(when (fx>= field-spec (length flds)) (n-flds (if (fixnum? flds) flds (length flds))))
(when (fx>= field-spec n-flds)
($oops who "invalid field ordinal ~s for type ~s" ($oops who "invalid field ordinal ~s for type ~s"
field-spec rtd)) 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)])) [else ($oops who "invalid field specifier ~s" field-spec)]))
(define (r6rs:find-fld who rtd field-spec) (define (r6rs:find-fld who rtd field-spec)
@ -679,11 +800,14 @@
($oops who "~s is not a record type descriptor" rtd)) ($oops who "~s is not a record type descriptor" rtd))
(cond (cond
[(and (fixnum? field-spec) (fx>= field-spec 0)) [(and (fixnum? field-spec) (fx>= field-spec 0))
(let ((flds (child-flds rtd))) (let* ((flds (child-flds rtd))
(when (fx>= field-spec (length flds)) (n-flds (if (fixnum? flds) flds (length flds))))
(when (fx>= field-spec n-flds)
($oops who "invalid field index ~s for type ~s" ($oops who "invalid field index ~s for type ~s"
field-spec rtd)) 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)])) [else ($oops who "invalid field specifier ~s" field-spec)]))
(let () (let ()
@ -747,7 +871,18 @@
(set-who! #(csv7: record-field-mutable?) (set-who! #(csv7: record-field-mutable?)
(lambda (rtd field-spec) (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? (set-who! record-field-mutable?
(lambda (rtd field-spec) (lambda (rtd field-spec)
@ -804,7 +939,7 @@
(syntax-rules () ((_ type bytes pred) 'pred))) (syntax-rules () ((_ type bytes pred) 'pred)))
(record-datatype cases ty ->pred (record-datatype cases ty ->pred
($oops 'record-constructor "unrecognized type ~s" ty)))) ($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? (if (eqv? (rtd-pm rtd) -1) ; all pointers?
(let () (let ()
(define-syntax nlambda (define-syntax nlambda
@ -832,6 +967,7 @@
($oops #f "incorrect number of arguments to ~s" constructor)) ($oops #f "incorrect number of arguments to ~s" constructor))
(apply $record rtd xr)) (apply $record rtd xr))
(ash 1 nflds)))])) (ash 1 nflds)))]))
;; In this case, `flds` will be a list
(let* ([args (make-record-call-args flds (rtd-size rtd) (let* ([args (make-record-call-args flds (rtd-size rtd)
(map (lambda (x) 0) flds))] (map (lambda (x) 0) flds))]
[nargs (length args)] [nargs (length args)]