Free channel buffers on close rather than leaving them to the GC.

Changes

@@ -313,6 +313,10 @@ OCaml 5.2.0
   (Stephen Dolan, review by David Allsopp, Hugo Heuzard, Damien Doligez and
    Xavier Leroy)
 
+- #12678, #12898: free channel buffers on close rather than on finalization
+  (Damien Doligez, review by Jan Midtgaard and Gabriel Scherer, report
+   by Jan Midtgaard)
+
 - #12681: Fix TSan false positives due to volatile write handling
   (Olivier Nicole, Fabrice Buoro and Anmol Sahoo, review by Luc Maranget,
    Gabriel Scherer, Hernan Ponce de Leon and Xavier Leroy)

runtime/caml/io.h

@@ -46,7 +46,7 @@ struct channel {
   struct channel * next, * prev;/* Double chaining of channels (flush_all) */
   uintnat refcount;             /* Number of custom blocks owning the channel */
   int flags;                    /* Bitfield */
-  char buff[IO_BUFFER_SIZE];    /* The buffer itself */
+  char * buff;                  /* The buffer */
   char * name;                  /* Optional name (to report fd leaks) */
 };
 

runtime/io.c

@@ -55,6 +55,20 @@
 #define lseek _lseeki64
 #endif
 
+/* Representation of channel status and direction:
+
+   Open channels have fd >= 0 && buff != dummy_buff
+     Open input channels have max != NULL
+     Open output channels have max == NULL
+
+   Closed channels have fd == -1 && buff == dummy_buff && end == dummy_buff+1
+     Closed input channels have curr == max == buff (empty buffer)
+     Closed output channels have curr == end (full buffer)
+       and max == end (not NULL)
+
+*/
+static char dummy_buff[1];
+
 /* Locking channels.
 
    All operations on channels first take the channel lock.
@@ -165,6 +179,11 @@ CAMLexport struct channel * caml_open_descriptor_in(int fd)
   struct channel * channel;
 
   channel = (struct channel *) caml_stat_alloc(sizeof(struct channel));
+  channel->buff = (char *) caml_stat_alloc_noexc(IO_BUFFER_SIZE);
+  if (channel->buff == NULL){
+    caml_stat_free(channel);
+    caml_raise_out_of_memory();
+  }
   channel->fd = fd;
   caml_enter_blocking_section_no_pending();
   channel->offset = lseek(fd, 0, SEEK_CUR);
@@ -195,6 +214,7 @@ CAMLexport void caml_close_channel(struct channel *channel)
   close(channel->fd);
   caml_plat_mutex_free(&channel->mutex);
   caml_stat_free(channel->name);
+  caml_stat_free(channel->buff);
   caml_stat_free(channel);
 }
 
@@ -249,10 +269,11 @@ CAMLexport int caml_flush_partial(struct channel *channel)
     if (written == -1) {
       if (errno == EINTR) goto again;
       if (errno == EBADF || errno == EPIPE || errno == ECONNRESET) {
-        /* This is a permanent failure: retrying the flush later will not
-           make it go away.  Just discard the buffered data, so that
-           the finalizer can reclaim the channel. */
-        channel->curr = channel->buff;
+        /* This is a permanent failure: retrying the flush later will
+           not make it go away. If the channel is not closed, discard
+           the buffered data, so that a subsequent close will succeed,
+           or the finalizer can reclaim the channel. */
+        if (channel->fd != -1) channel->curr = channel->buff;
       }
       caml_sys_io_error(NO_ARG);
     }
@@ -560,6 +581,7 @@ void caml_finalize_channel(value vchan)
   caml_plat_unlock (&caml_all_opened_channels_mutex);
   caml_plat_mutex_free(&chan->mutex);
   caml_stat_free(chan->name);
+  if (chan->fd != -1) caml_stat_free(chan->buff);
   caml_stat_free(chan);
 }
 
@@ -589,8 +611,7 @@ static struct custom_operations channel_operations = {
 CAMLexport value caml_alloc_channel(struct channel *chan)
 {
   value res;
-  res = caml_alloc_custom_mem(&channel_operations, sizeof(struct channel *),
-                              sizeof(struct channel));
+  res = caml_alloc_custom(&channel_operations, sizeof(struct channel *), 0, 1);
   Channel(res) = chan;
   return res;
 }
@@ -657,8 +678,7 @@ CAMLprim value caml_ml_out_channels_list (value unit)
        channel != NULL;
        channel = channel->next) {
     CAMLassert(channel->flags & CHANNEL_FLAG_MANAGED_BY_GC);
-    /* Testing channel->fd >= 0 looks unnecessary, as
-       caml_ml_close_channel changes max when setting fd to -1. */
+    /* Unclosed output channels are exactly the ones with max == NULL */
     if (channel->max == NULL) {
       /* refcount is incremented here to keep the channel alive */
       channel->refcount ++;
@@ -703,18 +723,25 @@ CAMLprim value caml_ml_close_channel(value vchannel)
   struct channel * channel = Channel(vchannel);
 
   caml_channel_lock(channel);
-  /* Ensure that every read or write on the channel will cause an
-     immediate caml_flush_partial or caml_refill, thus raising a Sys_error
-     exception */
-  channel->curr = channel->max = channel->end;
-  /* Prevent any seek backward that would mark the last bytes of the
-   * channel buffer as valid */
-  channel->offset = 0;
-
   /* If already closed, we are done */
   if (channel->fd != -1) {
     fd = channel->fd;
     channel->fd = -1;
+    caml_stat_free(channel->buff);
+    channel->buff = dummy_buff;
+    channel->end = dummy_buff + 1;
+    /* Make sure that every read or write on the channel will cause an
+       immediate caml_flush_partial or caml_refill, thus raising a
+       Sys_error exception, and that a non-zero seek cannot stay
+       within the buffer.
+    */
+    if (channel->max == NULL){
+      /* closed output channel: full buffer with max != NULL */
+      channel->curr = channel->max = channel->end;
+    }else{
+      /* closed input channel: empty buffer */
+      channel->curr = channel->max = channel->buff;
+    }
     caml_enter_blocking_section_no_pending();
     result = close(fd);
     caml_leave_blocking_section();
@@ -791,9 +818,9 @@ CAMLprim value caml_ml_is_binary_mode(value vchannel)
 
 /*
    If the channel is closed, DO NOT raise a "bad file descriptor"
-   exception, but do nothing (the buffer is already empty).
+   exception, but do nothing.
    This is because some libraries will flush at exit, even on
-   file descriptors that may be closed.
+   channels that may be closed.
 */
 
 CAMLprim value caml_ml_flush(value vchannel)

testsuite/tests/lib-channels/close_in.ml

@@ -10,11 +10,23 @@ let () =
   let ic = open_in_bin Sys.argv.(0) in
   seek_in ic nb_bytes;
   close_in ic;
-  seek_in ic 0;
   assert (
     try
+      seek_in ic 0;
       ignore (input_byte ic);
       false
     with
     | Sys_error _ -> true
     | _           -> false)
+
+(* A variant of #11878, which #11965 failed to fix. *)
+let () =
+  let ic = open_in_bin Sys.argv.(0) in
+  close_in ic;
+  begin try
+    seek_in ic (-1);
+    ignore (input_byte ic);
+    assert false;
+  with
+  | Sys_error _ -> ()
+  end

testsuite/tests/lib-channels/close_out.ml

@@ -0,0 +1,19 @@
+(* TEST
+
+   arguments = "${test_build_directory}/testfile.tmp";
+*)
+
+(* Test that output to a closed out_channel triggers an exception every
+   time, not just the first time. *)
+
+let () =
+  let oc = open_out_bin Sys.argv.(1) in
+  close_out oc;
+  begin match output_byte oc 0 with
+  | exception Sys_error _ -> ()
+  | () -> assert false
+  end;
+  begin match output_byte oc 0 with
+  | exception Sys_error _ -> ()
+  | () -> assert false
+  end