add flsingle
The `flsingle` function takes a flonum and discards precision that wouldn't fit in a single-flonum. If single-precision arithmetic is somehow useful, then combine flonum operations with `flsingle` to discard precision on the result; even on Racket BC, that's likely to perform better than using generic arithmetic on single flonums.
This commit is contained in:
parent
dcf034280e
commit
744e69c0c1
|
@ -331,7 +331,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.8.0.6-2
|
||||
PB_BRANCH == circa-7.8.0.7-1
|
||||
PB_REPO == https://github.com/racket/pb
|
||||
|
||||
# Alternative source for Chez Scheme boot files, normally set by
|
||||
|
|
12
Makefile
12
Makefile
|
@ -45,7 +45,7 @@ RACKETCS_SUFFIX =
|
|||
RACKET =
|
||||
RACKET_FOR_BOOTFILES = $(RACKET)
|
||||
RACKET_FOR_BUILD = $(RACKET)
|
||||
PB_BRANCH = circa-7.8.0.6-2
|
||||
PB_BRANCH = circa-7.8.0.7-1
|
||||
PB_REPO = https://github.com/racket/pb
|
||||
EXTRA_REPOS_BASE =
|
||||
CS_CROSS_SUFFIX =
|
||||
|
@ -302,14 +302,14 @@ maybe-fetch-pb:
|
|||
if [ "$(RACKET_FOR_BOOTFILES)" = "" ] ; then $(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" ; fi
|
||||
fetch-pb-from:
|
||||
mkdir -p racket/src/ChezScheme/boot
|
||||
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.8.0.6-2 https://github.com/racket/pb racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.8.0.6-2 ; fi
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.8.0.6-2
|
||||
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.8.0.7-1 https://github.com/racket/pb racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.8.0.7-1 ; fi
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.8.0.7-1
|
||||
pb-stage:
|
||||
cd racket/src/ChezScheme/boot/pb && git branch circa-7.8.0.6-2
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.8.0.6-2
|
||||
cd racket/src/ChezScheme/boot/pb && git branch circa-7.8.0.7-1
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.8.0.7-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.8.0.6-2
|
||||
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.8.0.7-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)" GIT_CLONE_ARGS_qq="$(GIT_CLONE_ARGS_qq)" 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)" GIT_CLONE_ARGS_qq="$(GIT_CLONE_ARGS_qq)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"
|
||||
|
|
|
@ -12,7 +12,7 @@
|
|||
|
||||
(define collection 'multi)
|
||||
|
||||
(define version "7.8.0.6")
|
||||
(define version "7.8.0.7")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
@ -61,6 +61,17 @@ Like @racket[=], @racket[<], @racket[>], @racket[<=], @racket[>=],
|
|||
Like @racket[round], @racket[floor], @racket[ceiling], and
|
||||
@racket[truncate], but constrained to consume @tech{flonums}.}
|
||||
|
||||
|
||||
@defproc[(flsingle [a flonum?]) flonum?]{
|
||||
|
||||
Returns a value like @racket[a], but potentially discards precision
|
||||
and range so that the result can be represented as a single-precision
|
||||
IEEE floating-point number (even if @tech{single-flonums} are not
|
||||
supported).
|
||||
|
||||
@history[#:added "7.8.0.7"]}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(flsin [a flonum?]) flonum?]
|
||||
@defproc[(flcos [a flonum?]) flonum?]
|
||||
|
|
|
@ -154,24 +154,13 @@ For @tech{flonums}: Unchecked (potentially) versions of
|
|||
the corresponding safe bindings.}
|
||||
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(unsafe-flsin [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-flcos [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-fltan [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-flasin [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-flacos [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-flatan [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-fllog [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-flexp [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-flsqrt [a flonum?]) flonum?]
|
||||
@defproc[(unsafe-flexpt [a flonum?] [b flonum?]) flonum?]
|
||||
)]{
|
||||
@defproc[(unsafe-flsingle [a flonum?]) flonum?]{
|
||||
|
||||
For @tech{flonums}: Unchecked (potentially) version of
|
||||
@racket[flsingle].
|
||||
|
||||
@history[#:added "7.8.0.7"]}
|
||||
|
||||
For @tech{flonums}: Unchecked (potentially) versions of
|
||||
@racket[flsin], @racket[flcos], @racket[fltan], @racket[flasin],
|
||||
@racket[flacos], @racket[flatan], @racket[fllog], @racket[flexp],
|
||||
@racket[flsqrt], and @racket[flexpt]. Currently, some of these
|
||||
bindings are simply aliases for the corresponding safe bindings.}
|
||||
|
||||
@deftogether[(
|
||||
@defproc[(unsafe-make-flrectangular [a flonum?] [b flonum?])
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
(Section 'flonum)
|
||||
|
||||
(require racket/flonum
|
||||
scheme/unsafe/ops
|
||||
racket/unsafe/ops
|
||||
"for-util.rkt")
|
||||
|
||||
(define 1nary-table
|
||||
|
@ -215,6 +215,23 @@
|
|||
(err/rt-test (for/flvector #:length 5 #:fill 0 ([i 5]) 8.0))
|
||||
(err/rt-test (for/flvector #:length 10 #:fill 0 ([i 5]) 8.0))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; flsingle
|
||||
|
||||
(test 1.0 unsafe-flsingle 1.0)
|
||||
(test -1.0 unsafe-flsingle -1.0)
|
||||
(test +nan.0 unsafe-flsingle +nan.0)
|
||||
(test +inf.0 unsafe-flsingle +inf.0)
|
||||
(test -inf.0 unsafe-flsingle -inf.0)
|
||||
(test 1.2500000360947476e38 unsafe-flsingle 1.25e38)
|
||||
(test 1.2500000449239123e-37 unsafe-flsingle 1.25e-37)
|
||||
(test -1.2500000360947476e38 unsafe-flsingle -1.25e38)
|
||||
(test -1.2500000449239123e-37 unsafe-flsingle -1.25e-37)
|
||||
(test +inf.0 unsafe-flsingle 1e100)
|
||||
(test -inf.0 unsafe-flsingle -1e100)
|
||||
(test 0.0 unsafe-flsingle 1e-100)
|
||||
(test -0.0 unsafe-flsingle -1e-100)
|
||||
|
||||
;; ----------------------------------------
|
||||
;; flrandom
|
||||
|
||||
|
|
|
@ -353,6 +353,20 @@
|
|||
(test-un 0.5 unsafe-flsqrt 0.25)
|
||||
(test-un +nan.0 unsafe-flsqrt -1.0)
|
||||
|
||||
(test-un 1.0 unsafe-flsingle 1.0)
|
||||
(test-un -1.0 unsafe-flsingle -1.0)
|
||||
(test-un +nan.0 unsafe-flsingle +nan.0)
|
||||
(test-un +inf.0 unsafe-flsingle +inf.0)
|
||||
(test-un -inf.0 unsafe-flsingle -inf.0)
|
||||
(test-un 1.2500000360947476e38 unsafe-flsingle 1.25e38)
|
||||
(test-un 1.2500000449239123e-37 unsafe-flsingle 1.25e-37)
|
||||
(test-un -1.2500000360947476e38 unsafe-flsingle -1.25e38)
|
||||
(test-un -1.2500000449239123e-37 unsafe-flsingle -1.25e-37)
|
||||
(test-un +inf.0 unsafe-flsingle 1e100)
|
||||
(test-un -inf.0 unsafe-flsingle -1e100)
|
||||
(test-un 0.0 unsafe-flsingle 1e-100)
|
||||
(test-un -0.0 unsafe-flsingle -1e-100)
|
||||
|
||||
(test-un 8.0 'unsafe-fx->fl 8)
|
||||
(test-un -8.0 'unsafe-fx->fl -8)
|
||||
|
||||
|
|
|
@ -8,8 +8,8 @@
|
|||
(provide fl+ fl- fl* fl/
|
||||
flabs flsqrt flexp fllog
|
||||
flsin flcos fltan flasin flacos flatan
|
||||
flfloor flceiling flround fltruncate flexpt
|
||||
flrandom
|
||||
flfloor flceiling flround fltruncate
|
||||
flsingle flexpt flrandom
|
||||
fl= fl< fl<= fl> fl>= flmin flmax
|
||||
->fl fl->exact-integer
|
||||
flvector? flvector make-flvector
|
||||
|
|
|
@ -189,6 +189,13 @@ void S_pb_interp(ptr tc, void *bytecode) {
|
|||
#endif
|
||||
}
|
||||
break;
|
||||
case pb_mov_pb_d_s_d:
|
||||
{
|
||||
float f;
|
||||
f = fpregs[INSTR_dr_reg(instr)];
|
||||
fpregs[INSTR_dr_dest(instr)] = (double)f;
|
||||
}
|
||||
break;
|
||||
case pb_bin_op_pb_no_signal_pb_add_pb_register:
|
||||
regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)];
|
||||
break;
|
||||
|
|
|
@ -549,6 +549,17 @@ are considered nonpositive and nonnegative.
|
|||
(flnonnegative? -inf.0) ;=> #f
|
||||
\endschemedisplay
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{flsingle}{\categoryprocedure}{(flsingle \var{fl})}
|
||||
\returns a possibly less precise variant of \var{fl}
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent
|
||||
Potentially discards precision from \var{fl} so that the result is
|
||||
representable as an 32-bit IEEE floating-point number.
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{decode-float}{\categoryprocedure}{(decode-float \var{x})}
|
||||
|
|
|
@ -62,7 +62,7 @@ InstallLZ4Target=
|
|||
# no changes should be needed below this point #
|
||||
###############################################################################
|
||||
|
||||
Version=csv9.5.3.35
|
||||
Version=csv9.5.3.36
|
||||
Include=boot/$m
|
||||
PetiteBoot=boot/$m/petite.boot
|
||||
SchemeBoot=boot/$m/scheme.boot
|
||||
|
|
|
@ -668,6 +668,28 @@
|
|||
(fl= (flround -0.5000000000000001) -1.0)
|
||||
)
|
||||
|
||||
(mat flsingle
|
||||
(error? (flsingle))
|
||||
(error? (flsingle 2.0 3.0))
|
||||
(error? (flsingle 'a))
|
||||
(error? (flsingle 3))
|
||||
(error? (flsingle 2+1.0i))
|
||||
(error? (flsingle 2+1i))
|
||||
(eqv? (flsingle 19.0) 19.0)
|
||||
(eqv? (flsingle -19.0) -19.0)
|
||||
(eqv? (flsingle +nan.0) +nan.0)
|
||||
(eqv? (flsingle +inf.0) +inf.0)
|
||||
(eqv? (flsingle -inf.0) -inf.0)
|
||||
(fl~= (flsingle 1.25e38) 1.2500000360947476e38)
|
||||
(fl~= (flsingle 1.25e-37) 1.2500000449239123e-37)
|
||||
(fl~= (flsingle -1.25e38) -1.2500000360947476e38)
|
||||
(fl~= (flsingle -1.25e-37) -1.2500000449239123e-37)
|
||||
(eqv? (flsingle 1e100) +inf.0)
|
||||
(eqv? (flsingle -1e100) -inf.0)
|
||||
(eqv? (flsingle 1e-100) 0.0)
|
||||
(eqv? (flsingle -1e-100) -0.0)
|
||||
)
|
||||
|
||||
(mat flinteger?
|
||||
(error? (flinteger? 'a))
|
||||
(error? (flinteger? "hi"))
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -9708,6 +9708,12 @@ fl.mo:Expected error in mat flround: "flround: 2.0+1.0i is not a flonum".
|
|||
fl.mo:Expected error in mat flround: "flround: 2+1i is not a flonum".
|
||||
fl.mo:Expected error in mat flround: "flround: 19 is not a flonum".
|
||||
fl.mo:Expected error in mat flround: "flround: 2/3 is not a flonum".
|
||||
fl.mo:Expected error in mat flsingle: "incorrect argument count in call (flsingle)".
|
||||
fl.mo:Expected error in mat flsingle: "incorrect argument count in call (flsingle 2.0 3.0)".
|
||||
fl.mo:Expected error in mat flsingle: "flsingle: a is not a flonum".
|
||||
fl.mo:Expected error in mat flsingle: "flsingle: 3 is not a flonum".
|
||||
fl.mo:Expected error in mat flsingle: "flsingle: 2.0+1.0i is not a flonum".
|
||||
fl.mo:Expected error in mat flsingle: "flsingle: 2+1i is not a flonum".
|
||||
fl.mo:Expected error in mat flinteger?: "flinteger?: a is not a flonum".
|
||||
fl.mo:Expected error in mat flinteger?: "flinteger?: "hi" is not a flonum".
|
||||
fl.mo:Expected error in mat flinteger?: "flinteger?: (3 . 4) is not a flonum".
|
||||
|
|
|
@ -422,9 +422,13 @@
|
|||
|
||||
((orig-eval 'fasl-compressed) #f)
|
||||
|
||||
(define all-sources (append petite-sources scheme-sources))
|
||||
(define (source->so src #:abs? [abs? #t])
|
||||
(path->string ((if abs? path->complete-path values) (build-path out-subdir (path-replace-suffix src #".so")))))
|
||||
|
||||
(let ([failed? #f])
|
||||
(for ([src (append petite-sources scheme-sources)])
|
||||
(let ([dest (path->string (path->complete-path (build-path out-subdir (path-replace-suffix src #".so"))))])
|
||||
(for ([src (in-list all-sources)])
|
||||
(let ([dest (source->so src)])
|
||||
(parameterize ([current-directory (build-path scheme-dir "s")])
|
||||
;; (status (format "Compile ~a" src)) - Chez Scheme prints its own message
|
||||
(with-handlers (#;[exn:fail? (lambda (exn)
|
||||
|
@ -434,8 +438,7 @@
|
|||
(when failed?
|
||||
(raise-user-error 'make-boot "compilation failure(s)")))
|
||||
|
||||
(let ([src->so (lambda (src)
|
||||
(path->string (build-path out-subdir (path-replace-suffix src #".so"))))])
|
||||
(let ([src->so (lambda (src) (source->so #:abs? #f src))])
|
||||
(status (format "Writing ~a/petite.boot" target-machine))
|
||||
(eval `($make-boot-file ,(path->string (build-path out-subdir "petite.boot"))
|
||||
',(string->symbol target-machine) '()
|
||||
|
@ -443,4 +446,10 @@
|
|||
(status (format "Writing ~a/scheme.boot" target-machine))
|
||||
(eval `($make-boot-file ,(path->string (build-path out-subdir "scheme.boot"))
|
||||
',(string->symbol target-machine) '("petite")
|
||||
,@(map src->so scheme-sources)))))
|
||||
,@(map src->so scheme-sources))))
|
||||
|
||||
;; Clean up
|
||||
(for ([src (in-list all-sources)])
|
||||
(define so (source->so src))
|
||||
(when (file-exists? so)
|
||||
(delete-file so))))
|
||||
|
|
|
@ -606,6 +606,9 @@
|
|||
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
|
||||
`(set! ,(make-live-info) ,z (asm ,info ,asm-fptrunc ,x ,u))))])
|
||||
|
||||
(define-instruction value (fpsingle)
|
||||
[(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))])
|
||||
|
||||
(define-instruction pred (fp= fp< fp<=)
|
||||
[(op (x fpur) (y fpur))
|
||||
(let ([info (make-info-condition-code op #f #f)])
|
||||
|
@ -844,7 +847,8 @@
|
|||
asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-indirect-call asm-condition-code
|
||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom
|
||||
asm-fptrunc asm-fpsingle
|
||||
asm-lock asm-lock+/- asm-cas asm-fence
|
||||
asm-fpop-2 asm-fpsqrt asm-c-simple-call
|
||||
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
|
||||
|
@ -1870,6 +1874,11 @@
|
|||
(lambda (code* dest src)
|
||||
(emit vsqrt dest src code*)))
|
||||
|
||||
(define asm-fpsingle
|
||||
(lambda (code* dest-reg src-reg)
|
||||
(emit vcvt.dbl->sgl dest-reg src-reg
|
||||
(emit vcvt.sgl->dbl dest-reg dest-reg code*))))
|
||||
|
||||
(define asm-fptrunc
|
||||
(lambda (code* dest flonumreg tmpreg)
|
||||
(Trivit (dest)
|
||||
|
|
|
@ -428,6 +428,9 @@
|
|||
[(op (x ur) (y fpur))
|
||||
`(set! ,(make-live-info) ,x (asm ,info ,asm-fptrunc ,y))])
|
||||
|
||||
(define-instruction value (fpsingle)
|
||||
[(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))])
|
||||
|
||||
(define-instruction value (fpmove)
|
||||
[(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)]
|
||||
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)])
|
||||
|
@ -680,7 +683,8 @@
|
|||
asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-indirect-call asm-condition-code
|
||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom
|
||||
asm-fptrunc asm-fpsingle
|
||||
asm-lock asm-lock+/- asm-cas asm-fence
|
||||
asm-fpop-2 asm-fpsqrt asm-c-simple-call
|
||||
asm-return asm-c-return asm-size
|
||||
|
@ -1759,6 +1763,13 @@
|
|||
(Trivit (dest src)
|
||||
(emit fsqrt dest src code*))))
|
||||
|
||||
(define-who asm-fpsingle
|
||||
(lambda (code* dest src)
|
||||
(Trivit (dest src)
|
||||
(emit fcvt.d->s dest src
|
||||
(emit fcvt.s->d dest dest
|
||||
code*)))))
|
||||
|
||||
(define asm-fptrunc
|
||||
(lambda (code* dest src)
|
||||
(Trivit (dest src)
|
||||
|
|
|
@ -357,7 +357,7 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
;; Version and machine types:
|
||||
|
||||
(define-constant scheme-version #x09050323)
|
||||
(define-constant scheme-version #x09050324)
|
||||
|
||||
(define-syntax define-machine-types
|
||||
(lambda (x)
|
||||
|
@ -2823,6 +2823,7 @@
|
|||
(flfloor #f 1 #t #t)
|
||||
(flceiling #f 1 #t #t)
|
||||
(fltruncate #f 1 #t #t)
|
||||
(flsingle #f 1 #t #t)
|
||||
(flsin #f 1 #t #t)
|
||||
(flcos #f 1 #t #t)
|
||||
(fltan #f 1 #t #t)
|
||||
|
@ -3081,6 +3082,7 @@
|
|||
pb-d->i
|
||||
pb-s->d
|
||||
pb-d->s
|
||||
pb-d->s->d
|
||||
pb-i-bits->d-bits ; 64-bit only
|
||||
pb-d-bits->i-bits ; 64-bit only
|
||||
pb-i-i-bits->d-bits ; 32-bit only
|
||||
|
|
|
@ -7699,6 +7699,9 @@
|
|||
[(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)]
|
||||
[(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])])
|
||||
|
||||
(define-inline 3 flsingle
|
||||
[(e) (build-fp-op-1 %fpsingle e)])
|
||||
|
||||
(define-inline 3 flabs
|
||||
[(e) (build-flabs e)])
|
||||
|
||||
|
@ -8045,6 +8048,13 @@
|
|||
(lambda (e)
|
||||
(build-libcall #t src sexpr flsqrt e)))])
|
||||
|
||||
(define-inline 2 flsingle
|
||||
[(e)
|
||||
(build-checked-fp-op e
|
||||
(lambda (e) (build-fp-op-1 %fpsingle e))
|
||||
(lambda (e)
|
||||
(build-libcall #t src sexpr flsingle e)))])
|
||||
|
||||
(let ()
|
||||
(define-syntax define-fl-call
|
||||
(syntax-rules ()
|
||||
|
|
|
@ -677,6 +677,7 @@
|
|||
(define-library-entry (flfloor x) (flonum-oops 'flfloor x))
|
||||
(define-library-entry (flceiling x) (flonum-oops 'flceiling x))
|
||||
(define-library-entry (fltruncate x) (flonum-oops 'fltruncate x))
|
||||
(define-library-entry (flsingle x) (flonum-oops 'flsingle x))
|
||||
(define-library-entry (flsin x) (flonum-oops 'flsin x))
|
||||
(define-library-entry (flcos x) (flonum-oops 'flcos x))
|
||||
(define-library-entry (fltan x) (flonum-oops 'fltan x))
|
||||
|
|
|
@ -279,6 +279,11 @@
|
|||
(unless (flonum? x) (flargerr 'flround x))
|
||||
(#3%flround x)))
|
||||
|
||||
(set! flsingle
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr 'flsingle x))
|
||||
(#3%flsingle x)))
|
||||
|
||||
(set! fllp
|
||||
(lambda (x)
|
||||
(unless (flonum? x) (flargerr 'fllp x))
|
||||
|
|
|
@ -629,6 +629,7 @@
|
|||
(declare-primitive fpt value #t)
|
||||
(declare-primitive fpsqrt value #t) ; not implemented for some ppc32 (so we don't use it)
|
||||
(declare-primitive fptrunc value #t)
|
||||
(declare-primitive fpsingle value #t)
|
||||
(declare-primitive double->single value #t) ; not required by cpnanopass
|
||||
(declare-primitive single->double value #t) ; not required by cpnanopass
|
||||
|
||||
|
|
|
@ -357,6 +357,9 @@
|
|||
[(op (x ur) (y fpur))
|
||||
`(set! ,(make-live-info) ,x (asm ,info ,asm-fptrunc ,y))])
|
||||
|
||||
(define-instruction value (fpsingle)
|
||||
[(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))])
|
||||
|
||||
(define-instruction value (fpmove)
|
||||
[(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)]
|
||||
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)])
|
||||
|
@ -548,7 +551,8 @@
|
|||
asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-indirect-call asm-condition-code
|
||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
|
||||
asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom
|
||||
asm-fptrunc asm-fpsingle
|
||||
asm-inc! asm-lock! asm-cas!
|
||||
asm-fpop-2 asm-fpsqrt asm-c-simple-call
|
||||
asm-return asm-c-return asm-size
|
||||
|
@ -658,6 +662,8 @@
|
|||
(define-op mov.i->d mov-op (constant pb-i->d))
|
||||
(define-op mov.d->i mov-op (constant pb-d->i))
|
||||
|
||||
(define-op mov.d->s->d mov-op (constant pb-d->s->d))
|
||||
|
||||
;; 64-bit versions
|
||||
(define-op mov.i*>d mov-op (constant pb-i-bits->d-bits))
|
||||
(define-op mov.d*>i mov-op (constant pb-d-bits->i-bits))
|
||||
|
@ -1191,6 +1197,11 @@
|
|||
(Trivit (dest src)
|
||||
(emit fsqrt dest src code*))))
|
||||
|
||||
(define asm-fpsingle
|
||||
(lambda (code* dest src)
|
||||
(Trivit (dest src)
|
||||
(emit mov.d->s->d dest src code*))))
|
||||
|
||||
(define asm-fptrunc
|
||||
(lambda (code* dest src)
|
||||
(Trivit (dest src)
|
||||
|
|
|
@ -522,6 +522,9 @@
|
|||
[(op (z ur) (x fpur))
|
||||
`(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x))])
|
||||
|
||||
(define-instruction value (fpsingle)
|
||||
[(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))])
|
||||
|
||||
(define-instruction value (fp+ fp- fp/ fp*)
|
||||
[(op (x fpur) (y fpur) (z fpur))
|
||||
`(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
|
||||
|
@ -735,7 +738,7 @@
|
|||
asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-indirect-call asm-condition-code
|
||||
asm-trunc asm-fpt asm-fpcastto asm-fpcastfrom
|
||||
asm-trunc asm-fpt asm-fpcastto asm-fpcastfrom asm-fpsingle
|
||||
asm-lock asm-lock+/- asm-cas
|
||||
asm-load-single->double asm-store-double->single
|
||||
asm-fpop-2 asm-c-simple-call
|
||||
|
@ -1638,6 +1641,11 @@
|
|||
(lambda (dest-reg index-reg)
|
||||
(emit stfsx tmp dest-reg index-reg code*))))))))
|
||||
|
||||
(define asm-fpsingle
|
||||
(lambda (code* dest-reg src-reg)
|
||||
(Trivit (dest-reg src-reg)
|
||||
(emit frsp dest-reg src-reg code*))))
|
||||
|
||||
(define-who asm-fpop-2
|
||||
(lambda (op)
|
||||
(lambda (code* dest src1 src2)
|
||||
|
|
|
@ -1324,6 +1324,7 @@
|
|||
(file-regular? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard])
|
||||
(file-symbolic-link? [sig [(pathname) -> (boolean)]] [flags discard])
|
||||
(fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flsingle [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
|
||||
(fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [flags arith-op mifoldable discard safeongoodargs])
|
||||
(flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02 unboxed-arguments])
|
||||
(flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
|
||||
|
|
|
@ -570,6 +570,9 @@
|
|||
(define-instruction value (fpsqrt)
|
||||
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
|
||||
|
||||
(define-instruction value (fpsingle)
|
||||
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))])
|
||||
|
||||
(define-instruction effect inc-cc-counter
|
||||
[(op (x ur) (y imm32 ur) (z imm32 ur)) `(asm ,info ,asm-inc-cc-counter ,x ,y ,z)])
|
||||
|
||||
|
@ -749,7 +752,7 @@
|
|||
asm-logtest asm-fp-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
|
||||
asm-direct-jump asm-return-address asm-jump asm-conditional-jump
|
||||
asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code
|
||||
asm-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-div
|
||||
asm-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-fpsingle asm-div
|
||||
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
|
||||
asm-fpop-2 asm-fpmove asm-fpmovefrom asm-fpcastfrom asm-fpcastto asm-fpsqrt asm-c-simple-call
|
||||
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
|
||||
|
@ -1552,6 +1555,12 @@
|
|||
(Trivit (dest)
|
||||
(emit sse.movss (cons 'reg flreg) dest code*))))
|
||||
|
||||
(define asm-fpsingle
|
||||
(lambda (code* dest src)
|
||||
(Trivit (dest src)
|
||||
(emit sse.cvtsd2ss src dest
|
||||
(emit sse.cvtss2sd dest dest code*)))))
|
||||
|
||||
(define asm-fpt
|
||||
(lambda (code* dest src)
|
||||
(Trivit (dest src)
|
||||
|
|
|
@ -630,6 +630,9 @@
|
|||
(define-instruction value (fpsqrt)
|
||||
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
|
||||
|
||||
(define-instruction value (fpsingle)
|
||||
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))])
|
||||
|
||||
(define-instruction effect inc-cc-counter
|
||||
[(op (x ur) (y imm32 ur) (z imm32 ur)) `(asm ,info ,asm-inc-cc-counter ,x ,y ,z)])
|
||||
|
||||
|
@ -834,7 +837,7 @@
|
|||
asm-lea1 asm-lea2 asm-indirect-call asm-condition-code
|
||||
asm-fl-cvt asm-store-single asm-load-single asm-fpt asm-fptrunc asm-div asm-popcount
|
||||
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
|
||||
asm-fpsqrt asm-fpop-2 asm-fpmove asm-fpcast
|
||||
asm-fpsqrt asm-fpop-2 asm-fpmove asm-fpcast asm-fpsingle
|
||||
asm-c-simple-call
|
||||
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
|
||||
asm-enter asm-foreign-call asm-foreign-callable
|
||||
|
@ -1729,6 +1732,12 @@
|
|||
[(single->double) (emit sse.cvtss2sd src (cons 'reg dest-reg) code*)]
|
||||
[(double->single) (emit sse.cvtsd2ss src (cons 'reg dest-reg) code*)])))))
|
||||
|
||||
(define asm-fpsingle
|
||||
(lambda (code* dest src)
|
||||
(Trivit (dest src)
|
||||
(emit sse.cvtsd2ss src dest
|
||||
(emit sse.cvtss2sd dest dest code*)))))
|
||||
|
||||
(define asm-store-single->double
|
||||
(lambda (flreg)
|
||||
(lambda (code* base index offset)
|
||||
|
|
|
@ -75,6 +75,8 @@ static int is_inline_unboxable_op(Scheme_Object *obj, int flag, int unsafely, in
|
|||
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, "flsingle")) return 1;
|
||||
if (IS_NAMED_PRIM(obj, "unsafe-flsingle")) 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;
|
||||
|
@ -488,6 +490,7 @@ DECL_FP_GLUE(floor)
|
|||
DECL_FP_GLUE(ceiling)
|
||||
DECL_FP_GLUE(truncate)
|
||||
DECL_FP_GLUE(round)
|
||||
DECL_FLONUM_GLUE(single)
|
||||
|
||||
typedef void (*call_fp_proc)(void);
|
||||
# ifdef MZ_LONG_DOUBLE
|
||||
|
@ -943,6 +946,8 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
|
|||
f = call_truncate;
|
||||
else if (IS_NAMED_PRIM(rator, "flround"))
|
||||
f = call_round;
|
||||
else if (IS_NAMED_PRIM(rator, "flsingle") || IS_NAMED_PRIM(rator, "unsafe-flsingle"))
|
||||
f = call_single;
|
||||
else {
|
||||
scheme_signal_error("internal error: unknown flonum function");
|
||||
f = NULL;
|
||||
|
|
|
@ -2215,6 +2215,7 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
|
|||
|| IS_NAMED_PRIM(rator, "flceiling")
|
||||
|| IS_NAMED_PRIM(rator, "flround")
|
||||
|| IS_NAMED_PRIM(rator, "fltruncate")
|
||||
|| IS_NAMED_PRIM(rator, "flsingle")
|
||||
|| IS_NAMED_PRIM(rator, "flsin")
|
||||
|| IS_NAMED_PRIM(rator, "flcos")
|
||||
|| IS_NAMED_PRIM(rator, "fltan")
|
||||
|
@ -2225,6 +2226,9 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
|
|||
|| IS_NAMED_PRIM(rator, "fllog")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_FLUNOP, 0, 0, NULL, 1, 0, -1, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "unsafe-flsingle")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_FLUNOP, 0, 0, NULL, 1, 0, 1, NULL, dest);
|
||||
return 1;
|
||||
} else if (IS_NAMED_PRIM(rator, "exact->inexact")
|
||||
|| IS_NAMED_PRIM(rator, "real->double-flonum")) {
|
||||
scheme_generate_arith(jitter, rator, app->rand, NULL, 1, ARITH_EX_INEX, 0, 0, NULL, 1, 0, 0, NULL, dest);
|
||||
|
|
|
@ -125,6 +125,7 @@ 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_single (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[]);
|
||||
|
@ -190,6 +191,7 @@ static Scheme_Object *unsafe_flreal_part (int argc, Scheme_Object *argv[]);
|
|||
static Scheme_Object *unsafe_flimag_part (int argc, Scheme_Object *argv[]);
|
||||
|
||||
static Scheme_Object *unsafe_flrandom (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *unsafe_flsingle (int argc, Scheme_Object *argv[]);
|
||||
|
||||
#ifdef MZ_USE_SINGLE_FLOATS
|
||||
static Scheme_Object *TO_FLOAT(const Scheme_Object *n);
|
||||
|
@ -952,6 +954,16 @@ void scheme_init_flfxnum_number(Scheme_Startup_Env *env)
|
|||
| SCHEME_PRIM_PRODUCES_FLONUM);
|
||||
scheme_addto_prim_instance("flfloor", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fl_single, "flsingle", 1, 1, 1);
|
||||
if (scheme_can_inline_fp_op())
|
||||
flags = SCHEME_PRIM_IS_UNARY_INLINED;
|
||||
else
|
||||
flags = SCHEME_PRIM_SOMETIMES_INLINED;
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
|
||||
| SCHEME_PRIM_WANTS_FLONUM_FIRST
|
||||
| SCHEME_PRIM_PRODUCES_FLONUM);
|
||||
scheme_addto_prim_instance("flsingle", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(fl_sin, "flsin", 1, 1, 1);
|
||||
if (scheme_can_inline_fp_op())
|
||||
flags = SCHEME_PRIM_IS_UNARY_INLINED;
|
||||
|
@ -1505,6 +1517,17 @@ void scheme_init_unsafe_number(Scheme_Startup_Env *env)
|
|||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
|
||||
| SCHEME_PRIM_PRODUCES_FLONUM);
|
||||
scheme_addto_prim_instance("unsafe-flrandom", p, env);
|
||||
|
||||
p = scheme_make_folding_prim(unsafe_flsingle, "unsafe-flsingle", 1, 1, 1);
|
||||
if (scheme_can_inline_fp_op())
|
||||
flags = SCHEME_PRIM_IS_UNARY_INLINED;
|
||||
else
|
||||
flags = SCHEME_PRIM_SOMETIMES_INLINED;
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
|
||||
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
|
||||
| SCHEME_PRIM_PRODUCES_FLONUM
|
||||
| SCHEME_PRIM_WANTS_FLONUM_FIRST);
|
||||
scheme_addto_prim_instance("unsafe-flsingle", p, env);
|
||||
}
|
||||
|
||||
void scheme_init_extfl_unsafe_number(Scheme_Startup_Env *env)
|
||||
|
@ -2588,6 +2611,7 @@ 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); }
|
||||
double scheme_double_single(double x) { return (double)(float)x; }
|
||||
|
||||
#ifdef MZ_LONG_DOUBLE
|
||||
XFORM_NONGCING static long_double SCH_ROUNDL(long_double d)
|
||||
|
@ -5322,6 +5346,7 @@ SAFE_FL(floor)
|
|||
SAFE_FL(ceiling)
|
||||
SAFE_FL(truncate)
|
||||
SAFE_FL(round)
|
||||
SAFE_FL(single)
|
||||
SAFE_FL(sin)
|
||||
SAFE_FL(cos)
|
||||
SAFE_FL(tan)
|
||||
|
@ -5711,6 +5736,11 @@ static Scheme_Object *unsafe_flrandom (int argc, Scheme_Object *argv[])
|
|||
return scheme_make_double(scheme_double_random(argv[0]));
|
||||
}
|
||||
|
||||
static Scheme_Object *unsafe_flsingle (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return fl_single(argc, argv);
|
||||
}
|
||||
|
||||
static Scheme_Object *integer_to_extfl (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
#ifdef MZ_LONG_DOUBLE
|
||||
|
|
|
@ -15,7 +15,7 @@
|
|||
|
||||
#define USE_COMPILED_STARTUP 1
|
||||
|
||||
#define EXPECTED_PRIM_COUNT 1472
|
||||
#define EXPECTED_PRIM_COUNT 1474
|
||||
|
||||
#ifdef MZSCHEME_SOMETHING_OMITTED
|
||||
# undef USE_COMPILED_STARTUP
|
||||
|
|
|
@ -2538,6 +2538,7 @@ XFORM_NONGCING double scheme_double_truncate(double x);
|
|||
XFORM_NONGCING double scheme_double_round(double x);
|
||||
XFORM_NONGCING double scheme_double_floor(double x);
|
||||
XFORM_NONGCING double scheme_double_ceiling(double x);
|
||||
XFORM_NONGCING double scheme_double_single(double x);
|
||||
XFORM_NONGCING double scheme_double_sin(double x);
|
||||
XFORM_NONGCING double scheme_double_cos(double x);
|
||||
XFORM_NONGCING double scheme_double_tan(double x);
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
;; Check to make we're using a build of Chez Scheme
|
||||
;; that has all the features we need.
|
||||
(define-values (need-maj need-min need-sub need-dev)
|
||||
(values 9 5 3 35))
|
||||
(values 9 5 3 36))
|
||||
|
||||
(unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
|
||||
(error 'compile-file
|
||||
|
|
|
@ -28,6 +28,7 @@
|
|||
[flreal-part (known-procedure/folding 2)]
|
||||
[flround (known-procedure/folding 2)]
|
||||
[flsin (known-procedure/folding 2)]
|
||||
[flsingle (known-procedure/folding 2)]
|
||||
[flsqrt (known-procedure/folding 2)]
|
||||
[fltan (known-procedure/folding 2)]
|
||||
[fltruncate (known-procedure/folding 2)]
|
||||
|
|
|
@ -70,6 +70,7 @@
|
|||
[unsafe-flmin (known-procedure/pure/folding-unsafe -2 'flmin)]
|
||||
[unsafe-flrandom (known-procedure/pure/folding-unsafe 2 'flrandom)]
|
||||
[unsafe-flreal-part (known-procedure/pure/folding-unsafe 2 'flreal-part)]
|
||||
[unsafe-flsingle (known-procedure/pure/folding-unsafe 2 'flsingle)]
|
||||
[unsafe-flsqrt (known-procedure/pure/folding-unsafe 2 'flsqrt)]
|
||||
[unsafe-flvector-length (known-procedure/pure/folding-unsafe 2 'flvector-length)]
|
||||
[unsafe-flvector-ref (known-procedure/succeeds 4)]
|
||||
|
|
|
@ -568,6 +568,7 @@
|
|||
unsafe-flfloor
|
||||
unsafe-flceiling
|
||||
unsafe-fltruncate
|
||||
unsafe-flsingle
|
||||
|
||||
unsafe-flsin
|
||||
unsafe-flcos
|
||||
|
|
|
@ -59,6 +59,7 @@
|
|||
(define unsafe-flfloor (unsafe-primitive flfloor))
|
||||
(define unsafe-flceiling (unsafe-primitive flceiling))
|
||||
(define unsafe-fltruncate (unsafe-primitive fltruncate))
|
||||
(define unsafe-flsingle (unsafe-primitive flsingle))
|
||||
|
||||
(define unsafe-flsin (unsafe-primitive flsin))
|
||||
(define unsafe-flcos (unsafe-primitive flcos))
|
||||
|
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 7
|
||||
#define MZSCHEME_VERSION_Y 8
|
||||
#define MZSCHEME_VERSION_Z 0
|
||||
#define MZSCHEME_VERSION_W 6
|
||||
#define MZSCHEME_VERSION_W 7
|
||||
|
||||
/* A level of indirection makes `#` work as needed: */
|
||||
#define AS_a_STR_HELPER(x) #x
|
||||
|
|
Loading…
Reference in New Issue
Block a user