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.

.makefile

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

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
+	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.6-2
+	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 branch  circa-7.8.0.7-1
-	cd  racket/src/ChezScheme/boot/pb && git checkout  circa-7.8.0.6-2
+	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)"

pkgs/base/info.rkt

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

pkgs/racket-doc/scribblings/reference/flonums.scrbl

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

pkgs/racket-doc/scribblings/reference/unsafe.scrbl

@@ -154,24 +154,13 @@ For @tech{flonums}: Unchecked (potentially) versions of
 the corresponding safe bindings.}
 
 
-@deftogether[(
+@defproc[(unsafe-flsingle [a flonum?]) flonum?]{
-@defproc[(unsafe-flsin [a flonum?]) flonum?]
+
-@defproc[(unsafe-flcos [a flonum?]) flonum?]
+For @tech{flonums}: Unchecked (potentially) version of
-@defproc[(unsafe-fltan [a flonum?]) flonum?]
+@racket[flsingle].
-@defproc[(unsafe-flasin [a flonum?]) flonum?]
+
-@defproc[(unsafe-flacos [a flonum?]) flonum?]
+@history[#:added "7.8.0.7"]}
-@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?]
-)]{
 
-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?])

pkgs/racket-test-core/tests/racket/flonum.rktl

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

pkgs/racket-test-core/tests/racket/unsafe.rktl

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

racket/collects/racket/flonum.rkt

@@ -8,8 +8,8 @@
 (provide fl+ fl- fl* fl/
          flabs flsqrt flexp fllog
          flsin flcos fltan flasin flacos flatan
-         flfloor flceiling flround fltruncate flexpt
+         flfloor flceiling flround fltruncate
-         flrandom
+         flsingle flexpt flrandom
          fl= fl< fl<= fl> fl>= flmin flmax
          ->fl fl->exact-integer
          flvector? flvector make-flvector 

racket/src/ChezScheme/c/pb.c

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

racket/src/ChezScheme/csug/numeric.stex

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

racket/src/ChezScheme/makefiles/Mf-install.in

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

racket/src/ChezScheme/mats/fl.ms

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

racket/src/ChezScheme/mats/root-experr-compile-0-f-f-f

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

racket/src/ChezScheme/rktboot/make-boot.rkt

@@ -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)])
+    (for ([src (in-list all-sources)])
-      (let ([dest (path->string (path->complete-path (build-path out-subdir (path-replace-suffix src #".so"))))])
+      (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)
+  (let ([src->so (lambda (src) (source->so #:abs? #f src))])
-                   (path->string (build-path out-subdir (path-replace-suffix src #".so"))))])
     (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))))

racket/src/ChezScheme/s/arm32.ss

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

racket/src/ChezScheme/s/arm64.ss

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

racket/src/ChezScheme/s/cmacros.ss

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

racket/src/ChezScheme/s/cpnanopass.ss

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

racket/src/ChezScheme/s/library.ss

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

racket/src/ChezScheme/s/mathprims.ss

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

racket/src/ChezScheme/s/np-languages.ss

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

racket/src/ChezScheme/s/pb.ss

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

racket/src/ChezScheme/s/ppc32.ss

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

racket/src/ChezScheme/s/primdata.ss

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

racket/src/ChezScheme/s/x86.ss

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

racket/src/ChezScheme/s/x86_64.ss

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

racket/src/bc/src/jitarith.c

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

racket/src/bc/src/jitinline.c

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

racket/src/bc/src/number.c

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

racket/src/bc/src/schminc.h

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

racket/src/bc/src/schpriv.h

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

racket/src/cs/compile-file.ss

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

racket/src/cs/primitive/flfxnum.ss

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

racket/src/cs/primitive/unsafe.ss

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

racket/src/cs/rumble.sls

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

racket/src/cs/rumble/unsafe.ss

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

racket/src/version/racket_version.h

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