~ chicken-core (chicken-5) 9eea204cb79bdd300cabdcf3ae229ad4102276e1
commit 9eea204cb79bdd300cabdcf3ae229ad4102276e1
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Apr 9 23:16:43 2013 +0200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Wed Apr 10 19:40:09 2013 +0200
added initial support for memory-mapped files on Windows (contributed by rivo)
Signed-off-by: felix <felix@call-with-current-continuation.org>
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/NEWS b/NEWS
index 018d57ad..b013a84f 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/Unit posix b/manual/Unit posix
index 441f811a..2606e86c 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 d2cc9273..3d28e642 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 e0d35ee2..1f934d9b 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))))
Trap