performance tweaks for `for/{fx,fl,extfl}vector'

Also, provide a better error message when the body produces a
non-{fix,flo,extflo}num.

collects/data/bit-vector.rkt

@@ -138,6 +138,7 @@
 
 
 (define-vector-wraps "bit-vector"
+  "boolean?" boolean?
   bit-vector? bit-vector-length bit-vector-ref bit-vector-set! make-bit-vector
   unsafe-bit-vector-ref bit-vector-set! bit-vector-length
   in-bit-vector*

collects/racket/extflonum.rkt

@@ -11,6 +11,7 @@
          extflvector-copy)
 
 (define-vector-wraps "extflvector"
+  "extflonum?" extflonum?
   extflvector? extflvector-length extflvector-ref extflvector-set! make-extflvector
   unsafe-extflvector-ref unsafe-extflvector-set! unsafe-extflvector-length
   in-extflvector*

collects/racket/fixnum.rkt

@@ -20,6 +20,7 @@
          in-fxvector for/fxvector for*/fxvector)
 
 (define-vector-wraps "fxvector"
+  "fixnum?" fixnum?
   fxvector? fxvector-length fxvector-ref fxvector-set! make-fxvector
   unsafe-fxvector-ref unsafe-fxvector-set! unsafe-fxvector-length
   in-fxvector*

collects/racket/flonum.rkt

@@ -19,6 +19,7 @@
          in-flvector for/flvector for*/flvector)
 
 (define-vector-wraps "flvector"
+  "flonum?" flonum?
   flvector? flvector-length flvector-ref flvector-set! make-flvector
   unsafe-flvector-ref unsafe-flvector-set! unsafe-flvector-length
   in-flvector*

collects/racket/private/for.rkt

@@ -1497,10 +1497,10 @@
                            [i 0])
                           (for-clause ...) 
                           middle-body ...
-                          (let ([new-vec (if (eq? i (unsafe-vector-length vec))
+                          (let ([new-vec (if (eq? i (unsafe-vector*-length vec))
                                              (grow-vector vec)
                                              vec)])
-                            (unsafe-vector-set! new-vec i (let () last-body ...))
+                            (unsafe-vector*-set! new-vec i (let () last-body ...))
                             (values new-vec (unsafe-fx+ i 1))))])
              (shrink-vector vec i))))]
       [(_ #:length length-expr #:fill fill-expr (for-clause ...) body ...)
@@ -1546,8 +1546,8 @@
                   ([i 0])
                   (limited-for-clause ...)
                   middle-body ...
-                  (vector-set! v i (let () last-body ...))
+                  (unsafe-vector*-set! v i (let () last-body ...))
-                  (add1 i)))
+                  (unsafe-fx+ 1 i)))
                v))))]
       [(_ #:length length-expr (for-clause ...) body ...)
        (for_/vector #'(fv #:length length-expr #:fill 0 (for-clause ...) body ...) 

collects/racket/private/vector-wraps.rkt

@@ -9,6 +9,7 @@
 
 (define-syntax-rule (define-vector-wraps
                       fXvector-str
+                      fX?-str fX?
                       fXvector? fXvector-length fXvector-ref fXvector-set! make-fXvector
                       unsafe-fXvector-ref unsafe-fXvector-set! unsafe-fXvector-length
                       in-fXvector*
@@ -50,6 +51,9 @@
        (unsafe-fXvector-copy! new-vec 0 vec 0 i)
        new-vec)
 
+     (define (not-an-fX who v)
+       (raise-argument-error who fX?-str v))
+
      (define-for-syntax (for_/fXvector stx orig-stx for_/fXvector-stx for_/fold/derived-stx wrap-all?)
        (syntax-case stx ()
          [(for*/fXvector (for-clause ...) body ...)
@@ -67,7 +71,10 @@
                              (let ([new-vec (if (eq? i (unsafe-fXvector-length vec))
                                                 (grow-fXvector vec)
                                                 vec)])
-                               (fXvector-set! new-vec i (let () last-body ...))
+                               (let ([elem (let () last-body ...)])
+                                 (if (fX? elem)
+                                     (unsafe-fXvector-set! new-vec i elem)
+                                     (not-an-fX 'for*/fXvector elem)))
                                (values new-vec (unsafe-fx+ i 1))))])
                 (shrink-fXvector vec i))))]
          [(for*/fXvector #:length length-expr #:fill fill-expr (for-clause ...) body ...)
@@ -114,8 +121,11 @@
                        ([i 0])
                        (limited-for-clause ...)
                        middle-body ...
-                       (fXvector-set! v i (let () last-body ...))
+                       (let ([elem (let () last-body ...)])
-                       (add1 i)))
+                         (if (fX? elem)
+                             (unsafe-fXvector-set! v i elem)
+                             (not-an-fX 'for*/vector elem)))
+                       (unsafe-fx+ 1 i)))
                     v)))))]
          [(_ #:length length-expr (for-clause ...) body ...)
           (for_/fXvector #'(fv #:length length-expr #:fill fXzero (for-clause ...) body ...) 

collects/tests/racket/optimize.rktl

@@ -1788,6 +1788,32 @@
                       (+ p (unsafe-fx- p 1) (- p p) t))
                     'ok))))
 
+;; eliminate unneeded tests:
+(test-comp '(lambda (n)
+              (let ([p (fl+ n n)])
+                (if (flonum? p)
+                    (fl+ p p)
+                    'bad)))
+           '(lambda (n)
+              (let ([p (fl+ n n)])
+                (fl+ p p))))
+(test-comp '(lambda (n)
+              (let ([p (fx+ n n)])
+                (if (fixnum? p)
+                    (fx+ p p)
+                    'bad)))
+           '(lambda (n)
+              (let ([p (fx+ n n)])
+                (fx+ p p))))
+(test-comp '(lambda (n)
+              (let ([p (extfl+ n n)])
+                (if (extflonum? p)
+                    (extfl+ p p)
+                    'bad)))
+           '(lambda (n)
+              (let ([p (extfl+ n n)])
+                (extfl+ p p))))
+
 ;; simple cross-module inlining
 (test-comp `(module m racket/base 
               (require racket/bool)

src/racket/src/number.c

@@ -815,7 +815,8 @@ void scheme_init_flfxnum_number(Scheme_Env *env)
     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_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
+                                                            | SCHEME_PRIM_PRODUCES_FLONUM);
   scheme_add_global_constant("->fl", p, env);
 
   p = scheme_make_folding_prim(fl_to_integer, "fl->exact-integer", 1, 1, 1);

src/racket/src/optimize.c

@@ -2361,6 +2361,29 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
     info->single_result = -info->single_result;
   }
 
+  /* Check for things like (flonum? x) on an `x' known to have a flonum value. */
+  if (SCHEME_PRIMP(app->rator)
+      && (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)
+      && SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)) {
+    int pos = SCHEME_LOCAL_POS(app->rand);
+
+    if (!optimize_is_mutated(info, pos)) {
+      int t;
+      t = optimize_is_local_type_valued(info, pos);
+
+      if (t == SCHEME_LOCAL_TYPE_FLONUM) {
+        if (IS_NAMED_PRIM(app->rator, "flonum?"))
+          return scheme_true;
+      } else if (t == SCHEME_LOCAL_TYPE_FIXNUM) {
+        if (IS_NAMED_PRIM(app->rator, "fixnum?"))
+          return scheme_true;
+      } else if (t == SCHEME_LOCAL_TYPE_EXTFLONUM) {
+        if (IS_NAMED_PRIM(app->rator, "extflonum?"))
+          return scheme_true;
+      }
+    }
+  }
+
   /* Check for things like (cXr (cons X Y)): */
   if (SCHEME_PRIMP(app->rator)
       && (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {