suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fill out fl and fx operations; repair fixnum-overflow bug in quotient

Browse Source 
svn: r17524
This commit is contained in:
Matthew Flatt 2010-01-07 03:30:33 +00:00
parent 911123bf94
commit 41261c6047
26 changed files with 1445 additions and 847 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/private/xform.ss
View File

@ -870,7 +870,7 @@
strlen cos sin exp pow log sqrt atan2
isnan isinf fpclass _fpclass _isnan __isfinited __isnanl __isnan
__isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf
floor ceil round fmod fabs __maskrune _errno __errno
floor ceil round fmod modf fabs __maskrune _errno __errno
isalpha isdigit isspace tolower toupper
fread fwrite socket fcntl setsockopt connect send recv close
__builtin_next_arg __builtin_saveregs

4
collects/rnrs/arithmetic/fixnums-6.ss
View File

@ -47,8 +47,8 @@
(define-fx odd? fxodd? #f (a) nocheck)
(define-fx even? fxeven? #f (a) nocheck)
(define-fx max fxmax #f (a b ...) nocheck)
(define-fx min fxmin #f (a b ...) nocheck)
(define-fx max fxmax core:fxmax (a b ...) nocheck)
(define-fx min fxmin core:fxmin (a b ...) nocheck)
(define-fx + fx+ core:fx+ (a b) check)
(define-fx * fx* core:fx* (a b) check)

43
collects/rnrs/arithmetic/flonums-6.ss
View File

@ -6,6 +6,7 @@
[integer? r6rs:integer?]
finite? infinite? nan?)
(prefix-in core: scheme/flonum)
scheme/fixnum
(only-in rnrs/arithmetic/fixnums-6
fixnum?)
rnrs/conditions-6
@ -17,8 +18,7 @@
fldenominator
fllog (rename-out [core:flsqrt flsqrt]) flexpt
&no-infinities make-no-infinities-violation no-infinities-violation?
&no-nans make-no-nans-violation no-nans-violation?
fixnum->flonum)
&no-nans make-no-nans-violation no-nans-violation?)
;; More provided via macros
(define-inliner define-fl inexact-real? "flonum")
@ -39,8 +39,8 @@
(define-fl infinite? flinfinite? #f (a) nocheck)
(define-fl nan? flnan? #f (a) nocheck)
(define-fl max flmax #f (a b ...) nocheck)
(define-fl min flmin #f (a b ...) nocheck)
(define-fl max flmax core:flmax (a b ...) nocheck)
(define-fl min flmin core:flmin (a b ...) nocheck)
(define-fl + fl+ core:fl+ (a b ...) nocheck)
(define-fl * fl* core:fl* (a b ...) nocheck)
@ -83,30 +83,24 @@
1.0)
(raise-type-error 'fldenominator "flonum" c)))
(define-fl floor flfloor #f (a) nocheck)
(define-fl ceiling flceiling #f (a) nocheck)
(define-fl truncate fltruncate #f (a) nocheck)
(define-fl round flround #f (a) nocheck)
(define-fl exp flexp #f (a) nocheck)
(provide (rename-out [core:flfloor flfloor]
[core:flceiling flceiling]
[core:flround flround]
[core:fltruncate fltruncate]
[core:flexp flexp]))
(define fllog
(case-lambda
[(v)
(unless (inexact-real? v)
(raise-type-error 'fllog "flonum" v))
(let ([v (log v)])
(if (inexact-real? v)
v
+nan.0))]
[(v) (core:fllog v)]
[(v1 v2)
(/ (fllog v1) (fllog v2))]))
(define-fl sin flsin #f (a) nocheck)
(define-fl cos flcos #f (a) nocheck)
(define-fl tan fltan #f (a) nocheck)
(define-fl asin flasin #f (a) nocheck)
(define-fl acos flacos #f (a) nocheck)
(provide (rename-out [core:flsin flsin]
[core:flcos flcos]
[core:fltan fltan]
[core:flasin flasin]
[core:flacos flacos]))
(define-fl atan flatan #f [(a) (a b)] nocheck)
(define (flexpt a b)
@ -133,7 +127,4 @@
(raise-type-error 'real->flonum "real" r))
(exact->inexact r))
(define (fixnum->flonum fx)
(if (fixnum? fx)
(exact->inexact fx)
(raise-type-error 'fixnum->flonum "fixnum" fx)))
(provide (rename-out [fx->fl fixnum->flonum]))

5
collects/scheme/fixnum.ss
View File

@ -4,7 +4,8 @@
(provide fx->fl
fxabs
fx+ fx- fx*
fxquotient fxremainder
fxquotient fxremainder fxmodulo
fxand fxior fxxor
fxnot fxrshift fxlshift
fx>= fx> fx= fx< fx<=)
fx>= fx> fx= fx< fx<=
fxmin fxmax)

6
collects/scheme/flonum.ss
View File

@ -2,8 +2,10 @@
(require '#%flfxnum)
(provide fl+ fl- fl* fl/
flabs flsqrt
fl= fl< fl<= fl> fl>=
flabs flsqrt flexp fllog
flsin flcos fltan flasin flacos flatan
flfloor flceiling flround fltruncate
fl= fl< fl<= fl> fl>= flmin flmax
->fl
flvector? flvector make-flvector
flvector-length flvector-ref flvector-set!)

11
collects/scheme/unsafe/ops.ss
View File

@ -1,5 +1,10 @@
#lang scheme/base
(require '#%unsafe)
(provide (all-from-out '#%unsafe))
(require '#%unsafe
'#%flfxnum)
(provide (all-from-out '#%unsafe)
(prefix-out unsafe-
(combine-out flsin flcos fltan
flasin flacos flatan
fltruncate flround flfloor flceiling
flexp fllog)))

68
collects/scribblings/reference/numbers.scrbl
View File

@ -240,13 +240,13 @@ otherwise.}
@defproc[(remainder [n integer?] [m integer?]) integer?]{ Returns
@scheme[q] with the same sign as @scheme[n] such that
@scheme[_q] with the same sign as @scheme[n] such that
@itemize[
@item{@scheme[(abs q)] is between @scheme[0] (inclusive) and @scheme[(abs m)] (exclusive), and}
@item{@scheme[(abs _q)] is between @scheme[0] (inclusive) and @scheme[(abs m)] (exclusive), and}
@item{@scheme[(+ q (* m (quotient n m)))] equals @scheme[n].}
@item{@scheme[(+ _q (* m (quotient n m)))] equals @scheme[n].}
]
@ -263,13 +263,13 @@ otherwise.}
@defproc[(modulo [n integer?] [m integer?]) number?]{ Returns
@scheme[q] with the same sign as @scheme[m] where
@scheme[_q] with the same sign as @scheme[m] where
@itemize[
@item{@scheme[(abs q)] is between @scheme[0] (inclusive) and @scheme[(abs m)] (exclusive), and}
@item{@scheme[(abs _q)] is between @scheme[0] (inclusive) and @scheme[(abs m)] (exclusive), and}
@item{the difference between @scheme[q] and @scheme[(- n (* m (quotient n m)))] is a multiple of @scheme[m].}
@item{the difference between @scheme[_q] and @scheme[(- n (* m (quotient n m)))] is a multiple of @scheme[m].}
]
@ -878,13 +878,11 @@ they are as safe as generic operations like @scheme[+].
@defproc[(fl* [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(fl/ [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(flabs [a inexact-real?]) inexact-real?]
@defproc[(flsqrt [a inexact-real?]) inexact-real?]
)]{
Like @scheme[+], @scheme[-], @scheme[*], @scheme[/], @scheme[abs], and
@scheme[sqrt], but constrained to consume @tech{flonums}. The result
is always a @tech{flonum}. If a negative number is provided to
@scheme[sqrt], the result is @scheme[+nan.0].}
Like @scheme[+], @scheme[-], @scheme[*], @scheme[/], and @scheme[abs],
but constrained to consume @tech{flonums}. The result is always a
@tech{flonum}.}
@deftogether[(
@defproc[(fl= [a inexact-real?][b inexact-real?]) boolean?]
@ -892,10 +890,43 @@ is always a @tech{flonum}. If a negative number is provided to
@defproc[(fl> [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(fl<= [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(fl>= [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(flmin [a inexact-real?]) inexact-real?]
@defproc[(flmax [a inexact-real?]) inexact-real?]
)]{
Like @scheme[=], @scheme[<], @scheme[>], @scheme[<=], and @scheme[>=],
but constrained to consume @tech{flonums}.}
Like @scheme[=], @scheme[<], @scheme[>], @scheme[<=], @scheme[>=],
@scheme[min], and @scheme[max], but constrained to consume
@tech{flonums}.}
@deftogether[(
@defproc[(flround [a inexact-real?]) inexact-real?]
@defproc[(flfloor [a inexact-real?]) inexact-real?]
@defproc[(flceiling [a inexact-real?]) inexact-real?]
@defproc[(fltruncate [a inexact-real?]) inexact-real?]
)]{
Like @scheme[round], @scheme[floor], @scheme[ceiling], and
@scheme[truncate], but constrained to consume @tech{flonums}.}
@deftogether[(
@defproc[(flsin [a inexact-real?]) inexact-real?]
@defproc[(flcos [a inexact-real?]) inexact-real?]
@defproc[(fltan [a inexact-real?]) inexact-real?]
@defproc[(flasin [a inexact-real?]) inexact-real?]
@defproc[(flacos [a inexact-real?]) inexact-real?]
@defproc[(flatan [a inexact-real?]) inexact-real?]
@defproc[(fllog [a inexact-real?]) inexact-real?]
@defproc[(flexp [a inexact-real?]) inexact-real?]
@defproc[(flsqrt [a inexact-real?]) inexact-real?]
)]{
Like @scheme[sin], @scheme[cos], @scheme[tan], @scheme[asin],
@scheme[acos], @scheme[atan], @scheme[log], @scheme[exp], and
@scheme[flsqrt], but constrained to consume and produce
@tech{flonums}. The result is @scheme[+nan.0] when a number outside
the range @scheme[-1.0] to @scheme[1.0] is given to @scheme[flasin] or
@scheme[flacos], or when a negative number is given to @scheme[fllog]
or @scheme[flsqrt].}
@defproc[(->fl [a exact-integer?]) inexact-real?]{
Like @scheme[exact->inexact], but constrained to consume exact integers,
@ -985,12 +1016,14 @@ the @schememodname[scheme/fixnum] library to help debug the problems.
@defproc[(fx* [a fixnum?][b fixnum?]) fixnum?]
@defproc[(fxquotient [a fixnum?][b fixnum?]) fixnum?]
@defproc[(fxremainder [a fixnum?][b fixnum?]) fixnum?]
@defproc[(fxmodulo [a fixnum?][b fixnum?]) fixnum?]
@defproc[(fxabs [a fixnum?]) fixnum?]
)]{
Safe versions of @scheme[unsafe-fx+], @scheme[unsafe-fx-],
@scheme[unsafe-fx*], @scheme[unsafe-fxquotient],
@scheme[unsafe-fxremainder], and @scheme[unsafe-fxabs]. The
@scheme[unsafe-fxremainder], @scheme[unsafe-fxmodulo], and
@scheme[unsafe-fxabs]. The
@exnraise[exn:fail:contract:non-fixnum-result] if the arithmetic
result would not be a fixnum.}
@ -1017,10 +1050,13 @@ result would not be a fixnum.}
@defproc[(fx> [a fixnum?][b fixnum?]) boolean?]
@defproc[(fx<= [a fixnum?][b fixnum?]) boolean?]
@defproc[(fx>= [a fixnum?][b fixnum?]) boolean?]
@defproc[(fxmin [a fixnum?][b fixnum?]) fixnum?]
@defproc[(fxmax [a fixnum?][b fixnum?]) fixnum?]
)]{
Safe versions of @scheme[unsafe-fx=], @scheme[unsafe-fx<], @scheme[unsafe-fx>],
@scheme[unsafe-fx<=], and @scheme[unsafe-fx>=].}
Safe versions of @scheme[unsafe-fx=], @scheme[unsafe-fx<],
@scheme[unsafe-fx>], @scheme[unsafe-fx<=], @scheme[unsafe-fx>=],
@scheme[unsafe-fxmin], and @scheme[unsafe-fxmax].}

61
collects/scribblings/reference/unsafe.scrbl
View File

@ -39,15 +39,17 @@ can be prevented by adjusting the code inspector (see
@defproc[(unsafe-fx* [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxquotient [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxremainder [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxmodulo [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxabs [a fixnum?]) fixnum?]
)]{
For @tech{fixnums}: Like @scheme[+], @scheme[-], @scheme[*],
@scheme[quotient], @scheme[remainder], and @scheme[abs], but constrained to consume
@tech{fixnums} and produce a @tech{fixnum} result. The mathematical
operation on @scheme[a] and @scheme[b] must be representable as a
@tech{fixnum}. In the case of @scheme[unsafe-fxquotient] and
@scheme[unsafe-fxremainder], @scheme[b] must not be @scheme[0].}
@scheme[quotient], @scheme[remainder], @scheme[modulo], and
@scheme[abs], but constrained to consume @tech{fixnums} and produce a
@tech{fixnum} result. The mathematical operation on @scheme[a] and
@scheme[b] must be representable as a @tech{fixnum}. In the case of
@scheme[unsafe-fxquotient], @scheme[unsafe-fxremainder], and
@scheme[unsafe-fxmodulo], @scheme[b] must not be @scheme[0].}
@deftogether[(
@ -78,11 +80,13 @@ represent a @tech{fixnum}, and the result is effectively
@defproc[(unsafe-fx> [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx<= [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx>= [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fxmin [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxmax [a fixnum?][b fixnum?]) fixnum?]
)]{
For @tech{fixnums}: Like @scheme[=], @scheme[<], @scheme[>],
@scheme[<=], and @scheme[>=], but constrained to consume
@tech{fixnums}.}
@scheme[<=], @scheme[>=], @scheme[min], and @scheme[max], but
constrained to consume @tech{fixnums}.}
@defproc[(unsafe-fx->fl [a fixnum?]) inexact-real?]{
@ -96,11 +100,10 @@ Unchecked version of @scheme[->fl].
@defproc[(unsafe-fl* [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-fl/ [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-flabs [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flsqrt [a inexact-real?]) inexact-real?]
)]{
For @tech{flonums}: Unchecked versions of @scheme[fl+], @scheme[fl-],
@scheme[fl*], @scheme[fl/], @scheme[flabs], and @scheme[flsqrt].}
@scheme[fl*], @scheme[fl/], and @scheme[flabs].}
@deftogether[(
@ -109,11 +112,45 @@ For @tech{flonums}: Unchecked versions of @scheme[fl+], @scheme[fl-],
@defproc[(unsafe-fl> [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl<= [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl>= [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-flmin [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flmax [a inexact-real?]) inexact-real?]
)]{
For @tech{flonums}: Unchecked versions of @scheme[fl=],
@scheme[fl<], @scheme[fl>], @scheme[fl<=], and @scheme[fl>=], but constrained
to consume @tech{flonums}.}
For @tech{flonums}: Unchecked versions of @scheme[fl=], @scheme[fl<],
@scheme[fl>], @scheme[fl<=], @scheme[fl>=], @scheme[flmin], and
@scheme[flmax].}
@deftogether[(
@defproc[(unsafe-flround [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flfloor [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flceiling [a inexact-real?]) inexact-real?]
@defproc[(unsafe-fltruncate [a inexact-real?]) inexact-real?]
)]{
For @tech{flonums}: Unchecked (potentially) versions of
@scheme[flround], @scheme[flfloor], @scheme[flceiling], and
@scheme[fltruncate]. Currently, these bindings are simply aliases for
the corresponding safe bindings.}
@deftogether[(
@defproc[(unsafe-flsin [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flcos [a inexact-real?]) inexact-real?]
@defproc[(unsafe-fltan [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flasin [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flacos [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flatan [a inexact-real?]) inexact-real?]
@defproc[(unsafe-fllog [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flexp [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flsqrt [a inexact-real?]) inexact-real?]
)]{
For @tech{flonums}: Unchecked (potentially) versions of
@scheme[flsin], @scheme[flcos], @scheme[fltan], @scheme[flasin],
@scheme[flacos], @scheme[flatan], @scheme[fllog], @scheme[flexp], and
@scheme[flsqrt]. Currently, some of these bindings are simply aliases
for the corresponding safe bindings.}
@section{Unsafe Data Extraction}

5
collects/tests/mzscheme/fixnum.ss
View File

@ -16,6 +16,7 @@
(list fxquotient unsafe-fxquotient)
(list fxremainder unsafe-fxremainder)
(list fxmodulo unsafe-fxmodulo)
(list fxand unsafe-fxand)
(list fxior unsafe-fxior)
@ -25,7 +26,9 @@
(list fx> unsafe-fx>)
(list fx= unsafe-fx=)
(list fx<= unsafe-fx<=)
(list fx< unsafe-fx<)))
(list fx< unsafe-fx<)
(list fxmin unsafe-fxmin)
(list fxmax unsafe-fxmax)))
(define binary/small-second-arg-table
(list (list fxlshift unsafe-fxlshift)

3
collects/tests/mzscheme/number.ss
View File

@ -849,6 +849,7 @@
(err/rt-test (quotient 36.0+0.0i -7))
(test 0 quotient 0 5.0)
(test 0 quotient 0 -5.0)
(test (expt 2 30) quotient (- (expt 2 30)) -1)
(test 1 modulo 13 4)
(test 1 remainder 13 4)
(test 1.0 modulo 13 4.0)
@ -893,6 +894,8 @@
(test 0 modulo 0 -5.0)
(test 0 remainder 0 5.0)
(test 0 remainder 0 -5.0)
(test 0 modulo (- (expt 2 30)) -1)
(test 0 remainder (- (expt 2 30)) -1)
(define (divtest n1 n2)
(= n1 (+ (* n2 (quotient n1 n2))
(remainder n1 n2))))

34
collects/tests/mzscheme/optimize.ss
View File

@ -313,6 +313,19 @@
(un-exact 3.0 'flsqrt 9.0)
(un-exact +nan.0 'flsqrt -9.0)
(let ([test-trig
(lambda (trig fltrig)
(un (trig 1.0) fltrig 1.0)
(un +nan.0 fltrig +nan.0))])
(test-trig sin 'flsin)
(test-trig cos 'flcos)
(test-trig tan 'fltan)
(test-trig asin 'flasin)
(test-trig acos 'flacos)
(test-trig atan 'flatan)
(test-trig log 'fllog)
(test-trig exp 'flexp))
(un 1.0 'exact->inexact 1)
(un 1073741823.0 'exact->inexact (sub1 (expt 2 30)))
@ -376,6 +389,7 @@
(bin-exact 7 'quotient (* 7 (expt 2 100)) (expt 2 100))
(bin-exact 3 'fxquotient 10 3)
(bin-exact -3 'fxquotient 10 -3)
(bin-exact (expt 2 30) 'quotient (- (expt 2 30)) -1)
(bin-int 1 'remainder 10 3)
(bin-int 1 'remainder 10 -3)
@ -384,6 +398,18 @@
(bin-exact 7 'remainder (+ 7 (expt 2 100)) (expt 2 100))
(bin-exact 1 'fxremainder 10 3)
(bin-exact 1 'fxremainder 10 -3)
(bin-exact -1 'fxremainder -10 3)
(bin-exact -1 'fxremainder -10 -3)
(bin-int 1 'modulo 10 3)
(bin-int -2 'modulo 10 -3)
(bin-int -1 'modulo -10 -3)
(bin-int 2 'modulo -10 3)
(bin-exact 7 'modulo (+ 7 (expt 2 100)) (expt 2 100))
(bin-exact 1 'fxmodulo 10 3)
(bin-exact -2 'fxmodulo 10 -3)
(bin-exact -1 'fxmodulo -10 -3)
(bin-exact 2 'fxmodulo -10 3)
(bin 3 'min 3 300)
(bin -300 'min 3 -300)
@ -391,6 +417,10 @@
(tri 5 'min (lambda () 10) 5 20 void)
(tri 5 'min (lambda () 5) 10 20 void)
(tri 5 'min (lambda () 20) 10 5 void)
(bin-exact 3.0 'flmin 3.0 4.5)
(bin-exact 2.5 'flmin 3.0 2.5)
(bin-exact 30 'fxmin 30 45)
(bin-exact 25 'fxmin 30 25)
(bin 300 'max 3 300)
(bin 3 'max 3 -300)
@ -398,6 +428,10 @@
(tri 50 'max (lambda () 10) 50 20 void)
(tri 50 'max (lambda () 50) 10 20 void)
(tri 50 'max (lambda () 20) 10 50 void)
(bin-exact 4.5 'flmax 3.0 4.5)
(bin-exact 3.0 'flmax 3.0 2.5)
(bin-exact 45 'fxmax 30 45)
(bin-exact 30 'fxmax 30 25)
(bin-exact 11 'bitwise-and 11 43)
(bin-exact 0 'bitwise-and 11 32)

15
collects/tests/mzscheme/unsafe.ss
View File

@ -88,6 +88,12 @@
(test-bin #t unsafe-fx>= 2 2)
(test-bin #t unsafe-fx>= 2 1)
(test-bin 3 unsafe-fxmin 3 30)
(test-bin -30 unsafe-fxmin 3 -30)
(test-bin 30 unsafe-fxmax 3 30)
(test-bin 3 unsafe-fxmax 3 -30)
(test-bin 7.9 'unsafe-fl- 10.0 2.1)
(test-bin 3.7 'unsafe-fl- 1.0 -2.7)
@ -135,6 +141,15 @@
(test-un 8.0 'unsafe-fx->fl 8)
(test-un -8.0 'unsafe-fx->fl -8)
(test-bin 3.7 'unsafe-flmin 3.7 4.1)
(test-bin 2.1 'unsafe-flmin 3.7 2.1)
(test-bin +nan.0 'unsafe-flmin +nan.0 2.1)
(test-bin +nan.0 'unsafe-flmin 2.1 +nan.0)
(test-bin 3.7 'unsafe-flmax 3.7 2.1)
(test-bin 4.1 'unsafe-flmax 3.7 4.1)
(test-bin +nan.0 'unsafe-flmax +nan.0 2.1)
(test-bin +nan.0 'unsafe-flmax 2.1 +nan.0)
;; test unboxing:
(test-tri 9.0 '(lambda (x y z) (unsafe-fl+ (unsafe-fl- x z) y)) 4.5 7.0 2.5)
(test-tri 9.0 '(lambda (x y z) (unsafe-fl+ y (unsafe-fl- x z))) 4.5 7.0 2.5)

3
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 4.2.3.10
Added more fl and fx operations
Version 4.2.3.8
Added scheme/flonum; moved flvector operations to scheme/flonum

1298
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

48
src/mzscheme/src/eval.c
View File

@ -2849,13 +2849,27 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_m
|| IS_NAMED_PRIM(rator, "unsafe-fl=")
|| IS_NAMED_PRIM(rator, "unsafe-fl>")
|| IS_NAMED_PRIM(rator, "unsafe-fl>=")
|| IS_NAMED_PRIM(rator, "unsafe-flmin")
|| IS_NAMED_PRIM(rator, "unsafe-flmax")
|| (rotate_mode && IS_NAMED_PRIM(rator, "unsafe-flvector-ref"))
|| (rotate_mode && IS_NAMED_PRIM(rator, "unsafe-fx->fl")))
return 1;
} else if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNARY_INLINED) {
if (!rotate_mode) {
if (IS_NAMED_PRIM(rator, "flabs")
|| IS_NAMED_PRIM(rator, "flsqrt"))
|| IS_NAMED_PRIM(rator, "flsqrt")
|| IS_NAMED_PRIM(rator, "fltruncate")
|| IS_NAMED_PRIM(rator, "flround")
|| IS_NAMED_PRIM(rator, "flfloor")
|| IS_NAMED_PRIM(rator, "flceiling")
|| IS_NAMED_PRIM(rator, "flsin")
|| IS_NAMED_PRIM(rator, "flcos")
|| IS_NAMED_PRIM(rator, "fltan")
|| IS_NAMED_PRIM(rator, "flasin")
|| IS_NAMED_PRIM(rator, "flacos")
|| IS_NAMED_PRIM(rator, "flatan")
|| IS_NAMED_PRIM(rator, "fllog")
|| IS_NAMED_PRIM(rator, "flexp"))
return 1;
}
} else if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_BINARY_INLINED) {
@ -2868,7 +2882,8 @@ int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_m
|| IS_NAMED_PRIM(rator, "fl<=")
|| IS_NAMED_PRIM(rator, "fl=")
|| IS_NAMED_PRIM(rator, "fl>")
|| IS_NAMED_PRIM(rator, "fl>="))
|| IS_NAMED_PRIM(rator, "flmin")
|| IS_NAMED_PRIM(rator, "flmax"))
return 1;
}
} else if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_NARY_INLINED) {
@ -2896,6 +2911,8 @@ static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc, in
|| IS_NAMED_PRIM(rator, "unsafe-fl-")
|| IS_NAMED_PRIM(rator, "unsafe-fl*")
|| IS_NAMED_PRIM(rator, "unsafe-fl/")
|| IS_NAMED_PRIM(rator, "unsafe-flmin")
|| IS_NAMED_PRIM(rator, "unsafe-flmax")
|| (for_args
&& (IS_NAMED_PRIM(rator, "unsafe-fl<")
|| IS_NAMED_PRIM(rator, "unsafe-fl<=")
@ -2910,7 +2927,19 @@ static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc, in
}
} else if ((argc == 1) && (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {
if (IS_NAMED_PRIM(rator, "flabs")
|| IS_NAMED_PRIM(rator, "flsqrt"))
|| IS_NAMED_PRIM(rator, "flsqrt")
|| IS_NAMED_PRIM(rator, "fltruncate")
|| IS_NAMED_PRIM(rator, "flround")
|| IS_NAMED_PRIM(rator, "flfloor")
|| IS_NAMED_PRIM(rator, "flceiling")
|| IS_NAMED_PRIM(rator, "flsin")
|| IS_NAMED_PRIM(rator, "flcos")
|| IS_NAMED_PRIM(rator, "fltan")
|| IS_NAMED_PRIM(rator, "flasin")
|| IS_NAMED_PRIM(rator, "flacos")
|| IS_NAMED_PRIM(rator, "flatan")
|| IS_NAMED_PRIM(rator, "fllog")
|| IS_NAMED_PRIM(rator, "flexp"))
return 1;
if (IS_NAMED_PRIM(rator, "->fl")) {
if (non_fl_args) *non_fl_args = 1;
@ -2923,11 +2952,14 @@ static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc, in
|| IS_NAMED_PRIM(rator, "fl-")
|| IS_NAMED_PRIM(rator, "fl*")
|| IS_NAMED_PRIM(rator, "fl/")
|| IS_NAMED_PRIM(rator, "fl<")
|| IS_NAMED_PRIM(rator, "fl<=")
|| IS_NAMED_PRIM(rator, "fl=")
|| IS_NAMED_PRIM(rator, "fl>")
|| IS_NAMED_PRIM(rator, "fl>="))
|| IS_NAMED_PRIM(rator, "flmin")
|| IS_NAMED_PRIM(rator, "flmax")
|| (for_args
&& (IS_NAMED_PRIM(rator, "fl<")
|| IS_NAMED_PRIM(rator, "fl<=")
|| IS_NAMED_PRIM(rator, "fl=")
|| IS_NAMED_PRIM(rator, "fl>")
|| IS_NAMED_PRIM(rator, "fl>="))))
return 1;
if (IS_NAMED_PRIM(rator, "flvector-ref")) {
if (non_fl_args) *non_fl_args = 1;

269
src/mzscheme/src/jit.c
View File

@ -4078,7 +4078,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
return is_tail ? 2 : 1;
}
static int is_inline_unboxable_op(Scheme_Object *obj, int flag, int unsafely)
static int is_inline_unboxable_op(Scheme_Object *obj, int flag, int unsafely, int just_checking_result)
{
if (!SCHEME_PRIMP(obj))
return 0;
@ -4091,6 +4091,8 @@ static int is_inline_unboxable_op(Scheme_Object *obj, int flag, int unsafely)
if (IS_NAMED_PRIM(obj, "unsafe-fl/")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-flabs")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-flsqrt")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-flmin")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-flmax")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-fx->fl")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-f64vector-ref")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-flvector-ref")) return 1;
@ -4104,6 +4106,23 @@ static int is_inline_unboxable_op(Scheme_Object *obj, int flag, int unsafely)
if (IS_NAMED_PRIM(obj, "fl/")) return 1;
if (IS_NAMED_PRIM(obj, "flabs")) return 1;
if (IS_NAMED_PRIM(obj, "flsqrt")) return 1;
if (IS_NAMED_PRIM(obj, "flmin")) return 1;
if (IS_NAMED_PRIM(obj, "flmax")) return 1;
if (just_checking_result) {
if (IS_NAMED_PRIM(obj, "flfloor")) return 1;
if (IS_NAMED_PRIM(obj, "flceiling")) return 1;
if (IS_NAMED_PRIM(obj, "fltruncate")) return 1;
if (IS_NAMED_PRIM(obj, "flround")) return 1;
if (IS_NAMED_PRIM(obj, "flsin")) return 1;
if (IS_NAMED_PRIM(obj, "flcos")) return 1;
if (IS_NAMED_PRIM(obj, "fltan")) return 1;
if (IS_NAMED_PRIM(obj, "flasin")) return 1;
if (IS_NAMED_PRIM(obj, "flacos")) return 1;
if (IS_NAMED_PRIM(obj, "flatan")) return 1;
if (IS_NAMED_PRIM(obj, "fllog")) return 1;
if (IS_NAMED_PRIM(obj, "flexp")) return 1;
}
}
return 0;
@ -4116,7 +4135,7 @@ static int generate_pop_unboxed(mz_jit_state *jitter)
to pop them off before escaping. */
int i;
for (i = jitter->unbox_depth; i--; ) {
FUCOMPr(1); /* compare with single pop; we ignore the compare result, of course */
FSTPr(0);
}
CHECK_LIMIT();
#endif
@ -4161,14 +4180,14 @@ static int can_unbox_inline(Scheme_Object *obj, int fuel, int regs, int unsafely
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)obj;
if (!is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED, unsafely))
if (!is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED, unsafely, 0))
return 0;
return can_unbox_inline(app->rand, fuel - 1, regs, unsafely);
}
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)obj;
if (!is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, unsafely))
if (!is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, unsafely, 0))
return 0;
if (IS_NAMED_PRIM(app->rator, "unsafe-f64vector-ref")
|| IS_NAMED_PRIM(app->rator, "unsafe-flvector-ref")) {
@ -4197,7 +4216,7 @@ static int can_unbox_directly(Scheme_Object *obj)
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)obj;
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED, 1))
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_UNARY_INLINED, 1, 1))
return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {
@ -4210,7 +4229,7 @@ static int can_unbox_directly(Scheme_Object *obj)
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)obj;
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, 1))
if (is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, 1, 1))
return 1;
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED)) {
@ -4310,7 +4329,8 @@ static int can_fast_double(int arith, int cmp, int two_args)
|| (arith == -2)
|| (arith == 11)
|| (arith == 12)
|| (arith == 13))
|| (arith == 13)
|| (arith == 14))
return 1;
#endif
#ifdef INLINE_FP_COMP
@ -4362,11 +4382,31 @@ static int can_fast_double(int arith, int cmp, int two_args)
#define jit_beqr_d_fppop(d, s1, s2) jit_beqr_d(d, s1, s2)
#define jit_bantieqr_d_fppop(d, s1, s2) jit_bantieqr_d(d, s1, s2)
#define jit_extr_l_d_fppush(rd, rs) jit_extr_l_d(rd, rs)
#define jit_movr_d_rel(rd, rs) jit_movr_d(rd, rs)
#define R0_FP_ADJUST(x) /* empty */
#else
#define R0_FP_ADJUST(x) x
#endif
#ifdef CAN_INLINE_ALLOC
# ifdef JIT_USE_FP_OPS
#define DECL_FP_GLUE(op) static void call_ ## op(void) { save_fp = scheme_double_ ## op(save_fp); }
DECL_FP_GLUE(sin)
DECL_FP_GLUE(cos)
DECL_FP_GLUE(tan)
DECL_FP_GLUE(asin)
DECL_FP_GLUE(acos)
DECL_FP_GLUE(atan)
DECL_FP_GLUE(exp)
DECL_FP_GLUE(log)
DECL_FP_GLUE(floor)
DECL_FP_GLUE(ceiling)
DECL_FP_GLUE(truncate)
DECL_FP_GLUE(round)
typedef void (*call_fp_proc)(void);
# endif
#endif
#if defined(MZ_USE_JIT_I386)
# define mz_movi_d_fppush(rd,immd,tmp) { GC_CAN_IGNORE void *addr; addr = mz_retain_double(jitter, immd); \
(void)jit_patchable_movi_p(tmp, addr); \
@ -4406,7 +4446,8 @@ static int generate_alloc_double(mz_jit_state *jitter, int inline_retry)
return 1;
}
static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int reversed, int two_args, int second_const,
static int generate_double_arith(mz_jit_state *jitter, Scheme_Object *rator,
int arith, int cmp, int reversed, int two_args, int second_const,
jit_insn **_refd, jit_insn **_refdt, Branch_Info *for_branch,
int branch_short, int unsafe_fl, int unboxed, int unboxed_result)
/* Unless unboxed, first arg is in JIT_R1, second in JIT_R0.
@ -4416,7 +4457,7 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
{
#if defined(INLINE_FP_OPS) || defined(INLINE_FP_COMP)
GC_CAN_IGNORE jit_insn *ref8, *ref9, *ref10, *refd, *refdt;
int no_alloc = unboxed_result;
int no_alloc = unboxed_result, need_post_pop = 0;
if (!unsafe_fl) {
/* Maybe they're doubles */
@ -4460,6 +4501,8 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
/* abs needs no extra number */
} else if (arith == 13) {
/* sqrt needs no extra number */
} else if (arith == 14) {
/* flround, flsin, etc. needs no extra number */
} else if (arith == 12) {
/* exact->inexact needs no extra number */
} else {
@ -4515,19 +4558,35 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
__START_TINY_JUMPS__(1);
/* If R0 is nan, then copy to R1, ensuring nan result */
refn = jit_beqr_d(jit_forward(), fpr0, fpr0);
jit_movr_p(JIT_R1, JIT_R0);
if (unboxed)
jit_movr_d_rel(fpr1, fpr0);
else
jit_movr_p(JIT_R1, JIT_R0);
mz_patch_branch(refn);
if (arith == 9) {
refc = jit_bltr_d_fppop(jit_forward(), fpr0, fpr1);
if (unboxed) {
refc = jit_bltr_d(jit_forward(), fpr0, fpr1);
} else {
refc = jit_bltr_d_fppop(jit_forward(), fpr0, fpr1);
}
} else {
refc = jit_bger_d_fppop(jit_forward(), fpr0, fpr1);
if (unboxed) {
refc = jit_bger_d(jit_forward(), fpr0, fpr1);
} else {
refc = jit_bger_d_fppop(jit_forward(), fpr0, fpr1);
}
}
jit_movr_p(JIT_R0, JIT_R1);
if (unboxed) {
jit_movr_d_rel(fpr0, fpr1);
need_post_pop = 1;
} else
jit_movr_p(JIT_R0, JIT_R1);
mz_patch_branch(refc);
__END_TINY_JUMPS__(1);
/* no unsafe version of `min' and `max', so we never need an
unboxed result, but we've already set JIT_R0 */
no_alloc = 1;
if (!unboxed) {
/* we've already set JIT_R0 */
no_alloc = 1;
}
}
break;
case 11: /* abs */
@ -4539,6 +4598,48 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
case 13: /* sqrt */
jit_sqrt_d_fppop(fpr0, fpr0);
break;
#ifdef CAN_INLINE_ALLOC
# ifdef JIT_USE_FP_OPS
case 14: /* flfloor, flsin, etc. */
{
call_fp_proc f;
if (IS_NAMED_PRIM(rator, "flsin"))
f = call_sin;
else if (IS_NAMED_PRIM(rator, "flcos"))
f = call_cos;
else if (IS_NAMED_PRIM(rator, "fltan"))
f = call_tan;
else if (IS_NAMED_PRIM(rator, "flasin"))
f = call_asin;
else if (IS_NAMED_PRIM(rator, "flacos"))
f = call_acos;
else if (IS_NAMED_PRIM(rator, "flatan"))
f = call_atan;
else if (IS_NAMED_PRIM(rator, "flexp"))
f = call_exp;
else if (IS_NAMED_PRIM(rator, "fllog"))
f = call_log;
else if (IS_NAMED_PRIM(rator, "flfloor"))
f = call_floor;
else if (IS_NAMED_PRIM(rator, "flceiling"))
f = call_ceiling;
else if (IS_NAMED_PRIM(rator, "fltruncate"))
f = call_truncate;
else if (IS_NAMED_PRIM(rator, "flround"))
f = call_round;
else {
scheme_signal_error("internal error: unknown flonum function");
f = NULL;
}
(void)mz_tl_sti_d_fppop(tl_save_fp, JIT_FPR0, JIT_R2);
mz_prepare(0);
mz_finish(f);
(void)mz_tl_ldi_d_fppush(JIT_FPR0, tl_save_fp, JIT_R2);
}
break;
# endif
#endif
default:
break;
}
@ -4548,6 +4649,10 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
mz_rs_sync(); /* needed if arguments were unboxed */
generate_alloc_double(jitter, 0);
CHECK_LIMIT();
#if defined(MZ_USE_JIT_I386)
if (need_post_pop)
FSTPr(0);
#endif
} else if (unboxed_result) {
jitter->unbox_depth++;
}
@ -4641,6 +4746,24 @@ static int check_flonum_result(mz_jit_state *jitter, int reg, void *fail_code, S
return 1;
}
static void generate_modulo_setup(mz_jit_state *jitter, int branch_short, int a1, int a2)
/* r1 has two flags: bit 0 means two args have different sign; bit 1 means second arg is negative */
{
GC_CAN_IGNORE jit_insn *refx;
jit_movi_l(JIT_R1, 0x0);
__START_INNER_TINY__(branch_short);
refx = jit_bgei_l(jit_forward(), a1, 0);
jit_negr_l(a1, a1);
jit_movi_l(JIT_R1, 0x1);
mz_patch_branch(refx);
refx = jit_bgei_l(jit_forward(), a2, 0);
jit_xori_l(JIT_R1, JIT_R1, 0x3);
jit_negr_l(a2, a2);
mz_patch_branch(refx);
__END_INNER_TINY__(branch_short);
}
static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2,
int orig_args, int arith, int cmp, int v,
Branch_Info *for_branch, int branch_short,
@ -4653,6 +4776,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
arith = -2 -> /
arith = -3 -> quotient
arith = -4 -> remainder
arith = -5 -> modulo
arith = 3 -> bitwise-and
arith = 4 -> bitwise-ior
arith = 5 -> bitwise-xor
@ -4664,6 +4788,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
arith = 11 -> abs
arith = 12 -> exact->inexact
arith = 13 -> sqrt
arith = 14 -> unary floating-point op (consult `rator')
cmp = 0 -> = or zero?
cmp = +/-1 -> >=/<=
cmp = +/-2 -> >/< or positive/negative?
@ -4710,7 +4835,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
#endif
) {
/* Unboxed (and maybe unsafe) floating-point ops. */
int args_unboxed = ((arith != 9) && (arith != 10));
int args_unboxed = (((arith != 9) && (arith != 10)) || rand);
int flonum_depth, fl_reversed = 0, can_direct1, can_direct2;
if (inlined_flonum1 && inlined_flonum2) /* safe can be implemented as unsafe */
@ -4824,7 +4949,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
if (for_branch)
mz_rs_sync(); /* needed if arguments were unboxed */
generate_double_arith(jitter, arith, cmp, reversed, !!rand2, 0,
generate_double_arith(jitter, rator, arith, cmp, reversed, !!rand2, 0,
&refd, &refdt, for_branch, branch_short, 1,
args_unboxed, jitter->unbox);
CHECK_LIMIT();
@ -4985,7 +5110,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
&& can_fast_double(arith, cmp, 1))) {
/* Maybe they're both doubles... */
if (unsafe_fl) mz_rs_sync();
generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt,
generate_double_arith(jitter, rator, arith, cmp, reversed, 1, 0, &refd, &refdt,
for_branch, branch_short, unsafe_fl, 0, 0);
CHECK_LIMIT();
}
@ -5035,7 +5160,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
if (unsafe_fl || (!unsafe_fx && has_flonum_fast && can_fast_double(arith, cmp, 1))) {
/* Maybe they're both doubles... */
if (unsafe_fl) mz_rs_sync();
generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt,
generate_double_arith(jitter, rator, arith, cmp, reversed, 1, 0, &refd, &refdt,
for_branch, branch_short, unsafe_fl, 0, 0);
CHECK_LIMIT();
}
@ -5083,7 +5208,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
/* watch out: divide by 0 is special: */
&& ((arith != -2) || v || reversed))) {
/* Maybe it's a double... */
generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt,
generate_double_arith(jitter, rator, arith, cmp, reversed, 0, v, &refd, &refdt,
for_branch, branch_short, unsafe_fl, 0, 0);
CHECK_LIMIT();
}
@ -5119,7 +5244,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
if (!unsafe_fl) {
if (arith) {
if (((arith == -3) || (arith == -4)) && !rand2) {
if (((arith == -3) || (arith == -4) || (arith == -5)) && !rand2) {
(void)jit_movi_p(JIT_R1, scheme_make_integer(v));
rand2 = scheme_true;
reversed = !reversed;
@ -5163,13 +5288,17 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
/* No fast path for fixnum division, yet */
(void)jit_jmpi(refslow);
}
} else if ((arith == -3) || (arith == -4)) {
/* -3 : quotient -4 : remainder */
} else if ((arith == -3) || (arith == -4) || (arith == -5)) {
/* -3 : quotient -4 : remainder -5 : modulo */
jit_rshi_l(JIT_V1, JIT_R0, 0x1);
jit_rshi_l(JIT_R2, JIT_R1, 0x1);
if (reversed) {
if (!unsafe_fx || overflow_refslow)
(void)jit_beqi_l(refslow, JIT_R2, 0);
if (arith == -5) {
generate_modulo_setup(jitter, branch_short, JIT_V1, JIT_R2);
CHECK_LIMIT();
}
if (arith == -3)
jit_divr_l(JIT_R0, JIT_V1, JIT_R2);
else
@ -5177,11 +5306,51 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
} else {
if (!unsafe_fx || overflow_refslow)
(void)jit_beqi_l(refslow, JIT_V1, 0);
if (arith == -5) {
generate_modulo_setup(jitter, branch_short, JIT_R2, JIT_V1);
CHECK_LIMIT();
}
if (arith == -3)
jit_divr_l(JIT_R0, JIT_R2, JIT_V1);
else
jit_modr_l(JIT_R0, JIT_R2, JIT_V1);
}
if (arith == -5) {
GC_CAN_IGNORE jit_insn *refx, *refy;
__START_INNER_TINY__(branch_short);
refy = jit_beqi_l(jit_forward(), JIT_R0, 0);
refx = jit_bmci_l(jit_forward(), JIT_R1, 0x1);
if (reversed)
jit_subr_l(JIT_R0, JIT_R2, JIT_R0);
else
jit_subr_l(JIT_R0, JIT_V1, JIT_R0);
mz_patch_branch(refx);
refx = jit_bmci_l(jit_forward(), JIT_R1, 0x2);
jit_negr_l(JIT_R0, JIT_R0);
mz_patch_branch(refx);
mz_patch_branch(refy);
__END_INNER_TINY__(branch_short);
}
if (arith == -3) {
/* watch out for negation of most negative fixnum,
which is a positive number too big for a fixnum */
if (!unsafe_fx || overflow_refslow) {
GC_CAN_IGNORE jit_insn *refx;
__START_INNER_TINY__(branch_short);
refx = jit_bnei_l(jit_forward(), JIT_R0, (void *)(((long)1 << ((8 * JIT_WORD_SIZE) - 2))));
__END_INNER_TINY__(branch_short);
/* first argument must have been most negative fixnum,
second argument must have been -1: */
if (reversed)
jit_movi_p(JIT_R0, (void *)(((long)1 << ((8 * JIT_WORD_SIZE) - 1)) | 0x1));
else
jit_movi_p(JIT_R0, scheme_make_integer(-1));
(void)jit_jmpi(refslow);
__START_INNER_TINY__(branch_short);
mz_patch_branch(refx);
__END_INNER_TINY__(branch_short);
}
}
jit_lshi_l(JIT_R0, JIT_R0, 1);
jit_ori_l(JIT_R0, JIT_R0, 0x1);
} else if (arith == 3) {
@ -5827,6 +5996,8 @@ static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app,
if (!arith && for_branch) {
GC_CAN_IGNORE jit_insn *refx;
prepare_branch_jump(jitter, for_branch);
CHECK_LIMIT();
__START_SHORT_JUMPS__(branch_short);
refx = jit_beqi_p(jit_forward(), JIT_R0, scheme_false);
add_branch_false(for_branch, refx);
@ -6493,6 +6664,20 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "flsqrt")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 13, 0, 0, NULL, 1, 0, -1, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "flfloor")
|| IS_NAMED_PRIM(rator, "flceiling")
|| IS_NAMED_PRIM(rator, "flround")
|| IS_NAMED_PRIM(rator, "fltruncate")
|| IS_NAMED_PRIM(rator, "flsin")
|| IS_NAMED_PRIM(rator, "flcos")
|| IS_NAMED_PRIM(rator, "fltan")
|| IS_NAMED_PRIM(rator, "flasin")
|| IS_NAMED_PRIM(rator, "flacos")
|| IS_NAMED_PRIM(rator, "flatan")
|| IS_NAMED_PRIM(rator, "flexp")
|| IS_NAMED_PRIM(rator, "fllog")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 14, 0, 0, NULL, 1, 0, -1, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "exact->inexact")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 0, 0, NULL);
return 1;
@ -7106,18 +7291,51 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} else if (IS_NAMED_PRIM(rator, "remainder")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 0, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "modulo")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -5, 0, 0, NULL, 1, 0, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxremainder")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 1, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxmodulo")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -5, 0, 0, NULL, 1, 1, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "fxremainder")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, -1, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "fxmodulo")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, -5, 0, 0, NULL, 1, -1, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "min")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 0, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "max")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 0, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-flmin")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 0, 1, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-flmax")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 0, 1, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "flmin")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 0, -1, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "flmax")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 0, -1, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxmin")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 1, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxmax")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 1, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "fxmin")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, -1, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "fxmax")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, -1, 0, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "bitwise-and")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 0, 0, NULL);
return 1;
@ -7977,11 +8195,8 @@ int generate_inlined_test(mz_jit_state *jitter, Scheme_Object *obj, int branch_s
/* de-sync'd ok; syncs before jump */
{
switch (SCHEME_TYPE(obj)) {
#if 0
/* REMOVEME: need to fix this */
case scheme_application_type:
return generate_inlined_nary(jitter, (Scheme_App_Rec *)obj, 0, 0, for_branch, branch_short);
#endif
case scheme_application2_type:
return generate_inlined_unary(jitter, (Scheme_App2_Rec *)obj, 0, 0, for_branch, branch_short, need_sync);
case scheme_application3_type:

7
src/mzscheme/src/lightning/i386/fp.h
View File

@ -101,9 +101,10 @@
#define jit_movr_d(rd,s1) \
((s1) == (rd) ? 0 \
: (s1) == 0 ? FSTr ((rd)) \
: (rd) == 0 ? (FXCHr ((s1)), FSTr ((s1))) \
: (FLDr ((s1)), FSTr ((rd)+1)))
: (rd) == 0 ? (FSTPr(0), FSTr (((s1)-1))) \
: (FLDr ((s1)), FSTPr ((rd)+1)))
#define jit_movr_d_rel(rd,s1) ((rd < s1) ? (FSTPr(0), FLDr(0)) : (FSTr(1)))
/* - loads:

2
src/mzscheme/src/module.c
View File

@ -3113,7 +3113,7 @@ Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
for (j = 0; j < c; j++) {
SCHEME_VEC_ELS(naya)[j] = SCHEME_VEC_ELS(cvec)[j];
}
if (!sbm->shift_cache) {
if (0 && !sbm->shift_cache) {
sbm->cache_next = modidx_caching_chain;
modidx_caching_chain = sbm;
}

4
src/mzscheme/src/mzrt.c
View File

@ -166,7 +166,7 @@ void *mzrt_thread_stub(void *data){
scheme_init_os_thread();
proc_thread_self = stub_data->thread;
free(data);
//free(data); REMOVEME --- why does this break Mac OS X?
return start_proc(start_proc_data);
}
@ -214,7 +214,7 @@ mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* dat
stub_data->data = data;
stub_data->thread = thread;
# ifdef WIN32
thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL);
thread->threadid = CreateThread(NULL, 0, mzrt_thread_stub, stub_data, 0, NULL);
# else
pthread_create(&thread->threadid, attr, mzrt_thread_stub, stub_data);
# endif

74
src/mzscheme/src/numarith.c
View File

@ -40,6 +40,7 @@ static Scheme_Object *fx_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_mult (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[]);
@ -47,6 +48,7 @@ static Scheme_Object *unsafe_fx_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_mult (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[]);
static Scheme_Object *unsafe_fx_abs (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_plus (int argc, Scheme_Object *argv[]);
@ -122,11 +124,10 @@ void scheme_init_numarith(Scheme_Env *env)
2, 2,
2, 2),
env);
scheme_add_global_constant("modulo",
scheme_make_folding_prim(scheme_modulo,
"modulo",
2, 2, 1),
env);
p = scheme_make_folding_prim(scheme_modulo, "modulo", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("modulo", p, env);
}
void scheme_init_flfxnum_numarith(Scheme_Env *env)
@ -153,6 +154,10 @@ void scheme_init_flfxnum_numarith(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("fxremainder", p, env);
p = scheme_make_folding_prim(fx_mod, "fxmodulo", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("fxmodulo", p, env);
p = scheme_make_folding_prim(fx_abs, "fxabs", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("fxabs", p, env);
@ -218,6 +223,11 @@ void scheme_init_unsafe_numarith(Scheme_Env *env)
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-fxremainder", p, env);
p = scheme_make_folding_prim(unsafe_fx_mod, "unsafe-fxmodulo", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-fxmodulo", p, env);
p = scheme_make_folding_prim(unsafe_fx_abs, "unsafe-fxabs", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
@ -582,7 +592,9 @@ do_bin_quotient(const char *name, const Scheme_Object *n1, const Scheme_Object *
"%s: undefined for 0.0", name);
if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
return (scheme_make_integer (SCHEME_INT_VAL(n1) / SCHEME_INT_VAL(n2)));
/* Beware that most negative fixnum divided by -1
isn't a fixnum: */
return (scheme_make_integer_value(SCHEME_INT_VAL(n1) / SCHEME_INT_VAL(n2)));
}
if (SCHEME_DBLP(n1) || SCHEME_DBLP(n2)) {
Scheme_Object *r;
@ -781,9 +793,11 @@ rem_mod (int argc, Scheme_Object *argv[], char *name, int first_sign)
if (v) {
if (first_sign) {
/* remainder */
if (a < 0)
v = -v;
} else {
/* modulo */
int neg1, neg2;
neg1 = (a < 0);
@ -880,22 +894,30 @@ quotient_remainder(int argc, Scheme_Object *argv[])
/* Flfx */
/************************************************************************/
#define SAFE_FX(name, s_name, scheme_op) \
#define CHECK_SECOND_ZERO(name) \
if (!SCHEME_INT_VAL(argv[1])) \
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO, \
name ": undefined for 0");
#define SAFE_FX(name, s_name, scheme_op, EXTRA_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
Scheme_Object *o; \
if (!SCHEME_INTP(argv[0])) scheme_wrong_type(s_name, "fixnum", 0, argc, argv); \
if (!SCHEME_INTP(argv[1])) scheme_wrong_type(s_name, "fixnum", 1, argc, argv); \
EXTRA_CHECK \
o = scheme_op(argc, argv); \
if (!SCHEME_INTP(o)) scheme_non_fixnum_result(s_name, o); \
return o; \
}
SAFE_FX(fx_plus, "fx+", plus)
SAFE_FX(fx_minus, "fx-", minus)
SAFE_FX(fx_mult, "fx*", mult)
SAFE_FX(fx_div, "fxquotient", quotient)
SAFE_FX(fx_rem, "fxremainder", rem_prim)
SAFE_FX(fx_plus, "fx+", plus, )
SAFE_FX(fx_minus, "fx-", minus, )
SAFE_FX(fx_mult, "fx*", mult, )
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"))
static Scheme_Object *fx_abs(int argc, Scheme_Object *argv[])
{
@ -921,6 +943,34 @@ UNSAFE_FX(unsafe_fx_mult, *, mult)
UNSAFE_FX(unsafe_fx_div, /, quotient)
UNSAFE_FX(unsafe_fx_rem, %, rem_prim)
static Scheme_Object *unsafe_fx_mod(int argc, Scheme_Object *argv[])
{
int neg1, neg2;
long v, v1, av1, v2, av2;
if (scheme_current_thread->constant_folding) return scheme_modulo(argc, argv);
v1 = SCHEME_INT_VAL(argv[0]);
v2 = SCHEME_INT_VAL(argv[1]);
av1 = (v1 < 0) ? -v1 : v1;
av2 = (v2 < 0) ? -v2 : v2;
v = av1 % av2;
if (v) {
neg1 = (v1 < 0);
neg2 = (v2 < 0);
if (neg1 != neg2)
v = av2 - v;
if (neg2)
v = -v;
}
return scheme_make_integer(v);
}
static Scheme_Object *unsafe_fx_abs(int argc, Scheme_Object *argv[])
{
long v;

208
src/mzscheme/src/number.c
View File

@ -110,6 +110,19 @@ static Scheme_Object *fx_lshift (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_rshift (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_floor (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_ceiling (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_truncate (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_round (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_sin (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_cos (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_tan (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_asin (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_acos (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_atan (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_exp (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_log (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_and (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_or (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_xor (int argc, Scheme_Object *argv[]);
@ -588,6 +601,67 @@ void scheme_init_flfxnum_number(Scheme_Env *env)
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("fx->fl", p, env);
p = scheme_make_folding_prim(fl_truncate, "fltruncate", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("fltruncate", p, env);
p = scheme_make_folding_prim(fl_round, "flround", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flround", p, env);
p = scheme_make_folding_prim(fl_ceiling, "flceiling", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flceiling", p, env);
p = scheme_make_folding_prim(fl_floor, "flfloor", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flfloor", p, env);
p = scheme_make_folding_prim(fl_sin, "flsin", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flsin", p, env);
p = scheme_make_folding_prim(fl_cos, "flcos", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flcos", p, env);
p = scheme_make_folding_prim(fl_tan, "fltan", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("fltan", p, env);
p = scheme_make_folding_prim(fl_asin, "flasin", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flasin", p, env);
p = scheme_make_folding_prim(fl_acos, "flacos", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flacos", p, env);
p = scheme_make_folding_prim(fl_atan, "flatan", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flatan", p, env);
p = scheme_make_folding_prim(fl_log, "fllog", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("fllog", p, env);
p = scheme_make_folding_prim(fl_exp, "flexp", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("flexp", p, env);
}
void scheme_init_unsafe_number(Scheme_Env *env)
@ -1349,6 +1423,15 @@ ceiling (int argc, Scheme_Object *argv[])
ESCAPED_BEFORE_HERE;
}
XFORM_NONGCING static double SCH_TRUNC(double v)
{
if (v > 0)
v = floor(v);
else
v = ceil(v);
return v;
}
static Scheme_Object *
sch_truncate (int argc, Scheme_Object *argv[])
{
@ -1369,11 +1452,8 @@ sch_truncate (int argc, Scheme_Object *argv[])
}
#endif
if (t == scheme_double_type) {
double v = SCHEME_DBL_VAL(o);
if (v > 0)
v = floor(v);
else
v = ceil(v);
double v;
v = SCH_TRUNC(SCHEME_DBL_VAL(o));
return scheme_make_double(v);
}
if (t == scheme_bignum_type)
@ -1386,6 +1466,38 @@ sch_truncate (int argc, Scheme_Object *argv[])
ESCAPED_BEFORE_HERE;
}
XFORM_NONGCING static double SCH_ROUND(double d)
{
double i, frac;
int invert;
#ifdef FMOD_CAN_RETURN_POS_ZERO
if ((d == 0.0) && minus_zero_p(d))
return d;
#endif
if (d < 0) {
d = -d;
invert = 1;
} else
invert = 0;
frac = modf(d, &i);
if (frac < 0.5)
d = i;
else if (frac > 0.5)
d = i + 1;
else if (fmod(i, 2.0) != 0.0)
d = i + 1;
else
d = i;
if (invert)
d = -d;
return d;
}
static Scheme_Object *
sch_round (int argc, Scheme_Object *argv[])
{
@ -1424,34 +1536,8 @@ sch_round (int argc, Scheme_Object *argv[])
}
#endif
if (t == scheme_double_type) {
double d = SCHEME_DBL_VAL(o);
double i, frac;
int invert;
#ifdef FMOD_CAN_RETURN_POS_ZERO
if ((d == 0.0) && minus_zero_p(d))
return o;
#endif
if (d < 0) {
d = -d;
invert = 1;
} else
invert = 0;
frac = modf(d, &i);
if (frac < 0.5)
d = i;
else if (frac > 0.5)
d = i + 1;
else if (fmod(i, 2.0) != 0.0)
d = i + 1;
else
d = i;
if (invert)
d = -d;
double d;
d = SCH_ROUND(SCHEME_DBL_VAL(o));
return scheme_make_double(d);
}
if (t == scheme_bignum_type)
@ -1464,6 +1550,11 @@ sch_round (int argc, Scheme_Object *argv[])
ESCAPED_BEFORE_HERE;
}
double scheme_double_truncate(double x) { return SCH_TRUNC(x); }
double scheme_double_round(double x) { return SCH_ROUND(x); }
double scheme_double_floor(double x) { return floor(x); }
double scheme_double_ceiling(double x) { return ceil(x); }
#ifdef MZ_USE_SINGLE_FLOATS
#define TO_FLOAT_VAL scheme_get_val_as_float
@ -1793,13 +1884,33 @@ MK_SCH_TRIG(SCH_TAN, tan)
# define SCH_ASIN asin
#endif
static double SCH_ATAN(double v)
{
#ifdef TRIG_ZERO_NEEDS_SIGN_CHECK
if (v == 0.0) {
/* keep v the same */
} else
#endif
v = atan(v);
return v;
}
#ifdef LOG_ZERO_ISNT_NEG_INF
double SCH_LOG(double d) { if (d == 0.0) return scheme_minus_infinity_val; else return log(d); }
static double SCH_LOG(double d) { if (d == 0.0) return scheme_minus_infinity_val; else return log(d); }
#else
# define SCH_LOG log
#endif
#define BIGNUM_LOG(o) return bignum_log(o);
double scheme_double_sin(double x) { return SCH_SIN(x); }
double scheme_double_cos(double x) { return SCH_COS(x); }
double scheme_double_tan(double x) { return SCH_TAN(x); }
double scheme_double_asin(double x) { return SCH_ASIN(x); }
double scheme_double_acos(double x) { return acos(x); }
double scheme_double_atan(double x) { return SCH_ATAN(x); }
double scheme_double_log(double x) { return SCH_LOG(x); }
double scheme_double_exp(double x) { return exp(x); }
static Scheme_Object *scheme_inf_plus_pi()
{
return scheme_make_complex(scheme_inf_object, scheme_pi);
@ -1927,12 +2038,7 @@ atan_prim (int argc, Scheme_Object *argv[])
if (argv[0] == zeroi)
return zeroi;
#ifdef TRIG_ZERO_NEEDS_SIGN_CHECK
if (v == 0.0) {
/* keep v the same */
} else
#endif
v = atan(v);
v = SCH_ATAN(v);
#ifdef MZ_USE_SINGLE_FLOATS
# ifndef USE_SINGLE_FLOATS_AS_DEFAULT
@ -3109,6 +3215,28 @@ static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[])
return scheme_make_double(v);
}
#define SAFE_FL(op) \
static Scheme_Object * fl_ ## op (int argc, Scheme_Object *argv[]) \
{ \
double v; \
if (!SCHEME_DBLP(argv[0])) scheme_wrong_type("fl" #op, "inexact-real", 0, argc, argv); \
v = scheme_double_ ## op (SCHEME_DBL_VAL(argv[0])); \
return scheme_make_double(v); \
}
SAFE_FL(floor)
SAFE_FL(ceiling)
SAFE_FL(truncate)
SAFE_FL(round)
SAFE_FL(sin)
SAFE_FL(cos)
SAFE_FL(tan)
SAFE_FL(asin)
SAFE_FL(acos)
SAFE_FL(atan)
SAFE_FL(exp)
SAFE_FL(log)
#define UNSAFE_FX(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \

96
src/mzscheme/src/numcomp.c
View File

@ -43,24 +43,32 @@ static Scheme_Object *fx_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_max (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fx_max (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_max (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fl_max (int argc, Scheme_Object *argv[]);
#define zeroi scheme_exact_zero
@ -140,6 +148,16 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("fx>=", p, env);
p = scheme_make_folding_prim(fx_min, "fxmin", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("fxmin", p, env);
p = scheme_make_folding_prim(fx_max, "fxmax", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("fxmax", p, env);
p = scheme_make_folding_prim(fl_eq, "fl=", 2, 2, 1);
if (scheme_can_inline_fp_comp())
@ -165,6 +183,16 @@ void scheme_init_flfxnum_numcomp(Scheme_Env *env)
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("fl>=", p, env);
p = scheme_make_folding_prim(fl_min, "flmin", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("flmin", p, env);
p = scheme_make_folding_prim(fl_max, "flmax", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("flmax", p, env);
}
void scheme_init_unsafe_numcomp(Scheme_Env *env)
@ -196,6 +224,16 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env)
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-fx>=", p, env);
p = scheme_make_folding_prim(unsafe_fx_min, "unsafe-fxmin", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-fxmin", p, env);
p = scheme_make_folding_prim(unsafe_fx_max, "unsafe-fxmax", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-fxmax", p, env);
p = scheme_make_folding_prim(unsafe_fl_eq, "unsafe-fl=", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
@ -225,6 +263,18 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
scheme_add_global_constant("unsafe-fl>=", p, env);
p = scheme_make_folding_prim(unsafe_fl_min, "unsafe-flmin", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
scheme_add_global_constant("unsafe-flmin", p, env);
p = scheme_make_folding_prim(unsafe_fl_max, "unsafe-flmax", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
scheme_add_global_constant("unsafe-flmax", p, env);
}
/* Prototype needed for 3m conversion: */
@ -434,68 +484,90 @@ GEN_TWOARY_OP(static, sch_min, "min", bin_min, SCHEME_REALP, REAL_NUMBER_STR)
/* Flfx */
/************************************************************************/
#define SAFE_FX(name, s_name, op) \
#define SAFE_FX_X(name, s_name, op, T, F) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (!SCHEME_INTP(argv[0])) scheme_wrong_type(s_name, "fixnum", 0, argc, argv); \
if (!SCHEME_INTP(argv[1])) scheme_wrong_type(s_name, "fixnum", 1, argc, argv); \
if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
return scheme_true; \
return T; \
else \
return scheme_false; \
return F; \
}
#define SAFE_FX(name, s_name, op) SAFE_FX_X(name, s_name, op, scheme_true, scheme_false)
SAFE_FX(fx_eq, "fx=", ==)
SAFE_FX(fx_lt, "fx<", <)
SAFE_FX(fx_gt, "fx>", >)
SAFE_FX(fx_lt_eq, "fx<=", <=)
SAFE_FX(fx_gt_eq, "fx>=", >=)
SAFE_FX_X(fx_min, "fxmin", <, argv[0], argv[1])
SAFE_FX_X(fx_max, "fxmax", >, argv[0], argv[1])
#define UNSAFE_FX(name, op, fold) \
#define UNSAFE_FX_X(name, op, fold, T, F) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \
if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
return scheme_true; \
return T; \
else \
return scheme_false; \
return F; \
}
#define UNSAFE_FX(name, op, fold) UNSAFE_FX_X(name, op, fold, scheme_true, scheme_false)
UNSAFE_FX(unsafe_fx_eq, ==, scheme_bin_eq)
UNSAFE_FX(unsafe_fx_lt, <, scheme_bin_lt)
UNSAFE_FX(unsafe_fx_gt, >, scheme_bin_gt)
UNSAFE_FX(unsafe_fx_lt_eq, <=, scheme_bin_lt_eq)
UNSAFE_FX(unsafe_fx_gt_eq, >=, scheme_bin_gt_eq)
#define SAFE_FL(name, sname, op) \
UNSAFE_FX_X(unsafe_fx_min, <, bin_min, argv[0], argv[1])
UNSAFE_FX_X(unsafe_fx_max, >, bin_max, argv[0], argv[1])
#define SAFE_FL_X(name, sname, op, T, F) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (!SCHEME_FLOATP(argv[0])) scheme_wrong_type(sname, "inexact-real", 0, argc, argv); \
if (!SCHEME_FLOATP(argv[1])) scheme_wrong_type(sname, "inexact-real", 1, argc, argv); \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return scheme_true; \
return T; \
else \
return scheme_false; \
return F; \
}
#define SAFE_FL(name, sname, op) SAFE_FL_X(name, sname, op, scheme_true, scheme_false)
SAFE_FL(fl_eq, "fl=", ==)
SAFE_FL(fl_lt, "fl<", <)
SAFE_FL(fl_gt, "fl>", >)
SAFE_FL(fl_lt_eq, "fl<=", <=)
SAFE_FL(fl_gt_eq, "fl>=", >=)
#define UNSAFE_FL(name, op, fold) \
SAFE_FL_X(fl_min, "flmin", <, argv[0], argv[1])
SAFE_FL_X(fl_max, "flmax", >, argv[0], argv[1])
#define UNSAFE_FL_X(name, op, fold, T, F, PRE_CHECK) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \
PRE_CHECK \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return scheme_true; \
return T; \
else \
return scheme_false; \
return F; \
}
#define UNSAFE_FL(name, op, fold) UNSAFE_FL_X(name, op, fold, scheme_true, scheme_false, )
UNSAFE_FL(unsafe_fl_eq, ==, scheme_bin_eq)
UNSAFE_FL(unsafe_fl_lt, <, scheme_bin_lt)
UNSAFE_FL(unsafe_fl_gt, >, scheme_bin_gt)
UNSAFE_FL(unsafe_fl_lt_eq, <=, scheme_bin_lt_eq)
UNSAFE_FL(unsafe_fl_gt_eq, >=, scheme_bin_gt_eq)
#define CHECK_ARGV0_NAN if (MZ_IS_NAN(SCHEME_DBL_VAL(argv[0]))) return argv[0];
UNSAFE_FL_X(unsafe_fl_min, <, bin_min, argv[0], argv[1], CHECK_ARGV0_NAN)
UNSAFE_FL_X(unsafe_fl_max, >, bin_max, argv[0], argv[1], CHECK_ARGV0_NAN)

3
src/mzscheme/src/salloc.c
View File

@ -303,9 +303,6 @@ extern void GC_attach_current_thread_exceptions_to_handler();
#endif
#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS
void scheme_set_thread_local_variables(void *tlvas) XFORM_SKIP_PROC {
pthread_setspecific(scheme_thread_local_key, tlvas);
}
void* scheme_dbg_get_thread_local_variables() XFORM_SKIP_PROC {
return pthread_getspecific(scheme_thread_local_key);
}

4
src/mzscheme/src/schminc.h
View File

@ -14,8 +14,8 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 962
#define EXPECTED_UNSAFE_COUNT 53
#define EXPECTED_FLFXNUM_COUNT 36
#define EXPECTED_UNSAFE_COUNT 58
#define EXPECTED_FLFXNUM_COUNT 53
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

15
src/mzscheme/src/schpriv.h
View File

@ -1793,6 +1793,21 @@ typedef struct {
Scheme_Object *scheme_make_random_state(long seed);
long scheme_rand(Scheme_Random_State *rs);
/***** flonums *****/
double scheme_double_truncate(double x);
double scheme_double_round(double x);
double scheme_double_floor(double x);
double scheme_double_ceiling(double x);
double scheme_double_sin(double x);
double scheme_double_cos(double x);
double scheme_double_tan(double x);
double scheme_double_asin(double x);
double scheme_double_acos(double x);
double scheme_double_atan(double x);
double scheme_double_log(double x);
double scheme_double_exp(double x);
/*========================================================================*/
/* read, eval, print */
/*========================================================================*/

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.3.9"
#define MZSCHEME_VERSION "4.2.3.10"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_W 10
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)