Chez Schme: change struct predicate implementation
Instead of keeping a rectord type's ancestry in a vector ordered from subtype to supertype, keep the vector the other way around, and include a record type at the end of its own vector. This order makes a more direct test possible when checking for a known record type, especially one without a supertype, and it's generally easier to reason about. The revised compilation of record predicates trades some speed in one case for smaller generated code and speed in other cases. The case that becomes slower is when a predicate succeeds because the record is an immediate instance of the record type. The cases that go faster are when a predicate fails for a non-instance record or when a predicate succeeds for a non-immediate instance. It's possible that an immediate-instance shortcut is worthwhile on the grounds that it's a common case for a predicate used as contract, but we opt for simpler and less code for now, because the difference is small. Also, add `record-instance?`, which in unsafe mode can skip the check that its first argument is a record, and cptypes can substitute `record-instance?` for `record?` in some cases. This change was worked out independently and earlier by @yjqww6, especially the cptypes part. Related to #3679
This commit is contained in:
Matthew Flatt
parent
3a49533ff5
commit
9f6f988150
|
|
@ -344,7 +344,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
|
|||
RACKET_FOR_BUILD = $(RACKET)
|
||||
|
||||
# This branch name changes each time the pb boot files are updated:
|
||||
PB_BRANCH == circa-8.0.0.3-1
|
||||
PB_BRANCH == circa-8.0.0.6-2
|
||||
PB_REPO = https://github.com/racket/pb
|
||||
|
||||
# Alternative source for Chez Scheme boot files, normally set by
|
||||
|
|
|
|||
12
Makefile
12
Makefile
|
|
@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
|
|||
RACKET =
|
||||
RACKET_FOR_BOOTFILES = $(RACKET)
|
||||
RACKET_FOR_BUILD = $(RACKET)
|
||||
PB_BRANCH = circa-8.0.0.3-1
|
||||
PB_BRANCH = circa-8.0.0.6-2
|
||||
PB_REPO = https://github.com/racket/pb
|
||||
EXTRA_REPOS_BASE =
|
||||
CS_CROSS_SUFFIX =
|
||||
|
|
@ -309,18 +309,18 @@ maybe-fetch-pb-as-is:
|
|||
echo done
|
||||
fetch-pb-from:
|
||||
mkdir -p racket/src/ChezScheme/boot
|
||||
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-8.0.0.3-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.0.0.3-1:remotes/origin/circa-8.0.0.3-1 ; fi
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.0.0.3-1
|
||||
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-8.0.0.6-2 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.0.0.6-2:remotes/origin/circa-8.0.0.6-2 ; fi
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.0.0.6-2
|
||||
pb-fetch:
|
||||
$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)"
|
||||
pb-build:
|
||||
cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
|
||||
pb-stage:
|
||||
cd racket/src/ChezScheme/boot/pb && git branch circa-8.0.0.3-1
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout circa-8.0.0.3-1
|
||||
cd racket/src/ChezScheme/boot/pb && git branch circa-8.0.0.6-2
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout circa-8.0.0.6-2
|
||||
cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
|
||||
pb-push:
|
||||
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.0.0.3-1
|
||||
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.0.0.6-2
|
||||
win-cs-base:
|
||||
IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
|
||||
IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
;; In the Racket source repo, this version should change only when
|
||||
;; "racket_version.h" changes:
|
||||
(define version "8.0.0.5")
|
||||
(define version "8.0.0.6")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -282,7 +282,7 @@ typedef struct _bucket_pointer_list {
|
|||
#define size_record_inst(n) ptr_align(n)
|
||||
#define unaligned_size_record_inst(n) (n)
|
||||
|
||||
#define rtd_parent(x) INITVECTIT(RECORDDESCANCESTRY(x), 0)
|
||||
#define rtd_parent(x) INITVECTIT(RECORDDESCANCESTRY(x), Svector_length(RECORDDESCANCESTRY(x)) - ancestry_parent_offset)
|
||||
|
||||
/* type tagging macros */
|
||||
|
||||
|
|
|
|||
|
|
@ -4346,6 +4346,20 @@ record-type descriptor \var{rtd} is equivalent to the following.
|
|||
\endschemedisplay
|
||||
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{record-instance?}{\categoryprocedure}{(record-instance? \var{obj} \var{rtd})}
|
||||
\returns \scheme{#t} if \var{obj} is a record of the given type, otherwise \scheme{#f}
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent
|
||||
\var{obj} must be a record, and \var{rtd} must be a record-type descriptor.
|
||||
|
||||
The result is the same as for a two-argument \scheme{record?} call,
|
||||
but \var{obj} is constrained to be a record. In unsafe mode,
|
||||
\scheme{record-instance?} might be faster than \scheme{record?}.
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{record-type-descriptor}{\categoryprocedure}{(record-type-descriptor \var{rec})}
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ InstallLZ4Target=
|
|||
# no changes should be needed below this point #
|
||||
###############################################################################
|
||||
|
||||
Version=csv9.5.5.2
|
||||
Version=csv9.5.5.3
|
||||
Include=boot/$m
|
||||
PetiteBoot=boot/$m/petite.boot
|
||||
SchemeBoot=boot/$m/scheme.boot
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
# Mf-tarm64osx
|
||||
|
||||
m = tarm64osx
|
||||
m ?= tarm64osx
|
||||
|
||||
include Mf-arm64osx
|
||||
|
|
|
|||
|
|
@ -588,6 +588,7 @@
|
|||
|
||||
; use a gensym to make expansions equivalent
|
||||
(define my-rec (gensym "my-rec"))
|
||||
(define my-sub-rec (gensym "my-sub-rec"))
|
||||
(mat cptypes-type-record?
|
||||
; define-record
|
||||
(parameterize ([optimize-level 2])
|
||||
|
|
@ -673,6 +674,28 @@
|
|||
(define-record-type ,my-rec (fields a) (sealed #t))
|
||||
(define-record-type ,(gensym "other-rec") (fields a)))
|
||||
'(my-rec? other-rec?))
|
||||
|
||||
;; substituting `record-instance?`
|
||||
(cptypes-equivalent-expansion?
|
||||
`(let ()
|
||||
(define-record-type ,my-rec (fields a))
|
||||
(define-record-type ,my-sub-rec (fields a) (parent ,my-rec))
|
||||
(lambda (x) (and (my-rec? x) (list 'ok (my-sub-rec? x)))))
|
||||
`(let ()
|
||||
(define-record-type ,my-rec (fields a))
|
||||
(define-record-type ,my-sub-rec (fields a) (parent ,my-rec))
|
||||
(lambda (x) (and (my-rec? x) (list 'ok (#3%record-instance? x (record-type-descriptor ,my-sub-rec)))))))
|
||||
|
||||
;; substituting `sealed-record-instance?`
|
||||
(cptypes-equivalent-expansion?
|
||||
`(let ()
|
||||
(define-record-type ,my-rec (fields a))
|
||||
(define-record-type ,my-sub-rec (fields a) (parent ,my-rec) (sealed #t))
|
||||
(lambda (x) (and (my-rec? x) (list 'ok (my-sub-rec? x)))))
|
||||
`(let ()
|
||||
(define-record-type ,my-rec (fields a))
|
||||
(define-record-type ,my-sub-rec (fields a) (parent ,my-rec) (sealed #t))
|
||||
(lambda (x) (and (my-rec? x) (list 'ok (#3%$sealed-record-instance? x (record-type-descriptor ,my-sub-rec)))))))
|
||||
)
|
||||
|
||||
(mat cptypes-unsafe
|
||||
|
|
|
|||
|
|
@ -6405,10 +6405,10 @@
|
|||
(begin
|
||||
(if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6))
|
||||
(#3%$object-ref 'scheme-object b ,fixnum?)))])
|
||||
(if (#3%record? b g4) (#2%void) (#3%$record-oops 'set-box! b g4))
|
||||
(if (#3%record-instance? b g4) (#2%void) (#3%$record-oops 'set-box! b g4))
|
||||
(#3%$object-set! 'scheme-object b ,fixnum? g7))
|
||||
(#2%list
|
||||
(#3%record? b g5)
|
||||
(#3%record-instance? b g5)
|
||||
(#3%$object-ref 'scheme-object b ,fixnum?))))))
|
||||
(equal?
|
||||
(let ()
|
||||
|
|
|
|||
|
|
@ -64,6 +64,9 @@ primvars.mo:Expected error testing (pseudo-random-generator-seed! *pseudo-random
|
|||
primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f)): Exception in pseudo-random-generator-next!: not a pseudo-random generator #f
|
||||
primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #!eof) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound
|
||||
primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound
|
||||
primvars.mo:Expected error testing (record-instance? 1.0+2.0i (quote #[#{foo nks5foiv91hvnm77o1ekdo731-1} 3])): Exception in record-instance?: 1.0+2.0i is not a record
|
||||
primvars.mo:Expected error testing (record-instance? 1.0+2.0i (quote "")): Exception in record-instance?: 1.0+2.0i is not a record
|
||||
primvars.mo:Expected error testing (record-instance? 1.0+2.0i (quote #f)): Exception in record-instance?: 1.0+2.0i is not a record
|
||||
primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote 0)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure
|
||||
primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote #f)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure
|
||||
primvars.mo:Expected error testing (vector->pseudo-random-generator (quote "a")): Exception in vector->pseudo-random-generator: not a valid pseudo-random generator state vector "a"
|
||||
|
|
|
|||
|
|
@ -60,6 +60,9 @@
|
|||
#(fld uid #f scheme-object 65)
|
||||
#(fld counts #f scheme-object 73))))
|
||||
|
||||
(define base-rtd-ancestry (vector #f base-rtd))
|
||||
(define ANCESTRY-PARENT-OFFSET 2)
|
||||
|
||||
(define (s:struct-type? v)
|
||||
(or (struct-type? v)
|
||||
(base-rtd? v)))
|
||||
|
|
@ -138,16 +141,17 @@
|
|||
(define rtd-ancestors (make-weak-hasheq))
|
||||
|
||||
(define (register-rtd-ancestors! struct:name parent)
|
||||
;; ancestry vector is `(vector #f ... parent self)`
|
||||
(unless (hash-ref rtd-ancestors struct:name #f)
|
||||
(cond
|
||||
[(not parent)
|
||||
(hash-set! rtd-ancestors struct:name (vector #f))]
|
||||
(hash-set! rtd-ancestors struct:name (vector #f struct:name))]
|
||||
[(eq? parent struct:base-rtd-subtype)
|
||||
(hash-set! rtd-ancestors struct:name (vector base-rtd #f))]
|
||||
(hash-set! rtd-ancestors struct:name (vector #f base-rtd struct:name))]
|
||||
[else
|
||||
(define p-vec (hash-ref rtd-ancestors parent))
|
||||
(define vec (make-vector (+ 1 (vector-length p-vec)) parent))
|
||||
(vector-copy! vec 1 p-vec)
|
||||
(define vec (make-vector (+ 1 (vector-length p-vec)) struct:name))
|
||||
(vector-copy! vec 0 p-vec)
|
||||
(hash-set! rtd-ancestors struct:name vec)])))
|
||||
|
||||
(define rtd-fields (make-weak-hasheq))
|
||||
|
|
@ -344,7 +348,7 @@
|
|||
(assert-accessor)
|
||||
(lambda (rtd)
|
||||
(cond
|
||||
[(base-rtd? rtd) '#(#f)]
|
||||
[(base-rtd? rtd) base-rtd-ancestry]
|
||||
[else
|
||||
(define vec (hash-ref rtd-ancestors rtd))
|
||||
(define-values (r-name init-cnt auto-cnt ref set immutables super skipped?)
|
||||
|
|
@ -353,7 +357,7 @@
|
|||
(if (eq? super struct:base-rtd-subtype)
|
||||
base-rtd
|
||||
super))
|
||||
(unless (eq? parent (vector-ref vec 0))
|
||||
(unless (eq? parent (vector-ref vec (- (vector-length vec) ANCESTRY-PARENT-OFFSET)))
|
||||
(error "ancestry sanity check failed" rtd vec parent))
|
||||
vec]))]
|
||||
[(size)
|
||||
|
|
|
|||
|
|
@ -357,7 +357,7 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
;; Version and machine types:
|
||||
|
||||
(define-constant scheme-version #x09050502)
|
||||
(define-constant scheme-version #x09050503)
|
||||
|
||||
(define-syntax define-machine-types
|
||||
(lambda (x)
|
||||
|
|
@ -1627,7 +1627,7 @@
|
|||
|
||||
(define-primitive-structure-disps record-type type-typed-object
|
||||
([ptr type]
|
||||
[ptr ancestry] ; vector: parent at 0, grandparent at 1, etc.
|
||||
[ptr ancestry] ; (vector #f .... grandparent parent self)
|
||||
[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
|
||||
|
|
@ -1641,6 +1641,9 @@
|
|||
(define-constant rtd-opaque #b0010)
|
||||
(define-constant rtd-sealed #b0100)
|
||||
|
||||
(define-constant ancestry-parent-offset 2)
|
||||
(define-constant minimum-ancestry-vector-length 2)
|
||||
|
||||
; we do this as a macro here since we want the freshest version possible
|
||||
; in syntax.ss when we use it as a patch, whereas we want the old
|
||||
; version in non-patched record.ss, so he can operate on host-system
|
||||
|
|
|
|||
|
|
@ -487,7 +487,7 @@
|
|||
(if omit-rtds? (constant fasl-omit-rtds) 0))])
|
||||
(and (not (fx= flags 0)) flags))])
|
||||
(c-build-fasl x t a?)
|
||||
($fasl-start p t situation x
|
||||
($fasl-start p t situation x a?
|
||||
(lambda (x p) (c-faslobj x t p a?)))))
|
||||
|
||||
(define-record-type visit-chunk
|
||||
|
|
@ -611,7 +611,8 @@
|
|||
(parameterize ([$target-machine (machine-type)])
|
||||
(let ([t ($fasl-table)])
|
||||
($fasl-enter x1 t (constant annotation-all) 0)
|
||||
($fasl-start wpoop t (constant fasl-type-visit-revisit) x1 (lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))))
|
||||
($fasl-start wpoop t (constant fasl-type-visit-revisit) x1 (constant annotation-all)
|
||||
(lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))))
|
||||
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 source-info-string)])
|
||||
(when hostop
|
||||
; the host library file contains expander output possibly augmented with
|
||||
|
|
@ -622,7 +623,8 @@
|
|||
(parameterize ([$target-machine (machine-type)])
|
||||
(let ([t ($fasl-table)])
|
||||
($fasl-enter x1 t (constant annotation-all) 0)
|
||||
($fasl-start hostop t (constant fasl-type-visit-revisit) x1 (lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))
|
||||
($fasl-start hostop t (constant fasl-type-visit-revisit) x1 (constant annotation-all)
|
||||
(lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))
|
||||
(cfh0 (+ n 1) (cons rcinfo* rrcinfo**) (cons lpinfo* rlpinfo**) (cons final* rfinal**)))))))))))
|
||||
|
||||
(define library/program-info?
|
||||
|
|
@ -1605,7 +1607,8 @@
|
|||
(let ([x (fold-left (lambda (outer ir) (with-output-language (Lexpand Outer) `(group ,outer ,ir)))
|
||||
(car ir*) (cdr ir*))])
|
||||
($fasl-enter x t (constant annotation-all) 0)
|
||||
($fasl-start wpoop t (constant fasl-type-visit-revisit) x (lambda (x p) ($fasl-out x p t (constant annotation-all))))))))))))))
|
||||
($fasl-start wpoop t (constant fasl-type-visit-revisit) x (constant annotation-all)
|
||||
(lambda (x p) ($fasl-out x p t (constant annotation-all))))))))))))))
|
||||
|
||||
(define build-required-library-list
|
||||
(lambda (node* visit-lib*)
|
||||
|
|
|
|||
|
|
@ -120,7 +120,8 @@
|
|||
; file for cross compilation, because the offsets may be incorrect
|
||||
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
|
||||
(define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors))
|
||||
(define rtd-parent (lambda (x) (vector-ref (rtd-ancestors x) 0)))
|
||||
(define rtd-parent (lambda (x) (let ([a (rtd-ancestors x)])
|
||||
(vector-ref a (fx- (vector-length a) (constant ancestry-parent-offset))))))
|
||||
(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))
|
||||
|
|
@ -3936,19 +3937,19 @@
|
|||
(begin
|
||||
(residualize-seq '() (list ?x) ctxt)
|
||||
false-rec))]))))
|
||||
(define-inline 2 r6rs:record?
|
||||
[(?x) (one-arg-case ?x ctxt)])
|
||||
(define-inline 2 record?
|
||||
[(?x) (one-arg-case ?x ctxt)]
|
||||
[(?x ?rtd)
|
||||
(define two-arg-case
|
||||
(lambda (?x ?rtd level ctxt needs-record?)
|
||||
(let ([rtdval (value-visit-operand! ?rtd)])
|
||||
(define abandon-ship
|
||||
(lambda (xval xres maybe-rtd)
|
||||
(if (definitely-not-a-record? xres)
|
||||
(begin
|
||||
(residualize-seq '() (list ?x ?rtd) ctxt)
|
||||
false-rec)
|
||||
(cond
|
||||
[needs-record? #f]
|
||||
[else
|
||||
(residualize-seq '() (list ?x ?rtd) ctxt)
|
||||
false-rec])
|
||||
(and maybe-rtd
|
||||
(not needs-record?)
|
||||
(begin
|
||||
(residualize-seq (list ?x ?rtd) '() ctxt)
|
||||
(build-primcall (app-preinfo ctxt) 3
|
||||
|
|
@ -3993,7 +3994,9 @@
|
|||
[(quote ,d1)
|
||||
; could also return #f here and let folding happen
|
||||
(residualize-seq '() (list ?x ?rtd) ctxt)
|
||||
(if (record? d1 d0) true-rec false-rec)]
|
||||
(cond
|
||||
[(and needs-record? (not (record? d1))) #f]
|
||||
[else (if (record? d1 d0) true-rec false-rec)])]
|
||||
; could handle record-type forms if ctrtd recorded rtdrtd (a ctrtd's rtd is always base-ctrtd)
|
||||
[(record ,rtd ,rtd-expr ,e* ...)
|
||||
(guard (let f ([rtd rtd])
|
||||
|
|
@ -4033,7 +4036,14 @@
|
|||
[else
|
||||
(and (fx= level 3)
|
||||
(let ([xval (value-visit-operand! ?x)])
|
||||
(abandon-ship xval (result-exp/indirect-ref xval) #f)))]))]))
|
||||
(abandon-ship xval (result-exp/indirect-ref xval) #f)))]))))
|
||||
(define-inline 2 r6rs:record?
|
||||
[(?x) (one-arg-case ?x ctxt)])
|
||||
(define-inline 2 record?
|
||||
[(?x) (one-arg-case ?x ctxt)]
|
||||
[(?x ?rtd) (two-arg-case ?x ?rtd level ctxt #f)])
|
||||
(define-inline 2 record-instance?
|
||||
[(?x ?rtd) (two-arg-case ?x ?rtd level ctxt #t)]))
|
||||
|
||||
(define-inline 2 csv7:record-type-field-names
|
||||
[(?rtd)
|
||||
|
|
|
|||
|
|
@ -3963,6 +3963,11 @@
|
|||
(define build-and
|
||||
(lambda (e1 e2)
|
||||
`(if ,e1 ,e2 ,(%constant sfalse))))
|
||||
(define maybe-build-and
|
||||
(lambda (e1 e2)
|
||||
(if e1
|
||||
(build-and e1 e2)
|
||||
e2)))
|
||||
(define build-simple-or
|
||||
(lambda (e1 e2)
|
||||
`(if ,e1 ,(%constant strue) ,e2)))
|
||||
|
|
@ -11134,44 +11139,66 @@
|
|||
,(%mref ,t ,(constant record-type-flags-disp))
|
||||
(immediate ,(fix (constant rtd-opaque)))))))))))
|
||||
(define build-sealed-isa?
|
||||
(lambda (e e-rtd)
|
||||
(lambda (e e-rtd assume-record?)
|
||||
(bind #t (e)
|
||||
(bind #f (e-rtd)
|
||||
(build-and
|
||||
(%type-check mask-typed-object type-typed-object ,e)
|
||||
(maybe-build-and
|
||||
(and (not assume-record?)
|
||||
(%type-check mask-typed-object type-typed-object ,e))
|
||||
(%inline eq?
|
||||
,(%mref ,e ,(constant typed-object-type-disp))
|
||||
,e-rtd))))))
|
||||
(define build-unsealed-isa?
|
||||
(lambda (e e-rtd)
|
||||
(let ([t (make-tmp 't)] [a (make-tmp 'a)])
|
||||
(let ([known-depth (nanopass-case (L7 Expr) e-rtd
|
||||
[(quote ,d) (and (record-type-descriptor? d)
|
||||
(vector-length (rtd-ancestors d)))]
|
||||
[else #f])])
|
||||
(bind #t (e e-rtd)
|
||||
(build-and
|
||||
(%type-check mask-typed-object type-typed-object ,e)
|
||||
`(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))])
|
||||
,(build-simple-or
|
||||
(%inline eq? ,t ,e-rtd)
|
||||
(build-and
|
||||
(%type-check mask-record type-record ,t)
|
||||
`(let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))])
|
||||
,(begin
|
||||
;; take advantage of being able to use the type field of a vector
|
||||
;; as a pointer offset with just shifting:
|
||||
(safe-assert (zero? (constant type-vector)))
|
||||
(bind #f ([d (%inline -/pos ,(%mref ,a ,(constant vector-type-disp))
|
||||
,(if known-depth
|
||||
`(immediate ,(fxsll known-depth (constant vector-length-offset)))
|
||||
(%mref ,(%mref ,e-rtd ,(constant record-type-ancestry-disp))
|
||||
,(constant vector-type-disp))))])
|
||||
`(if (inline ,(make-info-condition-code 'positive #f #t) ,%condition-code)
|
||||
,(%inline eq? ,e-rtd ,(%mref ,a
|
||||
,(translate d (constant vector-length-offset) (constant log2-ptr-bytes))
|
||||
,(fx- (constant vector-data-disp) (constant ptr-bytes))))
|
||||
,(%constant sfalse))))))))))))))
|
||||
(lambda (e e-rtd assume-record?)
|
||||
(let ([known-depth (nanopass-case (L7 Expr) e-rtd
|
||||
[(quote ,d) (and (record-type-descriptor? d)
|
||||
(vector-length (rtd-ancestors d)))]
|
||||
[else #f])])
|
||||
;; `t` is rtd of `e`, and it's used once
|
||||
(define (compare-at-depth t known-depth)
|
||||
(cond
|
||||
[(eqv? known-depth (constant minimum-ancestry-vector-length))
|
||||
;; no need to check ancestry array length
|
||||
(%inline eq? ,e-rtd ,(%mref ,(%mref ,t ,(constant record-type-ancestry-disp))
|
||||
,(fx+ (constant vector-data-disp)
|
||||
(fx* (fx- known-depth 1) (constant ptr-bytes)))))]
|
||||
[known-depth
|
||||
;; need to check ancestry array length
|
||||
(let ([a (make-tmp 'a)])
|
||||
`(let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))])
|
||||
(if ,(%inline <=
|
||||
(immediate ,(fxsll known-depth (constant vector-length-offset)))
|
||||
,(%mref ,a ,(constant vector-type-disp)))
|
||||
,(%inline eq? ,e-rtd ,(%mref ,a ,(fx+ (constant vector-data-disp)
|
||||
(fx* (fx- known-depth 1) (constant ptr-bytes)))))
|
||||
,(%constant sfalse))))]
|
||||
[else
|
||||
(bind #t (e-rtd)
|
||||
(let ([a (make-tmp 'a)] [rtd-a (make-tmp 'rtd-a)] [rtd-len (make-tmp 'rtd-len)])
|
||||
`(let ([,rtd-a ,(%mref ,e-rtd ,(constant record-type-ancestry-disp))])
|
||||
(let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))])
|
||||
(let ([,rtd-len ,(%mref ,rtd-a ,(constant vector-type-disp))])
|
||||
(if ,(%inline <= ,rtd-len ,(%mref ,a ,(constant vector-type-disp)))
|
||||
,(begin
|
||||
;; take advantage of being able to use the type field of a vector
|
||||
;; as a pointer offset with just shifting:
|
||||
(safe-assert (zero? (constant type-vector)))
|
||||
(%inline eq? ,e-rtd ,(%mref ,a
|
||||
,(translate rtd-len (constant vector-length-offset) (constant log2-ptr-bytes))
|
||||
,(fx- (constant vector-data-disp) (constant ptr-bytes)))))
|
||||
,(%constant sfalse)))))))]))
|
||||
(cond
|
||||
[assume-record?
|
||||
(compare-at-depth (%mref ,e ,(constant typed-object-type-disp)) known-depth)]
|
||||
[else
|
||||
(let ([t (make-tmp 't)])
|
||||
(bind #t (e)
|
||||
(build-and
|
||||
(%type-check mask-typed-object type-typed-object ,e)
|
||||
`(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))])
|
||||
,(build-and
|
||||
(%type-check mask-record type-record ,t)
|
||||
(compare-at-depth t known-depth))))))]))))
|
||||
(define-inline 3 record?
|
||||
[(e) (build-record? e)]
|
||||
[(e e-rtd)
|
||||
|
|
@ -11179,8 +11206,16 @@
|
|||
(and (record-type-descriptor? x)
|
||||
(record-type-sealed? x)))
|
||||
e-rtd)
|
||||
(build-sealed-isa? e e-rtd)
|
||||
(build-unsealed-isa? e e-rtd))])
|
||||
(build-sealed-isa? e e-rtd #f)
|
||||
(build-unsealed-isa? e e-rtd #f))])
|
||||
(define-inline 3 record-instance?
|
||||
[(e e-rtd)
|
||||
(if (constant? (lambda (x)
|
||||
(and (record-type-descriptor? x)
|
||||
(record-type-sealed? x)))
|
||||
e-rtd)
|
||||
(build-sealed-isa? e e-rtd #t)
|
||||
(build-unsealed-isa? e e-rtd #t))])
|
||||
(define-inline 2 r6rs:record?
|
||||
[(e) (build-record? e)])
|
||||
(define-inline 2 record?
|
||||
|
|
@ -11190,11 +11225,13 @@
|
|||
[(quote ,d)
|
||||
(and (record-type-descriptor? d)
|
||||
(if (record-type-sealed? d)
|
||||
(build-sealed-isa? e e-rtd)
|
||||
(build-unsealed-isa? e e-rtd)))]
|
||||
(build-sealed-isa? e e-rtd #f)
|
||||
(build-unsealed-isa? e e-rtd #f)))]
|
||||
[else #f])])
|
||||
(define-inline 2 $sealed-record?
|
||||
[(e e-rtd) (build-sealed-isa? e e-rtd)])
|
||||
[(e e-rtd) (build-sealed-isa? e e-rtd #f)])
|
||||
(define-inline 2 $sealed-record-instance?
|
||||
[(e e-rtd) (build-sealed-isa? e e-rtd #t)])
|
||||
(define-inline 3 $record-type-field-count
|
||||
[(e) (%inline srl ,(%inline - ,(%mref ,e ,(constant record-type-size-disp))
|
||||
(immediate ,(fxsll (fx- (constant record-data-disp) (constant record-type-disp))
|
||||
|
|
@ -11204,8 +11241,8 @@
|
|||
[(e) (let ([rtd (let () (include "hashtable-types.ss") (record-type-descriptor eq-ht))])
|
||||
(let ([e-rtd `(quote ,rtd)])
|
||||
(if (record-type-sealed? rtd)
|
||||
(build-sealed-isa? e e-rtd)
|
||||
(build-unsealed-isa? e e-rtd))))]))
|
||||
(build-sealed-isa? e e-rtd #f)
|
||||
(build-unsealed-isa? e e-rtd #f))))]))
|
||||
(define-inline 2 gensym?
|
||||
[(e)
|
||||
(bind #t (e)
|
||||
|
|
|
|||
|
|
@ -42,9 +42,6 @@
|
|||
; don't use rtd-* as defined in record.ss in case we're building a patch
|
||||
; file for cross compilation, because the offsets may be incorrect
|
||||
(define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors))
|
||||
(define (rtd-parent x) (vector-ref (rtd-ancestors x) 0))
|
||||
;(define (rtd-ancestry x) ($object-ref 'scheme-object x (constant record-type-ancestry-disp)))
|
||||
;(define (rtd-parent x) (vector-ref (rtd-ancestry x) 0))
|
||||
|
||||
(define-record-type pred-$record/rtd
|
||||
(fields rtd)
|
||||
|
|
@ -56,7 +53,6 @@
|
|||
(nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0})
|
||||
(sealed #t))
|
||||
|
||||
|
||||
(define (check-constant-is? x pred?)
|
||||
(and (Lsrc? x)
|
||||
(nanopass-case (Lsrc Expr) x
|
||||
|
|
@ -210,9 +206,8 @@
|
|||
(define lx (vector-length ax))
|
||||
(define ay (rtd-ancestors y))
|
||||
(define ly (vector-length ay))
|
||||
(let ([pos (fx- ly lx 1)])
|
||||
(and (fx>= pos 0)
|
||||
(eq? x (vector-ref ay pos)))))))
|
||||
(and (fx<= lx ly)
|
||||
(eq? x (vector-ref ay (fx- lx 1)))))))
|
||||
|
||||
;includes the case when the are the same
|
||||
;or when one is the ancester of the other
|
||||
|
|
@ -226,36 +221,26 @@
|
|||
(define ay (rtd-ancestors y))
|
||||
(define ly (vector-length ay))
|
||||
(cond
|
||||
[(let ([pos (fx- ly lx 1)])
|
||||
(and (fx>= pos 0)
|
||||
(eq? x (vector-ref ay pos))))
|
||||
[(and (fx<= lx ly)
|
||||
(eq? x (vector-ref ay (fx- lx 1))))
|
||||
x]
|
||||
[(let ([pos (fx- lx ly 1)])
|
||||
(and (fx>= pos 0)
|
||||
(eq? y (vector-ref ax pos))))
|
||||
[(and (fx<= ly lx)
|
||||
(eq? y (vector-ref ax (fx- ly 1))))
|
||||
y]
|
||||
[(fx= lx 1) #f]
|
||||
[(fx= ly 1) #f]
|
||||
[else
|
||||
(let ()
|
||||
(define offset (fx- lx ly))
|
||||
(define f (if (fx< lx ly) (fx- offset) 0))
|
||||
(define l (fx- ly 1))
|
||||
(cond
|
||||
[(eq? (vector-ref ay f)
|
||||
(vector-ref ax (fx+ f offset)))
|
||||
(vector-ref ay f)]
|
||||
[else
|
||||
(let loop ([f f] [l l])
|
||||
(cond
|
||||
[(fx= (fx- l f) 1) (vector-ref ay l)]
|
||||
[else
|
||||
(let ()
|
||||
(define m (fxquotient (fx+ f l) 2))
|
||||
(if (eq? (vector-ref ay m)
|
||||
(vector-ref ax (fx+ m offset)))
|
||||
(loop f m)
|
||||
(loop m l)))]))]))]))]))
|
||||
[else
|
||||
;; binary search to find a common prefix, given that
|
||||
;; no elements are the same after a common prefix
|
||||
(let loop ([lo 0] [hi (fxmin lx ly)])
|
||||
(cond
|
||||
[(fx= lo hi) #f]
|
||||
[else (let* ([i (fxquotient (fx+ lo hi) 2)]
|
||||
[v (vector-ref ax i)])
|
||||
(cond
|
||||
[(eq? v (vector-ref ay i))
|
||||
(or (loop (fx+ i 1) hi)
|
||||
v)]
|
||||
[else
|
||||
(loop lo i)]))]))]))]))
|
||||
|
||||
(define (exact-integer? x)
|
||||
(and (integer? x) (exact? x)))
|
||||
|
|
|
|||
|
|
@ -929,13 +929,23 @@ Notes:
|
|||
(define-set-immediate set-car! (p val))
|
||||
(define-set-immediate set-cdr! (p val)))
|
||||
|
||||
(define-specialize 2 (record? $sealed-record?)
|
||||
[(val rtd) (let* ([val-type (get-type val)]
|
||||
(define-specialize 2 (record? $sealed-record? record-instance? $sealed-record-instance?)
|
||||
[(val rtd) (let* ([alt-if-record (case (primref-name pr)
|
||||
[record? 'record-instance?]
|
||||
[$sealed-record? '$sealed-record-instance?]
|
||||
[else #f])]
|
||||
[val-type (get-type val)]
|
||||
[to-unsafe (and (fx= level 2)
|
||||
(expr-is-rtd? rtd oldtypes))] ; use the old types
|
||||
(expr-is-rtd? rtd oldtypes) ; use the old types
|
||||
(or alt-if-record
|
||||
(predicate-implies? val-type '$record)))]
|
||||
[level (if to-unsafe 3 level)]
|
||||
[pr (if to-unsafe
|
||||
(primref->unsafe-primref pr)
|
||||
pr)]
|
||||
[pr (if (and alt-if-record
|
||||
(predicate-implies? val-type '$record))
|
||||
(lookup-primref (primref-level pr) alt-if-record)
|
||||
pr)])
|
||||
(cond
|
||||
[(predicate-implies? val-type (rtd->record-predicate rtd #f))
|
||||
|
|
|
|||
|
|
@ -500,6 +500,11 @@
|
|||
[(record-type-descriptor? x)
|
||||
(put-u8 p (constant fasl-type-rtd))
|
||||
(wrf (record-type-uid x) p t a?)
|
||||
(unless (eq? x (let ([a (rtd-ancestors x)])
|
||||
(vector-ref a (sub1 (vector-length a)))))
|
||||
(error 'fasl "mismatch"))
|
||||
(unless (eq-hashtable-ref (table-hash t) x #f)
|
||||
(error 'fasl "not in table!?"))
|
||||
(if (and a? (fxlogtest a? (constant fasl-omit-rtds)))
|
||||
(put-uptr p 0) ; => must be registered already at load time
|
||||
(wrf-fields (maybe-remake-rtd x) p t a?))]
|
||||
|
|
@ -677,7 +682,7 @@
|
|||
|
||||
(module (start)
|
||||
(define start
|
||||
(lambda (p t situation x proc)
|
||||
(lambda (p t situation x a? proc)
|
||||
(shift-externals! t)
|
||||
(dump-graph)
|
||||
(let-values ([(bv* size)
|
||||
|
|
@ -693,7 +698,7 @@
|
|||
(for-each (lambda (x)
|
||||
(if (eq? 'begin (cdr (eq-hashtable-ref (table-hash t) x #f)))
|
||||
(proc x p)
|
||||
(wrf x p t (constant annotation-all))))
|
||||
(wrf x p t a?)))
|
||||
begins)))
|
||||
(proc x p)
|
||||
(extractor))])
|
||||
|
|
@ -733,7 +738,7 @@
|
|||
(constant fasl-omit-rtds)
|
||||
0))])
|
||||
(bld x t a? 0)
|
||||
(start p t (constant fasl-type-visit-revisit) x (lambda (x p) (wrf x p t a?))))))
|
||||
(start p t (constant fasl-type-visit-revisit) x a? (lambda (x p) (wrf x p t a?))))))
|
||||
|
||||
(define-who fasl-write
|
||||
(case-lambda
|
||||
|
|
@ -775,7 +780,7 @@
|
|||
(emit-header p (constant scheme-version) (constant machine-type-any))
|
||||
(let ([t (make-table)])
|
||||
(bld-graph x t #f 0 #t really-bld-record)
|
||||
(start p t (constant fasl-type-visit-revisit) x (lambda (x p) (wrf-graph x p t #f really-wrf-record))))))
|
||||
(start p t (constant fasl-type-visit-revisit) x #f (lambda (x p) (wrf-graph x p t #f really-wrf-record))))))
|
||||
|
||||
($fasl-target (make-target bld-graph bld wrf start make-table wrf-graph fasl-base-rtd fasl-write fasl-file))
|
||||
)
|
||||
|
|
@ -789,7 +794,7 @@
|
|||
(set! $fasl-bld-graph (lambda (x t a? d inner? handler) ((target-fasl-bld-graph (fasl-target)) x t a? d inner? handler)))
|
||||
(set! $fasl-enter (lambda (x t a? d) ((target-fasl-enter (fasl-target)) x t a? d)))
|
||||
(set! $fasl-out (lambda (x p t a?) ((target-fasl-out (fasl-target)) x p t a?)))
|
||||
(set! $fasl-start (lambda (p t situation x proc) ((target-fasl-start (fasl-target)) p t situation x proc)))
|
||||
(set! $fasl-start (lambda (p t situation x a? proc) ((target-fasl-start (fasl-target)) p t situation x a? proc)))
|
||||
(set! $fasl-table (case-lambda
|
||||
[() ((target-fasl-table (fasl-target)))]
|
||||
[(external?-pred) ((target-fasl-table (fasl-target)) external?-pred)]))
|
||||
|
|
|
|||
|
|
@ -1622,6 +1622,7 @@
|
|||
(record-constructor-descriptor? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard cp02])
|
||||
(record-equal-procedure [sig [(record record) -> (maybe-procedure)]] [flags discard])
|
||||
(record-hash-procedure [sig [(record) -> (maybe-procedure)]] [flags discard])
|
||||
(record-instance? [sig [(record rtd) -> (boolean)]] [flags pure mifoldable discard cp02 cptypes2])
|
||||
(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])
|
||||
|
|
@ -2337,6 +2338,7 @@
|
|||
($sc-put-property! [flags single-valued])
|
||||
($script [flags single-valued])
|
||||
($sealed-record? [sig [(ptr rtd) -> (boolean)]] [flags pure mifoldable cptypes2]) ; first argument may be not a record
|
||||
($sealed-record-instance? [sig [(record rtd) -> (boolean)]] [flags pure mifoldable cptypes2])
|
||||
($seginfo [flags single-valued])
|
||||
($seginfo-generation [flags single-valued])
|
||||
($seginfo-space [flags single-valued])
|
||||
|
|
|
|||
|
|
@ -2319,8 +2319,22 @@
|
|||
($oops who "~s is not a record type descriptor" rtd))
|
||||
(#3%$sealed-record? x rtd))
|
||||
|
||||
(define-who ($sealed-record-instance? x rtd)
|
||||
(unless (record? x)
|
||||
($oops who "~s is not a record" x))
|
||||
(unless (record-type-descriptor? rtd)
|
||||
($oops who "~s is not a record type descriptor" rtd))
|
||||
(#3%$sealed-record-instance? x rtd))
|
||||
|
||||
(define ($record? x) (#3%$record? x))
|
||||
|
||||
(define-who (record-instance? x rtd)
|
||||
(unless (record? x)
|
||||
($oops who "~s is not a record" x))
|
||||
(unless (record-type-descriptor? rtd)
|
||||
($oops who "~s is not a record type descriptor" rtd))
|
||||
(#3%record-instance? x rtd))
|
||||
|
||||
(define-who ($record-type-descriptor r)
|
||||
(unless ($record? r) ($oops who "~s is not a record" r))
|
||||
(#3%$record-type-descriptor r))
|
||||
|
|
|
|||
|
|
@ -26,7 +26,8 @@
|
|||
|
||||
(let ()
|
||||
(define (rtd-ancestry x) ($object-ref 'scheme-object x (constant record-type-ancestry-disp)))
|
||||
(define (rtd-parent x) (vector-ref (rtd-ancestry x) 0))
|
||||
(define (rtd-parent x) (let ([a (rtd-ancestry x)])
|
||||
(vector-ref a (fx- (vector-length a) (constant ancestry-parent-offset)))))
|
||||
(define (rtd-size x) ($object-ref 'scheme-object x (constant record-type-size-disp)))
|
||||
(define (rtd-pm x) ($object-ref 'scheme-object x (constant record-type-pm-disp)))
|
||||
(define (rtd-mpm x) ($object-ref 'scheme-object x (constant record-type-mpm-disp)))
|
||||
|
|
@ -619,14 +620,15 @@
|
|||
(unless (eq? (rtd-size rtd) size) (squawk "different size")))
|
||||
rtd)]
|
||||
[else
|
||||
(let* ([len (if (not parent) 0 (vector-length (rtd-ancestry parent)))]
|
||||
[ancestry (make-vector (fx+ 1 len) parent)])
|
||||
(let loop ([i 0])
|
||||
(let* ([len (if (not parent) 1 (vector-length (rtd-ancestry parent)))]
|
||||
[ancestry (make-vector (fx+ 1 len) #f)])
|
||||
(let loop ([i 1])
|
||||
(unless (fx= i len)
|
||||
(vector-set! ancestry (fx+ i 1) (vector-ref (rtd-ancestry parent) i))
|
||||
(vector-set! ancestry i (vector-ref (rtd-ancestry parent) i))
|
||||
(loop (fx+ i 1))))
|
||||
(let ([rtd (apply #%$record base-rtd ancestry size pm mpm name
|
||||
(if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f extras)])
|
||||
(vector-set! ancestry len rtd)
|
||||
(with-tc-mutex ($sputprop uid '*rtd* rtd))
|
||||
rtd))]))))
|
||||
|
||||
|
|
|
|||
|
|
@ -753,11 +753,17 @@
|
|||
(when maybe-uid
|
||||
(eq-hashtable-set! (vfasl-info-rtds vfi) (unpack-symbol maybe-uid) v)
|
||||
;; make sure parent type is earlier
|
||||
(for-each (lambda (fld)
|
||||
(field-case (car fld*)
|
||||
[ptr (elem) (copy elem vfi)]
|
||||
[else (void)]))
|
||||
fld*))
|
||||
(safe-assert (pair? fld*))
|
||||
(let ([ancestry (car fld*)])
|
||||
(field-case ancestry
|
||||
[ptr (elem)
|
||||
(fasl-case* elem
|
||||
[(vector ty vec)
|
||||
(let ([parent (vector-ref vec (fx- (vector-length vec)
|
||||
(constant ancestry-parent-offset)))])
|
||||
(copy parent vfi))]
|
||||
[else (safe-assert (not 'vector)) (void)])]
|
||||
[else (safe-assert (not 'ptr)) (void)])))
|
||||
(let* ([vspc (cond
|
||||
[maybe-uid
|
||||
(constant vspace-rtd)]
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 8
|
||||
#define MZSCHEME_VERSION_Y 0
|
||||
#define MZSCHEME_VERSION_Z 0
|
||||
#define MZSCHEME_VERSION_W 5
|
||||
#define MZSCHEME_VERSION_W 6
|
||||
|
||||
/* A level of indirection makes `#` work as needed: */
|
||||
#define AS_a_STR_HELPER(x) #x
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user