bug#27782: mman patch for v3.0.9

[Matt Wette <matt.wette@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 344 bytes --]

Note.  I have made more changes based on feedback from the mailing list.

1) removed use of scm_c_take_typed_bytevector
2) changed code to generate PAGE_SIZE

I think the mmap finalizer still needs review from the Guile experts.

I'm attaching a patch to the v3.0.9 release (commit 9b20ca).
Sorry about not using format-patch, but diff.

Matt

[-- Attachment #2: v3.0.9-mman.patch --]
[-- Type: text/x-patch, Size: 15602 bytes --]

diff --git a/configure.ac b/configure.ac
index d5ce1c4ac..c3c33e8b3 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1018,6 +1018,8 @@ AC_CHECK_MEMBERS([struct tm.tm_gmtoff],,,
 ])
 GUILE_STRUCT_UTIMBUF
 
+AC_CHECK_FUNCS([msync])
+
 
 #--------------------------------------------------------------------
 #
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 5653d3758..16f3bbc49 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -1216,6 +1216,51 @@ valid separators.  Thus, programs should not assume that
 separator---e.g., when extracting the components of a file name.
 @end defvr
 
+@deffn {Scheme Procedure} mmap addr len [prot [flags [fd [offset]]]]
+@deffnx {Scheme Procedure} mmap/search addr len [prot [flags [fd [offset]]]]
+Create a memory mapping, returning a bytevector.  @var{addr}, if
+non-zero, is the staring address; or, if zero, is assigned by the
+system.  @var{prot}, if provided, assigns protection.  @var{fd},
+if provided associates the memory region with a file, starting
+at @var{offset}, if provided.
+The region returned by mmap will NOT be searched by the garbage
+ collector for pointers, while that returned by mmap/search will.
+Note that the finalizer for the returned bytevector will call munmap.
+Defaults for optional arguments are
+@table @asis
+@item prot
+(logior PROT_READ PROT_WRITE)
+@item flags
+(logior MAP_ANONYMOUS MAP_PRIVATE)
+@item fd
+-1
+@item offset
+0
+@end table
+@end deffn
+
+@deffn {Scheme Procedure} munmap bvec
+Given bytevector generated by mmap or mmap/search, unmap the
+the associated memory.  The argument will be modified to
+reflect a zero length bv.  The return value is unspecified.
+Note that munmap is called by finalizer associated with
+bytevectors returned from mmap and mmap/search.
+@end deffn
+
+@deffn {Scheme Procedure} msync addr length flag
+Flush changes made to the in-core copy of a file mapped using
+mmap or mmap/search.  This should be executed on modified memory
+before calling munmap.  The @var{flags} argument must be exactly one
+of the following:
+@table @code
+@item MS_ASYNC
+Initiate update, return immediately.
+@item MS_SYNC
+Initiate update, block until complete.
+@item MS_INVALIDATE
+Invalidate other mappings of the same file.
+@end table
+@end deffn
 
 @node User Information
 @subsection User Information
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 1f0bba556..1f4c5c793 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -67,13 +67,21 @@
 # include <sys/sendfile.h>
 #endif
 
+#ifdef HAVE_SYS_MMAN_H
+# include <sys/mman.h>
+#endif
+
 #include "async.h"
+#include "atomics-internal.h"           /* mmap */
 #include "boolean.h"
 #include "dynwind.h"
 #include "fdes-finalizers.h"
 #include "feature.h"
+#include "finalizers.h"                 /* mmap */
+#include "foreign.h"                    /* mmap */
 #include "fports.h"
 #include "gsubr.h"
+#include "ioext.h"                      /* mmap */
 #include "iselect.h"
 #include "list.h"
 #include "load.h"	/* for scm_i_mirror_backslashes */
@@ -2263,6 +2271,311 @@ scm_dir_free (SCM p)
 
 \f
 
+#ifdef HAVE_SYS_MMAN_H
+/* see https://pubs.opengroup.org/onlinepubs/9699919799/functions/mmap.html */
+
+static void
+mmap_finalizer (void *ptr, void *data)
+{
+  SCM bvec;
+  void *c_addr;
+  size_t c_len;
+  int rv;
+
+  bvec = SCM_PACK_POINTER (ptr);
+  if (!SCM_BYTEVECTOR_P (bvec))
+    scm_misc_error ("mmap", "expecting bytevector", SCM_EOL);
+
+  c_addr = SCM_BYTEVECTOR_CONTENTS (bvec);
+  c_len = SCM_BYTEVECTOR_LENGTH (bvec);
+  SCM_SYSCALL (rv = munmap(c_addr, c_len));
+  if (rv != 0)
+    scm_misc_error ("mmap", "failed to munmap memory", SCM_EOL);
+}
+
+/* Code for scm_dynwind_acquire_port and release_port sourced from ports.c. */
+
+static void
+release_port (SCM port)
+{
+  scm_t_port *pt = SCM_PORT (port);
+  uint32_t cur = 1, next = 0;
+  while (!scm_atomic_compare_and_swap_uint32 (&pt->refcount, &cur, next))
+    {
+      if (cur == 0)
+        return;
+      next = cur - 1;
+    }
+ if (cur > 1)
+    return;
+
+  if (SCM_PORT_TYPE (port)->close)
+    SCM_PORT_TYPE (port)->close (port);
+
+  /* Skip encoding code from ports.c! */
+}
+
+static void
+scm_dynwind_acquire_port (SCM port)
+{
+  scm_t_port *pt = SCM_PORT (port);
+  uint32_t cur = 1, next = 2;
+  while (!scm_atomic_compare_and_swap_uint32 (&pt->refcount, &cur, next))
+    {
+      if (cur == 0)
+        scm_wrong_type_arg_msg (NULL, 0, port, "open port");
+      next = cur + 1;
+    }
+  scm_dynwind_unwind_handler_with_scm (release_port, port,
+                                       SCM_F_WIND_EXPLICITLY);
+}
+
+SCM_DEFINE (scm_mmap_search, "mmap/search", 2, 4, 0,
+            (SCM addr, SCM len, SCM prot, SCM flags, SCM file, SCM offset),
+	    "Create a memory mapping, returning a bytevector..  @var{addr},\n"
+	    "if non-zero, is the staring address; or, if zero, is assigned by\n"
+	    "the system.  @var{prot}, if provided, assigns protection.\n"
+	    "@var{file}, a port or fd, if provided associates the memory\n"
+            "region with a file starting at @var{offset}, if provided.\n"
+	    "The region returned by mmap WILL be searched by the garbage\n"
+	    "collector for pointers.  See also mmap.  Note that the\n"
+            "finalizer for the returned bytevector will call munmap.\n"
+	    "Defaults for optional arguments are\n"
+	    "@table @asis\n"
+	    "@item prot\n(logior PROT_READ PROT_WRITE)\n"
+	    "@item flags\n(logior MAP_ANONYMOUS MAP_PRIVATE)\n"
+	    "@item fd\n-1\n"
+	    "@item offset\n0\n"
+	    "@end table")
+#define FUNC_NAME s_scm_mmap_search
+{
+  void *c_mem, *c_addr;
+  size_t c_len;
+  int c_prot, c_flags, c_fd;
+  scm_t_off c_offset;
+  SCM pointer, bvec;
+
+  if (SCM_POINTER_P (addr))
+    c_addr = SCM_POINTER_VALUE (addr);
+  else if (scm_is_integer (addr))
+    c_addr = (void*) scm_to_uintptr_t (addr);
+  else
+    scm_misc_error ("mmap", "bad addr", addr);
+
+  c_len = scm_to_size_t (len);
+
+  if (SCM_UNBNDP (prot))
+    c_prot = PROT_READ | PROT_WRITE;
+  else
+    c_prot = scm_to_int (prot);
+
+  if (SCM_UNBNDP (flags))
+    c_flags = MAP_ANONYMOUS | MAP_PRIVATE;
+  else
+    c_flags = scm_to_int (flags);
+
+  scm_dynwind_begin (0);
+  
+  if (SCM_UNBNDP (file))
+    c_fd = -1;
+  else if (scm_is_integer (file))
+    c_fd = scm_to_int (file);
+  else
+    {
+      /* Use the fd of the port under clobber protection from concurrency.
+         As scm_dynwind_acquire_port assumes that FILE is a port, check 
+         that first. */
+      SCM_VALIDATE_PORT (SCM_ARG5, file);
+      scm_dynwind_acquire_port (file);
+      c_fd = scm_to_int (scm_fileno (file));
+    }
+  
+  if (SCM_UNBNDP (offset))
+    c_offset = 0;
+  else
+    c_offset = scm_to_off_t (offset);
+
+  if ((c_addr == NULL) && (c_flags & MAP_FIXED))
+    scm_misc_error ("mmap", "cannot have NULL addr w/ MAP_FIXED", SCM_EOL);
+
+  SCM_SYSCALL (c_mem = mmap(c_addr, c_len, c_prot, c_flags, c_fd, c_offset));
+  if (c_mem == MAP_FAILED)
+    scm_syserror ("mmap");              /* errno set */
+
+  /* The fd is free to go now. */
+  scm_dynwind_end ();
+
+  pointer = scm_from_pointer ((signed char *) c_mem, mmap_finalizer);
+  bvec = scm_pointer_to_bytevector (pointer, c_len, c_offset,
+                                    SCM_ARRAY_ELEMENT_TYPE_VU8);
+
+  return bvec;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_mmap, "mmap", 2, 4, 0,
+            (SCM addr, SCM len, SCM prot, SCM flags, SCM file, SCM offset),
+	    "Create a memory mapping, returning a bytevector.  @var{addr}, if\n"
+	    "non-zero, is the staring address; or, if zero, is assigned by the\n"
+	    "system.  @var{prot}, if provided, assigns protection.\n"
+            "@var{file}, a port or fd, if provided associates the memory\n"
+            "region with a file, starting at @var{offset}, if provided.\n"
+	    "The region returned by mmap will NOT be searched by the garbage\n"
+	    "collector for pointers. See also mmap/search.  Note that the\n"
+            "finalizer for the returned bytevector will call munmap.\n"
+	    "Defaults for arguments are:\n"
+	    "@table @asis\n"
+	    "@item prot\n(logior PROT_READ PROT_WRITE)\n"
+	    "@item flags\n(logior MAP_ANONYMOUS MAP_PRIVATE)\n"
+	    "@item fd\n-1\n"
+	    "@item offset\n0\n"
+	    "@end table")
+#define FUNC_NAME s_scm_mmap
+{
+  void *c_mem;
+  size_t c_len;
+  SCM bvec;
+
+  bvec = scm_mmap_search(addr, len, prot, flags, file, offset);
+  c_mem = SCM_BYTEVECTOR_CONTENTS(bvec);
+  c_len = SCM_BYTEVECTOR_LENGTH(bvec);
+
+  /* Tell GC not to scan for pointers. */
+  GC_exclude_static_roots(c_mem, (char*) c_mem + c_len);
+
+  return bvec;
+}
+#undef FUNC_NAME
+
+/* The following copied from bytevectors.c. Kludge? */
+#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len)            \
+  SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents)	\
+  SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
+
+SCM_DEFINE (scm_munmap, "munmap", 1, 0, 0,
+            (SCM bvec),
+	    "Given bytevector generated by mmap or mmap/search, unmap the\n"
+            "the associated memory.  The argument will be modified to \n"
+            "reflect a zero length bv. The return value is unspecified.\n"
+            "Note that munmap is called by finalizer associated with\n"
+            "bytevectors returned from mmap and mmap/search.\n")
+#define FUNC_NAME s_scm_munmap
+{
+  void *addr;
+  size_t len;
+  int rv;
+
+  SCM_VALIDATE_BYTEVECTOR (1, bvec);
+
+  addr = (void *) SCM_BYTEVECTOR_CONTENTS (bvec);
+  len = SCM_BYTEVECTOR_LENGTH (bvec);
+
+  /* Invalidate further work on this bytevector. */
+  SCM_BYTEVECTOR_SET_LENGTH (bvec, 0);
+  SCM_BYTEVECTOR_SET_CONTENTS (bvec, NULL);
+
+  SCM_SYSCALL (rv = munmap(addr, len));
+  if (rv == -1)
+    SCM_SYSERROR;			/* errno set */
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_MSYNC
+SCM_DEFINE (scm_msync, "msync", 2, 0, 0,
+            (SCM bvec, SCM flags),
+	    "Flush changes made to the in-core copy of a file mapped using\n"
+            "mmap or mmap/search.  This should be executed on modified memory\n"
+            "before calling munmap.  The @var{flags} argument must be exactly\n"
+            "one of the following:\n"
+            "@table @code\n"
+            "@item MS_ASYNC\n"
+            "Initiate update, return immediately.\n"
+            "@item MS_SYNC\n"
+            "Initiate update, block until complete.\n"
+            "@item MS_INVALIDATE\n"
+            "Invalidate other mappings of the same file.\n"
+            "@end table\n"
+            "The return value is unspecified.")
+#define FUNC_NAME s_scm_msync
+{
+  void *addr;
+  size_t len;
+  int c_flags, rv;
+
+  SCM_VALIDATE_BYTEVECTOR (1, bvec);
+  addr = (void *) SCM_BYTEVECTOR_CONTENTS (bvec);
+  len = SCM_BYTEVECTOR_LENGTH (bvec);
+
+  c_flags = scm_to_int (flags);
+
+  SCM_SYSCALL (rv = msync(addr, len, c_flags));
+  if (rv == -1)
+    SCM_SYSERROR;			/* errno set */
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_MSYNC */
+
+static void init_mman(void) {
+  scm_add_feature("mman");
+
+#ifdef PROT_NONE
+  scm_c_define ("PROT_NONE", scm_from_int (PROT_NONE));
+#endif
+#ifdef PROT_READ
+  scm_c_define ("PROT_READ", scm_from_int (PROT_READ));
+#endif
+#ifdef PROT_WRITE
+  scm_c_define ("PROT_WRITE", scm_from_int (PROT_WRITE));
+#endif
+#ifdef PROT_EXEC
+  scm_c_define ("PROT_EXEC", scm_from_int (PROT_EXEC));
+#endif
+
+#ifdef MAP_ANONYMOUS
+  scm_c_define ("MAP_ANONYMOUS", scm_from_int (MAP_ANONYMOUS));
+#endif
+#ifdef MAP_ANON
+  scm_c_define ("MAP_ANON", scm_from_int (MAP_ANON));
+#endif
+#ifdef MAP_FILE
+  scm_c_define ("MAP_FILE", scm_from_int (MAP_FILE));
+#endif
+#ifdef MAP_FIXED
+  scm_c_define ("MAP_FIXED", scm_from_int (MAP_FIXED));
+#endif
+#ifdef MAP_HASSEMAPHORE
+  scm_c_define ("MAP_HASSEMAPHORE", scm_from_int (MAP_HASSEMAPHORE));
+#endif
+#ifdef MAP_PRIVATE
+  scm_c_define ("MAP_PRIVATE", scm_from_int (MAP_PRIVATE));
+#endif
+#ifdef MAP_SHARED
+  scm_c_define ("MAP_SHARED", scm_from_int (MAP_SHARED));
+#endif
+#ifdef MAP_NOCACHE
+  scm_c_define ("MAP_NOCACHE", scm_from_int (MAP_NOCACHE));
+#endif
+  scm_c_define ("PAGE_SIZE", scm_from_int (sysconf (_SC_PAGESIZE)));
+#ifdef MS_ASYNC
+  scm_c_define ("MS_ASYNC", scm_from_int (MS_ASYNC));
+#endif
+#ifdef MS_SYNC
+  scm_c_define ("MS_SYNC", scm_from_int (MS_SYNC));
+#endif
+#ifdef MS_INVALIDATE
+  scm_c_define ("MS_INVALIDATE", scm_from_int (MS_INVALIDATE));
+#endif
+}
+
+#endif /* HAVE_SYS_MMAN_H */
+
+\f
+
 void
 scm_init_filesys ()
 {
@@ -2387,6 +2700,9 @@ scm_init_filesys ()
 #ifdef HAVE_READLINKAT
   scm_add_feature("readlink-port");
 #endif
+#if defined(HAVE_SYS_MMAN_H)
+  init_mman();
+#endif
 
 #include "filesys.x"
 }
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 1ce50d30e..fa40b484f 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -80,6 +80,10 @@ SCM_API SCM scm_dirname (SCM filename);
 SCM_API SCM scm_basename (SCM filename, SCM suffix);
 SCM_API SCM scm_canonicalize_path (SCM path);
 SCM_API SCM scm_sendfile (SCM out, SCM in, SCM count, SCM offset);
+SCM_API SCM scm_mmap_search(SCM addr, SCM len, SCM prot, SCM flags, SCM fd, SCM offset);
+SCM_API SCM scm_mmap(SCM addr, SCM len, SCM prot, SCM flags, SCM fd, SCM offset);
+SCM_API SCM scm_msync(SCM bvec, SCM flags);
+SCM_API SCM scm_munmap(SCM bvec);
 SCM_INTERNAL SCM scm_i_relativize_path (SCM path, SCM in_path);
 
 SCM_INTERNAL void scm_init_filesys (void);
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 16fa2e952..3785e2f85 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -77,6 +77,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/load.test			\
 	    tests/match.test			\
 	    tests/match.test.upstream		\
+	    tests/mman.test			\
 	    tests/modules.test			\
 	    tests/multilingual.nottest		\
 	    tests/net-db.test			\
diff --git a/test-suite/tests/mman.test b/test-suite/tests/mman.test
new file mode 100644
index 000000000..592a800f8
--- /dev/null
+++ b/test-suite/tests/mman.test
@@ -0,0 +1,48 @@
+;;;; mman.test --- Tests for mmap API.    -*- scheme -*-
+;;;;
+;;;; Copyright 2022 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-mman)
+  #:use-module (test-suite lib)
+  #:use-module (test-suite guile-test)
+  #:use-module (rnrs bytevectors)
+  #:declarative? #f
+  )
+
+(define (mmap-test-file)
+  (data-file-name "foo.txt"))
+
+(define mmap-test-string "hello, world")
+
+(define (gen-mmap-test-file)
+  (with-output-to-file (mmap-test-file)
+    (lambda () (display mmap-test-string))))
+
+(when (provided? 'mman)
+
+  (gen-mmap-test-file)
+
+  (with-test-prefix "mman"
+
+    (pass-if "mman 1"
+      (let ((bv (mmap 0 #x100)))
+        (bytevector-u8-set! bv 0 34)
+        (= (bytevector-u8-ref bv 0) 34)))
+
+    ))
+
+;; --- last line ---