diff --git a/.makefile b/.makefile index be16e05813..20cf7cd47d 100644 --- a/.makefile +++ b/.makefile @@ -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 diff --git a/Makefile b/Makefile index 814a4a0b33..1e1066c37a 100644 --- a/Makefile +++ b/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)" diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 647a4409c3..8ee39a3fe9 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -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])) diff --git a/racket/src/ChezScheme/c/types.h b/racket/src/ChezScheme/c/types.h index e33f91af57..a003633a29 100644 --- a/racket/src/ChezScheme/c/types.h +++ b/racket/src/ChezScheme/c/types.h @@ -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 */ diff --git a/racket/src/ChezScheme/csug/objects.stex b/racket/src/ChezScheme/csug/objects.stex index ba3f97bd6b..7ff0b00c1e 100644 --- a/racket/src/ChezScheme/csug/objects.stex +++ b/racket/src/ChezScheme/csug/objects.stex @@ -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})} diff --git a/racket/src/ChezScheme/makefiles/Mf-install.in b/racket/src/ChezScheme/makefiles/Mf-install.in index f208fc6a01..557cdc48cb 100644 --- a/racket/src/ChezScheme/makefiles/Mf-install.in +++ b/racket/src/ChezScheme/makefiles/Mf-install.in @@ -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 diff --git a/racket/src/ChezScheme/mats/Mf-tarm64osx b/racket/src/ChezScheme/mats/Mf-tarm64osx index 520b683f43..e4d05eb21f 100644 --- a/racket/src/ChezScheme/mats/Mf-tarm64osx +++ b/racket/src/ChezScheme/mats/Mf-tarm64osx @@ -1,5 +1,5 @@ # Mf-tarm64osx -m = tarm64osx +m ?= tarm64osx include Mf-arm64osx diff --git a/racket/src/ChezScheme/mats/cptypes.ms b/racket/src/ChezScheme/mats/cptypes.ms index 9465cee774..d7d6b39386 100644 --- a/racket/src/ChezScheme/mats/cptypes.ms +++ b/racket/src/ChezScheme/mats/cptypes.ms @@ -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 diff --git a/racket/src/ChezScheme/mats/record.ms b/racket/src/ChezScheme/mats/record.ms index e947fda0b0..e16ab303ce 100644 --- a/racket/src/ChezScheme/mats/record.ms +++ b/racket/src/ChezScheme/mats/record.ms @@ -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 () diff --git a/racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f b/racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f index d4258cd9b4..7b59cb0f8a 100644 --- a/racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f +++ b/racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f @@ -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" diff --git a/racket/src/ChezScheme/rktboot/record.rkt b/racket/src/ChezScheme/rktboot/record.rkt index d035382d80..b4f69492a0 100644 --- a/racket/src/ChezScheme/rktboot/record.rkt +++ b/racket/src/ChezScheme/rktboot/record.rkt @@ -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) diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index fd4424044b..4879349dd3 100644 --- a/racket/src/ChezScheme/s/cmacros.ss +++ b/racket/src/ChezScheme/s/cmacros.ss @@ -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 diff --git a/racket/src/ChezScheme/s/compile.ss b/racket/src/ChezScheme/s/compile.ss index efdccfcd97..cc74227048 100644 --- a/racket/src/ChezScheme/s/compile.ss +++ b/racket/src/ChezScheme/s/compile.ss @@ -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*) diff --git a/racket/src/ChezScheme/s/cp0.ss b/racket/src/ChezScheme/s/cp0.ss index 10623b79d6..e27f01a43e 100644 --- a/racket/src/ChezScheme/s/cp0.ss +++ b/racket/src/ChezScheme/s/cp0.ss @@ -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) diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index 41b848a350..5852635ca8 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -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) diff --git a/racket/src/ChezScheme/s/cptypes-lattice.ss b/racket/src/ChezScheme/s/cptypes-lattice.ss index 451d2d48f5..5503ebcc87 100644 --- a/racket/src/ChezScheme/s/cptypes-lattice.ss +++ b/racket/src/ChezScheme/s/cptypes-lattice.ss @@ -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))) diff --git a/racket/src/ChezScheme/s/cptypes.ss b/racket/src/ChezScheme/s/cptypes.ss index 17eeecffd3..b26374633b 100644 --- a/racket/src/ChezScheme/s/cptypes.ss +++ b/racket/src/ChezScheme/s/cptypes.ss @@ -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)) diff --git a/racket/src/ChezScheme/s/fasl.ss b/racket/src/ChezScheme/s/fasl.ss index b56b6d0222..3f0ffe2c10 100644 --- a/racket/src/ChezScheme/s/fasl.ss +++ b/racket/src/ChezScheme/s/fasl.ss @@ -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)])) diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index d83e7442b4..8699730048 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/racket/src/ChezScheme/s/primdata.ss @@ -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]) diff --git a/racket/src/ChezScheme/s/prims.ss b/racket/src/ChezScheme/s/prims.ss index 2be34e334c..baa10ae658 100644 --- a/racket/src/ChezScheme/s/prims.ss +++ b/racket/src/ChezScheme/s/prims.ss @@ -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)) diff --git a/racket/src/ChezScheme/s/record.ss b/racket/src/ChezScheme/s/record.ss index 53bb7f2a39..473198fb74 100644 --- a/racket/src/ChezScheme/s/record.ss +++ b/racket/src/ChezScheme/s/record.ss @@ -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))])))) diff --git a/racket/src/ChezScheme/s/vfasl.ss b/racket/src/ChezScheme/s/vfasl.ss index befc436ee1..de3d0acb26 100644 --- a/racket/src/ChezScheme/s/vfasl.ss +++ b/racket/src/ChezScheme/s/vfasl.ss @@ -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)] diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index c1567748a8..9d1a611051 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -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