Re: [Chicken-hackers] posix win, memory mapped io

[Felix]

From: Brad Pitt <address@hidden>
Subject: [Chicken-hackers] posix win, memory mapped io
Date: Sun, 07 Apr 2013 03:17:08 +0400

> 
> Hello!
> 
> After some discussion in #chicken, im ready to present patch for posixwin.scm 
> that add support of memory mapped io functiond for windoze platform.
> I have tested only primitive flags combinations.
> 

Attached is a signed-off version, with updated NEWS and manual. Thanks
very much - it compiled fine and posix-tests ran ok. I did not make any
further tests.


cheers,
felix

From 50f5b2e31bc227dd856489a6075659d824c47796 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Tue, 9 Apr 2013 23:16:43 +0200
Subject: [PATCH] added initial support for memory-mapped files on Windows
 (contributed by rivo)

Signed-off-by: felix <address@hidden>
---
 NEWS                    |    1 +
 manual/Acknowledgements |   32 ++++-----
 manual/Unit posix       |    3 -
 posixwin.scm            |  172 +++++++++++++++++++++++++++++++++++++++++++----
 tests/posix-tests.scm   |   14 +++-
 5 files changed, 189 insertions(+), 33 deletions(-)

diff --git a/NEWS b/NEWS
index 018d57a..b013a84 100644
--- a/NEWS
+++ b/NEWS
@@ -20,6 +20,7 @@
   - read-line no longer returns trailing CRs in rare cases on TCP ports (#568)
   - write and pp now correctly use escape sequences for control characters
      (thanks to Florian Zumbiehl)
+  - posix: memory-mapped file support for Windows (thanks to "rivo")
 
 - Runtime system
   - Special events in poll() are now handled, avoiding hangs in threaded apps.
diff --git a/manual/Acknowledgements b/manual/Acknowledgements
index 4a0fd3d..7dd08d3 100644
--- a/manual/Acknowledgements
+++ b/manual/Acknowledgements
@@ -36,22 +36,22 @@ Myyrä, "nicktick", Lars Nilsson, Ian Oversby, "o.t.", Gene 
Pavlovsky,
 Levi Pearson, Jeronimo Pellegrini, Nicolas Pelletier, Derrell Piper,
 Carlos Pita, Robin Lee Powell, Alan Post, "Pupeno", Davide Puricelli,
 "presto", Doug Quale, Imran Rafique, Eric Raible, Ivan Raikov, Santosh
-Rajan, Joel Reymont, Chris Roberts, Eric Rochester, Paul Romanchenko,
-Andreas Rottman, David Rush, Lars Rustemeier, Daniel Sadilek, Otavio
-Salvador, Burton Samograd, "Sandro", "satori", Aleksej Saushev, Oskar
-Schirmer, Reed Sheridan, Ronald Schröder, Spencer Schumann, Ivan
-Shcheklein, Alex Shinn, Ivan Shmakov, "Shmul", Tony Sidaway, Jeffrey
-B. Siegal, Andrey Sidorenko, Michele Simionato, Iruata Souza, Volker
-Stolz, Jon Strait, Dorai Sitaram, Robert Skeels, Jason Songhurst,
-Clifford Stein, David Steiner, Sunnan, Zbigniew Szadkowski, Rick
-Taube, Nathan Thern, Mike Thomas, Minh Thu, Christian Tismer, Andre
-van Tonder, John Tobey, Henrik Tramberend, Vladimir Tsichevsky, Neil
-van Dyke, Sam Varner, Taylor Venable, Sander Vesik, Jaques Vidrine,
-Panagiotis Vossos, Shawn Wagner, Peter Wang, Ed Watkeys, Brad Watson,
-Thomas Weidner, Göran Weinholt, Matthew Welland, Drake Wilson, Jörg
-Wittenberger, Peter Wright, Mark Wutka, Adam Young, Richard Zidlicky,
-Houman Zolfaghari and Florian Zumbiehl for bug-fixes, tips and
-suggestions.
+Rajan, Joel Reymont, "rivo", Chris Roberts, Eric Rochester, Paul
+Romanchenko, Andreas Rottman, David Rush, Lars Rustemeier, Daniel
+Sadilek, Otavio Salvador, Burton Samograd, "Sandro", "satori", Aleksej
+Saushev, Oskar Schirmer, Reed Sheridan, Ronald Schröder, Spencer
+Schumann, Ivan Shcheklein, Alex Shinn, Ivan Shmakov, "Shmul", Tony
+Sidaway, Jeffrey B. Siegal, Andrey Sidorenko, Michele Simionato,
+Iruata Souza, Volker Stolz, Jon Strait, Dorai Sitaram, Robert Skeels,
+Jason Songhurst, Clifford Stein, David Steiner, Sunnan, Zbigniew
+Szadkowski, Rick Taube, Nathan Thern, Mike Thomas, Minh Thu, Christian
+Tismer, Andre van Tonder, John Tobey, Henrik Tramberend, Vladimir
+Tsichevsky, Neil van Dyke, Sam Varner, Taylor Venable, Sander Vesik,
+Jaques Vidrine, Panagiotis Vossos, Shawn Wagner, Peter Wang, Ed
+Watkeys, Brad Watson, Thomas Weidner, Göran Weinholt, Matthew
+Welland, Drake Wilson, Jörg Wittenberger, Peter Wright, Mark Wutka,
+Adam Young, Richard Zidlicky, Houman Zolfaghari and Florian Zumbiehl
+for bug-fixes, tips and suggestions.
 
 CHICKEN uses the "irregex" regular expression package written by Alex Shinn.
 
diff --git a/manual/Unit posix b/manual/Unit posix
index 441f811..2606e86 100644
--- a/manual/Unit posix 
+++ b/manual/Unit posix 
@@ -1460,9 +1460,6 @@ Microsoft tools or with MinGW):
  file-truncate
  file-lock  file-lock/blocking  file-unlock  file-test-lock
  create-fifo  fifo?
- prot/...
- map/...
- map-file-to-memory  unmap-file-from-memory  memory-mapped-file-pointer  
memory-mapped-file?
  set-alarm!
  terminal-port?  terminal-name
  process-fork  process-signal
diff --git a/posixwin.scm b/posixwin.scm
index d2cc927..3d28e64 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1686,6 +1686,165 @@ EOF
        (##sys#error 'current-user-name "cannot retrieve current user-name") ) 
) )
 
 
+;;; memory mapped files
+
+#>
+#define PROT_NONE       0
+#define PROT_READ       1
+#define PROT_WRITE      2
+#define PROT_EXEC       4
+#define MAP_FILE        0
+#define MAP_SHARED      1
+#define MAP_PRIVATE     2
+#define MAP_FIXED       0x10
+#define MAP_ANONYMOUS   0x20
+
+// This value is available starting with Windows XP with SP2 
+// and Windows Server 2003 with SP1.
+#ifndef FILE_MAP_EXECUTE
+#define FILE_MAP_EXECUTE 0x20
+#endif//FILE_MAP_EXECUTE
+
+static int page_flags[] =
+{
+    0,
+    PAGE_READONLY,
+    PAGE_READWRITE,
+    PAGE_READWRITE,
+    PAGE_EXECUTE_READ,
+    PAGE_EXECUTE_READ,
+    PAGE_EXECUTE_READWRITE
+};
+
+static int file_flags[] =
+{
+    0,
+    FILE_MAP_READ,
+    FILE_MAP_READ|FILE_MAP_WRITE,
+    FILE_MAP_READ|FILE_MAP_WRITE,
+    FILE_MAP_READ|FILE_MAP_EXECUTE,
+    FILE_MAP_READ|FILE_MAP_EXECUTE,
+    FILE_MAP_READ|FILE_MAP_WRITE|FILE_MAP_EXECUTE
+};
+
+void* mmap(void* addr,int len,int prot,int flags,int fd,int off)
+{
+    HANDLE hMap;
+    HANDLE hFile;
+
+    void* ptr;
+
+    if ((flags & MAP_FIXED) || (flags & MAP_PRIVATE) || (flags & 
MAP_ANONYMOUS))
+    {
+        errno = EINVAL;
+        return (void*)-1;
+    }
+
+    hFile = _get_osfhandle(fd);
+    if (hFile == INVALID_HANDLE_VALUE)
+    {
+        return (void*)-1;
+    }
+
+    hMap = CreateFileMapping(
+            hFile,
+            NULL,
+            page_flags[prot & (PROT_READ|PROT_WRITE|PROT_EXEC)],
+            0,
+            0,
+            NULL);
+
+    if (hMap == INVALID_HANDLE_VALUE)
+    {
+        set_last_errno();
+        return (void*)-1;
+    }
+
+    ptr = MapViewOfFile(
+            hMap,
+            file_flags[prot & (PROT_READ|PROT_WRITE|PROT_EXEC)],
+            0,
+            off,
+            len);
+
+    if (ptr == NULL)
+    {
+        set_last_errno();
+        ptr = (void*)-1;
+    }
+
+    CloseHandle(hMap);
+
+    return ptr;
+}
+
+int munmap(void* addr,int len)
+{
+    if (UnmapViewOfFile(addr))
+    {
+        errno = 0;
+        return 0;
+    }
+    set_last_errno();
+    return -1;
+}
+
+int is_bad_mmap(void* p)
+{
+    void* bad_ptr;
+    bad_ptr = (void*)-1;
+    return p == bad_ptr;
+}
+<#
+
+(define-foreign-variable _prot_none int "PROT_NONE")
+(define-foreign-variable _prot_read int "PROT_READ")
+(define-foreign-variable _prot_write int "PROT_WRITE")
+(define-foreign-variable _prot_exec int "PROT_EXEC")
+(define-foreign-variable _map_file int "MAP_FILE")
+(define-foreign-variable _map_shared int "MAP_SHARED")
+(define-foreign-variable _map_fixed int "MAP_FIXED")
+(define-foreign-variable _map_private int "MAP_PRIVATE")
+(define-foreign-variable _map_anonymous int "MAP_ANONYMOUS")
+
+(define prot/none _prot_none)
+(define prot/read _prot_read)
+(define prot/write _prot_write)
+(define prot/exec _prot_exec)
+(define map/file _map_file)
+(define map/shared _map_shared)
+(define map/private _map_private)
+(define map/fixed _map_fixed)
+(define map/anonymous _map_anonymous)
+
+(define map-file-to-memory
+  (let ([mmap (foreign-lambda c-pointer "mmap" c-pointer integer int int int 
integer)]
+        [bad-mmap? (foreign-lambda bool "is_bad_mmap" c-pointer)] )
+    (lambda (addr len prot flag fd . off)
+      (let ([addr (if (not addr) (##sys#null-pointer) addr)]
+            [off (if (pair? off) (car off) 0)] )
+        (unless (and (##core#inline "C_blockp" addr) (##core#inline 
"C_specialp" addr))
+          (##sys#signal-hook #:type-error 'map-file-to-memory "bad argument 
type - not a foreign pointer" addr) )
+        (let ([addr2 (mmap addr len prot flag fd off)])
+          (when (bad-mmap? addr2)
+            (posix-error #:file-error 'map-file-to-memory "cannot map file to 
memory" addr len prot flag fd off) )
+          (##sys#make-structure 'mmap addr2 len) ) ) ) ) )
+
+(define unmap-file-from-memory
+  (let ([munmap (foreign-lambda int "munmap" c-pointer integer)] )
+    (lambda (mmap . len)
+      (##sys#check-structure mmap 'mmap 'unmap-file-from-memory)
+      (let ([len (if (pair? len) (car len) (##sys#slot mmap 2))])
+        (unless (eq? 0 (munmap (##sys#slot mmap 1) len))
+      (posix-error #:file-error 'unmap-file-from-memory "cannot unmap file 
from memory" mmap len) ) ) ) ) )
+
+(define (memory-mapped-file-pointer mmap)
+  (##sys#check-structure mmap 'mmap 'memory-mapped-file-pointer)
+  (##sys#slot mmap 1) )
+
+(define (memory-mapped-file? x)
+  (##sys#structure? x 'mmap) )
+
 ;;; unimplemented stuff:
 
 (define-syntax define-unimplemented
@@ -1704,7 +1863,6 @@ EOF
 (define-unimplemented current-effective-user-name)
 (define-unimplemented current-group-id)
 (define-unimplemented current-user-id)
-(define-unimplemented map-file-to-memory)
 (define-unimplemented file-link)
 (define-unimplemented file-lock)
 (define-unimplemented file-lock/blocking)
@@ -1715,7 +1873,6 @@ EOF
 (define-unimplemented get-groups)
 (define-unimplemented group-information)
 (define-unimplemented initialize-groups)
-(define-unimplemented memory-mapped-file-pointer)
 (define-unimplemented parent-process-id)
 (define-unimplemented process-fork)
 (define-unimplemented process-group-id)
@@ -1733,7 +1890,6 @@ EOF
 (define-unimplemented signal-masked?)
 (define-unimplemented signal-unmask!)
 (define-unimplemented terminal-name)
-(define-unimplemented unmap-file-from-memory)
 (define-unimplemented user-information)
 (define-unimplemented utc-time->seconds)
 (define-unimplemented string->time)
@@ -1741,13 +1897,7 @@ EOF
 (define errno/wouldblock 0)
 
 (define (fifo? _) #f)
-(define (memory-mapped-file? _) #f)
 
-(define map/anonymous 0)
-(define map/file 0)
-(define map/fixed 0)
-(define map/private 0)
-(define map/shared 0)
 (define open/fsync 0)
 (define open/noctty 0)
 (define open/nonblock 0)
@@ -1755,7 +1905,3 @@ EOF
 (define perm/isgid 0)
 (define perm/isuid 0)
 (define perm/isvtx 0)
-(define prot/exec 0)
-(define prot/none 0)
-(define prot/read 0)
-(define prot/write 0)
diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
index e0d35ee..1f934d9 100644
--- a/tests/posix-tests.scm
+++ b/tests/posix-tests.scm
@@ -1,4 +1,4 @@
-(use files posix)
+(use files posix lolevel)
 
 (define-syntax assert-error
   (syntax-rules ()
@@ -31,3 +31,15 @@
 (assert-error (process-execute "false\x00123"))
 (assert-error (process-execute "false" '("1" "123\x00456")))
 (assert-error (process-execute "false" '("123\x00456") '("foo\x00bar" 
"blabla") '("lalala" "qux\x00mooh")))
+
+(let ((tnpfilpn (create-temporary-file)))
+  (let ((tmpfilno (file-open tnpfilpn (+ open/rdwr open/creat)))
+        (data "abcde")
+        (size 5))
+    (file-write tmpfilno data)
+    (let ((mmap (map-file-to-memory #f size prot/read map/file tmpfilno))
+          (str (make-string size)))
+      (assert (memory-mapped-file? mmap))
+      (move-memory! (memory-mapped-file-pointer mmap) str size)
+      (assert (blob=? (string->blob data) (string->blob str)))
+      (unmap-file-from-memory mmap))))
-- 
1.7.10.4