Moving :mmap out of core binary into a module

2 files changed, 350 insertions, 0 deletions

diff --git a/ext/PerlIO-mmap/mmap.pm b/ext/PerlIO-mmap/mmap.pm
new file mode 100644
index 0000000000..7db4a55137
--- /dev/null
+++ b/ext/PerlIO-mmap/mmap.pm
@@ -0,0 +1,30 @@
+package PerlIO::mmap;
+use strict;
+use warnings;
+our $VERSION = '0.010';
+
+use XSLoader;
+XSLoader::load(__PACKAGE__, __PACKAGE__->VERSION);
+
+1;
+
+__END__
+
+=head1 NAME
+
+PerlIO::mmap - Memory mapped IO
+
+=head1 SYNOPSIS
+
+ open my $fh, '<:mmap', $filename;
+
+=head1 DESCRIPTION
+
+This layer does C<read> and C<write> operations by mmap()ing the file if possible, but falls back to the default behavior if not.
+
+=head1 IMPLEMENTATION NOTE
+
+C<PerlIO::mmap> only exists to use XSLoader to load C code that provides support for using memory mapped IO. One does not need to explicitly C<use PerlIO::mmap;>.
+
+=cut
+
diff --git a/ext/PerlIO-mmap/mmap.xs b/ext/PerlIO-mmap/mmap.xs
new file mode 100644
index 0000000000..3e87d3b371
--- /dev/null
+++ b/ext/PerlIO-mmap/mmap.xs
@@ -0,0 +1,320 @@
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#if defined(PERLIO_LAYERS) && defined(HAS_MMAP)
+
+#include "perliol.h"
+#include <sys/mman.h>
+
+/*
+ * mmap as "buffer" layer
+ */
+
+typedef struct {
+    PerlIOBuf base;             /* PerlIOBuf stuff */
+    Mmap_t mptr;                /* Mapped address */
+    Size_t len;                 /* mapped length */
+    STDCHAR *bbuf;              /* malloced buffer if map fails */
+} PerlIOMmap;
+
+IV
+PerlIOMmap_map(pTHX_ PerlIO *f)
+{
+    dVAR;
+    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
+    const IV flags = PerlIOBase(f)->flags;
+    IV code = 0;
+    if (m->len)
+	abort();
+    if (flags & PERLIO_F_CANREAD) {
+	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
+	const int fd = PerlIO_fileno(f);
+	Stat_t st;
+	code = Fstat(fd, &st);
+	if (code == 0 && S_ISREG(st.st_mode)) {
+	    SSize_t len = st.st_size - b->posn;
+	    if (len > 0) {
+		Off_t posn;
+		if (PL_mmap_page_size <= 0)
+		  Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
+			     PL_mmap_page_size);
+		if (b->posn < 0) {
+		    /*
+		     * This is a hack - should never happen - open should
+		     * have set it !
+		     */
+		    b->posn = PerlIO_tell(PerlIONext(f));
+		}
+		posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
+		len = st.st_size - posn;
+		m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
+		if (m->mptr && m->mptr != (Mmap_t) - 1) {
+#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
+		    madvise(m->mptr, len, MADV_SEQUENTIAL);
+#endif
+#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
+		    madvise(m->mptr, len, MADV_WILLNEED);
+#endif
+		    PerlIOBase(f)->flags =
+			(flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
+		    b->end = ((STDCHAR *) m->mptr) + len;
+		    b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
+		    b->ptr = b->buf;
+		    m->len = len;
+		}
+		else {
+		    b->buf = NULL;
+		}
+	    }
+	    else {
+		PerlIOBase(f)->flags =
+		    flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
+		b->buf = NULL;
+		b->ptr = b->end = b->ptr;
+		code = -1;
+	    }
+	}
+    }
+    return code;
+}
+
+IV
+PerlIOMmap_unmap(pTHX_ PerlIO *f)
+{
+    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
+    IV code = 0;
+    if (m->len) {
+	PerlIOBuf * const b = &m->base;
+	if (b->buf) {
+	    /* The munmap address argument is tricky: depending on the
+	     * standard it is either "void *" or "caddr_t" (which is
+	     * usually "char *" (signed or unsigned).  If we cast it
+	     * to "void *", those that have it caddr_t and an uptight
+	     * C++ compiler, will freak out.  But casting it as char*
+	     * should work.  Maybe.  (Using Mmap_t figured out by
+	     * Configure doesn't always work, apparently.) */
+	    code = munmap((char*)m->mptr, m->len);
+	    b->buf = NULL;
+	    m->len = 0;
+	    m->mptr = NULL;
+	    if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
+		code = -1;
+	}
+	b->ptr = b->end = b->buf;
+	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
+    }
+    return code;
+}
+
+STDCHAR *
+PerlIOMmap_get_base(pTHX_ PerlIO *f)
+{
+    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
+    PerlIOBuf * const b = &m->base;
+    if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
+	/*
+	 * Already have a readbuffer in progress
+	 */
+	return b->buf;
+    }
+    if (b->buf) {
+	/*
+	 * We have a write buffer or flushed PerlIOBuf read buffer
+	 */
+	m->bbuf = b->buf;       /* save it in case we need it again */
+	b->buf = NULL;          /* Clear to trigger below */
+    }
+    if (!b->buf) {
+	PerlIOMmap_map(aTHX_ f);        /* Try and map it */
+	if (!b->buf) {
+	    /*
+	     * Map did not work - recover PerlIOBuf buffer if we have one
+	     */
+	    b->buf = m->bbuf;
+	}
+    }
+    b->ptr = b->end = b->buf;
+    if (b->buf)
+	return b->buf;
+    return PerlIOBuf_get_base(aTHX_ f);
+}
+
+SSize_t
+PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
+{
+    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
+    PerlIOBuf * const b = &m->base;
+    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
+	PerlIO_flush(f);
+    if (b->ptr && (b->ptr - count) >= b->buf
+	&& memEQ(b->ptr - count, vbuf, count)) {
+	b->ptr -= count;
+	PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
+	return count;
+    }
+    if (m->len) {
+	/*
+	 * Loose the unwritable mapped buffer
+	 */
+	PerlIO_flush(f);
+	/*
+	 * If flush took the "buffer" see if we have one from before
+	 */
+	if (!b->buf && m->bbuf)
+	    b->buf = m->bbuf;
+	if (!b->buf) {
+	    PerlIOBuf_get_base(aTHX_ f);
+	    m->bbuf = b->buf;
+	}
+    }
+    return PerlIOBuf_unread(aTHX_ f, vbuf, count);
+}
+
+SSize_t
+PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
+{
+    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
+    PerlIOBuf * const b = &m->base;
+
+    if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
+	/*
+	 * No, or wrong sort of, buffer
+	 */
+	if (m->len) {
+	    if (PerlIOMmap_unmap(aTHX_ f) != 0)
+		return 0;
+	}
+	/*
+	 * If unmap took the "buffer" see if we have one from before
+	 */
+	if (!b->buf && m->bbuf)
+	    b->buf = m->bbuf;
+	if (!b->buf) {
+	    PerlIOBuf_get_base(aTHX_ f);
+	    m->bbuf = b->buf;
+	}
+    }
+    return PerlIOBuf_write(aTHX_ f, vbuf, count);
+}
+
+IV
+PerlIOMmap_flush(pTHX_ PerlIO *f)
+{
+    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
+    PerlIOBuf * const b = &m->base;
+    IV code = PerlIOBuf_flush(aTHX_ f);
+    /*
+     * Now we are "synced" at PerlIOBuf level
+     */
+    if (b->buf) {
+	if (m->len) {
+	    /*
+	     * Unmap the buffer
+	     */
+	    if (PerlIOMmap_unmap(aTHX_ f) != 0)
+		code = -1;
+	}
+	else {
+	    /*
+	     * We seem to have a PerlIOBuf buffer which was not mapped
+	     * remember it in case we need one later
+	     */
+	    m->bbuf = b->buf;
+	}
+    }
+    return code;
+}
+
+IV
+PerlIOMmap_fill(pTHX_ PerlIO *f)
+{
+    PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
+    IV code = PerlIO_flush(f);
+    if (code == 0 && !b->buf) {
+	code = PerlIOMmap_map(aTHX_ f);
+    }
+    if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
+	code = PerlIOBuf_fill(aTHX_ f);
+    }
+    return code;
+}
+
+IV
+PerlIOMmap_close(pTHX_ PerlIO *f)
+{
+    PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
+    PerlIOBuf * const b = &m->base;
+    IV code = PerlIO_flush(f);
+    if (m->bbuf) {
+	b->buf = m->bbuf;
+	m->bbuf = NULL;
+	b->ptr = b->end = b->buf;
+    }
+    if (PerlIOBuf_close(aTHX_ f) != 0)
+	code = -1;
+    return code;
+}
+
+PerlIO *
+PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
+{
+ return PerlIOBase_dup(aTHX_ f, o, param, flags);
+}
+
+
+PERLIO_FUNCS_DECL(PerlIO_mmap) = {
+    sizeof(PerlIO_funcs),
+    "mmap",
+    sizeof(PerlIOMmap),
+    PERLIO_K_BUFFERED|PERLIO_K_RAW,
+    PerlIOBuf_pushed,
+    PerlIOBuf_popped,
+    PerlIOBuf_open,
+    PerlIOBase_binmode,         /* binmode */
+    NULL,
+    PerlIOBase_fileno,
+    PerlIOMmap_dup,
+    PerlIOBuf_read,
+    PerlIOMmap_unread,
+    PerlIOMmap_write,
+    PerlIOBuf_seek,
+    PerlIOBuf_tell,
+    PerlIOBuf_close,
+    PerlIOMmap_flush,
+    PerlIOMmap_fill,
+    PerlIOBase_eof,
+    PerlIOBase_error,
+    PerlIOBase_clearerr,
+    PerlIOBase_setlinebuf,
+    PerlIOMmap_get_base,
+    PerlIOBuf_bufsiz,
+    PerlIOBuf_get_ptr,
+    PerlIOBuf_get_cnt,
+    PerlIOBuf_set_ptrcnt,
+};
+
+#endif /* Layers available */
+
+MODULE = PerlIO::mmap	PACKAGE = PerlIO::mmap
+
+PROTOTYPES: DISABLE
+
+BOOT:
+{
+#if defined(PERLIO_LAYERS) && defined(HAS_MMAP)
+    PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
+#endif
+}
+