[Openmcl-cvs-notifications] r11081 - in /trunk/source: level-1/l1-boot-2.lisp level-1/l1-sockets.lisp level-1/linux-files.lisp lib/db-io.lisp
gb at clozure.com
gb at clozure.com
Mon Oct 13 22:00:40 EDT 2008
Author: gb
Date: Mon Oct 13 22:00:40 2008
New Revision: 11081
Log:
Stop wrapping (pseudo) file-descriptors around Windows file handlers;
there seem to be cases where this definitely loses, because the MSVCRT
runtime tries to flush buffers associated with (e.g.) a listening socket
when it's closed, and we often have to do I/O in Windows-specific ways
and can't always use the C runtime, anyway.
Handles are (depending on which function you're dealing with) either
pointers or pointer-sized integers; they can be used interchangably
with ints on Win32, but porting this change to Win64 may require some
changes (in l1-io.lisp, in the PIPE function, perhaps elsewhere.)
Supporting this requires some changss in the kernel (mostly in
windows-calls.c) To bootstrap it, most of the I/O functions in
that file assume that very small integers [0 .. 31] are fds wrapped
around a handle and that anything larger is the handle itself. All
of the actual work done by those functions is done on the handle,
without involving the C runtime.
I'll check in a win32 kernel and image in a few minutes. Mixing
older kernels/images won't work, but I don't want to change the
kernel/image compatibility stuff until this is further along.
SLIME sort of works, but not very reliably yet.
Modified:
trunk/source/level-1/l1-boot-2.lisp
trunk/source/level-1/l1-sockets.lisp
trunk/source/level-1/linux-files.lisp
trunk/source/lib/db-io.lisp
Modified: trunk/source/level-1/l1-boot-2.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-boot-2.lisp (original)
+++ trunk/source/level-1/l1-boot-2.lisp Mon Oct 13 22:00:40 2008
@@ -96,15 +96,23 @@
(defun initialize-interactive-streams ()
(let* ((encoding (lookup-character-encoding *terminal-character-encoding=
-name*))
(encoding-name (if encoding (character-encoding-name encoding))))
- (setq *stdin* (make-fd-stream 0
+ (setq *stdin* (make-fd-stream #-windows-target 0
+ #+windows-target (%ptr-to-int
+ (#_GetStdHandle #$STD_=
INPUT_HANDLE))
:basic t
:sharing :lock
:direction :input
:interactive (not *batch-flag*)
:encoding encoding-name))
- (setq *stdout* (make-fd-stream 1 :basic t :direction :output :sharing =
:lock :encoding encoding-name))
-
- (setq *stderr* (make-fd-stream 2 :basic t :direction :output :sharing =
:lock :encoding encoding-name))
+ (setq *stdout* (make-fd-stream #-windows-target 1
+ #+windows-target (%ptr-to-int
+ (#_GetStdHandle #$STD=
_OUTPUT_HANDLE))
+ :basic t :direction :output :sharing :l=
ock :encoding encoding-name))
+
+ (setq *stderr* (make-fd-stream #-windows-target 2
+ #+windows-target (%ptr-to-int
+ (#_GetStdHandle #$STD=
_ERROR_HANDLE))
+ :basic t :direction :output :sharing :lock :encoding e=
ncoding-name))
(if *batch-flag*
(let* ((tty-fd
#-windows-target
Modified: trunk/source/level-1/l1-sockets.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-sockets.lisp (original)
+++ trunk/source/level-1/l1-sockets.lisp Mon Oct 13 22:00:40 2008
@@ -60,10 +60,6 @@
#-windows-target `(int-errno-call ,form))
)
=
-(declaim (inline socket-handle))
-(defun socket-handle (fd)
- #+windows-target (#__get_osfhandle fd)
- #-windows-target fd)
=
#+windows-target
(defun %get-winsock-error ()
@@ -568,9 +564,8 @@
=
(defun set-socket-fd-blocking (fd block-flag)
#+windows-target
- (let* ((handle (socket-handle fd)))
- (rlet ((argp :u_long (if block-flag 0 1)))
- (#_ioctlsocket handle #.(u32->s32 #$FIONBIO) argp)))
+ (rlet ((argp :u_long (if block-flag 0 1)))
+ (#_ioctlsocket fd #.(u32->s32 #$FIONBIO) argp))
#-windows-target
(if block-flag
(fd-clear-flag fd #$O_NONBLOCK)
@@ -875,20 +870,7 @@
(eql res (- #$EOPNOTSUPP))
(eql res (- #$ENETUNREACH))))
(- #$EAGAIN)
- #+windows-target (if (< res 0)
- res
- (progn
- ;; SLIME still crashes on startup
- ;; on (at least) win32.
- ;; This is intended to make it
- ;; possible to attach GDB and
- ;; try to see what's going on.
- #+debug
- (format t "~& pid =3D ~d" (getpid))
- #+debug
- (sleep 60)
- (#__open_osfhandle res 0)))
- #-windows-target res))))
+ res))))
(cond (wait
(with-eagain fd :input
(_accept fd *multiprocessing-socket-io*)))
@@ -1191,12 +1173,7 @@
#+windows-target (let* ((handle (#_socket domain type protocol)))
(if (< handle 0)
(%get-winsock-error)
- (let* ((fd (#__open_osfhandle handle 0)))
- (if (< fd 0)
- (prog1
- (%get-errno)
- (#_CloseHandle handle))
- fd)))))
+ handle)))
=
=
=
@@ -1246,7 +1223,7 @@
=
=
(defun c_bind (sockfd sockaddr addrlen)
- (check-socket-error (#_bind (socket-handle sockfd) sockaddr addrlen)))
+ (check-socket-error (#_bind sockfd sockaddr addrlen)))
=
=
#+windows-target
@@ -1257,17 +1234,16 @@
(rlet ((writefds :fd_set)
(exceptfds :fd_set)
(tv :timeval :tv_sec 0 :tv_usec 0))
- (let* ((handle (socket-handle sockfd)))
- (fd-zero writefds)
- (fd-zero exceptfds)
- (fd-set handle writefds)
- (fd-set handle exceptfds)
- (when timeout-in-milliseconds
- (multiple-value-bind (seconds milliseconds)
- (floor timeout-in-milliseconds 1000)
- (setf (pref tv :timeval.tv_sec) seconds
- (pref tv :timeval.tv_usec) (* 1000 milliseconds))))
- (> (#_select 1 (%null-ptr) writefds exceptfds (if timeout-in-millise=
conds tv (%null-ptr))) 0))))
+ (fd-zero writefds)
+ (fd-zero exceptfds)
+ (fd-set sockfd writefds)
+ (fd-set sockfd exceptfds)
+ (when timeout-in-milliseconds
+ (multiple-value-bind (seconds milliseconds)
+ (floor timeout-in-milliseconds 1000)
+ (setf (pref tv :timeval.tv_sec) seconds
+ (pref tv :timeval.tv_usec) (* 1000 milliseconds))))
+ (> (#_select 1 (%null-ptr) writefds exceptfds (if timeout-in-milliseco=
nds tv (%null-ptr))) 0)))
=
=
;;; If attempts to connnect are interrupted, we basically have to
@@ -1279,7 +1255,7 @@
(unwind-protect
(progn
(set-socket-fd-blocking sockfd nil)
- (let* ((err (check-socket-error (#_connect (socket-handle sockf=
d) addr len))))
+ (let* ((err (check-socket-error (#_connect sockfd addr len))))
(cond ((or (eql err (- #+windows-target #$WSAEINPROGRESS
=
#-windows-target #$EINPROGRESS))
@@ -1294,17 +1270,17 @@
(set-socket-fd-blocking sockfd was-blocking))))
=
(defun c_listen (sockfd backlog)
- (check-socket-error (#_listen (socket-handle sockfd) backlog)))
+ (check-socket-error (#_listen sockfd backlog)))
=
(defun c_accept (sockfd addrp addrlenp)
(ignoring-eintr
- (check-socket-error (#_accept (socket-handle sockfd) addrp addrlenp))))
+ (check-socket-error (#_accept sockfd addrp addrlenp))))
=
(defun c_getsockname (sockfd addrp addrlenp)
- (check-socket-error (#_getsockname (socket-handle sockfd) addrp addrlenp=
)))
+ (check-socket-error (#_getsockname sockfd addrp addrlenp)))
=
(defun c_getpeername (sockfd addrp addrlenp)
- (check-socket-error (#_getpeername (socket-handle sockfd) addrp addrlenp=
)))
+ (check-socket-error (#_getpeername sockfd addrp addrlenp)))
=
#-windows-target
(defun c_socketpair (domain type protocol socketsptr)
@@ -1312,27 +1288,27 @@
=
=
(defun c_sendto (sockfd msgptr len flags addrp addrlen)
- (check-socket-error (#_sendto (socket-handle sockfd) msgptr len flags ad=
drp addrlen)))
+ (check-socket-error (#_sendto sockfd msgptr len flags addrp addrlen)))
=
(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp)
- (check-socket-error (#_recvfrom (socket-handle sockfd) bufptr len flags =
addrp addrlenp)))
+ (check-socket-error (#_recvfrom sockfd bufptr len flags addrp addrlenp)))
=
(defun c_shutdown (sockfd how)
- (check-socket-error (#_shutdown (socket-handle sockfd) how)))
+ (check-socket-error (#_shutdown sockfd how)))
=
(defun c_setsockopt (sockfd level optname optvalp optlen)
- (check-socket-error (#_setsockopt (socket-handle sockfd) level optname o=
ptvalp optlen)))
+ (check-socket-error (#_setsockopt sockfd level optname optvalp optlen)))
=
(defun c_getsockopt (sockfd level optname optvalp optlenp)
- (check-socket-error (#_getsockopt (socket-handle sockfd) level optname o=
ptvalp optlenp)))
+ (check-socket-error (#_getsockopt sockfd level optname optvalp optlenp)))
=
#-windows-target
(defun c_sendmsg (sockfd msghdrp flags)
- (check-socket-error (#_sendmsg (socket-handle sockfd) msghdrp flags)))
+ (check-socket-error (#_sendmsg sockfd msghdrp flags)))
=
#-windows-target
(defun c_recvmsg (sockfd msghdrp flags)
- (check-socket-error (#_recvmsg (socket-handle sockfd) msghdrp flags)))
+ (check-socket-error (#_recvmsg sockfd msghdrp flags)))
=0C
;;; Return a list of currently configured interfaces, a la ifconfig.
(defstruct ip-interface
Modified: trunk/source/level-1/linux-files.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/linux-files.lisp (original)
+++ trunk/source/level-1/linux-files.lisp Mon Oct 13 22:00:40 2008
@@ -405,14 +405,28 @@
(%%fstat fd stat)))
=
=
-(defun %file-kind (mode)
+(defun %file-kind (mode &optional fd)
+ (declare (ignorable fd))
(when mode
(let* ((kind (logand mode #$S_IFMT)))
(cond ((eql kind #$S_IFDIR) :directory)
((eql kind #$S_IFREG) :file)
#-windows-target
((eql kind #$S_IFLNK) :link)
- ((eql kind #$S_IFIFO) :pipe)
+ ((eql kind #$S_IFIFO) =
+ #-windows-target :pipe
+ ;; Windows doesn't seem to be able to distinguish between
+ ;; sockets and pipes. Since this function is currently
+ ;; (mostly) used for printing streams and since we've
+ ;; already done something fairly expensive (stat, fstat)
+ ;; to get here. try to distinguish between pipes and
+ ;; sockets by calling #_getsockopt. If that succeeds,
+ ;; we've got a socket; otherwise, we're probably got a pipe.
+ #+windows-target (rlet ((ptype :int)
+ (plen :int 4))
+ (if (and fd (eql 0 (#_getsockopt fd #$SOL_SOCKET #$SO_TYPE ptype plen=
)))
+ :socket
+ :pipe)))
#-windows-target
((eql kind #$S_IFSOCK) :socket)
((eql kind #$S_IFCHR) :character-special)
@@ -424,7 +438,7 @@
(defun %unix-fd-kind (fd)
(if (isatty fd)
:tty
- (%file-kind (nth-value 1 (%fstat fd)))))
+ (%file-kind (nth-value 1 (%fstat fd)) fd)))
=
#-windows-target
(defun %uts-string (result idx buf)
@@ -497,22 +511,19 @@
=
#+windows-target
(defun fd-dup (fd &key direction inheritable)
+ (declare (ignore direction))
(rlet ((handle #>HANDLE))
(#_DuplicateHandle (#_GetCurrentProcess)
- (#__get_osfhandle fd)
+ fd
(#_GetCurrentProcess) =
handle
0
(if inheritable #$TRUE #$FALSE)
- #$DUPLICATE_SAME_ACCESS)
- (#__open_osfhandle (pref handle #>HANDLE) (case direction
- (:input #$O_RDONLY)
- (:output #$O_WRONLY)
- (t #$O_RDWR)))))
+ #$DUPLICATE_SAME_ACCESS)))
=
=
(defun fd-fsync (fd)
- #+windows-target (progn fd 0)
+ #+windows-target (#_FlushFileBuffers fd)
#-windows-target
(int-errno-call (#_fsync fd)))
=
@@ -1606,11 +1617,17 @@
(logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
(setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
(setf (pref si #>STARTUPINFO.hStdInput)
- (%int-to-ptr (#__get_osfhandle (or new-in 0))))
+ (if new-in
+ (%int-to-ptr new-in)
+ (#_GetStdHandle #$STD_INPUT_HANDLE)))
(setf (pref si #>STARTUPINFO.hStdOutput)
- (%int-to-ptr (#__get_osfhandle (or new-out 1))))
+ (if new-out
+ (%int-to-ptr new-out)
+ (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
(setf (pref si #>STARTUPINFO.hStdError)
- (%int-to-ptr (#__get_osfhandle (or new-err 2))))
+ (if new-err
+ (%int-to-ptr new-err)
+ (#_GetStdHandle #$STD_ERROR_HANDLE)))
(if (zerop (#_CreateProcessW (%null-ptr)
command
(%null-ptr)
Modified: trunk/source/lib/db-io.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/db-io.lisp (original)
+++ trunk/source/lib/db-io.lisp Mon Oct 13 22:00:40 2008
@@ -112,7 +112,7 @@
(%null-ptr))))
(if (eql handle *windows-invalid-handle*)
(error "Error opening CDB database ~S" pathname)
- (#__open_osfhandle (%ptr-to-int handle) #$O_RDONLY)))))
+ (%ptr-to-int handle)))))
=
=
;;; Read N octets from FID into BUF. Return #of octets read or error.
More information about the Openmcl-cvs-notifications
mailing list