From 9f6f98815070fcb1431f8d64b72323aed0f165fe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 9 Feb 2021 19:31:42 -0700 Subject: [PATCH] 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 --- .makefile | 2 +- Makefile | 12 +- pkgs/base/info.rkt | 2 +- racket/src/ChezScheme/c/types.h | 2 +- racket/src/ChezScheme/csug/objects.stex | 14 +++ racket/src/ChezScheme/makefiles/Mf-install.in | 2 +- racket/src/ChezScheme/mats/Mf-tarm64osx | 2 +- racket/src/ChezScheme/mats/cptypes.ms | 23 ++++ racket/src/ChezScheme/mats/record.ms | 4 +- .../mats/root-experr-compile-0-f-f-f | 3 + racket/src/ChezScheme/rktboot/record.rkt | 16 ++- racket/src/ChezScheme/s/cmacros.ss | 7 +- racket/src/ChezScheme/s/compile.ss | 11 +- racket/src/ChezScheme/s/cp0.ss | 32 +++-- racket/src/ChezScheme/s/cpnanopass.ss | 115 ++++++++++++------ racket/src/ChezScheme/s/cptypes-lattice.ss | 55 +++------ racket/src/ChezScheme/s/cptypes.ss | 16 ++- racket/src/ChezScheme/s/fasl.ss | 15 ++- racket/src/ChezScheme/s/primdata.ss | 2 + racket/src/ChezScheme/s/prims.ss | 14 +++ racket/src/ChezScheme/s/record.ss | 12 +- racket/src/ChezScheme/s/vfasl.ss | 16 ++- racket/src/version/racket_version.h | 2 +- 23 files changed, 250 insertions(+), 129 deletions(-) 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