Changement du format pour intern/extern.

Pour les threads, adaptation des I/O a la possibilite d'un GC des qu'on fait enter_blocking_section. git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@716 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
author: Xavier Leroy <xavier.leroy@inria.fr> 1996-04-01 15:24:38 +0000
committer: Xavier Leroy <xavier.leroy@inria.fr> 1996-04-01 15:24:38 +0000
commit: 3b99a2c8d5c0aec40323e725b4fe28b4f3953344 (patch)
tree: 008f3c37ed9abb0c257fc794c64f318897647cef
parent: 3b91622e5db25564b9e8f48ef4a4260fab0b1396 (diff)
6 files changed, 330 insertions, 177 deletions
diff --git a/byterun/extern.c b/byterun/extern.c
index 15f709077..3c4404bda 100644
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -13,6 +13,7 @@
 
 /* Structured output */
 
+#include "alloc.h"
 #include "fail.h"
 #include "gc.h"
 #include "intext.h"
@@ -47,14 +48,14 @@ static void alloc_extern_table()
 
   extern_table = (struct extern_obj *)
     stat_alloc(extern_table_size * sizeof(struct extern_obj));
-  for (i = 0; i < extern_table_size; i++)
-    extern_table[i].obj = 0;
+  for (i = 0; i < extern_table_size; i++) extern_table[i].obj = 0;
 }
 
 static void resize_extern_table()
 {
   asize_t oldsize;
   struct extern_obj * oldtable;
+  value obj;
   asize_t i, h;
 
   oldsize = extern_table_size;
@@ -62,94 +63,162 @@ static void resize_extern_table()
   extern_table_size = 2 * extern_table_size;
   alloc_extern_table();
   for (i = 0; i < oldsize; i++) {
-    h = Hash(oldtable[i].obj);
-    while (extern_table[h].obj != 0) {
-      h++;
-      if (h >= extern_table_size) h = 0;
+    obj = oldtable[i].obj;
+    if (obj != 0) {
+      h = Hash(obj);
+      while (extern_table[h].obj != 0) {
+        h++;
+        if (h >= extern_table_size) h = 0;
+      }
+      extern_table[h].obj = obj;
+      extern_table[h].ofs = oldtable[i].ofs;
     }
-    extern_table[h].obj = oldtable[i].obj;
-    extern_table[h].ofs = oldtable[i].ofs;
   }
   stat_free((char *) oldtable);
 }
 
-/* Write integers on a channel */
+/* To buffer the output */
 
-static void output8(chan, code, val)
-     struct channel * chan;
+static char * extern_block, * extern_ptr, * extern_limit;
+
+static void alloc_extern_block()
+{
+  extern_block = stat_alloc(INITIAL_EXTERN_BLOCK_SIZE);
+  extern_limit = extern_block + INITIAL_EXTERN_BLOCK_SIZE;
+  extern_ptr = extern_block;
+}
+
+static void resize_extern_block(required)
+     int required;
+{
+  long curr_pos, size, reqd_size;
+
+  curr_pos = extern_ptr - extern_block;
+  size = extern_limit - extern_block;
+  reqd_size = curr_pos + required;
+  while (size <= reqd_size) size *= 2;
+  extern_block = stat_resize(extern_block, size);
+  extern_limit = extern_block + size;
+  extern_ptr = extern_block + curr_pos;
+}
+
+#define Write(c) \
+  if (extern_ptr >= extern_limit) resize_extern_block(1); \
+  *extern_ptr++ = (c)
+
+/* Write integers and blocks in the output buffer */
+
+static void writeblock(data, len)
+     char * data;
+     long len;
+{
+  if (extern_ptr + len > extern_limit) resize_extern_block(len);
+  bcopy(data, extern_ptr, len);
+  extern_ptr += len;
+}
+
+static void writecode8(code, val)
      int code;
      long val;
 {
-  putch(chan, code); putch(chan, val);
+  if (extern_ptr + 2 > extern_limit) resize_extern_block(2);
+  extern_ptr[0] = code;
+  extern_ptr[1] = val;
+  extern_ptr += 2;
 }
 
-static void output16(chan, code, val)
-     struct channel * chan;
+static void writecode16(code, val)
      int code;
      long val;
 {
-  putch(chan, code); putch(chan, val >> 8); putch(chan, val);
+  if (extern_ptr + 3 > extern_limit) resize_extern_block(3);
+  extern_ptr[0] = code;
+  extern_ptr[1] = val >> 8;
+  extern_ptr[2] = val;
+  extern_ptr += 3;
 }
 
-static void output32(chan, code, val)
-     struct channel * chan;
+static void write32(val)
+     long val;
+{
+  if (extern_ptr + 4 > extern_limit) resize_extern_block(4);
+  extern_ptr[0] = val >> 24;
+  extern_ptr[1] = val >> 16;
+  extern_ptr[2] = val >> 8;
+  extern_ptr[3] = val;
+  extern_ptr += 4;
+}
+
+static void writecode32(code, val)
      int code;
      long val;
 {
-  putch(chan, code);
-  putch(chan, val >> 24); putch(chan, val >> 16);
-  putch(chan, val >> 8); putch(chan, val);
+  if (extern_ptr + 5 > extern_limit) resize_extern_block(5);
+  extern_ptr[0] = code;
+  extern_ptr[1] = val >> 24;
+  extern_ptr[2] = val >> 16;
+  extern_ptr[3] = val >> 8;
+  extern_ptr[4] = val;
+  extern_ptr += 5;
 }
 
 #ifdef SIXTYFOUR
-static void output64(chan, code, val)
-     struct channel * chan;
+static void writecode64(code, val)
      int code;
      long val;
 {
   int i;
-  putch(chan, code);
-  for (i = 64 - 8; i >= 0; i -= 8) putch(chan, val >> i);
+  if (extern_ptr + 9 > extern_limit) resize_extern_block(9);
+  *extern_ptr ++ = code;
+  for (i = 64 - 8; i >= 0; i -= 8) *extern_ptr++ = val >> i;
 }
 #endif
 
+/* Marshal the given value in the output buffer */
+
 static byteoffset_t obj_counter;    /* Number of objects emitted so far */
 static unsigned long size_32;  /* Size in words of 32-bit block for struct. */
 static unsigned long size_64;  /* Size in words of 64-bit block for struct. */
 
-static void emit_compact(chan, v)
-     struct channel * chan;
+static void extern_cleanup()
+{
+  stat_free(extern_block);
+  stat_free((char *) extern_table);
+}
+
+static void extern_rec(v)
      value v;
 {
  tailcall:
   if (Is_long(v)) {
     long n = Long_val(v);
     if (n >= 0 && n < 0x40) {
-      putch(chan, PREFIX_SMALL_INT + n);
+      Write(PREFIX_SMALL_INT + n);
     } else if (n >= -(1 << 7) && n < (1 << 7)) {
-      output8(chan, CODE_INT8, n);
+      writecode8(CODE_INT8, n);
     } else if (n >= -(1 << 15) && n < (1 << 15)) {
-      output16(chan, CODE_INT16, n);
+      writecode16(CODE_INT16, n);
 #ifdef SIXTYFOUR
     } else if (n < -(1L << 31) || n >= (1L << 31)) {
-      output64(chan, CODE_INT64, n);
+      writecode64(CODE_INT64, n);
 #endif
     } else
-      output32(chan, CODE_INT32, n);
+      writecode32(CODE_INT32, n);
   } else if (!Is_atom(v) && !Is_young(v) && !Is_in_heap(v)) {
+    extern_cleanup();
     invalid_argument("output_value: abstract value");
   } else {
     header_t hd = Hd_val(v);
     tag_t tag = Tag_hd(hd);
     mlsize_t sz = Wosize_hd(hd);
-      asize_t h;
+    asize_t h;
     /* Atoms are treated specially for two reasons: they are not allocated
        in the externed block, and they are automatically shared. */
     if (sz == 0) {
       if (tag < 16) {
-        putch(chan, PREFIX_SMALL_BLOCK + tag);
+        Write(PREFIX_SMALL_BLOCK + tag);
       } else {
-        output32(chan, CODE_BLOCK32, hd);
+        writecode32(CODE_BLOCK32, hd);
       }
     } else {
       /* Check if already seen */
@@ -159,11 +228,11 @@ static void emit_compact(chan, v)
         if (extern_table[h].obj == v) {
           byteoffset_t d = obj_counter - extern_table[h].ofs;
           if (d < 0x100) {
-            output8(chan, CODE_SHARED8, d);
+            writecode8(CODE_SHARED8, d);
           } else if (d < 0x10000) {
-            output16(chan, CODE_SHARED16, d);
+            writecode16(CODE_SHARED16, d);
           } else {
-            output32(chan, CODE_SHARED32, d);
+            writecode32(CODE_SHARED32, d);
           }
           return;
         }
@@ -178,59 +247,65 @@ static void emit_compact(chan, v)
       case String_tag: {
         mlsize_t len = string_length(v);
         if (len < 0x20) {
-          putch(chan, PREFIX_SMALL_STRING + len);
+          Write(PREFIX_SMALL_STRING + len);
         } else if (len < 0x100) {
-          output8(chan, CODE_STRING8, len);
+          writecode8(CODE_STRING8, len);
         } else {
-          output32(chan, CODE_STRING32, len);
+          writecode32(CODE_STRING32, len);
         }
-        putblock(chan, String_val(v), len);
+        writeblock(String_val(v), len);
         size_32 += 1 + (len + 4) / 4;
         size_64 += 1 + (len + 8) / 8;
         break;
       }
       case Double_tag: {
-        if (sizeof(double) != 8)
+        if (sizeof(double) != 8) {
+          extern_cleanup();
           invalid_argument("output_value: non-standard floats");
-        putch(chan, CODE_DOUBLE_NATIVE);
-        putblock(chan, (char *) v, 8);
+        }
+        Write(CODE_DOUBLE_NATIVE);
+        writeblock((char *) v, 8);
         size_32 += 1 + 2;
         size_64 += 1 + 1;
         break;
       }
       case Double_array_tag: {
         mlsize_t nfloats;
-        if (sizeof(double) != 8)
+        if (sizeof(double) != 8) {
+          extern_cleanup();
           invalid_argument("output_value: non-standard floats");
+        }
         nfloats = Wosize_val(v) / Double_wosize;
         if (nfloats < 0x100) {
-          output8(chan, CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
+          writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
         } else {
-          output32(chan, CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
+          writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
         }
-        putblock(chan, (char *) v, Bosize_val(v));
+        writeblock((char *) v, Bosize_val(v));
         size_32 += 1 + nfloats * 2;
         size_64 += 1 + nfloats;
         break;
       }
       case Abstract_tag:
       case Final_tag:
+        extern_cleanup();
         invalid_argument("output_value: abstract value");
         break;
       case Closure_tag:
       case Infix_tag:
+        extern_cleanup();
         invalid_argument("output_value: functional value");
         break;
       default: {
         mlsize_t i;
         if (tag < 16 && sz < 8) {
-          putch(chan, PREFIX_SMALL_BLOCK + tag + (sz << 4));
+          Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
         } else {
-          output32(chan, CODE_BLOCK32, hd);
+          writecode32(CODE_BLOCK32, hd);
         }
         size_32 += 1 + sz;
         size_64 += 1 + sz;
-        for (i = 0; i < sz - 1; i++) emit_compact(chan, Field(v, i));
+        for (i = 0; i < sz - 1; i++) extern_rec(Field(v, i));
         v = Field(v, i);
         goto tailcall;
       }
@@ -239,22 +314,25 @@ static void emit_compact(chan, v)
   }
 }
 
-value output_value(chan, v) /* ML */
-     struct channel * chan;
+static long extern_value(v)
      value v;
 {
-  value start_loc, final_loc;
-  putword(chan, Intext_magic_number);
-  start_loc = pos_out(chan);
-  putword(chan, 0);
-  putword(chan, 0);
-  putword(chan, 0);
+  long res_len;
+  alloc_extern_block();
   extern_table_size = INITIAL_EXTERN_TABLE_SIZE;
   alloc_extern_table();
   obj_counter = 0;
   size_32 = 0;
   size_64 = 0;
-  emit_compact(chan, v);
+  /* Write magic number */
+  write32(Intext_magic_number);
+  /* Set aside space for the sizes */
+  extern_ptr += 4*4;
+  /* Marshal the object */
+  extern_rec(v);
+  /* Free the table of shared objects */
+  stat_free((char *) extern_table);
+  /* Write the sizes */
 #ifdef SIXTYFOUR
   if (size_32 >= (1L << 32) || size_64 >= (1L << 32)) {
     /* The object is so big its size cannot be written in the header.
@@ -263,12 +341,35 @@ value output_value(chan, v) /* ML */
     failwith("output_value: object too big");
   }
 #endif
-  final_loc = pos_out(chan);
-  seek_out(chan, start_loc);
-  putword(chan, obj_counter);
-  putword(chan, size_32);
-  putword(chan, size_64);
-  seek_out(chan, final_loc);
-  stat_free((char *) extern_table);
+  res_len = extern_ptr - extern_block;
+  extern_ptr = extern_block + 4;
+  write32(res_len - 5*4);
+  write32(obj_counter);
+  write32(size_32);
+  write32(size_64);
+  /* Result is res_len bytes starting at extern_block */
+  return res_len;
+}
+
+value output_value(chan, v) /* ML */
+     struct channel * chan;
+     value v;
+{
+  long len;
+  len = extern_value(v);
+  putblock(chan, extern_block, len);
+  stat_free(extern_block);
   return Val_unit;
 }
+
+value output_value_to_string(v) /* ML */
+     value v;
+{
+  long len;
+  value res;
+  len = extern_value(v);
+  res = alloc_string(len);
+  bcopy(extern_block, String_val(res), len);
+  stat_free(extern_block);
+  return res;
+}
diff --git a/byterun/intern.c b/byterun/intern.c
index c73a325f5..6b56eefb8 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -23,7 +23,9 @@
 #include "misc.h"
 #include "reverse.h"
 
-static header_t * intern_ptr;
+static unsigned char * intern_input, * intern_src;
+static int intern_input_malloced;
+static header_t * intern_dest;
 static asize_t obj_counter;
 static value * intern_obj_table;
 static unsigned int intern_color;
@@ -33,69 +35,46 @@ static value intern_block;
 #define Sign_extend_shift ((sizeof(long) - 1) * 8)
 #define Sign_extend(x) (((long)(x) << Sign_extend_shift) >> Sign_extend_shift)
 
-static long input8u(chan)
-     struct channel * chan;
-{
-  return getch(chan);
-}
-
-static long input8s(chan)
-     struct channel * chan;
-{
-  long b1 = getch(chan);
-  return Sign_extend(b1);
-}
-
-static long input16u(chan)
-     struct channel * chan;
-{
-  long b1 = getch(chan);
-  long b2 = getch(chan);
-  return (b1 << 8) + b2;
-}
-
-static long input16s(chan)
-     struct channel * chan;
-{
-  long b1 = getch(chan);
-  long b2 = getch(chan);
-  return (Sign_extend(b1) << 8) + b2;
-}
-
-static long input32u(chan)
-     struct channel * chan;
-{
-  long b1 = getch(chan);
-  long b2 = getch(chan);
-  long b3 = getch(chan);
-  long b4 = getch(chan);
-  return (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
-}
-
-static long input32s(chan)
-     struct channel * chan;
-{
-  long b1 = getch(chan);
-  long b2 = getch(chan);
-  long b3 = getch(chan);
-  long b4 = getch(chan);
-  return (Sign_extend(b1) << 24) + (b2 << 16) + (b3 << 8) + b4;
-}
+#define read8u() (*intern_src++)
+#define read8s() Sign_extend(*intern_src++)
+#define read16u() \
+  (intern_src += 2, \
+   (intern_src[-2] << 8) + intern_src[-1])
+#define read16s() \
+  (intern_src += 2, \
+   (Sign_extend(intern_src[-2]) << 8) + intern_src[-1])
+#define read32u() \
+  (intern_src += 4, \
+   (intern_src[-4] << 24) + (intern_src[-3] << 16) + \
+   (intern_src[-2] << 8) + intern_src[-1])
+#define read32s() \
+  (intern_src += 4, \
+   (Sign_extend(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \
+   (intern_src[-2] << 8) + intern_src[-1])
 
 #ifdef SIXTYFOUR
-static long input64s(chan)
-     struct channel * chan;
+static long read64s()
 {
   long res;
   int i;
   res = 0;
-  for (i = 0; i < 8; i++) res = (res << 8) + getch(chan);
+  for (i = 0; i < 8; i++) res = (res << 8) + intern_src[i];
+  intern_src += 8;
   return res;
 }
 #endif
 
-static void read_compact(chan, dest)
-     struct channel * chan;
+#define readblock(dest,len) \
+  (bcopy(intern_src, dest, len), intern_src += len)
+
+static void intern_cleanup()
+{
+  if (intern_input_malloced) stat_free((char *) intern_input);
+  if (intern_obj_table != NULL) stat_free((char *) intern_obj_table);
+  Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
+}
+
+static void intern_rec(dest)
      value * dest;
 {
   unsigned int code;
@@ -106,7 +85,7 @@ static void read_compact(chan, dest)
   header_t header;
 
  tailcall:
-  code = getch(chan);
+  code = read8u();
   if (code >= PREFIX_SMALL_INT) {
     if (code >= PREFIX_SMALL_BLOCK) {
       /* Small block */
@@ -116,14 +95,14 @@ static void read_compact(chan, dest)
       if (size == 0) {
         v = Atom(tag);
       } else {
-        v = Val_hp(intern_ptr);
+        v = Val_hp(intern_dest);
         *dest = v;
         intern_obj_table[obj_counter++] = v;
-        dest = (value *) (intern_ptr + 1);
-        *intern_ptr = Make_header(size, tag, intern_color);
-        intern_ptr += 1 + size;
+        dest = (value *) (intern_dest + 1);
+        *intern_dest = Make_header(size, tag, intern_color);
+        intern_dest += 1 + size;
         for(/*nothing*/; size > 1; size--, dest++)
-          read_compact(chan, dest);
+          intern_rec(dest);
         goto tailcall;
       }
     } else {
@@ -136,87 +115,84 @@ static void read_compact(chan, dest)
       len = (code & 0x1F);
     read_string:
       size = (len + sizeof(value)) / sizeof(value);
-      v = Val_hp(intern_ptr);
+      v = Val_hp(intern_dest);
       intern_obj_table[obj_counter++] = v;
-      *intern_ptr = Make_header(size, String_tag, intern_color);
-      intern_ptr += 1 + size;
+      *intern_dest = Make_header(size, String_tag, intern_color);
+      intern_dest += 1 + size;
       Field(v, size - 1) = 0;
       ofs_ind = Bsize_wsize(size) - 1;
       Byte(v, ofs_ind) = ofs_ind - len;
-      really_getblock(chan, String_val(v), len);
+      readblock(String_val(v), len);
     } else {
       switch(code) {
       case CODE_INT8:
-        v = Val_long(input8s(chan));
+        v = Val_long(read8s());
         break;
       case CODE_INT16:
-        v = Val_long(input16s(chan));
+        v = Val_long(read16s());
         break;
       case CODE_INT32:
-        v = Val_long(input32s(chan));
+        v = Val_long(read32s());
         break;
       case CODE_INT64:
 #ifdef SIXTYFOUR
-        v = Val_long(input64s(chan));
+        v = Val_long(read64s());
         break;
 #else
-        stat_free((char *) intern_obj_table);
-        Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
+        intern_cleanup();
         failwith("input_value: integer too large");
         break;
 #endif
       case CODE_SHARED8:
-        ofs = input8u(chan);
+        ofs = read8u();
       read_shared:
         Assert(ofs > 0 && ofs <= obj_counter); 
         v = intern_obj_table[obj_counter - ofs];
         break;
       case CODE_SHARED16:
-        ofs = input16u(chan);
+        ofs = read16u();
         goto read_shared;
       case CODE_SHARED32:
-        ofs = input32u(chan);
+        ofs = read32u();
         goto read_shared;
       case CODE_BLOCK32:
-        header = (header_t) input32u(chan);
+        header = (header_t) read32u();
         tag = Tag_hd(header);
         size = Wosize_hd(header);
         goto read_block;
       case CODE_STRING8:
-        len = input8u(chan);
+        len = read8u();
         goto read_string;
       case CODE_STRING32:
-        len = input32u(chan);
+        len = read32u();
         goto read_string;
       case CODE_DOUBLE_LITTLE:
       case CODE_DOUBLE_BIG:
         if (sizeof(double) != 8) {
-          stat_free((char *) intern_obj_table);
-          Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
+          intern_cleanup();
           invalid_argument("input_value: non-standard floats");
         }
-        v = Val_hp(intern_ptr);
+        v = Val_hp(intern_dest);
         intern_obj_table[obj_counter++] = v;
-        *intern_ptr = Make_header(Double_wosize, Double_tag, intern_color);
-        intern_ptr += 1 + Double_wosize;
-        really_getblock(chan, (char *) v, 8);
+        *intern_dest = Make_header(Double_wosize, Double_tag, intern_color);
+        intern_dest += 1 + Double_wosize;
+        readblock((char *) v, 8);
         if (code != CODE_DOUBLE_NATIVE) Reverse_double(v);
         break;
       case CODE_DOUBLE_ARRAY8_LITTLE:
       case CODE_DOUBLE_ARRAY8_BIG:
-        len = input8u(chan);
+        len = read8u();
       read_double_array:
         if (sizeof(double) != 8) {
-          stat_free((char *) intern_obj_table);
-          Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
+          intern_cleanup();
           invalid_argument("input_value: non-standard floats");
         }
         size = len * Double_wosize;
-        v = Val_hp(intern_ptr);
+        v = Val_hp(intern_dest);
         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);
+        *intern_dest = Make_header(size, Double_array_tag, intern_color);
+        intern_dest += 1 + size;
+        readblock((char *) v, len * 8);
         if (code != CODE_DOUBLE_ARRAY8_NATIVE && 
             code != CODE_DOUBLE_ARRAY32_NATIVE) {
           mlsize_t i;
@@ -225,7 +201,7 @@ static void read_compact(chan, dest)
         break;
       case CODE_DOUBLE_ARRAY32_LITTLE:
       case CODE_DOUBLE_ARRAY32_BIG:
-        len = input32u(chan);
+        len = read32u();
         goto read_double_array;
       }
     }
@@ -233,25 +209,13 @@ static void read_compact(chan, dest)
   *dest = v;
 }
 
-value input_value(chan)         /* ML */
-     struct channel * chan;
+static void intern_alloc(whsize, num_objects)
+     mlsize_t whsize, num_objects;
 {
-  uint32 magic;
-  mlsize_t num_objects, size_32, size_64, whsize, wosize;
-  value res;
+  mlsize_t wosize;
 
-  magic = getword(chan);
-  if (magic != Intext_magic_number) failwith("input_value: bad object");
-  num_objects = getword(chan);
-  size_32 = getword(chan);
-  size_64 = getword(chan);
-#ifdef SIXTYFOUR
-  whsize = size_64;
-#else
-  whsize = size_32;
-#endif
   if (whsize == 0) {
-    read_compact(chan, &res);
+    intern_obj_table = NULL;
   } else {
     wosize = Wosize_whsize(whsize);
     if (wosize > Max_wosize) failwith("intern: structure too big");
@@ -262,11 +226,83 @@ value input_value(chan)         /* ML */
     intern_header = Hd_val(intern_block);
     intern_color = Color_hd(intern_header);
     Assert (intern_color == White || intern_color == Black);
-    intern_ptr = (header_t *) Hp_val(intern_block);
+    intern_dest = (header_t *) Hp_val(intern_block);
     obj_counter = 0;
     intern_obj_table = (value *) stat_alloc(num_objects * sizeof(value));
-    read_compact(chan, &res);
-    stat_free((char *) intern_obj_table);
   }
+}
+
+value input_value(chan)         /* ML */
+     struct channel * chan;
+{
+  uint32 magic;
+  mlsize_t block_len, num_objects, size_32, size_64, whsize;
+  value res;
+
+  magic = getword(chan);
+  if (magic != Intext_magic_number) failwith("input_value: bad object");
+  block_len = getword(chan);
+  num_objects = getword(chan);
+  size_32 = getword(chan);
+  size_64 = getword(chan);
+  /* Read block from channel */
+  intern_input = (unsigned char *) stat_alloc(block_len);
+  intern_input_malloced = 1;
+  if (really_getblock(chan, (char *)intern_input, block_len) == 0) {
+    stat_free((char *) intern_input);
+    failwith("input_value: truncated object");
+  }
+  intern_src = intern_input;
+  /* Allocate result */
+#ifdef SIXTYFOUR
+  whsize = size_64;
+#else
+  whsize = size_32;
+#endif
+  intern_alloc(whsize, num_objects);
+  /* Fill it in */
+  intern_rec(&res);
+  /* Free everything */
+  stat_free((char *) intern_input);
+  if (intern_obj_table != NULL) stat_free((char *) intern_obj_table);
+  return res;
+}
+
+value input_value_from_string(str, ofs) /* ML */
+     value str, ofs;
+{
+  uint32 magic;
+  mlsize_t block_len, num_objects, size_32, size_64, whsize;
+  value res;
+  Push_roots(r, 1);
+
+  intern_input = &Byte_u(str, Long_val(ofs));
+  intern_input_malloced = 0;
+  magic = read32u();
+  if (magic != Intext_magic_number) failwith("input_value: bad object");
+  block_len = read32u();
+  num_objects = read32u();
+  size_32 = read32u();
+  size_64 = read32u();
+  /* Allocate result */
+#ifdef SIXTYFOUR
+  whsize = size_64;
+#else
+  whsize = size_32;
+#endif
+  r[0] = str;
+  intern_alloc(whsize, num_objects);
+  str = r[0];
+  intern_input = &Byte_u(str, Long_val(ofs) + 5*4); /* If a GC occurred */
+  /* Fill it in */
+  intern_rec(&res);
+  /* Free everything */
+  if (intern_obj_table != NULL) stat_free((char *) intern_obj_table);
+  /* Build result */
+  r[0] = res;
+  res = alloc_tuple(2);
+  Field(res, 0) = r[0];
+  Field(res, 1) = Val_long(Long_val(ofs) + 5*4 + block_len);
+  Pop_roots();
   return res;
 }
diff --git a/byterun/intext.h b/byterun/intext.h
index 7ffafefea..e127cf398 100644
--- a/byterun/intext.h
+++ b/byterun/intext.h
@@ -22,7 +22,7 @@
 
 /* Magic number */
 
-#define Intext_magic_number 0x8495A6BD
+#define Intext_magic_number 0x8495A6BE
 
 /* Codes for the compact format */
 
@@ -58,6 +58,10 @@
 
 /* Initial sizes of data structures for extern */
 
+#ifndef INITIAL_EXTERN_BLOCK_SIZE
+#define INITIAL_EXTERN_BLOCK_SIZE 8192
+#endif
+
 #ifndef INITIAL_EXTERN_TABLE_SIZE
 #define INITIAL_EXTERN_TABLE_SIZE 2039
 #endif
diff --git a/byterun/io.c b/byterun/io.c
index 342dd6896..e1abf3014 100644
--- a/byterun/io.c
+++ b/byterun/io.c
@@ -86,6 +86,8 @@ static void really_write(fd, p, n)
      int n;
 {
   int retcode;
+  Assert(!Is_young(p));
+  enter_blocking_section();
   while (n > 0) {
 #ifdef HAS_UI
     retcode = ui_write(fd, p, n);
@@ -100,6 +102,7 @@ static void really_write(fd, p, n)
     p += retcode;
     n -= retcode;
   }
+  leave_blocking_section();
 }   
 
 value flush(channel)            /* ML */
@@ -227,6 +230,7 @@ static int really_read(fd, p, n)
 {
   int retcode;
 
+  Assert(!Is_young(p));
   enter_blocking_section();
 #ifdef HAS_UI
   retcode = ui_read(fd, p, n);
diff --git a/byterun/signals.c b/byterun/signals.c
index 4b21b60e4..521ff3c0e 100644
--- a/byterun/signals.c
+++ b/byterun/signals.c
@@ -26,6 +26,8 @@ Volatile int pending_signal = 0;
 Volatile int something_to_do = 0;
 Volatile int force_major_slice = 0;
 value signal_handlers = 0;
+void (*enter_blocking_section_hook)() = NULL;
+void (*leave_blocking_section_hook)() = NULL;
 
 static void execute_signal(signal_number)
      int signal_number;
@@ -72,11 +74,13 @@ void enter_blocking_section()
     if (!pending_signal) break;
     async_signal_mode = 0;
   }
+  if (enter_blocking_section_hook != NULL) enter_blocking_section_hook();
 }
 
 /* This function may be called from outside a blocking section. */
 void leave_blocking_section()
 {
+  if (leave_blocking_section_hook != NULL) leave_blocking_section_hook();
   async_signal_mode = 0;
 }
 
diff --git a/byterun/signals.h b/byterun/signals.h
index 6f064173e..5689546c0 100644
--- a/byterun/signals.h
+++ b/byterun/signals.h
@@ -20,10 +20,14 @@ extern value signal_handlers;
 extern Volatile int pending_signal;
 extern Volatile int something_to_do;
 extern Volatile int force_major_slice;
+extern Volatile int async_signal_mode;
 
 void enter_blocking_section P((void));
 void leave_blocking_section P((void));
 void urge_major_slice P((void));
 
+extern void (*enter_blocking_section_hook)();
+extern void (*leave_blocking_section_hook)();
+
 #endif /* _signals_ */
author	Xavier Leroy <xavier.leroy@inria.fr>	1996-04-01 15:24:38 +0000
committer	Xavier Leroy <xavier.leroy@inria.fr>	1996-04-01 15:24:38 +0000
commit	3b99a2c8d5c0aec40323e725b4fe28b4f3953344 (patch)
tree	008f3c37ed9abb0c257fc794c64f318897647cef
parent	3b91622e5db25564b9e8f48ef4a4260fab0b1396 (diff)