Chez Scheme: save an instruction on record predicates
Combine separate subtraction and comparison instructions into one in the case of non-sealed record types.
This commit is contained in:
Matthew Flatt
parent
30eb35b99c
commit
f299c4304d
|
|
@ -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
|
||||
|
|
|
|||
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.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)"
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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))]
|
||||
|
|
|
|||
|
|
@ -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))]
|
||||
|
|
|
|||
|
|
@ -3215,6 +3215,7 @@
|
|||
pb-mul
|
||||
pb-div
|
||||
pb-subz
|
||||
pb-subp
|
||||
pb-and
|
||||
pb-ior
|
||||
pb-xor
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(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) (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))))))]))))))))))))
|
||||
,(fx- (constant vector-data-disp) (constant ptr-bytes))))
|
||||
,(%constant sfalse))))))))))))))
|
||||
(define-inline 3 record?
|
||||
[(e) (build-record? e)]
|
||||
[(e e-rtd)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user