Ajout de flush_all + modifs pour Cash (Bruno Verlyck)

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

byterun/backtrace.c

@@ -93,7 +93,7 @@ static value read_debug_info(void)
     close(fd);
     CAMLreturn(Val_false);
   }
-  chan = open_descriptor(fd);
+  chan = open_descriptor_in(fd);
   num_events = getword(chan);
   events = alloc(num_events, 0);
   for (i = 0; i < num_events; i++) {

byterun/debugger.c

@@ -72,8 +72,8 @@ static void open_connection(void)
   if (dbg_socket == -1 ||
       connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1)
     fatal_error("cannot connect to debugger");
-  dbg_in = open_descriptor(dbg_socket);
-  dbg_out = open_descriptor(dbg_socket);
+  dbg_in = open_descriptor_in(dbg_socket);
+  dbg_out = open_descriptor_out(dbg_socket);
   if (!debugger_in_use) putword(dbg_out, -1); /* first connection */
   putword(dbg_out, getpid());
   flush(dbg_out);

byterun/intern.c

@@ -102,7 +102,7 @@ static void intern_cleanup(void)
   if (intern_extra_block != NULL) {
     /* free newly allocated heap chunk */
     free_for_heap(intern_extra_block); 
-  } else if (intern_block != NULL) {
+  } else if (intern_block != 0) {
     /* restore original header for heap block, otherwise GC is confused */
     Hd_val(intern_block) = intern_header;
   }
@@ -286,7 +286,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
   if (whsize == 0) {
     intern_obj_table = NULL;
     intern_extra_block = NULL;
-    intern_block = NULL;
+    intern_block = 0;
     return;
   }
   wosize = Wosize_whsize(whsize);

byterun/io.c

@@ -48,13 +48,16 @@ CAMLexport void (*channel_mutex_lock) (struct channel *) = NULL;
 CAMLexport void (*channel_mutex_unlock) (struct channel *) = NULL;
 CAMLexport void (*channel_mutex_unlock_exn) (void) = NULL;
 
+/* List of opened channels */
+CAMLexport struct channel * all_opened_channels = NULL;
+
 /* Basic functions over type struct channel *.
    These functions can be called directly from C.
    No locking is performed. */
 
 /* Functions shared between input and output */
 
-CAMLexport struct channel * open_descriptor(int fd)
+CAMLexport struct channel * open_descriptor_in(int fd)
 {
   struct channel * channel;
 
@@ -64,13 +67,39 @@ CAMLexport struct channel * open_descriptor(int fd)
   channel->curr = channel->max = channel->buff;
   channel->end = channel->buff + IO_BUFFER_SIZE;
   channel->mutex = NULL;
+  channel->revealed = 0;
+  channel->old_revealed = 0;
+  channel->refcount = 0;
+  channel->next = all_opened_channels;
+  all_opened_channels = channel;
   return channel;
 }
 
+CAMLexport struct channel * open_descriptor_out(int fd)
+{
+  struct channel * channel;
+
+  channel = open_descriptor_in(fd);
+  channel->max = NULL;
+  return channel;
+}
+
+static void unlink_channel(struct channel *channel)
+{
+  struct channel ** cp = &all_opened_channels;
+  
+  while (*cp != channel && *cp != NULL)
+    cp = &(*cp)->next;
+  if (*cp != NULL)
+    *cp = (*cp)->next;
+}
+
 CAMLexport void close_channel(struct channel *channel)
 {
   close(channel->fd);
+  if (channel->refcount > 0) return;
   if (channel_mutex_free != NULL) (*channel_mutex_free)(channel);
+  unlink_channel(channel);
   stat_free(channel);
 }
 
@@ -196,7 +225,6 @@ CAMLexport int putblock(struct channel *channel, char *p, long int len)
       memmove(channel->buff, channel->buff + written, towrite - written);
     channel->offset += written;
     channel->curr = channel->end - written;
-    channel->max = channel->end - written;
     return free;
   }
 }
@@ -369,10 +397,12 @@ CAMLexport long input_scan_line(struct channel *channel)
    objects into a heap-allocated object.  Perform locking
    and unlocking around the I/O operations. */
 
-static void finalize_channel(value vchan)
+CAMLexport void finalize_channel(value vchan)
 {
   struct channel * chan = Channel(vchan);
+  if (--chan->refcount > 0) return;
   if (channel_mutex_free != NULL) (*channel_mutex_free)(chan);
+  unlink_channel(chan);
   stat_free(chan);
 }
 
@@ -392,17 +422,47 @@ static struct custom_operations channel_operations = {
   custom_deserialize_default
 };
 
-static value alloc_channel(struct channel *chan)
+CAMLexport value alloc_channel(struct channel *chan)
 {
   value res = alloc_custom(&channel_operations, sizeof(struct channel *),
                            1, 1000);
   Channel(res) = chan;
+  chan->refcount++;
   return res;
 }
 
-CAMLprim value caml_open_descriptor(value fd)
+CAMLprim value caml_open_descriptor_in(value fd)
 {
-  return alloc_channel(open_descriptor(Int_val(fd)));
+  return alloc_channel(open_descriptor_in(Int_val(fd)));
+}
+
+CAMLprim value caml_open_descriptor_out(value fd)
+{
+  return alloc_channel(open_descriptor_out(Int_val(fd)));
+}
+
+#define Pair_tag 0
+
+CAMLprim value caml_out_channels_list (value unit)
+{
+  CAMLparam0 ();
+  CAMLlocal3 (res, tail, chan);
+  struct channel * channel;
+
+  res = Val_emptylist;
+  for (channel = all_opened_channels;
+       channel != NULL;
+       channel = channel->next) 
+    /* Testing channel->fd >= 0 looks unnecessary, as
+       caml_close_channel changes max when setting fd to -1. */
+    if (channel->max == NULL) {
+      chan = alloc_channel (channel);
+      tail = res;
+      res = alloc_small (2, Pair_tag);
+      Field (res, 0) = chan;
+      Field (res, 1) = tail;
+    }
+  CAMLreturn (res);
 }
 
 CAMLprim value channel_descriptor(value vchannel)
@@ -444,9 +504,7 @@ CAMLprim value caml_flush_partial(value vchannel)
 {
   struct channel * channel = Channel(vchannel);
   int res;
-  /* Don't fail if channel is closed, this causes problem with flush on
-     stdout and stderr at exit.  Revise when "flushall" is implemented. */
-  if (channel->fd == -1) return Val_true;
+
   Lock(channel);
   res = flush_partial(channel);
   Unlock(channel);
@@ -456,9 +514,7 @@ CAMLprim value caml_flush_partial(value vchannel)
 CAMLprim value caml_flush(value vchannel)
 {
   struct channel * channel = Channel(vchannel);
-  /* Don't fail if channel is closed, this causes problem with flush on
-     stdout and stderr at exit.  Revise when "flushall" is implemented. */
-  if (channel->fd == -1) return Val_unit;
+
   Lock(channel);
   flush(channel);
   Unlock(channel);

byterun/io.h

@@ -32,6 +32,10 @@ struct channel {
   char * curr;                  /* Current position in the buffer */
   char * max;                   /* Logical end of the buffer (for input) */
   void * mutex;                 /* Placeholder for mutex (for systhreads) */
+  struct channel * next;        /* Linear chaining of channels (flush_all) */
+  int revealed;                 /* For Cash only */
+  int old_revealed;             /* For Cash only */
+  int refcount;                 /* For Cash only */
   char buff[IO_BUFFER_SIZE];    /* The buffer itself */
 };
 
@@ -54,7 +58,8 @@ struct channel {
    ? refill(channel)                                                        \
    : (unsigned char) *((channel))->curr++)
 
-CAMLextern struct channel * open_descriptor (int);
+CAMLextern struct channel * open_descriptor_in (int);
+CAMLextern struct channel * open_descriptor_out (int);
 CAMLextern void close_channel (struct channel *);
 CAMLextern int channel_binary_mode (struct channel *);
 

byterun/startup.c

@@ -371,7 +371,7 @@ CAMLexport void caml_main(char **argv)
   stat_free(req_prims);
   /* Load the globals */
   seek_section(fd, &trail, "DATA");
-  chan = open_descriptor(fd);
+  chan = open_descriptor_in(fd);
   global_data = input_val(chan);
   close_channel(chan); /* this also closes fd */
   stat_free(trail.section);

otherlibs/threads/pervasives.ml

@@ -178,7 +178,7 @@ let string_of_bool b =
 let bool_of_string = function
   | "true" -> true
   | "false" -> false
-  | _ -> invalid_arg "string_of_bool"
+  | _ -> invalid_arg "bool_of_string"
 
 let string_of_int n =
   format_int "%d" n
@@ -202,8 +202,8 @@ let rec (@) l1 l2 =
 type in_channel
 type out_channel
 
-external open_descriptor_out: int -> out_channel = "caml_open_descriptor"
-external open_descriptor_in: int -> in_channel = "caml_open_descriptor"
+external open_descriptor_out: int -> out_channel = "caml_open_descriptor_out"
+external open_descriptor_in: int -> in_channel = "caml_open_descriptor_in"
 
 let stdin = open_descriptor_in 0
 let stdout = open_descriptor_out 1
@@ -256,6 +256,21 @@ let rec flush oc =
       wait_outchan oc (-1); false in
   if success then () else flush oc
 
+external out_channels_list : unit -> out_channel list 
+                           = "caml_out_channels_list"
+
+let flush_all () = 
+  let rec iter = function
+      [] -> ()
+    | a::l ->
+        begin try
+            flush a
+        with Sys_error _ ->
+          () (* ignore channels closed during a preceding flush. *)
+        end;
+        iter l
+  in iter (out_channels ())
+
 external unsafe_output_partial : out_channel -> string -> int -> int -> int
                         = "caml_output_partial"
 
@@ -451,7 +466,7 @@ let read_float () = float_of_string(read_line())
 
 external sys_exit : int -> 'a = "sys_exit"
 
-let exit_function = ref (fun () -> flush stdout; flush stderr)
+let exit_function = ref flush_all
 
 let at_exit f =
   let g = !exit_function in

otherlibs/unix/unix.ml

@@ -166,9 +166,9 @@ let write fd buf ofs len =
   else unsafe_write fd buf ofs len
 
 external in_channel_of_descr : file_descr -> in_channel
-                             = "caml_open_descriptor"
+                             = "caml_open_descriptor_in"
 external out_channel_of_descr : file_descr -> out_channel
-                              = "caml_open_descriptor"
+                              = "caml_open_descriptor_out"
 external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor"
 external descr_of_out_channel : out_channel -> file_descr
                               = "channel_descriptor"

otherlibs/win32unix/unix.ml

@@ -188,8 +188,8 @@ let write fd buf ofs len =
 
 (* Interfacing with the standard input/output library *)
 
-external open_read_descriptor : int -> in_channel = "caml_open_descriptor"
-external open_write_descriptor : int -> out_channel = "caml_open_descriptor"
+external open_read_descriptor : int -> in_channel = "caml_open_descriptor_in"
+external open_write_descriptor : int -> out_channel = "caml_open_descriptor_out"
 external fd_of_in_channel : in_channel -> int = "channel_descriptor"
 external fd_of_out_channel : out_channel -> int = "channel_descriptor"
 

stdlib/pervasives.ml

@@ -188,8 +188,8 @@ let rec (@) l1 l2 =
 type in_channel
 type out_channel
 
-external open_descriptor_out: int -> out_channel = "caml_open_descriptor"
-external open_descriptor_in: int -> in_channel = "caml_open_descriptor"
+external open_descriptor_out: int -> out_channel = "caml_open_descriptor_out"
+external open_descriptor_in: int -> in_channel = "caml_open_descriptor_in"
 
 let stdin = open_descriptor_in 0
 let stdout = open_descriptor_out 1
@@ -215,6 +215,15 @@ let open_out_bin name =
 
 external flush : out_channel -> unit = "caml_flush"
 
+external out_channels_list : unit -> out_channel list 
+                           = "caml_out_channels_list"
+
+let flush_all () = 
+  let rec iter = function
+      [] -> ()
+    | a::l -> flush a; iter l
+  in iter (out_channels_list ())
+
 external unsafe_output : out_channel -> string -> int -> int -> unit
                        = "caml_output"
 
@@ -345,7 +354,7 @@ external decr: int ref -> unit = "%decr"
 
 external sys_exit : int -> 'a = "sys_exit"
 
-let exit_function = ref (fun () -> flush stdout; flush stderr)
+let exit_function = ref flush_all
 
 let at_exit f =
   let g = !exit_function in

stdlib/pervasives.mli

@@ -482,6 +482,8 @@ val flush : out_channel -> unit
            performing all pending writes on that channel.
            Interactive programs must be careful about flushing standard
            output and standard error at the right time. *)
+val flush_all : unit -> unit
+        (* Flush all opened output channels. *)
 val output_char : out_channel -> char -> unit
         (* Write the character on the given output channel. *)
 val output_string : out_channel -> string -> unit