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:
Matthew Flatt 2020-08-04 12:19:43 -06:00
parent dcf034280e
commit 744e69c0c1
38 changed files with 601 additions and 380 deletions

View File

@ -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

View File

@ -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)"

View File

@ -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]))

View File

@ -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?]

View File

@ -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?])

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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;

View File

@ -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})}

View File

@ -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

View File

@ -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

View File

@ -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".

View File

@ -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))))

View File

@ -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)

View File

@ -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)

View File

@ -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

View File

@ -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 ()

View File

@ -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))

View File

@ -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))

View File

@ -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

View File

@ -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)

View File

@ -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)

View File

@ -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])

View File

@ -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)

View File

@ -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)

View File

@ -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;

View File

@ -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);

View File

@ -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

View File

@ -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

View File

@ -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);

View File

@ -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

View 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)]

View File

@ -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)]

View File

@ -568,6 +568,7 @@
unsafe-flfloor
unsafe-flceiling
unsafe-fltruncate
unsafe-flsingle
unsafe-flsin
unsafe-flcos

View File

@ -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))

View File

@ -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