From e604c2deb90b50f1a061fe773305f724baecd3cb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 30 Dec 2020 12:07:18 -0700 Subject: [PATCH] Chez Scheme: change record-type predicate to constant-time Change the representation of records to keep an ancestor vector instead of just a parent, so a record-type predicate (for a non-sealed type) can be constant-time. --- .makefile | 2 +- Makefile | 12 ++-- pkgs/base/info.rkt | 2 +- racket/src/ChezScheme/c/alloc.c | 2 +- racket/src/ChezScheme/c/fasl.c | 2 +- racket/src/ChezScheme/c/types.h | 2 + racket/src/ChezScheme/c/vfasl.c | 9 +-- racket/src/ChezScheme/makefiles/Mf-install.in | 2 +- racket/src/ChezScheme/rktboot/r6rs-lang.rkt | 2 + racket/src/ChezScheme/rktboot/record.rkt | 59 +++++++++++++------ racket/src/ChezScheme/s/arm64.ss | 18 +++++- racket/src/ChezScheme/s/cmacros.ss | 4 +- racket/src/ChezScheme/s/cp0.ss | 3 +- racket/src/ChezScheme/s/cpnanopass.ss | 53 ++++++++++++----- racket/src/ChezScheme/s/fasl.ss | 2 +- racket/src/ChezScheme/s/mkheader.ss | 2 +- racket/src/ChezScheme/s/np-languages.ss | 1 + racket/src/ChezScheme/s/record.ss | 21 ++++--- racket/src/ChezScheme/s/x86_64.ss | 11 +++- racket/src/version/racket_version.h | 2 +- 20 files changed, 148 insertions(+), 63 deletions(-) diff --git a/.makefile b/.makefile index 85c10b3d16..40098c79e8 100644 --- a/.makefile +++ b/.makefile @@ -338,7 +338,7 @@ RACKET_FOR_BOOTFILES = $(RACKET) RACKET_FOR_BUILD = $(RACKET) # This branch name changes each time the pb boot files are updated: -PB_BRANCH == circa-7.9.0.15-1 +PB_BRANCH == circa-7.9.0.22-1 PB_REPO = https://github.com/racket/pb # Alternative source for Chez Scheme boot files, normally set by diff --git a/Makefile b/Makefile index 12989afd16..7e98eb8f74 100644 --- a/Makefile +++ b/Makefile @@ -47,7 +47,7 @@ RACKETCS_SUFFIX = RACKET = RACKET_FOR_BOOTFILES = $(RACKET) RACKET_FOR_BUILD = $(RACKET) -PB_BRANCH = circa-7.9.0.15-1 +PB_BRANCH = circa-7.9.0.22-1 PB_REPO = https://github.com/racket/pb EXTRA_REPOS_BASE = CS_CROSS_SUFFIX = @@ -307,18 +307,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-7.9.0.15-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.15-1:remotes/origin/circa-7.9.0.15-1 ; fi - cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.15-1 + if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.22-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.22-1:remotes/origin/circa-7.9.0.22-1 ; fi + cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.22-1 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-7.9.0.15-1 - cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.15-1 + cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.22-1 + cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.22-1 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-7.9.0.15-1 + cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.22-1 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 472755c2aa..35286e7f0f 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 "7.9.0.21") +(define version "7.9.0.22") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/racket/src/ChezScheme/c/alloc.c b/racket/src/ChezScheme/c/alloc.c index f068c02331..cbeac73d54 100644 --- a/racket/src/ChezScheme/c/alloc.c +++ b/racket/src/ChezScheme/c/alloc.c @@ -783,7 +783,7 @@ ptr Srecord_type(ptr r) { } ptr Srecord_type_parent(ptr rtd) { - return RECORDDESCPARENT(rtd); + return rtd_parent(rtd); } uptr Srecord_type_size(ptr rtd) { diff --git a/racket/src/ChezScheme/c/fasl.c b/racket/src/ChezScheme/c/fasl.c index 4449916602..25bc6a3802 100644 --- a/racket/src/ChezScheme/c/fasl.c +++ b/racket/src/ChezScheme/c/fasl.c @@ -1341,7 +1341,7 @@ static IBOOL rtd_equiv(x, y) ptr x, y; { /* recognize `base-rtd` shape: */ || ((RECORDINSTTYPE(x) == x) && (RECORDINSTTYPE(y) == y))) && - RECORDDESCPARENT(x) == RECORDDESCPARENT(y) && + rtd_parent(x) == rtd_parent(y) && equalp(RECORDDESCPM(x), RECORDDESCPM(y)) && equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) && equalp(RECORDDESCFLDS(x), RECORDDESCFLDS(y)) && diff --git a/racket/src/ChezScheme/c/types.h b/racket/src/ChezScheme/c/types.h index 499b6b9e0c..fdb19f88d3 100644 --- a/racket/src/ChezScheme/c/types.h +++ b/racket/src/ChezScheme/c/types.h @@ -279,6 +279,8 @@ 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) + /* type tagging macros */ #define TYPE(x,type) ((ptr)((iptr)(x) - typemod + (type))) diff --git a/racket/src/ChezScheme/c/vfasl.c b/racket/src/ChezScheme/c/vfasl.c index f361355d69..61de95cb9b 100644 --- a/racket/src/ChezScheme/c/vfasl.c +++ b/racket/src/ChezScheme/c/vfasl.c @@ -370,12 +370,13 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) if (!Ssymbolp(RECORDDESCUID(meta_rtd))) RECORDINSTTYPE(rtd) = RECORDDESCUID(meta_rtd); - /* fixup parent before continuing, relying on parents being earlier in `rtd`s */ - parent_rtd = RECORDDESCPARENT(rtd); + /* fixup parent before continuing, relying on parents being earlier in `rtd`s; + we let the rest of the ancestor vector get fixed up later */ + parent_rtd = rtd_parent(rtd); if (parent_rtd != Sfalse) { ptr parent_uid = RECORDDESCUID(parent_rtd); if (!Ssymbolp(parent_uid)) - RECORDDESCPARENT(rtd) = parent_uid; + rtd_parent(rtd) = parent_uid; } new_rtd = rtd; @@ -561,7 +562,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets } break; } - tf = RECORDDESCPARENT(tf); + tf = rtd_parent(tf); if (tf == Sfalse) break; } diff --git a/racket/src/ChezScheme/makefiles/Mf-install.in b/racket/src/ChezScheme/makefiles/Mf-install.in index 95ea1cc64d..05b968eb9c 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.3.57 +Version=csv9.5.3.58 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/racket/src/ChezScheme/rktboot/r6rs-lang.rkt b/racket/src/ChezScheme/rktboot/r6rs-lang.rkt index 050c15b2df..55161fb732 100644 --- a/racket/src/ChezScheme/rktboot/r6rs-lang.rkt +++ b/racket/src/ChezScheme/rktboot/r6rs-lang.rkt @@ -17,6 +17,7 @@ do-$make-record-type register-rtd-name! register-rtd-fields! + register-rtd-ancestors! s:struct-type? record-predicate record-accessor @@ -563,6 +564,7 @@ (install-protocol! struct:name name-protocol) (register-rtd-name! struct:name 'name) (register-rtd-fields! struct:name 'fields-vec) + (register-rtd-ancestors! struct:name super) (define make-name (name-protocol maker)) (define . getter) ... (define . setter) ...))))]))] diff --git a/racket/src/ChezScheme/rktboot/record.rkt b/racket/src/ChezScheme/rktboot/record.rkt index b06fa1b5bf..d035382d80 100644 --- a/racket/src/ChezScheme/rktboot/record.rkt +++ b/racket/src/ChezScheme/rktboot/record.rkt @@ -11,6 +11,7 @@ (provide do-$make-record-type register-rtd-name! register-rtd-fields! + register-rtd-ancestors! s:struct-type? $make-record-type @@ -43,6 +44,22 @@ record-writer $object-ref) +;; Let there be records: this declaration is the root origin of +;; #!base-rtd. From this description, #!base-rtd gets fasled in a boot +;; file and loaded to define #!base-rtd on startup. The field offsets +;; below don't matter, since they're fixed up for the target plaform. +(define base-rtd-fields + (map vector-copy + '(#(fld ancestors #f scheme-object 9) + #(fld size #f scheme-object 17) + #(fld pm #f scheme-object 25) + #(fld mpm #f scheme-object 33) + #(fld name #f scheme-object 41) + #(fld flds #f scheme-object 49) + #(fld flags #f scheme-object 57) + #(fld uid #f scheme-object 65) + #(fld counts #f scheme-object 73)))) + (define (s:struct-type? v) (or (struct-type? v) (base-rtd? v))) @@ -83,6 +100,7 @@ (hash-set! rtd-extensions struct:name (apply (struct-type-make-constructor in-base-rtd) more))) (register-rtd-name! struct:name name) (register-rtd-fields! struct:name fields) + (register-rtd-ancestors! struct:name super) (when sealed? (hash-set! rtd-sealed?s struct:name #t)) (when (or opaque? (and super (hash-ref rtd-opaque?s super #f))) @@ -117,6 +135,20 @@ (define (register-rtd-name! struct:name name) (hash-set! rtd-names struct:name name)) +(define rtd-ancestors (make-weak-hasheq)) + +(define (register-rtd-ancestors! struct:name parent) + (unless (hash-ref rtd-ancestors struct:name #f) + (cond + [(not parent) + (hash-set! rtd-ancestors struct:name (vector #f))] + [(eq? parent struct:base-rtd-subtype) + (hash-set! rtd-ancestors struct:name (vector base-rtd #f))] + [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) + (hash-set! rtd-ancestors struct:name vec)]))) (define rtd-fields (make-weak-hasheq)) @@ -244,18 +276,6 @@ (struct-type-info rtd)) (make-struct-field-mutator set i)))) -(define base-rtd-fields - (map vector-copy - '(#(fld parent #f scheme-object 9) - #(fld size #f scheme-object 17) - #(fld pm #f scheme-object 25) - #(fld mpm #f scheme-object 33) - #(fld name #f scheme-object 41) - #(fld flds #f scheme-object 49) - #(fld flags #f scheme-object 57) - #(fld uid #f scheme-object 65) - #(fld counts #f scheme-object 73)))) - ;; If `sym/i` is an integer, it *does* count parent fields (define (csv7:record-field-accessor/mutator rtd sym/i mut?) (define (lookup-field-by-name rtd sym) @@ -320,17 +340,22 @@ (if (base-rtd? rtd) null (hash-ref rtd-fields rtd)))))] - [(parent) + [(ancestors) (assert-accessor) (lambda (rtd) (cond - [(base-rtd? rtd) #f] + [(base-rtd? rtd) '#(#f)] [else + (define vec (hash-ref rtd-ancestors rtd)) (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?) (struct-type-info rtd)) - (if (eq? super struct:base-rtd-subtype) - base-rtd - super)]))] + (define parent + (if (eq? super struct:base-rtd-subtype) + base-rtd + super)) + (unless (eq? parent (vector-ref vec 0)) + (error "ancestry sanity check failed" rtd vec parent)) + vec]))] [(size) (assert-accessor) (lambda (rtd) diff --git a/racket/src/ChezScheme/s/arm64.ss b/racket/src/ChezScheme/s/arm64.ss index a0eca90e17..2c7c0ca3ed 100644 --- a/racket/src/ChezScheme/s/arm64.ss +++ b/racket/src/ChezScheme/s/arm64.ss @@ -127,7 +127,7 @@ [(and (not (eq? x1 %zero)) (unsigned12? (- imm))) (let ([u (make-tmp 'u)]) (seq - (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x1 (immediate ,imm))) + (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x1 (immediate ,(- imm)))) (return x0 u 0 type)))] [else (let ([u (make-tmp 'u)]) @@ -661,6 +661,10 @@ ;; NB: use sqrt or something like that? [(op) '()]) + (define-instruction effect (debug) + [(op) + `(asm ,info ,asm-debug)]) + (define-instruction effect (c-call) [(op (x ur)) (let ([ulr (make-precolored-unspillable 'ulr %lr)]) @@ -705,6 +709,7 @@ asm-fpop-2 asm-fpsqrt asm-c-simple-call asm-return asm-c-return asm-size asm-enter asm-foreign-call asm-foreign-callable + asm-debug asm-read-counter asm-inc-cc-counter signed9? unsigned12? aligned-offset? funkymask shifted16 @@ -938,6 +943,8 @@ (define-op mrs mrs-op) + (define-op und und-op) + (define-op fadd f-arith-op #b0010) ; selector is at bit 12 (define-op fsub f-arith-op #b0011) (define-op fmul f-arith-op #b0000) @@ -1396,6 +1403,11 @@ [5 op2] [0 (ax-ea-reg-code dest)]))) + (define und-op + (lambda (op code*) + (emit-code (op code*) + [0 0]))) + ;; asm helpers (define-who ax-cond @@ -2053,6 +2065,10 @@ [else (loop (cddr regs) (two sp (cons 'reg (car regs)) (cons 'reg (cadr regs)) code*))])))) + (define asm-debug + (lambda (code*) + (emit und code*))) + (define asm-read-counter (lambda (op0 op1 crn crm op2) (lambda (code* dest) diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index 3e89a8f94d..edf9db2ba0 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 #x09050339) +(define-constant scheme-version #x0905033A) (define-syntax define-machine-types (lambda (x) @@ -1626,7 +1626,7 @@ (define-primitive-structure-disps record-type type-typed-object ([ptr type] - [ptr parent] + [ptr ancestry] ; vector: parent at 0, grandparent at 1, etc. [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 diff --git a/racket/src/ChezScheme/s/cp0.ss b/racket/src/ChezScheme/s/cp0.ss index ed66a6bbf9..ad4548e885 100644 --- a/racket/src/ChezScheme/s/cp0.ss +++ b/racket/src/ChezScheme/s/cp0.ss @@ -119,7 +119,8 @@ ; 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-flds (csv7:record-field-accessor #!base-rtd 'flds)) - (define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent)) + (define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) + (define rtd-parent (lambda (x) (vector-ref (rtd-ancestors x) 0))) (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)) diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index 6884ffc9c1..11a7b482c9 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -217,6 +217,8 @@ (annotation-expression x) x))) + (define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) + (let () (import (nanopass) np-languages) @@ -11099,23 +11101,42 @@ ,e-rtd)))))) (define build-unsealed-isa? (lambda (e e-rtd) - (let ([t (make-assigned-tmp 't)] [Ltop (make-local-label 'Ltop)]) - (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 + (let ([t (make-tmp 't)] [a (make-tmp 'a)] [d (make-tmp 'd)]) + (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) - `(label ,Ltop - (seq - (set! ,t ,(%mref ,t ,(constant record-type-parent-disp))) - ,(build-simple-or - (%inline eq? ,t ,e-rtd) - `(if ,(%inline eq? ,t ,(%constant sfalse)) - ,(%constant sfalse) - (goto ,Ltop))))))))))))) + `(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))) + (cond + [known-depth + `(let ([,d ,(%mref ,a ,(constant vector-type-disp))]) + ,(build-and + (%inline < (immediate ,(fxsll known-depth (constant vector-length-offset))) ,d) + (%inline eq? ,e-rtd ,(%mref ,a + ,(translate d (constant vector-length-offset) (constant log2-ptr-bytes)) + ,(fx- (constant vector-data-disp) (fx* (fx+ known-depth 1) + (constant ptr-bytes)))))))] + [else + `(let ([,d ,(%inline - ,(%mref ,a ,(constant vector-type-disp)) + ,(%mref ,(%mref ,e-rtd ,(constant record-type-ancestry-disp)) + ,(constant vector-type-disp)))]) + ,(build-and + (%inline > ,d (immediate 0)) + (%inline eq? ,e-rtd ,(%mref ,a + ,(translate d (constant vector-length-offset) (constant log2-ptr-bytes)) + ,(fx- (constant vector-data-disp) (constant ptr-bytes))))))])))))))))))) (define-inline 3 record? [(e) (build-record? e)] [(e e-rtd) diff --git a/racket/src/ChezScheme/s/fasl.ss b/racket/src/ChezScheme/s/fasl.ss index b5c45b831c..b56b6d0222 100644 --- a/racket/src/ChezScheme/s/fasl.ss +++ b/racket/src/ChezScheme/s/fasl.ss @@ -38,7 +38,7 @@ ; file for cross compilation, because the offsets may be incorrect (define rtd-size (csv7:record-field-accessor #!base-rtd 'size)) (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) -(define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent)) +(define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) (define rtd-name (csv7:record-field-accessor #!base-rtd 'name)) (define rtd-uid (csv7:record-field-accessor #!base-rtd 'uid)) (define rtd-flags (csv7:record-field-accessor #!base-rtd 'flags)) diff --git a/racket/src/ChezScheme/s/mkheader.ss b/racket/src/ChezScheme/s/mkheader.ss index 8563bbf061..6c5ca768b2 100644 --- a/racket/src/ChezScheme/s/mkheader.ss +++ b/racket/src/ChezScheme/s/mkheader.ss @@ -1099,7 +1099,7 @@ (defref RTDCOUNTSTIMESTAMP rtd-counts timestamp) (defref RTDCOUNTSIT rtd-counts data) - (defref RECORDDESCPARENT record-type parent) + (defref RECORDDESCANCESTRY record-type ancestry) (defref RECORDDESCSIZE record-type size) (defref RECORDDESCPM record-type pm) (defref RECORDDESCMPM record-type mpm) diff --git a/racket/src/ChezScheme/s/np-languages.ss b/racket/src/ChezScheme/s/np-languages.ss index 3ce3a8bb68..1315d61cb8 100644 --- a/racket/src/ChezScheme/s/np-languages.ss +++ b/racket/src/ChezScheme/s/np-languages.ss @@ -537,6 +537,7 @@ (declare-primitive c-simple-return effect #f) (declare-primitive check-stack-align effect #f) ; x86 (declare-primitive deactivate-thread effect #f) ; threaded version only + (declare-primitive debug effect #f) ; x86_64 and arm64 (declare-primitive fldl effect #f) ; x86 (declare-primitive flds effect #f) ; x86 (declare-primitive inc-cc-counter effect #f) diff --git a/racket/src/ChezScheme/s/record.ss b/racket/src/ChezScheme/s/record.ss index 482ba4c11a..53bb7f2a39 100644 --- a/racket/src/ChezScheme/s/record.ss +++ b/racket/src/ChezScheme/s/record.ss @@ -25,7 +25,8 @@ ;;; include size of tag in record size OR don't include tag in record offsets (let () - (define (rtd-parent x) ($object-ref 'scheme-object x (constant record-type-parent-disp))) + (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-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))) @@ -618,10 +619,16 @@ (unless (eq? (rtd-size rtd) size) (squawk "different size"))) rtd)] [else - (let ([rtd (apply #%$record base-rtd parent size pm mpm name - (if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f extras)]) - (with-tc-mutex ($sputprop uid '*rtd* rtd)) - rtd)])))) + (let* ([len (if (not parent) 0 (vector-length (rtd-ancestry parent)))] + [ancestry (make-vector (fx+ 1 len) parent)]) + (let loop ([i 0]) + (unless (fx= i len) + (vector-set! ancestry (fx+ i 1) (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)]) + (with-tc-mutex ($sputprop uid '*rtd* rtd)) + rtd))])))) (set-who! $remake-rtd (lambda (rtd compute-field-offsets) @@ -629,7 +636,7 @@ (assert (not (eq? key (machine-type)))) (or ($sgetprop uid key #f) (let ([base-rtd ($record-type-descriptor rtd)] - [parent (rtd-parent rtd)] + [ancestry (rtd-ancestry rtd)] [name (rtd-name rtd)] [flags (rtd-flags rtd)] [flds (rtd-flds rtd)]) @@ -642,7 +649,7 @@ (compute-field-offsets who (constant record-type-disp) (cons `(immutable scheme-object ,uid) fields))))]) - (let ([rtd (apply #%$record base-rtd parent size pm mpm name + (let ([rtd (apply #%$record base-rtd ancestry size pm mpm name (if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f (let* ([n (length (rtd-flds ($record-type-descriptor base-rtd)))] [ls (list-tail (rtd-flds base-rtd) n)]) diff --git a/racket/src/ChezScheme/s/x86_64.ss b/racket/src/ChezScheme/s/x86_64.ss index 17d517ef0c..50146cc507 100644 --- a/racket/src/ChezScheme/s/x86_64.ss +++ b/racket/src/ChezScheme/s/x86_64.ss @@ -791,6 +791,9 @@ (define-instruction effect (pause) [(op) `(asm ,info ,asm-pause)]) + (define-instruction effect (debug) + [(op) `(asm ,info ,asm-debug)]) + (define-instruction value read-performance-monitoring-counter [(op (z ur) (x ur mem imm)) (safe-assert (eq? z %rax)) @@ -848,7 +851,7 @@ asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-lea1 asm-lea2 asm-indirect-call asm-condition-code asm-fl-cvt asm-store-single asm-load-single asm-fpt asm-fptrunc asm-div asm-popcount - asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg + asm-exchange asm-pause asm-debug asm-locked-incr asm-locked-decr asm-locked-cmpxchg asm-fpsqrt asm-fpop-2 asm-fpmove asm-fpcast asm-fpsingle asm-c-simple-call asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size @@ -983,6 +986,8 @@ (define-op rdpmc two-byte-op #b1111 #b00110011) ; read performance monitoring counter (define-op pause two-byte-op #b11110011 #b10010000) ; equivalent to rep nop + (define-op int3 byte-op #b11001100) + (define-op dec (#;b *) unary-op #b1111111 #b001) (define-op inc (#;b *) unary-op #b1111111 #b000) (define-op neg (b *) unary-op #b1111011 #b011) ; was commented out in x86_64macros @@ -2031,6 +2036,10 @@ (lambda (code*) (emit pause code*))) + (define asm-debug + (lambda (code*) + (emit int3 code*))) + (define asm-exchange (lambda (code* dest src0 src1) (Trivit (dest src1) diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index cc149f51c6..d9b6f62a47 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 9 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 21 +#define MZSCHEME_VERSION_W 22 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x