sb-simple-streams: use the Windows file mapping API for memory-mapped files

[sbcl.git] / contrib / sb-simple-streams / file.lisp

diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp
index 7b71b9d..e668269 100644 (file)
--- a/contrib/sb-simple-streams/file.lisp
+++ b/contrib/sb-simple-streams/file.lisp
@@ -80,7 +80,8 @@
                      (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
                              namestring fd)
                      (when original
-                       (revert-file namestring original))))
+                       (revert-file namestring original)))
+                   :dont-save t)
                  stream)))))))
 
 (defmethod device-open ((stream file-simple-stream) options)
@@ -115,8 +116,8 @@
 ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine
 ;;; as well, snarf error reporting from there.
 (defun revert-file (filename original)
-  (declare (type simple-base-string filename)
-           (type (or simple-base-string null) original))
+  (declare (type simple-string filename)
+           (type (or simple-string null) original))
   ;; We can't do anything unless we know what file were
   ;; dealing with, and we don't want to do anything
   ;; strange unless we were writing to the file.
@@ -140,8 +141,8 @@
 ;;; TODO: use this in src/code/fd-stream.lisp:fd-stream-misc-routine
 ;;; as well, snarf error reporting from there.
 (defun delete-original (filename original)
-  (declare (type simple-base-string filename)
-           (type (or simple-base-string null) original))
+  (declare (type simple-string filename)
+           (type (or simple-string null) original))
   (when original
     (multiple-value-bind (okay err) (sb-unix:unix-unlink original)
       (unless okay
@@ -221,9 +222,20 @@
             (warn "Unable to memory-map entire file.")
             (setf size (1- most-positive-fixnum)))
           (let ((buffer
+                 #-win32
                  (handler-case
-                  (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
-                  (sb-posix:syscall-error nil))))
+                     (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
+                   (sb-posix:syscall-error nil))
+                 #+win32
+                 (let ((mapping
+                        (sb-win32:create-file-mapping
+                         (sb-win32:get-osfhandle fd) nil 2 0 size nil)))
+                   (typecase mapping
+                     ((integer -1 0) nil)
+                     (t (let ((sap (prog1 (sb-win32:map-view-of-file
+                                           mapping 4 0 0 size)
+                                     (sb-win32:close-handle mapping))))
+                          (and (not (zerop (sb-sys:sap-int sap))) sap)))))))
             (when (null buffer)
               (sb-unix:unix-close fd)
               (sb-ext:cancel-finalization stream)
@@ -243,15 +255,18 @@
                (melding-stream stream) efmt 'mapped))
             (sb-ext:finalize stream
               (lambda ()
-                (sb-posix:munmap buffer size)
-                (format *terminal-io* "~&;;; ** unmapped ~S" buffer))))))
+                #+win32 (sb-win32:unmap-view-of-file buffer)
+                #-win32 (sb-posix:munmap buffer size)
+                (format *terminal-io* "~&;;; ** unmapped ~S" buffer))
+              :dont-save t))))
       stream)))
 
 
 (defmethod device-close ((stream mapped-file-simple-stream) abort)
   (with-stream-class (mapped-file-simple-stream stream)
     (when (sm buffer stream)
-      (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
+      #+win32 (sb-win32:unmap-view-of-file (sm buffer stream))
+      #-win32 (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
       (setf (sm buffer stream) nil))
     (sb-unix:unix-close (or (sm input-handle stream) (sm output-handle stream))))
   t)
@@ -267,6 +282,6 @@
   (let ((pathname (getf options :filename)))
     (with-stream-class (probe-simple-stream stream)
       (add-stream-instance-flags stream :simple)
-      (when (sb-unix:unix-access (sb-int:unix-namestring pathname nil) sb-unix:f_ok)
+      (when (sb-unix:unix-access (file-namestring pathname) sb-unix:f_ok)
         (setf (sm pathname stream) pathname)
         t))))