Menu
▾
▴
[Sbcl-commits] master: sb-win32: offer low-level bindings for file mapping functions
|
From: David L. <lic...@us...> - 2011-08-10 18:26:20
|
The branch "master" has been updated in SBCL:
via ad4b18f5d843d91cc48c9b6cc936a6c7be5fce27 (commit)
from 3ccd2c124ae60833f54406a2b478d13835e4b7df (commit)
- Log -----------------------------------------------------------------
commit ad4b18f5d843d91cc48c9b6cc936a6c7be5fce27
Author: Anton Kovalenko <an...@sw...>
Date: Thu Oct 7 04:37:07 2010 +0400
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);
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|