Deprecation of Bigarray.*.map_file and introduction of Unix.map_file, continued

This is a follow-up to GPR #997 with a different implementation that creates fewer dependencies.

We add to the runtime a `byterun/bigarray.c` file that contains the bigarray creation functions that used to be in `otherlibs/bigarray/bigarray_stubs.c`.  In the latter file we keep all primitives needed to implement the Bigarray interface.  The functions in the new `byterun/bigarray.c` make it possible to create bigarrays both from the bigarray library and from the unix library.

The header file `bigarray.h` moves to `byterun/caml/bigarray.h` accordingly.

The `map_file` implementations move to `otherlibs/unix/mmap.c` and `otherlibs/win32unix/mmap.c`.  Some bigarray allocation code shared between the two implementations is put in `otherlibs/unix/mmap_ba.c`.

Through a couple of `#ifdef`, the `map_file` implementations can also be compiled from within `otherlibs/bigarray` with the same semantics they had in 4.04.

As a consequence, the bigarray library still contains a standalone, Unix-independent implementation of `Bigarray.*.map_file`; the only difference with 4.04 is that it is marked deprecated.

Current status: compiled and lightly tested under Unix.  Win32 implementation neither compiled nor tested.

5 files changed, 308 insertions, 26 deletions

diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
index 571fe7fe15..3fbd07be70 100644
--- a/otherlibs/unix/Makefile
+++ b/otherlibs/unix/Makefile
@@ -31,7 +31,8 @@ COBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \
   getnameinfo.o getpeername.o getpid.o getppid.o getproto.o getpw.o \
   gettimeofday.o getserv.o getsockname.o getuid.o gmtime.o \
   initgroups.o isatty.o itimer.o kill.o link.o listen.o lockf.o lseek.o \
-  mkdir.o mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o \
+  mkdir.o mkfifo.o mmap.o mmap_ba.o \
+  nice.o open.o opendir.o pipe.o putenv.o read.o \
   readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o \
   setgid.o setgroups.o setsid.o setuid.o shutdown.o signals.o \
   sleep.o socket.o socketaddr.o \
diff --git a/otherlibs/unix/mmap.c b/otherlibs/unix/mmap.c
new file mode 100644
index 0000000000..c81c71c974
--- /dev/null
+++ b/otherlibs/unix/mmap.c
@@ -0,0 +1,218 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* Needed (under Linux at least) to get pwrite's prototype in unistd.h.
+   Must be defined before the first system .h is included. */
+#define _XOPEN_SOURCE 600
+
+#include <stddef.h>
+#include "caml/bigarray.h"
+#include "caml/fail.h"
+#include "caml/io.h"
+#include "caml/mlvalues.h"
+#include "caml/signals.h"
+#include "caml/sys.h"
+#include "unixsupport.h"
+
+#include <errno.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#ifdef HAS_MMAP
+#include <sys/types.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#endif
+
+/* Defined in [mmap_ba.c] */
+CAMLextern value
+caml_ba_mapped_alloc(int flags, int num_dims, void * data, intnat * dim);
+
+/* Temporary compatibility stuff so that this file can also be compiled
+   from otherlibs/bigarray/ and included in the bigarray library. */
+
+#ifdef IN_OCAML_BIGARRAY
+#define MAP_FILE "Bigarray.map_file"
+#define MAP_FILE_ERROR() caml_sys_error(NO_ARG)
+#else
+#define MAP_FILE "Unix.map_file"
+#define MAP_FILE_ERROR() uerror("map_file", Nothing)
+#endif
+
+#if defined(HAS_MMAP)
+
+#ifndef MAP_FAILED
+#define MAP_FAILED ((void *) -1)
+#endif
+
+/* [caml_grow_file] function contributed by Gerd Stolpmann (PR#5543). */
+
+static int caml_grow_file(int fd, file_offset size)
+{
+  char c;
+  int p;
+
+  /* First use pwrite for growing - it is a conservative method, as it
+     can never happen that we shrink by accident
+   */
+#ifdef HAS_PWRITE
+  c = 0;
+  p = pwrite(fd, &c, 1, size - 1);
+#else
+
+  /* Emulate pwrite with lseek. This should only be necessary on ancient
+     systems nowadays
+   */
+  file_offset currpos;
+  currpos = lseek(fd, 0, SEEK_CUR);
+  if (currpos != -1) {
+    p = lseek(fd, size - 1, SEEK_SET);
+    if (p != -1) {
+      c = 0;
+      p = write(fd, &c, 1);
+      if (p != -1)
+        p = lseek(fd, currpos, SEEK_SET);
+    }
+  }
+  else p=-1;
+#endif
+#ifdef HAS_TRUNCATE
+  if (p == -1 && errno == ESPIPE) {
+    /* Plan B. Check if at least ftruncate is possible. There are
+       some non-seekable descriptor types that do not support pwrite
+       but ftruncate, like shared memory. We never get into this case
+       for real files, so there is no danger of truncating persistent
+       data by accident
+     */
+    p = ftruncate(fd, size);
+  }
+#endif
+  return p;
+}
+
+
+CAMLprim value caml_unix_map_file(value vfd, value vkind, value vlayout,
+                                  value vshared, value vdim, value vstart)
+{
+  int fd, flags, major_dim, shared;
+  intnat num_dims, i;
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  file_offset startpos, file_size, data_size;
+  struct stat st;
+  uintnat array_size, page, delta;
+  void * addr;
+
+  fd = Int_val(vfd);
+  flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
+  startpos = File_offset_val(vstart);
+  num_dims = Wosize_val(vdim);
+  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
+  /* Extract dimensions from OCaml array */
+  num_dims = Wosize_val(vdim);
+  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
+    caml_invalid_argument(MAP_FILE ": bad number of dimensions");
+  for (i = 0; i < num_dims; i++) {
+    dim[i] = Long_val(Field(vdim, i));
+    if (dim[i] == -1 && i == major_dim) continue;
+    if (dim[i] < 0)
+      caml_invalid_argument(MAP_FILE ": negative dimension");
+  }
+  /* Determine file size. We avoid lseek here because it is fragile,
+     and because some mappable file types do not support it
+   */
+  caml_enter_blocking_section();
+  if (fstat(fd, &st) == -1) {
+    caml_leave_blocking_section();
+    MAP_FILE_ERROR();
+  }
+  file_size = st.st_size;
+  /* Determine array size in bytes (or size of array without the major
+     dimension if that dimension wasn't specified) */
+  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
+  for (i = 0; i < num_dims; i++)
+    if (dim[i] != -1) array_size *= dim[i];
+  /* Check if the major dimension is unknown */
+  if (dim[major_dim] == -1) {
+    /* Determine major dimension from file size */
+    if (file_size < startpos) {
+      caml_leave_blocking_section();
+      caml_failwith(MAP_FILE ": file position exceeds file size");
+    }
+    data_size = file_size - startpos;
+    dim[major_dim] = (uintnat) (data_size / array_size);
+    array_size = dim[major_dim] * array_size;
+    if (array_size != data_size) {
+      caml_leave_blocking_section();
+      caml_failwith(MAP_FILE ": file size doesn't match array dimensions");
+    }
+  } else {
+    /* Check that file is large enough, and grow it otherwise */
+    if (file_size < startpos + array_size) {
+      if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */
+        caml_leave_blocking_section();
+        MAP_FILE_ERROR();
+      }
+    }
+  }
+  /* Determine offset so that the mapping starts at the given file pos */
+  page = sysconf(_SC_PAGESIZE);
+  delta = (uintnat) startpos % page;
+  /* Do the mmap */
+  shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
+  if (array_size > 0)
+    addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
+                shared, fd, startpos - delta);
+  else
+    addr = NULL;                /* PR#5463 - mmap fails on empty region */
+  caml_leave_blocking_section();
+  if (addr == (void *) MAP_FAILED) MAP_FILE_ERROR();
+  addr = (void *) ((uintnat) addr + delta);
+  /* Build and return the OCaml bigarray */
+  return caml_ba_mapped_alloc(flags, num_dims, addr, dim);
+}
+
+#else
+
+CAMLprim value caml_unix_map_file(value vfd, value vkind, value vlayout,
+                                  value vshared, value vdim, value vpos)
+{
+  caml_invalid_argument("Unix.map_file: not supported");
+  return Val_unit;
+}
+
+#endif
+
+CAMLprim value caml_unix_map_file_bytecode(value * argv, int argn)
+{
+  return caml_unix_map_file(argv[0], argv[1], argv[2],
+                          argv[3], argv[4], argv[5]);
+}
+
+void caml_unix_unmap_file(void * addr, uintnat len)
+{
+#if defined(HAS_MMAP)
+  uintnat page = sysconf(_SC_PAGESIZE);
+  uintnat delta = (uintnat) addr % page;
+  if (len == 0) return;         /* PR#5463 */
+  addr = (void *)((uintnat)addr - delta);
+  len  = len + delta;
+#if defined(_POSIX_SYNCHRONIZED_IO)
+  msync(addr, len, MS_ASYNC);   /* PR#3571 */
+#endif
+  munmap(addr, len);
+#endif
+}
diff --git a/otherlibs/unix/mmap_ba.c b/otherlibs/unix/mmap_ba.c
new file mode 100644
index 0000000000..70b1a35494
--- /dev/null
+++ b/otherlibs/unix/mmap_ba.c
@@ -0,0 +1,80 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include "caml/alloc.h"
+#include "caml/bigarray.h"
+#include "caml/custom.h"
+#include "caml/memory.h"
+#include "caml/misc.h"
+
+/* Allocation of bigarrays for memory-mapped files.
+   This is the OS-independent part of [mmap.c]. */
+
+CAMLextern void caml_unix_unmap_file(void * addr, uintnat len);
+
+static void caml_ba_mapped_finalize(value v)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(v);
+  CAMLassert(b->flags & CAML_BA_MANAGED_MASK == CAML_BA_MAPPED_FILE);
+  if (b->proxy == NULL) {
+    caml_unix_unmap_file(b->data, caml_ba_byte_size(b));
+  } else {
+    if (-- b->proxy->refcount == 0) {
+      caml_unix_unmap_file(b->proxy->data, b->proxy->size);
+      caml_stat_free(b->proxy);
+    }
+  }
+}
+
+/* Operation table for bigarrays representing memory-mapped files.
+   Only the finalization method differs from regular bigarrays. */
+
+static struct custom_operations caml_ba_mapped_ops = {
+  "_bigarray",
+  caml_ba_mapped_finalize,
+  caml_ba_compare,
+  caml_ba_hash,
+  caml_ba_serialize,
+  caml_ba_deserialize,
+  custom_compare_ext_default
+};
+
+/* [caml_ba_mapped_alloc] allocates a new bigarray object in the heap
+   corresponding to a memory-mapped file. */
+
+CAMLexport value
+caml_ba_mapped_alloc(int flags, int num_dims, void * data, intnat * dim)
+{
+  uintnat asize;
+  int i;
+  value res;
+  struct caml_ba_array * b;
+  intnat dimcopy[CAML_BA_MAX_NUM_DIMS];
+
+  Assert(num_dims >= 0 && num_dims <= CAML_BA_MAX_NUM_DIMS);
+  Assert((flags & CAML_BA_KIND_MASK) <= CAML_BA_CHAR);
+  for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i];
+  asize = SIZEOF_BA_ARRAY + num_dims * sizeof(intnat);
+  res = caml_alloc_custom(&caml_ba_mapped_ops, asize, 0, 1);
+  b = Caml_ba_array_val(res);
+  b->data = data;
+  b->num_dims = num_dims;
+  b->flags = flags | CAML_BA_MAPPED_FILE;
+  b->proxy = NULL;
+  for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i];
+  return res;
+}
diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index 04be342a1b..b237ea4ec2 100644
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -342,20 +342,15 @@ module LargeFile =
     external fstat : file_descr -> stats = "unix_fstat_64"
   end
 
-type map_file_impl =
-  { map_file_impl
-    : 'a 'b 'c. file_descr
-      -> ('a, 'b) CamlinternalBigarray.kind
-      -> 'c CamlinternalBigarray.layout
-      -> bool
-      -> int array
-      -> int64
-      -> ('a, 'b, 'c) CamlinternalBigarray.genarray
-  }
-let map_file_impl =
-  ref { map_file_impl = fun _ _ _ _ _ _ -> failwith "Bigarray not initialized!" }
+external map_internal:
+   file_descr -> ('a, 'b) CamlinternalBigarray.kind
+              -> 'c CamlinternalBigarray.layout
+              -> bool -> int array -> int64
+              -> ('a, 'b, 'c) CamlinternalBigarray.genarray
+     = "caml_unix_map_file_bytecode" "caml_unix_map_file"
+
 let map_file fd ?(pos=0L) kind layout shared dims =
-  !map_file_impl.map_file_impl fd kind layout shared dims pos
+  map_internal fd kind layout shared dims pos
 
 type access_permission =
     R_OK
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index 7c490688b8..c62c2a0ef2 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -1647,15 +1647,3 @@ val setsid : unit -> int
 
    On Windows, not implemented. *)
 
-(**/**)
-type map_file_impl =
-  { map_file_impl
-    : 'a 'b 'c. file_descr
-      -> ('a, 'b) CamlinternalBigarray.kind
-      -> 'c CamlinternalBigarray.layout
-      -> bool
-      -> int array
-      -> int64
-      -> ('a, 'b, 'c) CamlinternalBigarray.genarray
-  }
-val map_file_impl : map_file_impl ref