Merge branch 'tib-3' of ../sbcl-win32-threads into tib-3

contrib/sb-simple-streams/internal.lisp

@@ -569,7 +569,7 @@
           (multiple-value-bind (fd errno)
               (if name
                   #+win32
-                  (sb-win32:win32-unixlike-open name mask mode)
+                  (sb-win32:unixlike-open name mask mode)
                   #-win32
                   (sb-unix:unix-open name mask mode)
                   (values nil sb-unix:enoent))

package-data-list.lisp-expr

@@ -2786,7 +2786,11 @@ SBCL itself"
                "GET-LAST-ERROR" "GET-OSFHANDLE" "OPEN-OSFHANDLE" "HANDLE"
                "HANDLE-CLEAR-INPUT" "HANDLE-LISTEN" "INT-PTR"
                "INVALID-HANDLE" "INVALID-FILE-ATTRIBUTES"
-	       "MILLISLEEP"
+               "CREATE-WAITABLE-TIMER"
+               "SET-WAITABLE-TIMER"
+               "CANCEL-WAITABLE-TIMER"
+               "WAIT-OBJECT-OR-SIGNAL"
+               "MICROSLEEP"
                "PEEK-CONSOLE-INPUT"
                "PEEK-NAMED-PIPE" "READ-FILE" "WRITE-FILE"
                "WITH-PROCESS-TIMES" "GET-VERSION-EX"
@@ -2802,4 +2806,5 @@ SBCL itself"
                "FILE-TRUNCATE-EXISTING"
                "FILE-CREATE-NEW"
                "FILE-CREATE-ALWAYS"
-               "WIN32-UNIXLIKE-OPEN")))
+               "UNIXLIKE-OPEN"
+	       "UNIXLIKE-CLOSE")))

src/code/fd-stream.lisp

@@ -1867,6 +1867,12 @@
                         input-type
                         output-type))))))
 
+(defun fd-close (fd)
+  #!+win32
+  (sb!win32:unixlike-close fd)
+  #!-win32
+  (sb!unix:unix-close fd))
+
 ;;; Handles the resource-release aspects of stream closing, and marks
 ;;; it as closed.
 (defun release-fd-stream-resources (fd-stream)
@@ -1880,7 +1886,7 @@
         ;; us with a dangling finalizer (that would close the same
         ;; --possibly reassigned-- FD again), or a stream with a closed
         ;; FD that appears open.
-        (sb!unix:unix-close (fd-stream-fd fd-stream))
+	(fd-close (fd-stream-fd fd-stream))
         (set-closed-flame fd-stream)
         (when (fboundp 'cancel-finalization)
           (cancel-finalization fd-stream)))
@@ -2256,7 +2262,7 @@
     (when (and auto-close (fboundp 'finalize))
       (finalize stream
                 (lambda ()
-                  (sb!unix:unix-close fd)
+		  (fd-close fd)
                   #!+sb-show
                   (format *terminal-io* "** closed file descriptor ~W **~%"
                           fd))
@@ -2430,7 +2436,7 @@
                 #!-win32
                 (sb!unix:unix-open namestring mask mode)
                 #!+win32
-                (sb!win32:win32-unixlike-open namestring mask mode)
+                (sb!win32:unixlike-open namestring mask mode)
                 (values nil sb!unix:enoent))
           (labels ((open-error (format-control &rest format-arguments)
                      (error 'simple-file-error

src/code/run-program.lisp

@@ -518,6 +518,47 @@ status slot."
   (pty-name sb-alien:c-string)
   (wait sb-alien:int))
 
+;;; Command-line argument quoting according to MSVC runtime rules:
+;;; 
+;;; n backslashes mean n backslashes when they're followed by
+;;; something other than quotation mark;
+;;;
+;;; 2n backslashes mean n backslashes when they're followed by a
+;;; quotation mark, and the quotation mark quotes argument or argument
+;;; chunk;
+;;;
+;;; 2n+1 backslashes and quotation mark mean n backslashes and literal
+;;; (escaped) quotation mark.
+;;;
+;;; See the description of CommandLineToArgvW, URL at the time of
+;;; writing follows:
+;;; http://msdn.microsoft.com/en-us/library/bb776391(VS.85).aspx
+#+win32
+(defun mswin-escape-command-argument (arg)
+  (if (string= "" arg)
+      "\"\""
+      (flet ((white-space-p (character)
+               (member character '(#\Return #\Newline #\Space #\Tab))))
+	(let ((has-spaces (find-if #'white-space-p arg))
+	      (n-backslashes 0))
+	  (with-output-to-string (out)
+	    (flet ((maybe-double-quote ()
+		     (when has-spaces (write-char #\" out)))
+		   (duplicate-backslashes (extra)
+		     (loop repeat (+ extra n-backslashes)
+			   do (write-char #\\ out))))
+	      (maybe-double-quote)
+	      (loop for character across arg
+		    do (when (char= #\" character)
+			 (duplicate-backslashes 1))
+		       (setf n-backslashes
+			     (case character
+			       (#\\ (1+ n-backslashes))
+			       (t 0)))
+		       (write-char character out)
+		    finally (when has-spaces (duplicate-backslashes 0)))
+	      (maybe-double-quote)))))))
+
 ;;; FIXME: There shouldn't be two semiredundant versions of the
 ;;; documentation. Since this is a public extension function, the
 ;;; documentation should be in the doc string. So all information from
@@ -684,10 +725,7 @@ Users Manual for details about the PROCESS structure."#-win32"
              #-win32 arg
              ;; Apparently any spaces or double quotes in the arguments
              ;; need to be escaped on win32.
-             #+win32 (if (position-if
-                          (lambda (c) (find c '(#\" #\Space))) arg)
-                         (write-to-string arg)
-                         arg)))
+             #+win32 (mswin-escape-command-argument arg)))
     (let (;; Clear various specials used by GET-DESCRIPTOR-FOR to
           ;; communicate cleanup info.
           *close-on-error*

src/code/save.lisp

@@ -166,6 +166,8 @@ sufficiently motivated to do lengthy fixes."
 
 (defun deinit ()
   (call-hooks "save" *save-hooks*)
+  #!+(and sb-thread win32)
+  (win32-itimer-deinit)
   (when (rest (sb!thread:list-all-threads))
     (error "Cannot save core with multiple threads running."))
   (float-deinit)

src/code/target-thread.lisp

@@ -1098,12 +1098,14 @@ first thing to do is usually a WITH-INTERRUPTS or a
 WITHOUT-INTERRUPTS. Within a thread interrupts are queued, they are
 run in same the order they were sent."
   #!+(and sb-thread win32)
+  (let ((thread-sap (%thread-sap thread)))
+    (and thread-sap
   (let ((r (interrupt-lisp-thread
             (sap-int (%thread-sap thread))
             (get-lisp-obj-address
              (lambda ()
                (sb!unix::invoke-interruption function))))))
-    (zerop r))
+           (zerop r))))
   #!+(and (not sb-thread) win32)
   (progn
     (declare (ignore thread))
@@ -1148,6 +1150,7 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
   (defun %thread-sap (thread)
     (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))
           (target (thread-os-thread thread)))
+      (and target
       (loop
         (when (sap= thread-sap (int-sap 0)) (return nil))
         (let ((os-thread (sap-ref-word thread-sap
@@ -1156,7 +1159,7 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
           (when (= os-thread target) (return thread-sap))
           (setf thread-sap
                 (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
-                                           sb!vm::thread-next-slot)))))))
+                                                sb!vm::thread-next-slot))))))))
 
   (defun %symbol-value-in-thread (symbol thread)
     ;; Prevent the thread from dying completely while we look for the TLS

src/code/timer.lisp

@@ -312,8 +312,54 @@ triggers."
             (incf (%timer-expire-time timer) (%timer-repeat-interval timer))
             (%schedule-timer timer))))))
 
-;;; Expiring timers
+;;; setitimer is unavailable for win32, but we can emulate it when
+;;; threads are available.
+#!+(and sb-thread win32)
+(progn
+;;; scheduler lock already protects us
+
+  (defvar *waitable-timer-handle* nil)
+
+  (defvar *timer-thread* nil)
+
+  (defun get-waitable-timer ()
+    (assert (under-scheduler-lock-p))
+    (or *waitable-timer-handle*
+        (prog1
+            (setf *waitable-timer-handle*
+                  (sb!win32:create-waitable-timer nil 0 nil))
+          (setf *timer-thread*
+                (sb!thread:make-thread
+                 (lambda ()
+                   (loop while
+                         (or (zerop
+                               (sb!win32:wait-object-or-signal
+                                *waitable-timer-handle*))
+                             *waitable-timer-handle*)
+                         doing (run-expired-timers)))
+                 :name "System timer watchdog thread")))))
+
+  (defun win32-itimer-deinit ()
+    (with-scheduler-lock ()
+      (when *timer-thread*
+        (sb!thread:terminate-thread *timer-thread*)
+        (sb!thread:join-thread *timer-thread* :default nil))
+      (when *waitable-timer-handle*
+        (sb!win32:close-handle *waitable-timer-handle*)
+        (setf *waitable-timer-handle* nil))))
+
+  (defun win32-itimer-cancel ()
+    (sb!win32:cancel-waitable-timer
+     (get-waitable-timer)))
+
+  (defun win32-itimer-schedule (timer-type p-sec p-usec sec usec)
+    (declare (ignore timer-type p-sec p-usec))
+    (sb!win32:set-waitable-timer
+     (get-waitable-timer)
+     (- (* 10 (+ usec (* sec 1000000))))
+     0 nil nil 0)))
 
+;;; Expiring timers
 (defun real-time->sec-and-usec (time)
   ;; KLUDGE: Always leave 0.0001 second for other stuff in order to
   ;; avoid starvation.
@@ -334,9 +380,13 @@ triggers."
     (if next-timer
         (let ((delta (- (%timer-expire-time next-timer)
                         (get-internal-real-time))))
-          (apply #'sb!unix:unix-setitimer
+          (apply #!-(and sb-thread win32) #'sb!unix:unix-setitimer
+                 #!+(and sb-thread win32) #'win32-itimer-schedule
                  :real 0 0 (real-time->sec-and-usec delta)))
-        (sb!unix:unix-setitimer :real 0 0 0 0))))
+        #!-(and sb-thread win32)
+        (sb!unix:unix-setitimer :real 0 0 0 0)
+        #!+(and sb-thread win32)
+        (win32-itimer-cancel))))
 
 (defun run-timer (timer)
   (let ((function (%timer-interrupt-function timer))

src/code/toplevel.lisp

@@ -155,6 +155,9 @@ command-line.")
 |#
 
 ;;;; miscellaneous external functions
+#!+win32
+(defconstant long-sleep
+  (ash 1 #!-sb-thread 28 #!+sb-thread 58))
 
 (defun sleep (seconds)
   #!+sb-doc
@@ -183,14 +186,13 @@ any non-negative real number."
              (sb!unix:nanosleep (expt 10 8) 0))
     (sb!unix:nanosleep sec nsec))
   #!+win32
-  (let ((sleep-units (truncate (* seconds 1000)))
-	(long-sleep (ash 1 28)))
+  (let ((sleep-units (truncate (* seconds 1000000))))
     (multiple-value-bind (long-sleeps remainder)
 	(floor sleep-units long-sleep)
       (loop repeat long-sleeps
-	    do (sb!win32:millisleep long-sleep))
+            do (sb!win32:microsleep long-sleep))
       (unless (zerop remainder)
-	(sb!win32:millisleep remainder))
+        (sb!win32:microsleep remainder))
       nil)))
 
 ;;;; the default toplevel function