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
This commit is contained in:
Matthew Flatt
parent
5d45d6dca2
commit
aa0c555c70
|
|
@ -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}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
10
s/cmacros.ss
10
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]))
|
||||
|
|
|
|||
202
s/cp0.ss
202
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]
|
||||
|
|
|
|||
31
s/cpcheck.ss
31
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
|
||||
|
|
|
|||
|
|
@ -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?])
|
||||
|
|
|
|||
44
s/fasl.ss
44
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?)
|
||||
|
|
|
|||
63
s/inspect.ss
63
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]
|
||||
|
|
|
|||
|
|
@ -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)))]))
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
256
s/record.ss
256
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)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user