diff --git a/.makefile b/.makefile index 40098c79e8..6c40311293 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.22-1 +PB_BRANCH == circa-7.9.0.22-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 7e98eb8f74..a08b30310a 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.22-1 +PB_BRANCH = circa-7.9.0.22-2 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.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 + if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.22-2 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.22-2:remotes/origin/circa-7.9.0.22-2 ; fi + cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.22-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-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 branch circa-7.9.0.22-2 + cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.22-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-7.9.0.22-1 + cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.22-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/racket/src/ChezScheme/c/pb.c b/racket/src/ChezScheme/c/pb.c index f023c65424..b522b80ffa 100644 --- a/racket/src/ChezScheme/c/pb.c +++ b/racket/src/ChezScheme/c/pb.c @@ -401,6 +401,20 @@ void S_pb_interp(ptr tc, void *bytecode) { flag = (r == 0); } break; + case pb_bin_op_pb_signal_pb_subp_pb_register: + { + iptr r = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)]; + regs[INSTR_drr_dest(instr)] = r; + flag = (r > 0); + } + break; + case pb_bin_op_pb_signal_pb_subp_pb_immediate: + { + iptr r = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr); + regs[INSTR_dri_dest(instr)] = r; + flag = (r > 0); + } + break; case pb_cmp_op_pb_eq_pb_register: flag = regs[INSTR_dr_dest(instr)] == regs[INSTR_dr_reg(instr)]; break; diff --git a/racket/src/ChezScheme/s/arm32.ss b/racket/src/ChezScheme/s/arm32.ss index bc89fd2e47..fc719ac739 100644 --- a/racket/src/ChezScheme/s/arm32.ss +++ b/racket/src/ChezScheme/s/arm32.ss @@ -354,27 +354,27 @@ ; WARNING: do not assume that if x isn't the same as z then x is independent ; of z, since x might be an mref with z as it's base or index - (define-instruction value (- -/ovfl -/eq) + (define-instruction value (- -/ovfl -/eq -/pos) [(op (z ur) (x ur) (y funky12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))] [(op (z ur) (x funky12) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-rsb (memq op '(-/ovfl -/eq))) ,y ,x))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-rsb (not (eq? op '-))) ,y ,x))] [(op (z ur) (x ur) (y negate-funky12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(-/ovfl -/eq))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '-))) ,x ,y))] [(op (z ur) (x ur) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))]) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))]) (define-instruction value (+ +/ovfl +/carry) [(op (z ur) (x ur) (y funky12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))] [(op (z ur) (x funky12) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,y ,x))] [(op (z ur) (x ur) (y negate-funky12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '+))) ,x ,y))] [(op (z ur) (x negate-funky12) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,y ,x))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '+))) ,y ,x))] [(op (z ur) (x ur) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))]) (define-instruction value (*) ; no imm form available @@ -2295,6 +2295,7 @@ [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow) (i? bvc bvs)] [(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if oveflow + [(positive) (i? ble bgt)] [(carry) (i? bcc bcs)] [(fp<) (i? (r? ble bcs) (r? bgt bcc))] [(fp<=) (i? (r? blt bhi) (r? bge bls))] diff --git a/racket/src/ChezScheme/s/arm64.ss b/racket/src/ChezScheme/s/arm64.ss index 2c7c0ca3ed..831df49e53 100644 --- a/racket/src/ChezScheme/s/arm64.ss +++ b/racket/src/ChezScheme/s/arm64.ss @@ -236,23 +236,23 @@ ; WARNING: do not assume that if x isn't the same as z then x is independent ; of z, since x might be an mref with z as it's base or index - (define-instruction value (- -/ovfl -/eq) + (define-instruction value (- -/ovfl -/eq -/pos) [(op (z ur) (x ur) (y unsigned12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))] [(op (z ur) (x ur) (y neg-unsigned12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(-/ovfl -/eq))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '-))) ,x ,y))] [(op (z ur) (x ur) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))]) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))]) (define-instruction value (+ +/ovfl +/carry) [(op (z ur) (x ur) (y unsigned12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))] [(op (z ur) (x ur) (y neg-unsigned12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '+))) ,x ,y))] [(op (z ur) (x unsigned12) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,y ,x))] [(op (z ur) (x ur) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))]) (define-instruction value (*) ; no imm form available @@ -2280,6 +2280,7 @@ [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow) (i? bvc bvs)] + [(positive) (i? ble bgt)] [(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if oveflow [(carry) (i? bcc bcs)] [(fp<) (i? (r? ble bcs) (r? bgt bcc))] diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index edf9db2ba0..7337af659f 100644 --- a/racket/src/ChezScheme/s/cmacros.ss +++ b/racket/src/ChezScheme/s/cmacros.ss @@ -3215,6 +3215,7 @@ pb-mul pb-div pb-subz + pb-subp pb-and pb-ior pb-xor diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index 11a7b482c9..cd7af1f5d7 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -11101,7 +11101,7 @@ ,e-rtd)))))) (define build-unsealed-isa? (lambda (e e-rtd) - (let ([t (make-tmp 't)] [a (make-tmp 'a)] [d (make-tmp 'd)]) + (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)))] @@ -11119,24 +11119,16 @@ ;; 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))))))])))))))))))) + (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)))))))))))))) (define-inline 3 record? [(e) (build-record? e)] [(e e-rtd) diff --git a/racket/src/ChezScheme/s/np-languages.ss b/racket/src/ChezScheme/s/np-languages.ss index 1315d61cb8..eab5f30c35 100644 --- a/racket/src/ChezScheme/s/np-languages.ss +++ b/racket/src/ChezScheme/s/np-languages.ss @@ -591,6 +591,7 @@ (declare-primitive +/carry value #f) (declare-primitive -/ovfl value #f) (declare-primitive -/eq value #f) + (declare-primitive -/pos value #f) (declare-primitive asmlibcall value #f) (declare-primitive cpuid value #t) ; x86_64 only, actually side-effects ebx/ecx/edx (declare-primitive fstpl value #f) ; x86 only diff --git a/racket/src/ChezScheme/s/pb.ss b/racket/src/ChezScheme/s/pb.ss index 19c8a9a3a4..77ca1fc022 100644 --- a/racket/src/ChezScheme/s/pb.ss +++ b/racket/src/ChezScheme/s/pb.ss @@ -214,7 +214,7 @@ ; WARNING: do not assume that if x isn't the same as z then x is independent ; of z, since x might be an mref with z as it's base or index - (define-instruction value (- -/ovfl -/eq) + (define-instruction value (- -/ovfl -/eq -/pos) [(op (z ur) (x ur) (y signed16)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub op) ,x ,y))] [(op (z ur) (x ur) (y ur)) @@ -623,6 +623,7 @@ (define-op div bin-op (constant pb-div)) (define-op subz signal-bin-op (constant pb-subz)) ; signals on 0 instead of overflow + (define-op subp signal-bin-op (constant pb-subp)) ; signals on positive (define-op land bin-op (constant pb-and)) (define-op lior bin-op (constant pb-ior)) @@ -1110,9 +1111,13 @@ (lambda (op) (lambda (code* dest src0 src1) (Trivit (dest src0 src1) - (if (eq? op '-/eq) - (emit subz #t dest src0 src1 code*) - (emit sub (eq? op '-/ovfl) dest src0 src1 code*)))))) + (cond + [(eq? op '-/eq) + (emit subz #t dest src0 src1 code*)] + [(eq? op '-/pos) + (emit subp #t dest src0 src1 code*)] + [else + (emit sub (eq? op '-/ovfl) dest src0 src1 code*)]))))) (define asm-mul (lambda (set-cc?) @@ -1624,5 +1629,6 @@ (define-who asm-foreign-callable (lambda (info) - (sorry! who "callables are not supported")))) + (sorry! who "callables are not supported") + (values 'c-init 'c-args 'c-result 'c-return)))) ) diff --git a/racket/src/ChezScheme/s/ppc32.ss b/racket/src/ChezScheme/s/ppc32.ss index cf9bbae6f9..82bf687983 100644 --- a/racket/src/ChezScheme/s/ppc32.ss +++ b/racket/src/ChezScheme/s/ppc32.ss @@ -296,7 +296,7 @@ [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-sub-from/ovfl ,y ,x))]) - (define-instruction value (-/eq) + (define-instruction value (-/eq -/pos) [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-sub-from/eq ,y ,x))]) @@ -1994,7 +1994,8 @@ [(fp<= <=) (i? (r? blt bgt) (r? bge ble))] [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] - [(carry multiply-overflow overflow) (i? bns bso)]) + [(carry multiply-overflow overflow) (i? bns bso)] + [(positive) (i? ble bgt)]) (let ([type (info-condition-code-type info)] [reversed? (info-condition-code-reversed? info)]) (make-cgchunk info l1 l2 next-addr diff --git a/racket/src/ChezScheme/s/x86.ss b/racket/src/ChezScheme/s/x86.ss index 774713cd37..3ddea50662 100644 --- a/racket/src/ChezScheme/s/x86.ss +++ b/racket/src/ChezScheme/s/x86.ss @@ -261,7 +261,7 @@ `(set! ,(make-live-info) ,t (asm ,info ,asm-sub ,t ,y)) `(set! ,(make-live-info) ,z ,t)))]) - (define-instruction value (-/ovfl -/eq) ; must set condition codes, so can't use lea or sub-negate + (define-instruction value (-/ovfl -/eq -/pos) ; must set condition codes, so can't use lea or sub-negate [(op (z mem) (x z) (y ur imm32)) `(set! ,(make-live-info) ,z (asm ,info ,asm-sub ,x ,y))] [(op (z mem) (x zero) (y z)) @@ -2157,6 +2157,7 @@ [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow multiply-overflow) (i? bvc bvs)] + [(positive) (i? ble bgt)] [(carry) (i? bcc bcs)] ; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100 ; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1 diff --git a/racket/src/ChezScheme/s/x86_64.ss b/racket/src/ChezScheme/s/x86_64.ss index 50146cc507..1ea01fac1f 100644 --- a/racket/src/ChezScheme/s/x86_64.ss +++ b/racket/src/ChezScheme/s/x86_64.ss @@ -323,7 +323,7 @@ `(set! ,(make-live-info) ,t (asm ,info ,asm-sub ,t ,y)) `(set! ,(make-live-info) ,z ,t)))]) - (define-instruction value (-/ovfl -/eq) ; must set condition codes, so can't use lea or sub-negate + (define-instruction value (-/ovfl -/eq -/pos) ; must set condition codes, so can't use lea or sub-negate [(op (z mem) (x z) (y ur imm32)) `(set! ,(make-live-info) ,z (asm ,info ,asm-sub ,x ,y))] [(op (z mem) (x zero) (y z)) @@ -2383,6 +2383,7 @@ [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow multiply-overflow) (i? bvc bvs)] + [(positive) (i? ble bgt)] [(carry) (i? bcc bcs)] ; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100 ; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1