fix an allocation in bytecode compiler; add flvector equality

svn: r17353

collects/compiler/private/xform.ss

@@ -1523,45 +1523,46 @@
                          null
                          e))))]
             [(function? e)
-             (if (skip-function? e)
+             (let ([name (register-proto-information e)])
-                 e
+               (when (eq? (tok-n (car e)) '__xform_nongcing__)
-                 (let ([name (register-proto-information e)])
+                 (hash-table-put! non-gcing-functions name #t))
-                   (when (eq? (tok-n (car e)) '__xform_nongcing__)
+               (if (skip-function? e)
-                     (hash-table-put! non-gcing-functions name #t))
+                   e
-                   (when show-info? (printf "/* FUNCTION ~a */~n" name))
+                   (begin
-                   (if (or (positive? suspend-xform)
+                     (when show-info? (printf "/* FUNCTION ~a */~n" name))
-                           (not pgc?)
+                     (if (or (positive? suspend-xform)
-                           (and where 
+                             (not pgc?)
-                                (regexp-match re:h where)
+                             (and where 
-                                (let loop ([e e][prev #f])
+                                  (regexp-match re:h where)
-                                  (cond
+                                  (let loop ([e e][prev #f])
-                                   [(null? e) #t]
+                                    (cond
-                                   [(and (eq? '|::| (tok-n (car e)))
+                                     [(null? e) #t]
-                                         prev
+                                     [(and (eq? '|::| (tok-n (car e)))
-                                         (eq? (tok-n prev) (tok-n (cadr e))))
+                                           prev
-                                    ;; inline constructor: need to convert
+                                           (eq? (tok-n prev) (tok-n (cadr e))))
-                                    #f]
+                                      ;; inline constructor: need to convert
-                                   [else (loop (cdr e) (car e))]))))
+                                      #f]
-                       ;; Not pgc, xform suspended,
+                                     [else (loop (cdr e) (car e))]))))
-                       ;; or still in headers and probably a simple inlined function
+                         ;; Not pgc, xform suspended,
-                       (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))])
+                         ;; or still in headers and probably a simple inlined function
-                         (when palm?
+                         (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))])
-                           (fprintf map-port "(~aimpl ~s)~n" 
+                           (when palm?
-                                    (if palm-static? "s" "")
+                             (fprintf map-port "(~aimpl ~s)~n" 
-                                    name)
+                                      (if palm-static? "s" "")
-                           (call-graph name e))
+                                      name)
-                         (append
+                             (call-graph name e))
-                          (if palm-static?
+                           (append
-                              ;; Need to make sure prototype is there for section
+                            (if palm-static?
-                              (add-segment-label
+                                ;; Need to make sure prototype is there for section
-                               name
+                                (add-segment-label
-                               (let loop ([e e])
+                                 name
-                                 (if (braces? (car e))
+                                 (let loop ([e e])
-                                     (list (make-tok semi #f #f))
+                                   (if (braces? (car e))
-                                     (cons (car e) (loop (cdr e))))))
+                                       (list (make-tok semi #f #f))
-                              null)
+                                       (cons (car e) (loop (cdr e))))))
-                          e))
+                                null)
-                       (convert-function e name))))]
+                            e))
+                         (convert-function e name)))))]
             [(var-decl? e)
              (when show-info? (printf "/* VAR */~n"))
              (if (and can-drop-vars?

collects/scribblings/reference/numbers.scrbl

@@ -909,6 +909,10 @@ indirections that make f64vectors more convenient for working with
 foreign libraries. The lack of indirections make unsafe
 @tech{flvector} access more efficient.
 
+Two @tech{flvectors} are @scheme[equal?] if they have the same length,
+and if the values in corresponding slots of the @tech{flvectors} are
+@scheme[equal?].
+
 @defproc[(flvector? [v any/c]) boolean?]{
 
 Returns @scheme[#t] if @scheme[v] is a @tech{flvector}, @scheme[#f] otherwise.}

collects/tests/mzscheme/basic.ss

@@ -3,6 +3,8 @@
 
 (Section 'basic)
 
+(require scheme/flonum)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (test '() 'null null)
@@ -1934,7 +1936,8 @@
           [l (list 1 2 3)]
           [v (vector 5 6 7)]
           [a (make-a 1 (make-a 2 3))]
-          [b (box (list 1 2 3))])
+          [b (box (list 1 2 3))]
+          [fl (flvector 1.0 +nan.0 0.0)])
 
       (test 0 hash-count h1)
 
@@ -1947,7 +1950,8 @@
                      (hash-set! h1 (save 3.45) 'flonum)
                      (hash-set! h1 (save 3/45) 'rational)
                      (hash-set! h1 (save 3+45i) 'complex)
-                     (hash-set! h1 (save (integer->char 955)) 'char))]
+                     (hash-set! h1 (save (integer->char 955)) 'char)
+                     (hash-set! h1 (save fl) 'flvector))]
             [puts2 (lambda ()
                      (hash-set! h1 (save (list 5 7)) 'another-list)
                      (hash-set! h1 (save 3+0.0i) 'izi-complex)
@@ -1962,7 +1966,7 @@
             (puts1))
           (begin
             (puts1)
-            (test 7 hash-count h1)
+            (test 8 hash-count h1)
             (puts2))))
 
       (when reorder?
@@ -1974,7 +1978,7 @@
             (loop (add1 i))
             (hash-remove! h1 i))))
 
-      (test 13 hash-count h1)
+      (test 14 hash-count h1)
       (test 'list hash-ref h1 l)
       (test 'list hash-ref h1 (list 1 2 3))
       (test 'another-list hash-ref h1 (list 5 7))
@@ -1993,6 +1997,7 @@
       (test 'box hash-ref h1 b)
       (test 'box hash-ref h1 #&(1 2 3))
       (test 'char hash-ref h1 (integer->char 955))
+      (test 'flvector hash-ref h1 (flvector 1.0 +nan.0 0.0))
       (test #t
             andmap
             (lambda (i)
@@ -2010,13 +2015,14 @@
               (,(make-a 1 (make-a 2 3)) . struct)
               (,an-ax . structx)
               (#\u3BB . char)
-              (#&(1 2 3) . box)))
+              (#&(1 2 3) . box)
+              (,(flvector 1.0 +nan.0 0.0) . flvector)))
       (hash-remove! h1 (list 1 2 3))
-      (test 12 hash-count h1)
+      (test 13 hash-count h1)
       (test 'not-there hash-ref h1 l (lambda () 'not-there))
       (let ([c 0])
         (hash-for-each h1 (lambda (k v) (set! c (add1 c))))
-        (test 12 'count c))
+        (test 13 'count c))
       ;; return the hash table:
       h1))
 

src/mzscheme/src/bool.c

@@ -388,6 +388,19 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
     if (union_check(obj1, obj2, eql))
       return 1;
     return vector_equal(obj1, obj2, eql);
+  } else if (SCHEME_FLVECTORP(obj1)) {
+    long l1, l2, i;
+    l1 = SCHEME_FLVEC_SIZE(obj1);
+    l2 = SCHEME_FLVEC_SIZE(obj2);
+    if (l1 == l2) {
+      for (i = 0; i < l1; i++) {
+        if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
+                        SCHEME_FLVEC_ELS(obj2)[i]))
+          return 0;
+      }
+      return 1;
+    }
+    return 0;
   } else if (SCHEME_BYTE_STRINGP(obj1)
 	     || SCHEME_GENERAL_PATHP(obj1)) {
     int l1, l2;

src/mzscheme/src/fun.c

@@ -1467,8 +1467,13 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
   if (captured && (captured->count > offset)) {
     /* We need to extend the closure map.  All the info
        is in captured, so just build it from scratch. */
-    int old_pos, j;
+    int old_pos, j, new_size;
-    closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * (captured->count + (has_tl ? 1 : 0)));
+    new_size = (captured->count + (has_tl ? 1 : 0));
+    if (cl->flonum_map)
+      new_size += boxmap_size(data->num_params + new_size);
+    closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * new_size);
+    if (cl->flonum_map)
+      memset(closure_map, 0, sizeof(mzshort) * new_size);
     offset = captured->count;
     convert_boxes = NULL;
     for (j = captured->size; j--; ) {
@@ -1519,7 +1524,7 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
         int bsz;
         bsz = boxmap_size(convert_size);
         memcpy(closure_map XFORM_OK_PLUS (has_tl ? 1 : 0), 
-               convert_boxes, 
+               convert_boxes,
                bsz * sizeof(mzshort));
       }
     } else

src/mzscheme/src/hash.c

@@ -945,6 +945,47 @@ static long overflow_equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi)
   return val;
 }
 
+XFORM_NONGCING static long dbl_hash_val(double d) 
+  XFORM_SKIP_PROC
+{
+  int e;
+  
+  if (MZ_IS_NAN(d)) {
+    d = 0.0;
+    e = 1000;
+  } else if (MZ_IS_POS_INFINITY(d)) {
+    d = 0.5;
+    e = 1000;
+  } else if (MZ_IS_NEG_INFINITY(d)) {
+    d = -0.5;
+    e = 1000;
+  } else if (!d && scheme_minus_zero_p(d)) {
+    d = 0;
+    e = 1000;
+  } else {
+    /* frexp should not be used on inf or nan: */
+    d = frexp(d, &e);
+  }
+
+  return ((long)(d * (1 << 30))) + e;
+}
+
+XFORM_NONGCING static long dbl_hash2_val(double d)  
+  XFORM_SKIP_PROC
+{
+  int e;
+  
+  if (MZ_IS_NAN(d)
+      || MZ_IS_POS_INFINITY(d)
+      || MZ_IS_NEG_INFINITY(d)) {
+    e = 1;
+  } else {
+    /* frexp should not be used on inf or nan: */
+    d = frexp(d, &e);
+  }
+  return e;
+}
+
 #define OVERFLOW_HASH() overflow_equal_hash_key(o, k - t, hi)
 
 /* Based on Bob Jenkins's one-at-a-time hash function at
@@ -971,26 +1012,7 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi)
 #endif
   case scheme_double_type:
     {
-      double d;
+      return k + dbl_hash_val(SCHEME_DBL_VAL(o));
-      int e;
-      d = SCHEME_DBL_VAL(o);
-      if (MZ_IS_NAN(d)) {
-	d = 0.0;
-	e = 1000;
-      } else if (MZ_IS_POS_INFINITY(d)) {
-	d = 0.5;
-	e = 1000;
-      } else if (MZ_IS_NEG_INFINITY(d)) {
-	d = -0.5;
-	e = 1000;
-      } else if (!d && scheme_minus_zero_p(d)) {
-	d = 0;
-	e = 1000;
-      } else {
-	/* frexp should not be used on inf or nan: */
-	d = frexp(d, &e);
-      }
-      return k + ((long)(d * (1 << 30))) + e;
     }
   case scheme_bignum_type:
     {
@@ -1059,6 +1081,22 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi)
       o = SCHEME_VEC_ELS(o)[len];
       break;
     }
+  case scheme_flvector_type:
+    {
+      long len = SCHEME_FLVEC_SIZE(o), i;
+      double d;
+
+      if (!len)
+	return k + 1;
+      
+      for (i = 0; i < len; i++) {
+	SCHEME_USE_FUEL(1);
+	d = SCHEME_FLVEC_ELS(o)[i];
+        k = (k << 5) + k + dbl_hash_val(d);
+      }
+      
+      return k;
+    }
   case scheme_char_type:
     return k + SCHEME_CHAR_VAL(o);
   case scheme_byte_string_type:
@@ -1396,18 +1434,7 @@ static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
 #endif
   case scheme_double_type:
     {
-      double d;
+      return dbl_hash2_val(SCHEME_FLOAT_VAL(o));
-      int e;
-      d = SCHEME_FLOAT_VAL(o);
-      if (MZ_IS_NAN(d)
-	  || MZ_IS_POS_INFINITY(d)
-	  || MZ_IS_NEG_INFINITY(d)) {
-	e = 1;
-      } else {
-	/* frexp should not be used on inf or nan: */
-	d = frexp(d, &e);
-      }
-      return e;
     }
   case scheme_bignum_type:
     return SCHEME_BIGDIG(o)[0];
@@ -1454,6 +1481,23 @@ static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
 	k += equal_hash_key2(SCHEME_VEC_ELS(o)[i], hi);
       }
       
+      return k;
+    }
+  case scheme_flvector_type:
+    {
+      long len = SCHEME_FLVEC_SIZE(o), i;
+      double d;
+      long k = 0;
+
+      if (!len)
+	return k + 1;
+      
+      for (i = 0; i < len; i++) {
+	SCHEME_USE_FUEL(1);
+	d = SCHEME_FLVEC_ELS(o)[i];
+        k = (k << 5) + k + dbl_hash2_val(d);
+      }
+      
       return k;
     }
   case scheme_char_type:

src/mzscheme/src/jit.c

@@ -638,7 +638,7 @@ static void *generate_one(mz_jit_state *old_jitter,
     if (ok) {
       /* That was big enough: */
       if (jitter->unbox || jitter->unbox_depth)
-	scheme_signal_error("ended with unbox or depth");
+	scheme_signal_error("internal error: ended with unbox or depth");
       if (known_size) {
 	/* That was in the permanent area, so return: */
 	jit_flush_code(buffer, jit_get_ip().ptr);
@@ -4468,7 +4468,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
       unsafe_fl = 1;
     
     if (!args_unboxed && rand)
-      scheme_signal_error("unvalid mode");
+      scheme_signal_error("internal error: invalid mode");
 
     if (inlined_flonum1 && !inlined_flonum2) {
       GC_CAN_IGNORE Scheme_Object *tmp;
@@ -4571,7 +4571,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
       --jitter->unbox;
     jitter->unbox_depth -= flonum_depth;
     if (!jitter->unbox && jitter->unbox_depth && rand)
-      scheme_signal_error("broken unbox depth");
+      scheme_signal_error("internal error: broken unbox depth");
     if (for_branch)
       mz_rs_sync(); /* needed if arguments were unboxed */
 
@@ -5190,7 +5190,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
             ref3 = jit_bmcr_l(jit_forward(), JIT_R0, JIT_R2);
           } else {
             /* shouldn't get here */
-            scheme_signal_error("bitwise-bit-test? constant in wrong position");
+            scheme_signal_error("internal error: bitwise-bit-test? constant in wrong position");
             ref3 = NULL;
           }
           break;
@@ -6789,7 +6789,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
 	which = 3;
         base_offset = ((int)&SCHEME_FLVEC_ELS(0x0));
         if (unbox) {
-          if (jitter->unbox_depth) scheme_signal_error("bad depth for flvector-ref");
+          if (jitter->unbox_depth) 
+            scheme_signal_error("internal error: bad depth for flvector-ref");
           jitter->unbox = 0;
         }
       } else if (IS_NAMED_PRIM(rator, "unsafe-struct-ref")) {
@@ -7996,7 +7997,7 @@ static int generate_unboxed(Scheme_Object *obj, mz_jit_state *jitter, int inline
   }
 
   if (!jitter->unbox || jitter->unbox_depth)
-    scheme_signal_error("bad unboxing mode or depth");
+    scheme_signal_error("internal error: bad unboxing mode or depth");
   
   /* It probably would be useful to special-case a let-one
      sequence down to something that can be unboxed. */
@@ -8497,7 +8498,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
         break;
       case SPLICE_EXPD:
         {
-          scheme_signal_error("cannot JIT a top-level splice form");
+          scheme_signal_error("internal error: cannot JIT a top-level splice form");
         }
         break;
       default: