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.
This commit is contained in:
Matthew Flatt
parent
a8819af26a
commit
e604c2deb9
|
|
@ -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
|
||||
|
|
|
|||
12
Makefile
12
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)"
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
|
|
|||
|
|
@ -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) {
|
||||
|
|
|
|||
|
|
@ -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)) &&
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) ...))))]))]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user