add fx{+,-,*,lshift}/wraparound
Expose machine-level operations that stay within the fixnum range, which can be useful for things like hash-code computations where it's ok to just lose bits. Operations like `unsafe-fx+` turn out to do that already in the current implementation, but with no guarantee (and with no checking of arguments). For Racket BC, before this commit, JIT-inlined `fxlshift` incorrectly handled a negative second argument like `arithmetic-shift` instead of erroring.
This commit is contained in:
Matthew Flatt
parent
bec35108b4
commit
128892c996
|
|
@ -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.5-1
|
||||
PB_BRANCH == circa-7.9.0.6-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.5-1
|
||||
PB_BRANCH = circa-7.9.0.6-1
|
||||
PB_REPO = https://github.com/racket/pb
|
||||
EXTRA_REPOS_BASE =
|
||||
CS_CROSS_SUFFIX =
|
||||
|
|
@ -306,14 +306,14 @@ 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.5-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.5-1:remotes/origin/circa-7.9.0.5-1 ; fi
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.5-1
|
||||
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.6-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.6-1:remotes/origin/circa-7.9.0.6-1 ; fi
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.6-1
|
||||
pb-stage:
|
||||
cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.5-1
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.5-1
|
||||
cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.6-1
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.6-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.5-1
|
||||
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.6-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.5")
|
||||
(define version "7.9.0.6")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -68,9 +68,16 @@ result would not be a fixnum.
|
|||
@defproc[(fxrshift [a fixnum?] [b fixnum?]) fixnum?]
|
||||
)]{
|
||||
|
||||
Safe versions of @racket[unsafe-fxand], @racket[unsafe-fxior],
|
||||
@racket[unsafe-fxxor], @racket[unsafe-fxnot],
|
||||
@racket[unsafe-fxlshift], and @racket[unsafe-fxrshift]. The
|
||||
Like @racket[bitwise-and], @racket[bitwise-ior],
|
||||
@racket[bitwise-xor], @racket[bitwise-not], and
|
||||
@racket[arithmetic-shift], but constrained to consume @tech{fixnums};
|
||||
the result is always a @tech{fixnum}. The @racket[unsafe-fxlshift] and
|
||||
@racket[unsafe-fxrshift] operations correspond to
|
||||
@racket[arithmetic-shift], but require non-negative arguments;
|
||||
@racket[unsafe-fxlshift] is a positive (i.e., left) shift, and
|
||||
@racket[unsafe-fxrshift] is a negative (i.e., right) shift, where the
|
||||
number of bits to shift must be no more than the number of bits used to
|
||||
represent a @tech{fixnum}. The
|
||||
@exnraise[exn:fail:contract:non-fixnum-result] if the arithmetic
|
||||
result would not be a fixnum.
|
||||
|
||||
|
|
@ -78,6 +85,25 @@ result would not be a fixnum.
|
|||
and @racket[fxxor].}]}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(fx+/wraparound [a fixnum?] [b fixnum?]) fixnum?]
|
||||
@defproc[(fx-/wraparound [a fixnum?] [b fixnum?]) fixnum?]
|
||||
@defproc[(fx*/wraparound [a fixnum?] [b fixnum?]) fixnum?]
|
||||
@defproc[(fxlshift/wraparound [a fixnum?] [b fixnum?]) fixnum?]
|
||||
)]{
|
||||
|
||||
Like @racket[fx+], @racket[fx-], @racket[fx*], and @racket[fxlshift],
|
||||
but a fixnum result is produced for any allowed arguments (i.e., for
|
||||
any fixnum argument, except that the second
|
||||
@racket[fxlshift/wraparound] argument must be between 0 and the number
|
||||
of bits in a fixnum, inclusive). The result is produced by simply discarding bits
|
||||
that do not fit in a fixnum representation. The result is negative if
|
||||
the highest of the retained bits is set---even, for example, if the
|
||||
value was produced by adding two positive fixnums.
|
||||
|
||||
@history[#:added "7.9.0.6"]}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(fx= [a fixnum?] [b fixnum?] ...) boolean?]
|
||||
@defproc[(fx< [a fixnum?] [b fixnum?] ...) boolean?]
|
||||
|
|
@ -88,9 +114,9 @@ result would not be a fixnum.
|
|||
@defproc[(fxmax [a fixnum?] [b fixnum?] ...) fixnum?]
|
||||
)]{
|
||||
|
||||
Safe versions of @racket[unsafe-fx=], @racket[unsafe-fx<],
|
||||
@racket[unsafe-fx>], @racket[unsafe-fx<=], @racket[unsafe-fx>=],
|
||||
@racket[unsafe-fxmin], and @racket[unsafe-fxmax].
|
||||
Like @racket[=], @racket[<], @racket[>],
|
||||
@racket[<=], @racket[>=], @racket[min], and @racket[max], but
|
||||
constrained to consume @tech{fixnums}.
|
||||
|
||||
@history/arity[]}
|
||||
|
||||
|
|
|
|||
|
|
@ -51,13 +51,10 @@ operations can be prevented by adjusting the code inspector (see
|
|||
@defproc[(unsafe-fxabs [a fixnum?]) fixnum?]
|
||||
)]{
|
||||
|
||||
For @tech{fixnums}: Like @racket[+], @racket[-], @racket[*],
|
||||
@racket[quotient], @racket[remainder], @racket[modulo], and
|
||||
@racket[abs], but constrained to consume @tech{fixnums} and produce a
|
||||
@tech{fixnum} result. The mathematical operation on @racket[a] and
|
||||
@racket[b] must be representable as a @tech{fixnum}. In the case of
|
||||
@racket[unsafe-fxquotient], @racket[unsafe-fxremainder], and
|
||||
@racket[unsafe-fxmodulo], @racket[b] must not be @racket[0].
|
||||
For @tech{fixnums}: Unchecked versions of @racket[fx+], @racket[fx-],
|
||||
@racket[fx*], @racket[fxquotient],
|
||||
@racket[fxremainder], @racket[fxmodulo], and
|
||||
@racket[fxabs].
|
||||
|
||||
@history[#:changed "7.0.0.13" @elem{Allow zero or more arguments for @racket[unsafe-fx+] and @racket[unsafe-fx*]
|
||||
and allow one or more arguments for @racket[unsafe-fx-].}]}
|
||||
|
|
@ -72,24 +69,28 @@ For @tech{fixnums}: Like @racket[+], @racket[-], @racket[*],
|
|||
@defproc[(unsafe-fxrshift [a fixnum?] [b fixnum?]) fixnum?]
|
||||
)]{
|
||||
|
||||
For @tech{fixnums}: Like @racket[bitwise-and], @racket[bitwise-ior],
|
||||
@racket[bitwise-xor], @racket[bitwise-not], and
|
||||
@racket[arithmetic-shift], but constrained to consume @tech{fixnums};
|
||||
the result is always a @tech{fixnum}. The @racket[unsafe-fxlshift] and
|
||||
@racket[unsafe-fxrshift] operations correspond to
|
||||
@racket[arithmetic-shift], but require non-negative arguments;
|
||||
@racket[unsafe-fxlshift] is a positive (i.e., left) shift, and
|
||||
@racket[unsafe-fxrshift] is a negative (i.e., right) shift, where the
|
||||
number of bits to shift must be no more than the number of bits used to
|
||||
represent a @tech{fixnum}. In the case of @racket[unsafe-fxlshift],
|
||||
bits in the result beyond the number of bits used to represent a
|
||||
@tech{fixnum} are effectively replaced with a copy of the high bit.
|
||||
For @tech{fixnums}: Unchecked versions of @racket[fxand], @racket[fxior], @racket[fxxor],
|
||||
@racket[fxnot], @racket[fxlshift], and @racket[fxrshift].
|
||||
|
||||
@history[#:changed "7.0.0.13" @elem{Allow zero or more arguments for
|
||||
@racket[unsafe-fxand], @racket[unsafe-fxior],
|
||||
and @racket[unsafe-fxxor].}]}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(unsafe-fx+/wraparound [a fixnum?] [b fixnum?]) fixnum?]
|
||||
@defproc[(unsafe-fx-/wraparound [a fixnum?] [b fixnum?]) fixnum?]
|
||||
@defproc[(unsafe-fx*/wraparound [a fixnum?] [b fixnum?]) fixnum?]
|
||||
@defproc[(unsafe-fxlshift/wraparound [a fixnum?] [b fixnum?]) fixnum?]
|
||||
)]{
|
||||
|
||||
For @tech{fixnums}: Unchecked versions of @racket[fx+/wraparound],
|
||||
@racket[fx-/wraparound], @racket[fx*/wraparound], and
|
||||
@racket[fxlshift/wraparound].
|
||||
|
||||
@history[#:added "7.9.0.6"]}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(unsafe-fx= [a fixnum?] [b fixnum?] ...) boolean?]
|
||||
@defproc[(unsafe-fx< [a fixnum?] [b fixnum?] ...) boolean?]
|
||||
|
|
@ -100,9 +101,9 @@ bits in the result beyond the number of bits used to represent a
|
|||
@defproc[(unsafe-fxmax [a fixnum?] [b fixnum?] ...) fixnum?]
|
||||
)]{
|
||||
|
||||
For @tech{fixnums}: Like @racket[=], @racket[<], @racket[>],
|
||||
@racket[<=], @racket[>=], @racket[min], and @racket[max], but
|
||||
constrained to consume @tech{fixnums}.
|
||||
For @tech{fixnums}: Unchecked versions of @racket[fx=], @racket[fx<],
|
||||
@racket[fx>], @racket[fx<=], @racket[fx>=],
|
||||
@racket[fxmin], and @racket[fxmax].
|
||||
|
||||
@history[#:changed "7.0.0.13" @elem{Allow one or more argument,
|
||||
instead of allowing just two.}]}
|
||||
|
|
|
|||
|
|
@ -22,6 +22,20 @@
|
|||
(test #f fixnum-for-every-system? (sub1 (- (expt 2 29))))
|
||||
(test #f fixnum-for-every-system? (expt 2 29))
|
||||
|
||||
(define (wraparound op)
|
||||
(lambda (x y)
|
||||
(unless (fixnum? x) (raise-argument-error 'wraparound "fixnum?" x))
|
||||
(unless (fixnum? y) (raise-argument-error 'wraparound "fixnum?" y))
|
||||
(define v (op x y))
|
||||
(if (zero? (bitwise-and v (add1 (greatext-fixnum))))
|
||||
(bitwise-ior v (- -1 (greatest-fixnum)))
|
||||
(bitwise-and v (greatest-fixnum)))))
|
||||
|
||||
(define (lshift x y)
|
||||
(unless (<= 0 y (integer-length (greatest-fixnum)))
|
||||
(error 'lshift "bad shift"))
|
||||
(arithmetic-shift x y))
|
||||
|
||||
(define unary-table
|
||||
(list (list fxnot unsafe-fxnot)
|
||||
(list fxabs unsafe-fxabs)
|
||||
|
|
@ -51,7 +65,15 @@
|
|||
(define binary-table
|
||||
(list (list fxquotient unsafe-fxquotient)
|
||||
(list fxremainder unsafe-fxremainder)
|
||||
(list fxmodulo unsafe-fxmodulo)))
|
||||
(list fxmodulo unsafe-fxmodulo)
|
||||
(list (wraparound +) fx+/wraparound)
|
||||
(list (wraparound -) fx-/wraparound)
|
||||
(list (wraparound *) fx*/wraparound)
|
||||
(list (wraparound lshift) fxlshift/wraparound)
|
||||
(list fx+/wraparound unsafe-fx+/wraparound)
|
||||
(list fx-/wraparound unsafe-fx-/wraparound)
|
||||
(list fx*/wraparound unsafe-fx*/wraparound)
|
||||
(list fxlshift/wraparound unsafe-fxlshift/wraparound)))
|
||||
|
||||
(define binary/small-second-arg-table
|
||||
(list (list fxlshift unsafe-fxlshift)
|
||||
|
|
@ -165,6 +187,10 @@
|
|||
;; check a small range
|
||||
(same-results/range/table)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(err/rt-test (fxvector-ref (fxvector 4 5 6) 4) exn:fail:contract? #rx"[[]0, 2[]]")
|
||||
|
|
|
|||
|
|
@ -107,11 +107,15 @@
|
|||
(test v name ((eval `(lambda (y) (let ([x1 (fx+ (random 1) ',arg1)])
|
||||
(,op x1 y))))
|
||||
arg2)))))]
|
||||
[bin-exact (lambda (v op arg1 arg2 [check-fixnum-as-bad? #f] #:bad-value [bad-value 'bad])
|
||||
(check-error-message op (eval `(lambda (x) (,op x ',arg2))) #:bad-value bad-value)
|
||||
[bin-exact (lambda (v op arg1 arg2 [check-fixnum-as-bad? #f]
|
||||
#:bad-value [bad-value 'bad]
|
||||
#:bad-as-second-only? [bad-as-second-only? #f])
|
||||
(unless bad-as-second-only?
|
||||
(check-error-message op (eval `(lambda (x) (,op x ',arg2))) #:bad-value bad-value))
|
||||
(check-error-message op (eval `(lambda (x) (,op ',arg1 x))) #:bad-value bad-value)
|
||||
(check-error-message op (eval `(lambda (x y) (,op x y))) #:first-arg arg1 #:bad-value bad-value)
|
||||
(check-error-message op (eval `(lambda (x y) (,op x y))) #:second-arg arg2 #:bad-value bad-value)
|
||||
(unless bad-as-second-only?
|
||||
(check-error-message op (eval `(lambda (x y) (,op x y))) #:second-arg arg2 #:bad-value bad-value))
|
||||
(when check-fixnum-as-bad?
|
||||
(check-error-message op (eval `(lambda (x) (,op x ',arg2))) #t)
|
||||
(check-error-message op (eval `(lambda (x) (,op x 10))) #t)
|
||||
|
|
@ -565,6 +569,7 @@
|
|||
(tri 13/2 '+ (lambda () 1) 5/2 3 void)
|
||||
(bin-exact 25 'fx+ 10 15)
|
||||
(tri-exact 33 'fx+ (lambda () 10) 15 8 void #f)
|
||||
(bin-exact 25 'fx+/wraparound 10 15)
|
||||
(bin-exact 3.4 'fl+ 1.1 2.3 #t)
|
||||
(tri-exact 7.4 'fl+ (lambda () 1.1) 2.3 4.0 void #f)
|
||||
|
||||
|
|
@ -579,6 +584,7 @@
|
|||
(tri 13/2 '- (lambda () 10) 3 1/2 void)
|
||||
(un-exact -3 'fx- 3)
|
||||
(bin-exact 13 'fx- 5 -8)
|
||||
(bin-exact 13 'fx-/wraparound 5 -8)
|
||||
(tri-exact 14 'fx- (lambda () 5) -8 -1 void #f)
|
||||
(un-exact -3.6 'fl- 3.6)
|
||||
(bin-exact -0.75 'fl- 1.5 2.25 #t)
|
||||
|
|
@ -599,6 +605,7 @@
|
|||
(tri 5 '* (lambda () 2) 3 5/6 void)
|
||||
(un-exact 11 'fx* 11)
|
||||
(bin-exact 253 'fx* 11 23)
|
||||
(bin-exact 253 'fx*/wraparound 11 23)
|
||||
(bin-exact 2.53 'fl* 1.1 2.3 #t)
|
||||
(tri-exact 506 'fx* (lambda () 11) 23 2 void #f)
|
||||
(tri-exact 7.59 'fl* (lambda () 1.1) 2.3 3.0 void #f)
|
||||
|
|
@ -729,7 +736,15 @@
|
|||
(bin-exact 2 'arithmetic-shift (expt 2 33) -32)
|
||||
(bin-exact 8 'arithmetic-shift (expt 2 33) -30)
|
||||
(bin-exact 4 'fxlshift 2 1)
|
||||
(bin-exact 4 'fxlshift 2 1 #:bad-value -2 #:bad-as-second-only? #t)
|
||||
(bin-exact 4 'fxlshift 2 1 #:bad-value 100 #:bad-as-second-only? #t)
|
||||
(bin-exact 1 'fxrshift 2 1)
|
||||
(bin-exact 1 'fxrshift 2 1 #:bad-value -2 #:bad-as-second-only? #t)
|
||||
(bin-exact 1 'fxrshift 2 1 #:bad-value 100 #:bad-as-second-only? #t)
|
||||
|
||||
(bin-exact 4 'fxlshift/wraparound 2 1)
|
||||
(bin-exact 4 'fxlshift/wraparound 2 1 #:bad-value -2 #:bad-as-second-only? #t)
|
||||
(bin-exact 4 'fxlshift/wraparound 2 1 #:bad-value 100 #:bad-as-second-only? #t)
|
||||
|
||||
(un-exact -1 'bitwise-not 0)
|
||||
(un-exact 0 'bitwise-not -1)
|
||||
|
|
|
|||
|
|
@ -3552,7 +3552,7 @@
|
|||
extra-p))
|
||||
(define n3 (inexact->exact (exact->inexact n2)))
|
||||
(unless (= n3 (arithmetic-shift 53-bit-number (+ num-zeros 1 extra-p)))
|
||||
(error 'random-exact->inexact "truncating round failed ~s" n2)))
|
||||
(error 'random-exact->inexact "truncating round failed ~s ~s ~s" n2 53-bit-number (+ num-zeros 1 extra-p))))
|
||||
(check-random-pairs check-shift-plus-bits-to-truncate)
|
||||
|
||||
;; If we add a one bit and then a non-zero bit anywhere later,
|
||||
|
|
|
|||
|
|
@ -151,6 +151,9 @@
|
|||
(err/rt-test (unsafe-fxmodulo (error "bad") 1) exn:fail?) ; not 0
|
||||
(err/rt-test (unsafe-fxmodulo 0 (error "bad")) exn:fail?) ; not 0
|
||||
|
||||
(test-bin 60 'unsafe-fxlshift 15 2)
|
||||
(test-bin 3 'unsafe-fxrshift 15 2)
|
||||
|
||||
(test-zero 0.0 'unsafe-fl+)
|
||||
(test-un 6.7 'unsafe-fl+ 6.7)
|
||||
(test-bin 3.4 'unsafe-fl+ 1.4 2.0)
|
||||
|
|
|
|||
|
|
@ -9,9 +9,10 @@
|
|||
(provide fx->fl fl->fx
|
||||
fxabs
|
||||
fx+ fx- fx*
|
||||
fx+/wraparound fx-/wraparound fx*/wraparound
|
||||
fxquotient fxremainder fxmodulo
|
||||
fxand fxior fxxor
|
||||
fxnot fxrshift fxlshift
|
||||
fxnot fxrshift fxlshift fxlshift/wraparound
|
||||
fx>= fx> fx= fx< fx<=
|
||||
fxmin fxmax
|
||||
fixnum-for-every-system?
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ InstallLZ4Target=
|
|||
# no changes should be needed below this point #
|
||||
###############################################################################
|
||||
|
||||
Version=csv9.5.3.49
|
||||
Version=csv9.5.3.50
|
||||
Include=boot/$m
|
||||
PetiteBoot=boot/$m/petite.boot
|
||||
SchemeBoot=boot/$m/scheme.boot
|
||||
|
|
|
|||
|
|
@ -177,6 +177,11 @@
|
|||
[write-string display-string]
|
||||
[call/ec call/1cc]
|
||||
[s:string->symbol string->symbol])
|
||||
;; Wraparound behavior not needed to compile Chez Scheme itself:
|
||||
(rename-out [fx+ fx+/wraparound]
|
||||
[fx- fx-/wraparound]
|
||||
[fx* fx*/wraparound]
|
||||
[fxlshift fxsll/wraparound])
|
||||
logbit? logbit1 logbit0 logtest
|
||||
(rename-out [logbit? fxlogbit?]
|
||||
[logbit1 fxlogbit1]
|
||||
|
|
|
|||
|
|
@ -357,7 +357,7 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
;; Version and machine types:
|
||||
|
||||
(define-constant scheme-version #x09050331)
|
||||
(define-constant scheme-version #x09050332)
|
||||
|
||||
(define-syntax define-machine-types
|
||||
(lambda (x)
|
||||
|
|
@ -2785,6 +2785,10 @@
|
|||
(sub1 #f 1 #f #t)
|
||||
(-1+ #f 1 #f #t)
|
||||
(fx* #f 2 #t #t)
|
||||
(fx*/wraparound #f 2 #t #t)
|
||||
(fx+/wraparound #f 2 #t #t)
|
||||
(fx-/wraparound #f 2 #t #t)
|
||||
(fxsll/wraparound #f 2 #t #t)
|
||||
(dofargint64 #f 1 #f #f)
|
||||
(dofretint64 #f 1 #f #f)
|
||||
(dofretuns64 #f 1 #f #f)
|
||||
|
|
|
|||
|
|
@ -2725,12 +2725,14 @@
|
|||
(partial-folder plus + + 0 generic-nan?)
|
||||
(partial-folder plus fx+ + 0 (lambda (x) #f) 3)
|
||||
(r6rs-fixnum-partial-folder plus r6rs:fx+ fx+ + 0 (lambda (x) #f) 3)
|
||||
(r6rs-fixnum-partial-folder plus fx+/wraparound fx+/wraparound + 0 (lambda (x) #f) 3)
|
||||
(partial-folder plus fl+ fl+ -0.0 fl-nan? #f obviously-fl?)
|
||||
(partial-folder plus cfl+ cfl+ -0.0 cfl-nan?)
|
||||
|
||||
(partial-folder plus * * 1 exact-zero?) ; exact zero trumps nan
|
||||
(partial-folder plus fx* * 1 exact-zero? 3)
|
||||
(r6rs-fixnum-partial-folder plus r6rs:fx* fx* * 1 exact-zero? 3)
|
||||
(r6rs-fixnum-partial-folder plus fx*/wraparound fx*/wraparound * 1 (lambda (x) #f) 3)
|
||||
(partial-folder plus fl* fl* 1.0 fl-nan? #f obviously-fl?)
|
||||
(partial-folder plus cfl* cfl* 1.0 cfl-nan?)
|
||||
|
||||
|
|
@ -2740,6 +2742,7 @@
|
|||
(partial-folder minus - - 0)
|
||||
(partial-folder minus fx- - 0)
|
||||
(r6rs-fixnum-partial-folder minus r6rs:fx- fx- - 0)
|
||||
(r6rs-fixnum-partial-folder plus fx-/wraparound fx-/wraparound - 0 (lambda (x) #f) 3)
|
||||
(partial-folder minus fl- fl- -0.0)
|
||||
(partial-folder minus cfl- cfl- -0.0)
|
||||
|
||||
|
|
@ -2883,6 +2886,7 @@
|
|||
(fold (fxarithmetic-shift-left tfixnum? u<fxwidth?) tfixnum? #2%bitwise-arithmetic-shift-left handle-shift)
|
||||
(fold (fxarithmetic-shift-right tfixnum? u<fxwidth?) tfixnum? #2%bitwise-arithmetic-shift-right handle-shift)
|
||||
(fold (fxsll tfixnum? u<=fxwidth?) tfixnum? #2%bitwise-arithmetic-shift-left handle-shift)
|
||||
(fold (fxsll/wraparound tfixnum? u<=fxwidth?) tfixnum? #2%fxsll/wraparound handle-shift)
|
||||
(fold (fxsra tfixnum? u<=fxwidth?) tfixnum? #2%bitwise-arithmetic-shift-right handle-shift)
|
||||
(fold (fxsrl tfixnum? u<=fxwidth?) tfixnum?
|
||||
(lambda (x k)
|
||||
|
|
|
|||
|
|
@ -4790,6 +4790,8 @@
|
|||
[(e1 . e*) (reduce src sexpr moi e1 e*)])
|
||||
(define-inline 3 r6rs:fx+ ; limited to two arguments
|
||||
[(e1 e2) (%inline + ,e1 ,e2)])
|
||||
(define-inline 3 fx+/wraparound
|
||||
[(e1 e2) (%inline + ,e1 ,e2)])
|
||||
(define-inline 3 fx1+
|
||||
[(e) (%inline + ,e (immediate ,(fix 1)))])
|
||||
(define-inline 2 $fx+?
|
||||
|
|
@ -4835,7 +4837,13 @@
|
|||
(goto ,Llib))))]
|
||||
[(e1 . e*) #f])
|
||||
(define-inline 2 r6rs:fx+ ; limited to two arguments
|
||||
[(e1 e2) (go src sexpr e1 e2)]))
|
||||
[(e1 e2) (go src sexpr e1 e2)])
|
||||
(define-inline 2 fx+/wraparound
|
||||
[(e1 e2)
|
||||
(bind #t (e1 e2)
|
||||
`(if ,(build-fixnums? (list e1 e2))
|
||||
,(%inline + ,e1 ,e2)
|
||||
,(build-libcall #t src sexpr fx+/wraparound e1 e2)))]))
|
||||
|
||||
(define-inline 3 fx-
|
||||
[(e) (%inline - (immediate 0) ,e)]
|
||||
|
|
@ -4844,6 +4852,8 @@
|
|||
(define-inline 3 r6rs:fx- ; limited to one or two arguments
|
||||
[(e) (%inline - (immediate 0) ,e)]
|
||||
[(e1 e2) (%inline - ,e1 ,e2)])
|
||||
(define-inline 3 fx-/wraparound
|
||||
[(e1 e2) (%inline - ,e1 ,e2)])
|
||||
(define-inline 3 fx1-
|
||||
[(e) (%inline - ,e (immediate ,(fix 1)))])
|
||||
(define-inline 2 $fx-?
|
||||
|
|
@ -4885,7 +4895,13 @@
|
|||
[(e1 . e*) #f])
|
||||
(define-inline 2 r6rs:fx- ; limited to one or two arguments
|
||||
[(e) (go src sexpr `(immediate ,(fix 0)) e)]
|
||||
[(e1 e2) (go src sexpr e1 e2)]))
|
||||
[(e1 e2) (go src sexpr e1 e2)])
|
||||
(define-inline 2 fx-/wraparound
|
||||
[(e1 e2)
|
||||
(bind #t (e1 e2)
|
||||
`(if ,(build-fixnums? (list e1 e2))
|
||||
,(%inline - ,e1 ,e2)
|
||||
,(build-libcall #t src sexpr fx-/wraparound e1 e2)))]))
|
||||
(define-inline 2 fx1-
|
||||
[(e) (let ([Llib (make-local-label 'Llib)])
|
||||
(bind #t (e)
|
||||
|
|
@ -4970,6 +4986,8 @@
|
|||
[(e1 . e*) (reduce src sexpr moi e1 e*)])
|
||||
(define-inline 3 r6rs:fx* ; limited to two arguments
|
||||
[(e1 e2) (build-fx* e1 e2 #f)])
|
||||
(define-inline 3 fx*/wraparound
|
||||
[(e1 e2) (build-fx* e1 e2 #f)])
|
||||
(let ()
|
||||
(define (go src sexpr e1 e2)
|
||||
(let ([Llib (make-local-label 'Llib)])
|
||||
|
|
@ -5003,7 +5021,13 @@
|
|||
(goto ,Llib))))]
|
||||
[(e1 . e*) #f])
|
||||
(define-inline 2 r6rs:fx* ; limited to two arguments
|
||||
[(e1 e2) (go src sexpr e1 e2)]))
|
||||
[(e1 e2) (go src sexpr e1 e2)])
|
||||
(define-inline 2 fx*/wraparound
|
||||
[(e1 e2)
|
||||
(bind #t (e1 e2)
|
||||
`(if ,(build-fixnums? (list e1 e2))
|
||||
,(build-fx* e1 e2 #f)
|
||||
,(build-libcall #t src sexpr fx*/wraparound e1 e2)))]))
|
||||
(let ()
|
||||
(define build-fx/p2
|
||||
(lambda (e1 p2)
|
||||
|
|
@ -5158,6 +5182,8 @@
|
|||
(define-inline 3 fxsll
|
||||
[(e1 e2) (do-fxsll e1 e2)])
|
||||
(define-inline 3 fxarithmetic-shift-left
|
||||
[(e1 e2) (do-fxsll e1 e2)])
|
||||
(define-inline 3 fxsll/wraparound
|
||||
[(e1 e2) (do-fxsll e1 e2)]))
|
||||
(define-inline 3 fxsrl
|
||||
[(e1 e2)
|
||||
|
|
@ -6797,6 +6823,19 @@
|
|||
[(e0 e1) (build-libcall #f src sexpr fxsll e0 e1)])
|
||||
(define-inline 2 fxarithmetic-shift-left
|
||||
[(e0 e1) (build-libcall #f src sexpr fxarithmetic-shift-left e0 e1)])
|
||||
(define-inline 2 fxsll/wraparound
|
||||
[(e1 e2)
|
||||
(bind #t (e1 e2)
|
||||
`(if ,(nanopass-case (L7 Expr) e2
|
||||
[(quote ,d)
|
||||
(guard (target-fixnum? d)
|
||||
($fxu< d (fx+ 1 (constant fixnum-bits))))
|
||||
(build-fixnums? (list e1 e2))]
|
||||
[else
|
||||
(build-and (build-fixnums? (list e1 e2))
|
||||
(%inline u< ,e2 (immediate ,(fix (fx+ 1 (constant fixnum-bits))))))])
|
||||
,(%inline sll ,e1 ,(build-unfix e2))
|
||||
,(build-libcall #t src sexpr fxsll/wraparound e1 e2)))])
|
||||
(define-inline 3 display-string
|
||||
[(e-s) (build-libcall #f src sexpr display-string e-s (%tc-ref current-output))]
|
||||
[(e-s e-op) (build-libcall #f src sexpr display-string e-s e-op)])
|
||||
|
|
|
|||
|
|
@ -523,6 +523,14 @@
|
|||
(define-library-entry (fx1+ x) (fxoops1 'fx1+ x))
|
||||
(define-library-entry (fx1- x) (fxoops1 'fx1- x))
|
||||
|
||||
(define-library-entry (fx+/wraparound x y) (fxoops2 'fx+/wraparound x y))
|
||||
(define-library-entry (fx-/wraparound x y) (fxoops2 'fx-/wraparound x y))
|
||||
(define-library-entry (fx*/wraparound x y) (fxoops2 'fx*/wraparound x y))
|
||||
(define-library-entry (fxsll/wraparound x y)
|
||||
(if (and (fixnum? x) (fixnum? y))
|
||||
(shift-count-oops 'fxsll/wraparound y)
|
||||
(fxoops2 'fxsll/wraparound x y)))
|
||||
|
||||
(define-library-entry (fx= x y) (fxnonfixnum2 'fx= x y))
|
||||
(define-library-entry (fx< x y) (fxnonfixnum2 'fx< x y))
|
||||
(define-library-entry (fx> x y) (fxnonfixnum2 'fx> x y))
|
||||
|
|
|
|||
|
|
@ -348,6 +348,14 @@
|
|||
[(x) (#2%r6rs:fx- x)]
|
||||
[(x y) (#2%r6rs:fx- x y)]))
|
||||
|
||||
(set-who! fx+/wraparound
|
||||
(lambda (x1 x2)
|
||||
(#2%fx+/wraparound x1 x2)))
|
||||
|
||||
(set-who! fx-/wraparound
|
||||
(lambda (x1 x2)
|
||||
(#2%fx-/wraparound x1 x2)))
|
||||
|
||||
(set! fx1-
|
||||
(lambda (x)
|
||||
(#2%fx1- x)))
|
||||
|
|
@ -403,6 +411,10 @@
|
|||
(fxargerr who x2))
|
||||
(fxargerr who x1))))
|
||||
|
||||
(set-who! fx*/wraparound
|
||||
(lambda (x1 x2)
|
||||
(#2%fx*/wraparound x1 x2)))
|
||||
|
||||
(set! fxquotient
|
||||
(rec fxquotient
|
||||
(case-lambda
|
||||
|
|
@ -518,16 +530,20 @@
|
|||
|
||||
(set! fxsll
|
||||
(lambda (x y)
|
||||
(#2%fxsll x y)))
|
||||
(#2%fxsll x y)))
|
||||
|
||||
(set! fxarithmetic-shift-left
|
||||
(lambda (x y)
|
||||
(#2%fxarithmetic-shift-left x y)))
|
||||
(set-who! fxsll/wraparound
|
||||
(lambda (x1 x2)
|
||||
(#2%fxsll/wraparound x1 x2)))
|
||||
|
||||
(set! fxsrl
|
||||
(lambda (x y)
|
||||
(#2%fxsrl x y)))
|
||||
|
||||
(set! fxarithmetic-shift-left
|
||||
(lambda (x y)
|
||||
(#2%fxarithmetic-shift-left x y)))
|
||||
|
||||
(set! fxsra
|
||||
(lambda (x y)
|
||||
(#2%fxsra x y)))
|
||||
|
|
|
|||
|
|
@ -1365,8 +1365,11 @@
|
|||
(ftype-pointer-null? [sig [(ftype-pointer) -> (boolean)]] [flags pure mifoldable discard])
|
||||
(ftype-pointer->sexpr [sig [(ftype-pointer) -> (ptr)]] [flags])
|
||||
(fx* [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 2 arguments
|
||||
(fx*/wraparound [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fx+ [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 2 arguments
|
||||
(fx+/wraparound [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fx- [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 1 or 2 arguments
|
||||
(fx-/wraparound [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fx/ [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 1 or 2 arguments
|
||||
(fx1+ [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fx1- [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
|
|
@ -1394,6 +1397,7 @@
|
|||
(fxquotient [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fxremainder [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxsll [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxsll/wraparound [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxsra [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxsrl [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02 safeongoodargs])
|
||||
|
|
|
|||
|
|
@ -1650,7 +1650,7 @@ Scheme_Object *scheme_jit_continuation_apply_install(Apply_LWC_Args *args);
|
|||
#define ARITH_IOR 4
|
||||
/* bitwise-xor, fxxor, unsafe-fxxor */
|
||||
#define ARITH_XOR 5
|
||||
/* arithmetic-shift, fxlshift, unsafe-fxlshift */
|
||||
/* fxlshift, unsafe-fxlshift */
|
||||
#define ARITH_LSH 6
|
||||
/* fxrshift, unsafe-fxrshift */
|
||||
#define ARITH_RSH -6
|
||||
|
|
@ -1675,6 +1675,16 @@ Scheme_Object *scheme_jit_continuation_apply_install(Apply_LWC_Args *args);
|
|||
#define ARITH_INEX_TRUNC_EX 16
|
||||
/* flexpt */
|
||||
#define ARITH_EXPT 17
|
||||
/* fx+/wraparound, unsafe-fl+/wraparound */
|
||||
#define ARITH_ADD_WRAP 18
|
||||
/* fx-/wraparound, unsafe-fx-/wraparound */
|
||||
#define ARITH_SUB_WRAP -18
|
||||
/* fx+/wraparound, unsafe-fx+/wraparound */
|
||||
#define ARITH_MUL_WRAP 19
|
||||
/* fxlshift/wraparound, unsafe-fxlshift/wraparound */
|
||||
#define ARITH_LSH_WRAP 20
|
||||
/* arithmetic-shift */
|
||||
#define ARITH_SH 21
|
||||
|
||||
/* Comparison codes. Used in jitarith.c and jitinline.c. */
|
||||
|
||||
|
|
|
|||
|
|
@ -416,7 +416,7 @@ static jit_insn *generate_arith_slow_path(mz_jit_state *jitter, Scheme_Object *r
|
|||
*_ref = ref;
|
||||
*_ref4 = ref4;
|
||||
|
||||
if (arith == ARITH_LSH) {
|
||||
if ((arith == ARITH_SH) || (arith == ARITH_LSH) || (arith == ARITH_LSH_WRAP)) {
|
||||
/* Add tag back to first arg, just in case. See arithmetic-shift branch to refslow. */
|
||||
ref = jit_get_ip();
|
||||
|
||||
|
|
@ -634,7 +634,7 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
|
|||
ref8 = ref9 = ref10 = NULL;
|
||||
}
|
||||
|
||||
if (!two_args && !second_const && ((arith == ARITH_MUL) || ((arith == ARITH_DIV) && reversed))) {
|
||||
if (!two_args && !second_const && ((arith == ARITH_MUL) || (arith == ARITH_MUL_WRAP) || ((arith == ARITH_DIV) && reversed))) {
|
||||
/* Special case: multiplication by exact 0 */
|
||||
(void)jit_movi_p(dest, scheme_make_integer(0));
|
||||
} else {
|
||||
|
|
@ -1400,10 +1400,14 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
if (rand2) {
|
||||
if (SCHEME_INTP(rand2)
|
||||
&& SCHEME_INT_SMALL_ENOUGH(rand2)
|
||||
&& ((arith != ARITH_LSH)
|
||||
|| ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT)
|
||||
&& (SCHEME_INT_VAL(rand2) >= -MAX_TRY_SHIFT)))
|
||||
&& ((cmp != 3)
|
||||
&& ((arith == ARITH_SH)
|
||||
? ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT)
|
||||
&& (SCHEME_INT_VAL(rand2) >= -MAX_TRY_SHIFT))
|
||||
: (((arith == ARITH_LSH) || (arith == ARITH_LSH_WRAP) || (arith == ARITH_RSH))
|
||||
? ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT)
|
||||
&& (SCHEME_INT_VAL(rand2) >= 0))
|
||||
: 1))
|
||||
&& ((cmp != CMP_BIT)
|
||||
|| ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT)
|
||||
&& (SCHEME_INT_VAL(rand2) >= 0)))) {
|
||||
/* Second is constant, so use constant mode.
|
||||
|
|
@ -1413,7 +1417,7 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
rand2 = NULL;
|
||||
} else if (SCHEME_INTP(rand)
|
||||
&& SCHEME_INT_SMALL_ENOUGH(rand)
|
||||
&& (arith != ARITH_LSH) && (arith != ARITH_RSH)
|
||||
&& (arith != ARITH_SH) && (arith != ARITH_LSH) && (arith != ARITH_LSH_WRAP) && (arith != ARITH_RSH)
|
||||
&& (cmp != CMP_BIT)) {
|
||||
/* First is constant; swap argument order and use constant mode. */
|
||||
v = SCHEME_INT_VAL(rand);
|
||||
|
|
@ -1619,33 +1623,33 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
|
||||
if (rand2) {
|
||||
/* First arg is in JIT_R1, second is in JIT_R0 */
|
||||
if (arith == ARITH_ADD) {
|
||||
if ((arith == ARITH_ADD) || (arith == ARITH_ADD_WRAP)) {
|
||||
jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
|
||||
if (unsafe_fx && !overflow_refslow)
|
||||
if ((unsafe_fx && !overflow_refslow) || (arith == ARITH_ADD_WRAP))
|
||||
jit_addr_l(dest, JIT_R2, JIT_R0);
|
||||
else {
|
||||
(void)jit_boaddr_l(refslow, JIT_R2, JIT_R0);
|
||||
jit_movr_p(dest, JIT_R2);
|
||||
}
|
||||
} else if (arith == ARITH_SUB) {
|
||||
} else if ((arith == ARITH_SUB) || (arith == ARITH_SUB_WRAP)) {
|
||||
if (reversed) {
|
||||
jit_movr_p(JIT_R2, JIT_R0);
|
||||
if (unsafe_fx && !overflow_refslow)
|
||||
if ((unsafe_fx && !overflow_refslow) || (arith == ARITH_SUB_WRAP))
|
||||
jit_subr_l(JIT_R2, JIT_R2, JIT_R1);
|
||||
else
|
||||
(void)jit_bosubr_l(refslow, JIT_R2, JIT_R1);
|
||||
} else {
|
||||
jit_movr_p(JIT_R2, JIT_R1);
|
||||
if (unsafe_fx && !overflow_refslow)
|
||||
if ((unsafe_fx && !overflow_refslow) || (arith == ARITH_SUB_WRAP))
|
||||
(void)jit_subr_l(JIT_R2, JIT_R2, JIT_R0);
|
||||
else
|
||||
(void)jit_bosubr_l(refslow, JIT_R2, JIT_R0);
|
||||
}
|
||||
jit_ori_ul(dest, JIT_R2, 0x1);
|
||||
} else if (arith == ARITH_MUL) {
|
||||
} else if ((arith == ARITH_MUL) || (arith == ARITH_MUL_WRAP)) {
|
||||
jit_andi_ul(JIT_R2, JIT_R1, (~0x1));
|
||||
jit_rshi_l(JIT_V1, JIT_R0, 0x1);
|
||||
if (unsafe_fx && !overflow_refslow)
|
||||
if ((unsafe_fx && !overflow_refslow) || (arith == ARITH_MUL_WRAP))
|
||||
jit_mulr_l(JIT_V1, JIT_V1, JIT_R2);
|
||||
else
|
||||
(void)jit_bomulr_l(refslow, JIT_V1, JIT_R2);
|
||||
|
|
@ -1738,7 +1742,7 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
/* xor */
|
||||
jit_andi_ul(JIT_R0, JIT_R0, (~0x1));
|
||||
jit_xorr_ul(dest, JIT_R1, JIT_R0);
|
||||
} else if ((arith == ARITH_LSH) || (arith == ARITH_RSH)) {
|
||||
} else if ((arith == ARITH_SH) || (arith == ARITH_LSH) || (arith == ARITH_LSH_WRAP) || (arith == ARITH_RSH)) {
|
||||
/* arithmetic-shift
|
||||
This is a lot of code, but if you're using
|
||||
arithmetic-shift, then you probably want it. */
|
||||
|
|
@ -1746,27 +1750,30 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
int v2 = (reversed ? JIT_R1 : JIT_R0);
|
||||
GC_CAN_IGNORE jit_insn *refi, *refc;
|
||||
|
||||
if ((arith != ARITH_RSH) && (!unsafe_fx || overflow_refslow))
|
||||
if (arith == ARITH_SH)
|
||||
refi = jit_bgei_l(jit_forward(), v2, (intptr_t)scheme_make_integer(0));
|
||||
else
|
||||
else {
|
||||
refi = NULL;
|
||||
if (!unsafe_fx || overflow_refslow)
|
||||
(void)jit_blti_l(refslow, v2, scheme_make_integer(0));
|
||||
}
|
||||
|
||||
if (!unsafe_fx || overflow_refslow || (arith == ARITH_RSH)) {
|
||||
if ((arith == ARITH_SH) || (arith == ARITH_RSH)) {
|
||||
/* Right shift */
|
||||
if (!unsafe_fx || overflow_refslow) {
|
||||
/* check for a small enough shift */
|
||||
if (arith == ARITH_RSH) {
|
||||
(void)jit_blti_p(refslow, v2, scheme_make_integer(0));
|
||||
(void)jit_bgti_p(refslow, v2, scheme_make_integer(MAX_TRY_SHIFT));
|
||||
jit_rshi_l(JIT_V1, v2, 0x1);
|
||||
(void)jit_bgti_l(refslow, v2, scheme_make_integer(MAX_TRY_SHIFT));
|
||||
} else {
|
||||
(void)jit_blti_p(refslow, v2, scheme_make_integer(-MAX_TRY_SHIFT));
|
||||
jit_notr_l(JIT_V1, v2);
|
||||
jit_rshi_l(JIT_V1, JIT_V1, 0x1);
|
||||
jit_addi_l(JIT_V1, JIT_V1, 0x1);
|
||||
(void)jit_blti_l(refslow, v2, scheme_make_integer(-MAX_TRY_SHIFT));
|
||||
}
|
||||
} else {
|
||||
}
|
||||
if (arith == ARITH_RSH)
|
||||
jit_rshi_l(JIT_V1, v2, 0x1);
|
||||
else {
|
||||
jit_notr_l(JIT_V1, v2);
|
||||
jit_rshi_l(JIT_V1, JIT_V1, 0x1);
|
||||
jit_addi_l(JIT_V1, JIT_V1, 0x1);
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
#ifdef MZ_USE_JIT_I386
|
||||
|
|
@ -1786,7 +1793,7 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
refc = NULL;
|
||||
|
||||
/* Left shift */
|
||||
if (!unsafe_fx || overflow_refslow || (arith == ARITH_LSH)) {
|
||||
if ((arith == ARITH_SH) || (arith == ARITH_LSH) || (arith == ARITH_LSH_WRAP)) {
|
||||
if (refi)
|
||||
mz_patch_branch(refi);
|
||||
if (!unsafe_fx || overflow_refslow)
|
||||
|
|
@ -1801,12 +1808,13 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
jit_lshr_l(JIT_R2, v1, JIT_V1);
|
||||
#endif
|
||||
CHECK_LIMIT();
|
||||
/* If shifting back right produces a different result, that's overflow... */
|
||||
jit_rshr_l(JIT_V1, JIT_R2, JIT_V1);
|
||||
/* !! In case we go refslow, it needs to add back tag to v1 !! */
|
||||
if (!unsafe_fx || overflow_refslow)
|
||||
if ((!unsafe_fx || overflow_refslow) && (arith != ARITH_LSH_WRAP)) {
|
||||
/* If shifting back right produces a different result, that's overflow... */
|
||||
jit_rshr_l(JIT_V1, JIT_R2, JIT_V1);
|
||||
/* !! In case we go refslow, it needs to add back tag to v1 !! */
|
||||
(void)jit_bner_p(refslow, JIT_V1, v1);
|
||||
/* No overflow. */
|
||||
}
|
||||
/* No overflow (or we don't care) */
|
||||
jit_ori_l(dest, JIT_R2, 0x1);
|
||||
}
|
||||
|
||||
|
|
@ -1833,24 +1841,24 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
}
|
||||
} else {
|
||||
/* Non-constant arg is in JIT_R0 */
|
||||
if (arith == ARITH_ADD) {
|
||||
if (unsafe_fx && !overflow_refslow)
|
||||
if ((arith == ARITH_ADD) || (arith == ARITH_ADD_WRAP)) {
|
||||
if ((unsafe_fx && !overflow_refslow) || (arith == ARITH_ADD_WRAP))
|
||||
jit_addi_l(dest, JIT_R0, (uintptr_t)v << 1);
|
||||
else {
|
||||
jit_movr_p(JIT_R2, JIT_R0);
|
||||
(void)jit_boaddi_l(refslow, JIT_R2, (uintptr_t)v << 1);
|
||||
jit_movr_p(dest, JIT_R2);
|
||||
}
|
||||
} else if (arith == ARITH_SUB) {
|
||||
} else if ((arith == ARITH_SUB) || (arith == ARITH_SUB_WRAP)) {
|
||||
if (reversed) {
|
||||
(void)jit_movi_p(JIT_R2, scheme_make_integer(v));
|
||||
if (unsafe_fx && !overflow_refslow)
|
||||
if ((unsafe_fx && !overflow_refslow) || (arith == ARITH_SUB_WRAP))
|
||||
jit_subr_l(JIT_R2, JIT_R2, JIT_R0);
|
||||
else
|
||||
(void)jit_bosubr_l(refslow, JIT_R2, JIT_R0);
|
||||
jit_addi_ul(dest, JIT_R2, 0x1);
|
||||
} else {
|
||||
if (unsafe_fx && !overflow_refslow)
|
||||
if ((unsafe_fx && !overflow_refslow) || (arith == ARITH_SUB_WRAP))
|
||||
jit_subi_l(dest, JIT_R0, (uintptr_t)v << 1);
|
||||
else {
|
||||
jit_movr_p(JIT_R2, JIT_R0);
|
||||
|
|
@ -1858,7 +1866,7 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
jit_movr_p(dest, JIT_R2);
|
||||
}
|
||||
}
|
||||
} else if (arith == ARITH_MUL) {
|
||||
} else if ((arith == ARITH_MUL) || (arith == ARITH_MUL_WRAP)) {
|
||||
if (v == 1) {
|
||||
/* R0 already is the answer */
|
||||
jit_movr_p(dest, JIT_R0);
|
||||
|
|
@ -1867,7 +1875,7 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
} else {
|
||||
(void)jit_movi_l(JIT_R2, ((intptr_t)scheme_make_integer(v) & (~0x1)));
|
||||
jit_rshi_l(JIT_V1, JIT_R0, 0x1);
|
||||
if (unsafe_fx && !overflow_refslow)
|
||||
if ((unsafe_fx && !overflow_refslow) || (arith == ARITH_MUL_WRAP))
|
||||
jit_mulr_l(JIT_V1, JIT_V1, JIT_R2);
|
||||
else {
|
||||
(void)jit_movi_p(JIT_R1, scheme_make_integer(v)); /* for slow path */
|
||||
|
|
@ -1887,9 +1895,10 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
} else if (arith == ARITH_XOR) {
|
||||
/* xor */
|
||||
jit_xori_ul(dest, JIT_R0, (uintptr_t)v << 1);
|
||||
} else if ((arith == ARITH_LSH) || (arith == ARITH_RSH)) {
|
||||
} else if ((arith == ARITH_SH) || (arith == ARITH_LSH) || (arith == ARITH_LSH_WRAP) || (arith == ARITH_RSH)) {
|
||||
/* arithmetic-shift */
|
||||
/* We only get here when v is between -MAX_TRY_SHIFT and MAX_TRY_SHIFT, inclusive */
|
||||
/* We only get here when v is in range, such as between -MAX_TRY_SHIFT and
|
||||
MAX_TRY_SHIFT inclusive for ARITH_SH. */
|
||||
if ((v <= 0) || (arith == ARITH_RSH)) {
|
||||
int amt = v;
|
||||
if (arith != ARITH_RSH)
|
||||
|
|
@ -1899,13 +1908,13 @@ int scheme_generate_arith_for(mz_jit_state *jitter, Scheme_Object *rator, Scheme
|
|||
} else {
|
||||
jit_andi_l(JIT_R0, JIT_R0, (~0x1));
|
||||
jit_lshi_l(JIT_R2, JIT_R0, v);
|
||||
if (!unsafe_fx && !overflow_refslow) {
|
||||
if ((!unsafe_fx || overflow_refslow) && (arith != ARITH_LSH_WRAP)) {
|
||||
/* If shifting back right produces a different result, that's overflow... */
|
||||
jit_rshi_l(JIT_V1, JIT_R2, v);
|
||||
/* !! In case we go refslow, it nseed to add back tag to JIT_R0 !! */
|
||||
(void)jit_bner_p(refslow, JIT_V1, JIT_R0);
|
||||
}
|
||||
/* No overflow. */
|
||||
/* No overflow (or we don't care) */
|
||||
jit_ori_l(dest, JIT_R2, 0x1);
|
||||
}
|
||||
} else if (arith == ARITH_NOT) {
|
||||
|
|
|
|||
|
|
@ -2415,8 +2415,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
|
|||
jit_movr_p(dest, JIT_R0);
|
||||
refdone = jit_jmpi(jit_forward());
|
||||
mz_patch_branch(ref);
|
||||
(void)jit_blti_p(refslow, JIT_R0, scheme_make_integer(0));
|
||||
(void)jit_bgti_p(refslow, JIT_R0, scheme_make_integer(255));
|
||||
(void)jit_blti_l(refslow, JIT_R0, scheme_make_integer(0));
|
||||
(void)jit_bgti_l(refslow, JIT_R0, scheme_make_integer(255));
|
||||
|
||||
jit_rshi_l(JIT_R0, JIT_R0, 1);
|
||||
jit_lshi_l(JIT_R2, JIT_R0, JIT_LOG_WORD_SIZE);
|
||||
|
|
@ -3674,6 +3674,12 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
} else if (IS_NAMED_PRIM(rator, "fx+")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_ADD, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fx+/wraparound")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_ADD_WRAP, 0, 0, NULL, 1, 1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "fx+/wraparound")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_ADD_WRAP, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fl+")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_ADD, 0, 0, NULL, 1, 0, 1, NULL, dest);
|
||||
return 1;
|
||||
|
|
@ -3689,6 +3695,12 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
} else if (IS_NAMED_PRIM(rator, "fx-")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_SUB, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fx-/wraparound")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_SUB_WRAP, 0, 0, NULL, 1, 1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "fx-/wraparound")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_SUB_WRAP, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fl-")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_SUB, 0, 0, NULL, 1, 0, 1, NULL, dest);
|
||||
return 1;
|
||||
|
|
@ -3704,6 +3716,12 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
} else if (IS_NAMED_PRIM(rator, "fx*")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MUL, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fx*/wraparound")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MUL_WRAP, 0, 0, NULL, 1, 1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "fx*/wraparound")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MUL_WRAP, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fl*")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_MUL, 0, 0, NULL, 1, 0, 1, NULL, dest);
|
||||
return 1;
|
||||
|
|
@ -3804,7 +3822,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_XOR, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "arithmetic-shift")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_LSH, 0, 0, NULL, 1, 0, 0, NULL, dest);
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_SH, 0, 0, NULL, 1, 0, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fxlshift")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_LSH, 0, 0, NULL, 1, 1, 0, NULL, dest);
|
||||
|
|
@ -3812,6 +3830,12 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
} else if (IS_NAMED_PRIM(rator, "fxlshift")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_LSH, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fxlshift/wraparound")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_LSH_WRAP, 0, 0, NULL, 1, 1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "fxlshift/wraparound")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_LSH_WRAP, 0, 0, NULL, 1, -1, 0, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-fxrshift")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand1, app->rand2, 2, ARITH_RSH, 0, 0, NULL, 1, 1, 0, NULL, dest);
|
||||
return 1;
|
||||
|
|
|
|||
|
|
@ -15,16 +15,22 @@ static Scheme_Object *rem_prim (int argc, Scheme_Object *argv[]);
|
|||
static Scheme_Object *quotient_remainder (int argc, Scheme_Object *argv[]);
|
||||
|
||||
static Scheme_Object *fx_plus (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_plus_wrap (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_minus (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_minus_wrap (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_mult (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_mult_wrap (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_div (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_rem (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_mod (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_abs (int argc, Scheme_Object *argv[]);
|
||||
|
||||
static Scheme_Object *unsafe_fx_plus (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_plus_wrap (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_minus (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_minus_wrap (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_mult (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_mult_wrap (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_div (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_rem (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_mod (int argc, Scheme_Object *argv[]);
|
||||
|
|
@ -168,6 +174,13 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_AD_HOC_OPT);
|
||||
scheme_addto_prim_instance("fx+", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fx_plus_wrap, "fx+/wraparound", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_NARY_INLINED
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM
|
||||
| SCHEME_PRIM_AD_HOC_OPT);
|
||||
scheme_addto_prim_instance("fx+/wraparound", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fx_minus, "fx-", 1, -1, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
|
||||
| SCHEME_PRIM_IS_BINARY_INLINED
|
||||
|
|
@ -176,6 +189,14 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_AD_HOC_OPT);
|
||||
scheme_addto_prim_instance("fx-", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fx_minus_wrap, "fx-/wraparound", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
|
||||
| SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_NARY_INLINED
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM
|
||||
| SCHEME_PRIM_AD_HOC_OPT);
|
||||
scheme_addto_prim_instance("fx-/wraparound", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fx_mult, "fx*", 0, -1, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_NARY_INLINED
|
||||
|
|
@ -183,6 +204,13 @@ void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_AD_HOC_OPT);
|
||||
scheme_addto_prim_instance("fx*", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fx_mult_wrap, "fx*/wraparound", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_NARY_INLINED
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM
|
||||
| SCHEME_PRIM_AD_HOC_OPT);
|
||||
scheme_addto_prim_instance("fx*/wraparound", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fx_div, "fxquotient", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
|
|
@ -346,6 +374,13 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("unsafe-fx+", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(unsafe_fx_plus_wrap, "unsafe-fx+/wraparound", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_NARY_INLINED
|
||||
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("unsafe-fx+/wraparound", p, env);
|
||||
|
||||
REGISTER_SO(scheme_unsafe_fx_minus_proc);
|
||||
p = scheme_make_folding_prim(unsafe_fx_minus, "unsafe-fx-", 1, -2, 1);
|
||||
scheme_unsafe_fx_minus_proc = p;
|
||||
|
|
@ -356,6 +391,13 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("unsafe-fx-", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(unsafe_fx_minus_wrap, "unsafe-fx-/wraparound", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_NARY_INLINED
|
||||
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("unsafe-fx-/wraparound", p, env);
|
||||
|
||||
REGISTER_SO(scheme_unsafe_fx_times_proc);
|
||||
p = scheme_make_folding_prim(unsafe_fx_mult, "unsafe-fx*", 0, -1, 1);
|
||||
scheme_unsafe_fx_times_proc = p;
|
||||
|
|
@ -365,6 +407,13 @@ void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("unsafe-fx*", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(unsafe_fx_mult_wrap, "unsafe-fx*/wraparound", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_NARY_INLINED
|
||||
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("unsafe-fx*/wraparound", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(unsafe_fx_div, "unsafe-fxquotient", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
|
||||
|
|
@ -1219,6 +1268,20 @@ SAFE_FX(fx_div, "fxquotient", quotient, CHECK_SECOND_ZERO("fxquotient"))
|
|||
SAFE_FX(fx_rem, "fxremainder", rem_prim, CHECK_SECOND_ZERO("fxremainder"))
|
||||
SAFE_FX(fx_mod, "fxmodulo", scheme_modulo, CHECK_SECOND_ZERO("fxmodulo"))
|
||||
|
||||
#define SAFE_FX_WRAP(name, s_name, op) \
|
||||
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
|
||||
{ \
|
||||
uintptr_t r; \
|
||||
if (!SCHEME_INTP(argv[0])) scheme_wrong_contract(s_name, "fixnum?", 0, argc, argv); \
|
||||
if (!SCHEME_INTP(argv[1])) scheme_wrong_contract(s_name, "fixnum?", 1, argc, argv); \
|
||||
r = ((uintptr_t)SCHEME_INT_VAL(argv[0]) op (uintptr_t)SCHEME_INT_VAL(argv[1])); \
|
||||
return scheme_make_integer(r); \
|
||||
}
|
||||
|
||||
SAFE_FX_WRAP(fx_plus_wrap, "fx+/wraparound", +)
|
||||
SAFE_FX_WRAP(fx_minus_wrap, "fx-/wraparound", -)
|
||||
SAFE_FX_WRAP(fx_mult_wrap, "fx*/wraparound", *)
|
||||
|
||||
static Scheme_Object *fx_abs(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Object *o;
|
||||
|
|
@ -1251,8 +1314,11 @@ static Scheme_Object *fx_abs(int argc, Scheme_Object *argv[])
|
|||
}
|
||||
|
||||
UNSAFE_FX(unsafe_fx_plus, +, fx_plus, scheme_make_integer(0), )
|
||||
UNSAFE_FX(unsafe_fx_plus_wrap, +, fx_plus, scheme_make_integer(0), )
|
||||
UNSAFE_FX(unsafe_fx_minus, -, fx_minus, scheme_false, if (argc == 1) v = -v;)
|
||||
UNSAFE_FX(unsafe_fx_minus_wrap, -, fx_minus, scheme_false, if (argc == 1) v = -v;)
|
||||
UNSAFE_FX(unsafe_fx_mult, *, fx_mult, scheme_make_integer(1), )
|
||||
UNSAFE_FX(unsafe_fx_mult_wrap, *, fx_mult, scheme_make_integer(1), )
|
||||
UNSAFE_FX(unsafe_fx_div, /, fx_div, scheme_false, )
|
||||
UNSAFE_FX(unsafe_fx_rem, %, fx_rem, scheme_false, )
|
||||
|
||||
|
|
|
|||
|
|
@ -118,6 +118,7 @@ static Scheme_Object *fx_xor (int argc, Scheme_Object *argv[]);
|
|||
static Scheme_Object *fx_not (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_lshift (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_rshift (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_lshift_wrap (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fl_to_fx (int argc, Scheme_Object *argv[]);
|
||||
|
||||
|
|
@ -162,6 +163,7 @@ static Scheme_Object *unsafe_fx_xor (int argc, Scheme_Object *argv[]);
|
|||
static Scheme_Object *unsafe_fx_not (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_lshift (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_rshift (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_lshift_wrap (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fx_to_fl (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_fl_to_fx (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *fl_ref (int argc, Scheme_Object *argv[]);
|
||||
|
|
@ -894,6 +896,11 @@ void scheme_init_flfxnum_number(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("fxrshift", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fx_lshift_wrap, "fxlshift/wraparound", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("fxlshift/wraparound", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fx_to_fl, "fx->fl", 1, 1, 1);
|
||||
if (scheme_can_inline_fp_op())
|
||||
flags = SCHEME_PRIM_IS_UNARY_INLINED;
|
||||
|
|
@ -1373,6 +1380,12 @@ void scheme_init_unsafe_number(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("unsafe-fxlshift", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(unsafe_fx_lshift_wrap, "unsafe-fxlshift/wraparound", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
|
||||
| SCHEME_PRIM_PRODUCES_FIXNUM);
|
||||
scheme_addto_prim_instance("unsafe-fxlshift/wraparound", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(unsafe_fx_rshift, "unsafe-fxrshift", 2, 2, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
|
||||
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
|
||||
|
|
@ -5260,6 +5273,11 @@ static Scheme_Object *neg_bitwise_shift(int argc, Scheme_Object *argv[])
|
|||
return scheme_bitwise_shift(argc, a);
|
||||
}
|
||||
|
||||
static Scheme_Object *wrap_bitwise_shift(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return scheme_make_integer((intptr_t)((uintptr_t)SCHEME_INT_VAL(argv[0]) << SCHEME_INT_VAL(argv[1])));
|
||||
}
|
||||
|
||||
#define SAFE_FX(name, s_name, scheme_op, sec_p, sec_t, no_args) \
|
||||
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
|
||||
{ \
|
||||
|
|
@ -5292,6 +5310,7 @@ SAFE_FX(fx_xor, "fxxor", bitwise_xor, SCHEME_INTP, "fixnum?", scheme_make_intege
|
|||
|
||||
SAFE_FX(fx_lshift, "fxlshift", scheme_bitwise_shift, FIXNUM_WIDTH_P, FIXNUM_WIDTH_TYPE, scheme_false)
|
||||
SAFE_FX(fx_rshift, "fxrshift", neg_bitwise_shift, FIXNUM_WIDTH_P, FIXNUM_WIDTH_TYPE, scheme_false)
|
||||
SAFE_FX(fx_lshift_wrap, "fxlshift/wraparound", wrap_bitwise_shift, FIXNUM_WIDTH_P, FIXNUM_WIDTH_TYPE, scheme_false)
|
||||
|
||||
static Scheme_Object *fx_not (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
|
|
@ -5501,6 +5520,7 @@ UNSAFE_FX(unsafe_fx_or, |, bitwise_or, intptr_t, scheme_make_integer(0))
|
|||
UNSAFE_FX(unsafe_fx_xor, ^, bitwise_xor, intptr_t, scheme_make_integer(0))
|
||||
UNSAFE_FX(unsafe_fx_lshift, <<, fold_fixnum_bitwise_shift, uintptr_t, scheme_false)
|
||||
UNSAFE_FX(unsafe_fx_rshift, >>, neg_bitwise_shift, intptr_t, scheme_false)
|
||||
UNSAFE_FX(unsafe_fx_lshift_wrap, <<, fold_fixnum_bitwise_shift, uintptr_t, scheme_false)
|
||||
|
||||
static Scheme_Object *unsafe_fx_not (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
|
||||
#define USE_COMPILED_STARTUP 1
|
||||
|
||||
#define EXPECTED_PRIM_COUNT 1474
|
||||
#define EXPECTED_PRIM_COUNT 1482
|
||||
|
||||
#ifdef MZSCHEME_SOMETHING_OMITTED
|
||||
# undef USE_COMPILED_STARTUP
|
||||
|
|
|
|||
|
|
@ -38,8 +38,11 @@
|
|||
[flvector-set! (known-procedure/folding 8)]
|
||||
[flvector? (known-procedure/pure/folding 2)]
|
||||
[fx* (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fx*/wraparound (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fx+ (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fx+/wraparound (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fx- (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fx-/wraparound (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fx->fl (known-procedure/has-unsafe/folding/limited 2 'unsafe-fx->fl 'fixnum)]
|
||||
[fx< (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fx<= (known-procedure/folding/limited -2 'fixnum)]
|
||||
|
|
@ -50,6 +53,7 @@
|
|||
[fxand (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fxior (known-procedure/folding/limited -1 'fixnum)]
|
||||
[fxlshift (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fxlshift/wraparound (known-procedure/folding/limited 4 'fixnum)]
|
||||
[fxmax (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fxmin (known-procedure/folding/limited -2 'fixnum)]
|
||||
[fxmodulo (known-procedure/folding/limited 4 'fixnum)]
|
||||
|
|
|
|||
|
|
@ -76,8 +76,11 @@
|
|||
[unsafe-flvector-ref (known-procedure/succeeds 4)]
|
||||
[unsafe-flvector-set! (known-procedure/succeeds 8)]
|
||||
[unsafe-fx* (known-procedure/pure/folding-unsafe -1 'fx*)]
|
||||
[unsafe-fx*/wraparound (known-procedure/pure/folding-unsafe 4 'fx*/wraparound)]
|
||||
[unsafe-fx+ (known-procedure/pure/folding-unsafe -1 'fx+)]
|
||||
[unsafe-fx+/wraparound (known-procedure/pure/folding-unsafe 4 'fx+/wraparound)]
|
||||
[unsafe-fx- (known-procedure/pure/folding-unsafe -2 'fx-)]
|
||||
[unsafe-fx-/wraparound (known-procedure/pure/folding-unsafe 4 'fx-/wraparound)]
|
||||
[unsafe-fx->extfl (known-procedure/pure/folding-unsafe 2 'fx->extfl)]
|
||||
[unsafe-fx->fl (known-procedure/pure/folding-unsafe 2 'fx->fl)]
|
||||
[unsafe-fx< (known-procedure/pure/folding-unsafe -2 'fx<)]
|
||||
|
|
@ -89,6 +92,7 @@
|
|||
[unsafe-fxand (known-procedure/pure/folding-unsafe -1 'fxand)]
|
||||
[unsafe-fxior (known-procedure/pure/folding-unsafe -1 'fxior)]
|
||||
[unsafe-fxlshift (known-procedure/pure/folding-unsafe 4 'fxlshift)]
|
||||
[unsafe-fxlshift/wraparound (known-procedure/folding/limited 4 'fixnum)]
|
||||
[unsafe-fxmax (known-procedure/pure/folding-unsafe -2 'fxmax)]
|
||||
[unsafe-fxmin (known-procedure/pure/folding-unsafe -2 'fxmin)]
|
||||
[unsafe-fxmodulo (known-procedure/pure/folding-unsafe 4 'fxmodulo)]
|
||||
|
|
|
|||
|
|
@ -406,6 +406,7 @@
|
|||
fx->fl
|
||||
fxrshift
|
||||
fxlshift
|
||||
fxlshift/wraparound
|
||||
fl->fx
|
||||
->fl
|
||||
fl->exact-integer
|
||||
|
|
@ -529,6 +530,10 @@
|
|||
unsafe-fxnot
|
||||
unsafe-fxrshift
|
||||
unsafe-fxlshift
|
||||
unsafe-fx+/wraparound
|
||||
unsafe-fx-/wraparound
|
||||
unsafe-fx*/wraparound
|
||||
unsafe-fxlshift/wraparound
|
||||
|
||||
unsafe-fx=
|
||||
unsafe-fx<
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@
|
|||
flonum->fixnum fl->fx
|
||||
fxarithmetic-shift-right fxrshift
|
||||
fxarithmetic-shift-left fxlshift
|
||||
fxsll/wraparound fxlshift/wraparound
|
||||
real->flonum ->fl
|
||||
time-utc->date seconds->date)
|
||||
(set! rewrites-added? #t)))
|
||||
|
|
|
|||
|
|
@ -111,6 +111,7 @@
|
|||
(define (fx->fl x) (#2%fixnum->flonum x))
|
||||
(define (fxrshift x y) (#2%fxarithmetic-shift-right x y))
|
||||
(define (fxlshift x y) (#2%fxarithmetic-shift-left x y))
|
||||
(define (fxlshift/wraparound x y) (#2%fxsll/wraparound x y))
|
||||
|
||||
(define (fl->fx x) (#2%flonum->fixnum x))
|
||||
(define (->fl x) (#2%real->flonum x))
|
||||
|
|
|
|||
|
|
@ -17,8 +17,11 @@
|
|||
(define unsafe-char->integer (unsafe-primitive char->integer))
|
||||
|
||||
(define unsafe-fx+ (unsafe-primitive fx+))
|
||||
(define unsafe-fx+/wraparound (unsafe-primitive fx+/wraparound))
|
||||
(define unsafe-fx- (unsafe-primitive fx-))
|
||||
(define unsafe-fx-/wraparound (unsafe-primitive fx-/wraparound))
|
||||
(define unsafe-fx* (unsafe-primitive fx*))
|
||||
(define unsafe-fx*/wraparound (unsafe-primitive fx*/wraparound))
|
||||
(define (unsafe-fxquotient n d) (#3%fxquotient n d))
|
||||
(define unsafe-fxremainder (unsafe-primitive fxremainder))
|
||||
(define unsafe-fxmodulo (unsafe-primitive fxmodulo))
|
||||
|
|
@ -29,6 +32,7 @@
|
|||
(define unsafe-fxnot (unsafe-primitive fxnot))
|
||||
(define unsafe-fxrshift (unsafe-primitive fxarithmetic-shift-right))
|
||||
(define unsafe-fxlshift (unsafe-primitive fxarithmetic-shift-left))
|
||||
(define unsafe-fxlshift/wraparound (unsafe-primitive fxsll/wraparound))
|
||||
|
||||
(define unsafe-fx= (unsafe-primitive fx=))
|
||||
(define unsafe-fx< (unsafe-primitive fx<))
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 7
|
||||
#define MZSCHEME_VERSION_Y 9
|
||||
#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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user