From 0d48b1acdac8ebca4d3afd02e651c89ef676d922 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 16 Jan 2006 15:39:57 +0000 Subject: [PATCH] 0.9.8.42: Merge "first round of i/o fixes" (sbcl-devel 2006-01-13 from James Bielman) ... some extended horribleness, mostly isolated horribleness. --- build-order.lisp-expr | 3 +- package-data-list.lisp-expr | 16 +++- src/code/fd-stream.lisp | 15 ++++ src/code/toplevel.lisp | 3 + src/code/win32.lisp | 151 ++++++++++++++++++++++++++++++++++++++ src/runtime/win32-os.c | 9 +++ tools-for-build/grovel-headers.c | 6 +- version.lisp-expr | 2 +- 8 files changed, 201 insertions(+), 4 deletions(-) create mode 100644 src/code/win32.lisp diff --git a/build-order.lisp-expr b/build-order.lisp-expr index dd675e7..7d0fdff 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -212,9 +212,10 @@ ;; "src/code/unix.lisp" needs this. It's generated automatically by ;; grovel_headers.c, i.e. it's not in CVS. - #!-win32 ("output/stuff-groveled-from-headers" :not-host) + ("output/stuff-groveled-from-headers" :not-host) ("src/code/unix" :not-host) + #!+win32 ("src/code/win32" :not-host) #!+mach ("src/code/mach" :not-host) #!+mach ("src/code/mach-os" :not-host) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 350c7f4..c266fa7 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2327,4 +2327,18 @@ structure representations" ;; These were exported from the original PCL version of this ;; package, but aren't used in SBCL. ;;"NESTED-WALK-FORM" "MACROEXPAND-ALL" - ))) + )) + + #!+win32 + #s(sb-cold:package-data + :name "SB!WIN32" + :doc "private: a wrapper layer for Win32 functions needed by +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"))) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 90621d9..1afdecf 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -659,6 +659,12 @@ (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) tail)))) (setf (fd-stream-listen stream) nil) + #!+win32 + (unless (sb!win32:fd-listen fd) + (unless (sb!sys:wait-until-fd-usable + fd :input (fd-stream-timeout stream)) + (error 'io-timeout :stream stream :direction :read))) + #!-win32 (sb!unix:with-restarted-syscall (count errno) ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands ;; into something which uses the not-yet-defined type @@ -1571,6 +1577,10 @@ (or (not (eql (fd-stream-ibuf-head fd-stream) (fd-stream-ibuf-tail fd-stream))) (fd-stream-listen fd-stream) + #!+win32 + (setf (fd-stream-listen fd-stream) + (sb!win32:fd-listen (fd-stream-fd fd-stream))) + #!-win32 (setf (fd-stream-listen fd-stream) (eql (sb!unix:with-restarted-syscall () (sb!alien:with-alien ((read-fds (sb!alien:struct @@ -1660,6 +1670,11 @@ (setf (fd-stream-unread fd-stream) nil) (setf (fd-stream-ibuf-head fd-stream) 0) (setf (fd-stream-ibuf-tail fd-stream) 0) + #!+win32 + (progn + (sb!win32:fd-clear-input (fd-stream-fd fd-stream)) + (setf (fd-stream-listen fd-stream) nil)) + #!-win32 (catch 'eof-input-catcher (loop (let ((count (sb!unix:with-restarted-syscall () diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index d3b3271..9e492a2 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -145,6 +145,7 @@ steppers to maintain contextual information.") :format-arguments (list n) :datum n :expected-type '(real 0))) + #!-win32 (multiple-value-bind (sec nsec) (if (integerp n) (values n 0) @@ -152,6 +153,8 @@ steppers to maintain contextual information.") (truncate n) (values sec (truncate frac 1e-9)))) (sb!unix:nanosleep sec nsec)) + #!+win32 + (sb!win32:millisleep (truncate (* n 1000))) nil) ;;;; SCRUB-CONTROL-STACK diff --git a/src/code/win32.lisp b/src/code/win32.lisp new file mode 100644 index 0000000..34ee5ca --- /dev/null +++ b/src/code/win32.lisp @@ -0,0 +1,151 @@ +;;;; This file contains Win32 support routines that SBCL needs to +;;;; implement itself, in addition to those that apply to Win32 in +;;;; unix.lisp. In theory, some of these functions might someday be +;;;; useful to the end user. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!WIN32") + +;;; Alien definitions for commonly used Win32 types. Woe unto whoever +;;; tries to untangle this someday for 64-bit Windows. +(define-alien-type int-ptr long) +(define-alien-type handle int-ptr) +(define-alien-type dword unsigned-long) +(define-alien-type bool int) + +;;; HANDLEs are actually pointers, but an invalid handle is -1 cast +;;; to a pointer. +(defconstant invalid-handle -1) + +;;;; Error Handling + +;;; Retrieve the calling thread's last-error code value. The +;;; last-error code is maintained on a per-thread basis. +(define-alien-routine ("GetLastError@0" get-last-error) dword) + +;;; Flag constants for FORMAT-MESSAGE. +(defconstant format-message-from-system #x1000) + +;;; Format an error message based on a lookup table. See MSDN for the +;;; full meaning of the all options---most are not used when getting +;;; system error codes. +(define-alien-routine ("FormatMessageA@28" format-message) dword + (flags dword) + (source (* t)) + (message-id dword) + (language-id dword) + (buffer c-string) + (size dword) + (arguments (* t))) + +;;;; File Handles + +;;; Get the operating system handle for a C file descriptor. Returns +;;; INVALID-HANDLE on failure. +(define-alien-routine ("_get_osfhandle" get-osfhandle) handle + (fd int)) + +;;; Read data from a file handle into a buffer. This may be used +;;; synchronously or with "overlapped" (asynchronous) I/O. +(define-alien-routine ("ReadFile@20" read-file) bool + (file handle) + (buffer (* t)) + (bytes-to-read dword) + (bytes-read (* dword)) + (overlapped (* t))) + +;;; Write data from a buffer to a file handle. This may be used +;;; synchronously or with "overlapped" (asynchronous) I/O. +(define-alien-routine ("WriteFile@20" write-file) bool + (file handle) + (buffer (* t)) + (bytes-to-write dword) + (bytes-written (* dword)) + (overlapped (* t))) + +;;; Copy data from a named or anonymous pipe into a buffer without +;;; removing it from the pipe. BUFFER, BYTES-READ, BYTES-AVAIL, and +;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read. +;;; Return TRUE on success, FALSE on failure. +(define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool + (pipe handle) + (buffer (* t)) + (buffer-size dword) + (bytes-read (* dword)) + (bytes-avail (* dword)) + (bytes-left-this-message (* dword))) + +;;; Flush the console input buffer if HANDLE is a console handle. +;;; Returns true on success, false if the handle does not refer to a +;;; console. +(define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool + (handle handle)) + +;;; Read data from the console input buffer without removing it, +;;; without blocking. Buffer should be large enough for LENGTH * +;;; INPUT-RECORD-SIZE bytes. +(define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool + (handle handle) + (buffer (* t)) + (length dword) + (nevents (* dword))) + +;;; Listen for input on a Windows file handle. Unlike UNIX, there +;;; isn't a unified interface to do this---we have to know what sort +;;; of handle we have. Of course, there's no way to actually +;;; introspect it, so we have to try various things until we find +;;; something that works. Returns true if there could be input +;;; available, or false if there is not. +(defun handle-listen (handle) + (with-alien ((avail dword) + (buf (array char #.input-record-size))) + (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil)) + (return-from handle-listen (plusp avail))) + + (unless (zerop (peek-console-input handle (cast buf (* t)) input-record-size (addr avail))) + (return-from handle-listen (plusp avail))) + + ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case + ;; HANDLE is a socket. + t)) + +;;; Listen for input on a C runtime file handle. Returns true if +;;; there could be input available, or false if there is not. +(defun fd-listen (fd) + (let ((handle (get-osfhandle fd))) + (if handle + (handle-listen handle) + t))) + +;;; Clear all available input from a file handle. +(defun handle-clear-input (handle) + (flush-console-input-buffer handle) + (with-alien ((buf (array char 1024)) + (count dword)) + (loop + (unless (handle-listen handle) + (return)) + (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil)) + (return)) + (when (< count 1024) + (return))))) + +;;; Clear all available input from a C runtime file handle. +(defun fd-clear-input (fd) + (let ((handle (get-osfhandle fd))) + (when handle + (handle-clear-input handle)))) + +;;;; System Functions + +;;; Sleep for MILLISECONDS milliseconds. +(define-alien-routine ("Sleep@4" millisleep) void + (milliseconds dword)) diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c index 0f2cd29..a867faf 100644 --- a/src/runtime/win32-os.c +++ b/src/runtime/win32-os.c @@ -624,6 +624,15 @@ void scratch(void) mkdir(0); isatty(0); access(0,0); + GetLastError(); + FormatMessageA(0, 0, 0, 0, 0, 0, 0); + _get_osfhandle(0); + ReadFile(0, 0, 0, 0, 0); + WriteFile(0, 0, 0, 0, 0); + PeekNamedPipe(0, 0, 0, 0, 0, 0); + FlushConsoleInputBuffer(0); + PeekConsoleInput(0, 0, 0, 0); + Sleep(0); } /* EOF */ diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index 18af788..a7600d9 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -21,6 +21,8 @@ #include #include #ifdef _WIN32 + #define WIN32_LEAN_AND_MEAN + #include #include #else #include @@ -80,7 +82,9 @@ main(int argc, char *argv[]) \n\ "); #ifdef _WIN32 - printf (";;; This file is presently unused for the Windows version of sbcl.\n"); + printf("(in-package \"SB!WIN32\")\n\n"); + + defconstant ("input-record-size", sizeof (INPUT_RECORD)); #else printf("(in-package \"SB!ALIEN\")\n\n"); diff --git a/version.lisp-expr b/version.lisp-expr index 581a07d..7c7a8b8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.8.41" +"0.9.8.42" -- 1.7.10.4