From ad4b18f5d843d91cc48c9b6cc936a6c7be5fce27 Mon Sep 17 00:00:00 2001
From: Anton Kovalenko <anton@sw4me.com>
Date: Thu, 7 Oct 2010 04:37:07 +0400
Subject: [PATCH] sb-win32: offer low-level bindings for file mapping
 functions

  Includes functions offered by Windows that are similar in
  spirit to mmap.

  Currently these are low-level FFI versions only, and no attempt
  is made to export them from sb-posix under the name mmap.  In
  sb-posix, only a wrapper for msync and definitions of several
  constants is offered, as needed for sb-simple-streams.

Thanks to Anton Kovalenko.

Also take this opportunity to sort the sb-win32 package
definition as a flat list.
---
 contrib/sb-posix/interface.lisp |   21 +++++++++++++++++++++
 package-data-list.lisp-expr     |   31 ++++++++++++++++++++++++-------
 src/code/win32.lisp             |   30 ++++++++++++++++++++++++++++++
 src/runtime/win32-os.c          |    5 +++++
 4 files changed, 80 insertions(+), 7 deletions(-)

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 4669aaf..f8eef1f 100644
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -442,8 +442,29 @@ not supported."
  (define-call "munmap" int minusp
    (start sb-sys:system-area-pointer) (length unsigned))
 
+#-win32
 (define-call "msync" int minusp
   (addr sb-sys:system-area-pointer) (length unsigned) (flags int)))
+#+win32
+(progn
+  ;; No attempt is made to offer a full mmap-like interface on Windows.
+  ;; It would be possible to do so (and has been done by AK on his
+  ;; branch), but the use case is unclear to me.  However, the following
+  ;; definitions are needed to keep existing code in sb-simple-streams
+  ;; running. --DFL
+  (defconstant PROT-READ #x02)
+  (defconstant PROT-WRITE #x04)
+  (defconstant PROT-EXEC #x10)
+  (defconstant PROT-NONE 0)
+  (defconstant MAP-SHARED 0)
+  (defconstant MAP-PRIVATE 1)
+  (defconstant MS-ASYNC nil)
+  (defconstant MS-SYNC nil)
+  (export                            ;export on the fly like define-call
+   (defun msync (address length flags)
+     (declare (ignore flags))
+     (when (zerop (sb-win32:flush-view-of-file address length))
+       (sb-win32::win32-error "FlushViewOfFile")))))
 
 ;;; mlockall, munlockall
 (define-call "mlockall" int minusp (flags int))
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 8b80bf2..112d88e 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2835,10 +2835,27 @@ structure representations"
 SBCL itself"
       :use ("CL" "SB!ALIEN" "SB!EXT" "SB!INT" "SB!SYS")
       :export ("BOOL"
-               "DWORD" "FD-CLEAR-INPUT" "FD-LISTEN"
-               "FLUSH-CONSOLE-INPUT-BUFFER" "FORMAT-MESSAGE"
-               "GET-LAST-ERROR" "GET-OSFHANDLE" "HANDLE"
-               "HANDLE-CLEAR-INPUT" "HANDLE-LISTEN" "INT-PTR"
-               "INVALID-HANDLE" "MILLISLEEP" "PEEK-CONSOLE-INPUT"
-               "PEEK-NAMED-PIPE" "READ-FILE" "WRITE-FILE"
-               "WITH-PROCESS-TIMES" "GET-VERSION-EX")))
+               "CLOSE-HANDLE"
+               "CREATE-FILE-MAPPING"
+               "DWORD"
+               "FD-CLEAR-INPUT"
+               "FD-LISTEN"
+               "FLUSH-CONSOLE-INPUT-BUFFER"
+               "FLUSH-VIEW-OF-FILE"
+               "FORMAT-MESSAGE"
+               "GET-LAST-ERROR"
+               "GET-OSFHANDLE"
+               "GET-VERSION-EX"
+               "HANDLE"
+               "HANDLE-CLEAR-INPUT"
+               "HANDLE-LISTEN"
+               "INT-PTR"
+               "INVALID-HANDLE"
+               "MAP-VIEW-OF-FILE"
+               "MILLISLEEP"
+               "PEEK-CONSOLE-INPUT"
+               "PEEK-NAMED-PIPE"
+               "READ-FILE"
+               "UNMAP-VIEW-OF-FILE"
+               "WRITE-FILE"
+               "WITH-PROCESS-TIMES")))
diff --git a/src/code/win32.lisp b/src/code/win32.lisp
index c970412..7481fc5 100644
--- a/src/code/win32.lisp
+++ b/src/code/win32.lisp
@@ -637,3 +637,33 @@ UNIX epoch: January 1st 1970."
           (setf aname (make-system-buffer length))
           (alien-funcall afunc aname (addr length))))
       (cast-and-free aname))))
+
+;; File mapping support routines
+(define-alien-routine (#!+sb-unicode "CreateFileMappingW"
+                       #!-sb-unicode "CreateFileMappingA"
+                       create-file-mapping)
+    handle
+  (handle handle)
+  (security-attributes (* t))
+  (protection dword)
+  (maximum-size-high dword)
+  (maximum-size-low dword)
+  (name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
+
+(define-alien-routine ("MapViewOfFile" map-view-of-file)
+    system-area-pointer
+  (file-mapping handle)
+  (desired-access dword)
+  (offset-high dword)
+  (offset-low dword)
+  (size dword))
+
+(define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool
+  (address (* t)))
+
+(define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool
+  (address (* t))
+  (length dword))
+
+(define-alien-routine ("CloseHandle" close-handle) bool
+  (handle handle))
diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c
index a767461..406f011 100644
--- a/src/runtime/win32-os.c
+++ b/src/runtime/win32-os.c
@@ -573,8 +573,12 @@ void scratch(void)
     strerror(42);
     write(0, 0, 0);
     RtlUnwind(0, 0, 0, 0);
+    MapViewOfFile(0,0,0,0,0);
+    UnmapViewOfFile(0);
+    FlushViewOfFile(0,0);
     #ifndef LISP_FEATURE_SB_UNICODE
       CreateDirectoryA(0,0);
+      CreateFileMappingA(0,0,0,0,0,0);
       GetComputerNameA(0, 0);
       GetCurrentDirectoryA(0,0);
       GetEnvironmentVariableA(0, 0, 0);
@@ -585,6 +589,7 @@ void scratch(void)
       SetEnvironmentVariableA(0, 0);
     #else
       CreateDirectoryW(0,0);
+      CreateFileMappingW(0,0,0,0,0,0);
       FormatMessageW(0, 0, 0, 0, 0, 0, 0);
       GetComputerNameW(0, 0);
       GetCurrentDirectoryW(0,0);
-- 
1.7.10.4