Improve slime connection on Windows

modes/lisp-mode/lisp-mode.lisp

@@ -797,17 +797,14 @@
 (defun start-thread ()
   (unless *wait-message-thread*
     (setf *wait-message-thread*
-          (bt:make-thread (lambda ()
-                            (loop
-                              ;; workaround for windows (to reduce cpu usage)
-                              #+win32 (sleep 0.001)
-
+          (bt:make-thread
+           (lambda () (loop
+                        (handler-case
+                            (progn
                               (unless (connected-p)
                                 (setf *wait-message-thread* nil)
                                 (return))
-                              (when (handler-case
-                                        (message-waiting-p *connection* :timeout 10)
-                                      (change-connection () nil))
+                              (when (message-waiting-p *connection* :timeout 1)
                                 (let ((barrior t))
                                   (send-event (lambda ()
                                                 (unwind-protect (progn (pull-events)
@@ -818,8 +815,9 @@
                                       (return))
                                     (unless barrior
                                       (return))
-                                    (sleep 0.1))))))
-                          :name "lisp-wait-message"))))
+                                    (sleep 0.1)))))
+                          (change-connection ()))))
+           :name "lisp-wait-message"))))
 
 (define-command slime-connect (hostname port &optional (start-repl t))
     ((list (prompt-for-string "Hostname: " *localhost*)
@@ -1140,6 +1138,7 @@
                     (sleep 0.5))))
       (unless successp
         (error condition)))
+    #-win32
     (add-hook *exit-editor-hook* 'slime-quit-all)))
 
 (define-command slime (&optional ask-impl) ("P")
@@ -1255,9 +1254,24 @@
 
 ;; workaround for windows
 #+win32
-(add-hook *exit-editor-hook*
-          ;; quit slime to exit lem normally (incomplete)
-          'slime-quit*)
+(progn
+  (defun slime-quit-all-for-win32 ()
+    "quit slime and remove connection to exit lem normally on windows (incomplete)"
+    (let ((conn-list (copy-list *connection-list*)))
+      (slime-quit-all)
+      (loop :while *connection*
+            :do (remove-connection *connection*))
+      #+sbcl
+      (progn
+        (sleep 0.5)
+        (dolist (c conn-list)
+          (let* ((s  (lem-lisp-mode.swank-protocol::connection-socket c))
+                 (fd (sb-bsd-sockets::socket-file-descriptor (usocket:socket s))))
+            ;;(usocket:socket-shutdown s :IO)
+            ;;(usocket:socket-close s)
+            (sockint::shutdown fd sockint::SHUT_RDWR)
+            (sockint::close fd))))))
+  (add-hook *exit-editor-hook* 'slime-quit-all-for-win32))
 
 (pushnew (cons ".lisp$" 'lisp-mode) *auto-mode-alist* :test #'equal)
 (pushnew (cons ".asd$" 'lisp-mode) *auto-mode-alist* :test #'equal)

modes/lisp-mode/swank-protocol.lisp

@@ -155,10 +155,16 @@ Parses length information to determine how many characters to read."
     (setup connection)
     connection))
 
+(defun read-return-message (connection)
+  "Read only ':return' message. Other messages such as ':indentation-update' are dropped."
+  (loop :for info := (read-message connection)
+        :until (eq (car info) :return)
+        :finally (return info)))
+
 (defun setup (connection)
   (emacs-rex connection `(swank:connection-info))
   ;; Read the connection information message
-  (let* ((info (read-message connection))
+  (let* ((info (read-return-message connection))
          (data (getf (getf info :return) :ok))
          (impl (getf data :lisp-implementation))
          (machine (getf data :machine)))
@@ -193,12 +199,13 @@ Parses length information to determine how many characters to read."
      swank-c-p-c
      swank-arglists
      swank-repl))
-  (read-message connection)
+  (read-return-message connection)
   ;; Start it up
   (emacs-rex-string connection "(swank:init-presentations)")
+  (read-return-message connection)
   (emacs-rex-string connection "(swank-repl:create-repl nil :coding-system \"utf-8-unix\")")
   ;; Wait for startup
-  (read-message connection)
+  (read-return-message connection)
   ;; Read all the other messages, dumping them
   (read-all-messages connection))
 
@@ -232,8 +239,25 @@ to check if input is available."
                        (with-swank-syntax ()
                          (prin1-to-string form))))
 
+;; workaround for windows
+;;  (usocket:wait-for-input needs WSAResetEvent before call)
+#+(and sbcl win32)
+(sb-alien:define-alien-routine ("WSAResetEvent" wsa-reset-event)
+    (boolean #.sb-vm::n-machine-word-bits)
+  (event-object usocket::ws-event))
+
 (defun message-waiting-p (connection &key (timeout 0))
   "t if there's a message in the connection waiting to be read, nil otherwise."
+
+  ;; workaround for windows
+  ;;  (usocket:wait-for-input needs WSAResetEvent before call)
+  #+(and sbcl win32)
+  (let ((socket (connection-socket connection)))
+    (when (usocket::wait-list socket)
+      (wsa-reset-event
+       (usocket::os-wait-list-%wait
+        (usocket::wait-list socket)))))
+
   (if (usocket:wait-for-input (connection-socket connection)
                               :ready-only t
                               :timeout timeout)

modes/lisp-mode/util.lisp

@@ -10,7 +10,7 @@
   (let (socket)
     (unwind-protect
          (handler-case (progn
-                         (setq socket (usocket:socket-listen "127.0.0.1" port :reuse-address t))
+                         (setq socket (usocket:socket-listen "127.0.0.1" port :reuse-address nil))
                          port)
            (usocket:address-in-use-error () nil)
            (usocket:socket-error (e)