Ajout du tag Double_array_tag.

Deplacement de copy_double dans floats.c.


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@153 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

8 files changed, 92 insertions, 20 deletions

diff --git a/byterun/alloc.c b/byterun/alloc.c
index 37d9ce7100..d5ed621b59 100644
--- a/byterun/alloc.c
+++ b/byterun/alloc.c
@@ -60,16 +60,6 @@ value alloc_final (len, fun, mem, max)
   return result;
 }
 
-value copy_double(d)
-     double d;
-{
-  value res;
-
-  Alloc_small(res, Double_wosize, Double_tag);
-  Store_double_val(res, d);
-  return res;
-}
-
 value copy_string(s)
      char * s;
 {
diff --git a/byterun/compare.c b/byterun/compare.c
index 1c9919edfb..99c26321d7 100644
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -42,6 +42,18 @@ static long compare_val(v1, v2)
     double d2 = Double_val(v2);
     if (d1 == d2) return 0; else if (d1 < d2) return -1; else return 1;
   }
+  case Double_array_tag: {
+    mlsize_t sz1 = Wosize_val(v1);
+    mlsize_t sz2 = Wosize_val(v2);
+    mlsize_t i;
+    if (sz1 != sz2) return sz1 - sz2;
+    for (i = 0; i < sz1; i++) {
+      double d1 = Double_field(v1, i);
+      double d2 = Double_field(v2, i);
+      if (d1 != d2) { if (d1 < d2) return -1; else return 1; }
+    }
+    return 0;
+  }
   case Abstract_tag:
   case Final_tag:
     invalid_argument("equal: abstract value");
diff --git a/byterun/extern.c b/byterun/extern.c
index 4be22d62ad..07ead7e0dc 100644
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -175,14 +175,23 @@ static void emit_compact(chan, v)
         break;
       }
       case Double_tag: {
-        double buffer;
         if (sizeof(double) != 8)
           invalid_argument("output_value: non-standard floats");
         putch(chan, CODE_DOUBLE_NATIVE);
-        buffer = Double_val(v);
-        putblock(chan, (char *) &buffer, 8);
-        size_32 += 1 + sizeof(double) / 4;
-        size_64 += 1 + sizeof(double) / 8;
+        putblock(chan, (char *) v, 8);
+        size_32 += 1 + 2;
+        size_64 += 1 + 1;
+        break;
+      }
+      case Double_array_tag: {
+        mlsize_t nfloats;
+        if (sizeof(double) != 8)
+          invalid_argument("output_value: non-standard floats");
+        nfloats = Wosize_val(v) / Double_wosize;
+        output32(chan, CODE_DOUBLE_ARRAY_NATIVE, nfloats);
+        putblock(chan, (char *) v, Bosize_val(v));
+        size_32 += 1 + nfloats * 2;
+        size_64 += 1 + nfloats;
         break;
       }
       case Abstract_tag:
diff --git a/byterun/floats.c b/byterun/floats.c
index 7e6fc703bc..ee0dbc070a 100644
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -60,6 +60,20 @@ void Store_double_val(val, dbl)
 #endif
 #endif
 
+value copy_double(d)
+     double d;
+{
+  value res;
+
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
+}
+
 value format_float(fmt, arg)    /* ML */
      value fmt, arg;
 {
diff --git a/byterun/hash.c b/byterun/hash.c
index 7585c1b948..b7a6f0a3d0 100644
--- a/byterun/hash.c
+++ b/byterun/hash.c
@@ -30,7 +30,7 @@ static void hash_aux(obj)
      value obj;
 {
   unsigned char * p;
-  mlsize_t i;
+  mlsize_t i, j;
   tag_t tag;
 
   hash_univ_limit--;
@@ -69,6 +69,21 @@ static void hash_aux(obj)
 #endif
         Combine_small(*p);
       break;
+    case Double_array_tag:
+      hash_univ_count--;
+      for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
+#ifdef BIG_ENDIAN
+      for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
+           i > 0;
+           p--, i--)
+#else
+      for (p = &Byte_u(obj, j), i = sizeof(double);
+           i > 0;
+           p++, i--)
+#endif
+        Combine_small(*p);
+      }
+      break;
     case Abstract_tag:
     case Final_tag:
       /* We don't know anything about the contents of the block.
diff --git a/byterun/intern.c b/byterun/intern.c
index 4fb438b44a..0c64bf7bed 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -188,6 +188,25 @@ static void read_compact(chan, dest)
         really_getblock(chan, (char *) v, 8);
         if (code != CODE_DOUBLE_NATIVE) Reverse_double(v);
         break;
+      case CODE_DOUBLE_ARRAY_LITTLE:
+      case CODE_DOUBLE_ARRAY_BIG:
+        if (sizeof(double) != 8) {
+          stat_free((char *) intern_obj_table);
+          Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
+          invalid_argument("input_value: non-standard floats");
+        }
+        len = input32u(chan);
+        size = len * Double_wosize;
+        v = Val_hp(intern_ptr);
+        intern_obj_table[obj_counter++] = v;
+        *intern_ptr = Make_header(size, Double_array_tag, intern_color);
+        intern_ptr += 1 + size;
+        really_getblock(chan, (char *) v, len * 8);
+        if (code != CODE_DOUBLE_NATIVE) {
+          mlsize_t i;
+          for (i = 0; i < len; i++) Reverse_double((value)((double *)v + i));
+        }
+        break;
       }
     }
   }
diff --git a/byterun/intext.h b/byterun/intext.h
index 7b1a26c414..501bed6a42 100644
--- a/byterun/intext.h
+++ b/byterun/intext.h
@@ -34,6 +34,13 @@
 #else
 #define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE
 #endif
+#define CODE_DOUBLE_ARRAY_BIG 0xD
+#define CODE_DOUBLE_ARRAY_LITTLE 0xE
+#ifdef BIG_ENDIAN
+#define CODE_DOUBLE_ARRAY_NATIVE CODE_DOUBLE_ARRAY_BIG
+#else
+#define CODE_DOUBLE_ARRAY_NATIVE CODE_DOUBLE_ARRAY_LITTLE
+#endif
 
 /* Initial sizes of data structures for extern */
 
diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
index d9b1242f54..2f32ea70ca 100644
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -132,7 +132,7 @@ bits  63    10 9     8 7   0
 #endif
 
 /* The lowest tag for blocks containing no value. */
-#define No_scan_tag (Num_tags - 5)
+#define No_scan_tag (Num_tags - 6)
 
 
 /* 1- If tag < No_scan_tag : a tuple of fields.  */
@@ -177,17 +177,23 @@ typedef opcode_t * code_t;
 #define Double_tag (No_scan_tag + 3)
 #define Double_wosize ((sizeof(double) / sizeof(value)))
 #ifndef ALIGN_DOUBLE
-#define Double_val(v) (* (double *) (v))
-#define Store_double_val(v,d) (* (double *) (v) = (d))
+#define Double_val(v) (* (double *)(v))
+#define Store_double_val(v,d) (* (double *)(v) = (d))
 #else
 double Double_val P((value));
 void Store_double_val P((value,double));
 #endif
 
+/* Arrays of floating-point numbers. */
+#define Double_array_tag (No_scan_tag + 4)
+#define Double_field(v,i) Double_val((value)((double *)(v) + (i)))
+#define Store_double_field(v,i,d) \
+  Store_double_val((value)((double *)(v) + (i)),d)
+
 /* Finalized things.  Just like abstract things, but the GC will call the
    [Final_fun] before deallocation.
 */
-#define Final_tag (No_scan_tag + 4)
+#define Final_tag (No_scan_tag + 5)
 typedef void (*final_fun) P((value));
 #define Final_fun(val) (((final_fun *) (val)) [0]) /* Also an l-value. */