[slime-cvs] CVS update: slime/swank-cmucl.lisp

[Luke Gorrie]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv16640

Modified Files:
	swank-cmucl.lisp 
Log Message:
Implemented new multiprocessing interface.

(create-socket): Make FDs non-blocking when multiprocessing is
enabled.

(startup-multiprocessing): Set *swank-in-background* to :spawn.

Date: Thu Jan 15 06:41:59 2004
Author: lgorrie

Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.48 slime/swank-cmucl.lisp:1.49
--- slime/swank-cmucl.lisp:1.48	Tue Jan 13 17:48:25 2004
+++ slime/swank-cmucl.lisp	Thu Jan 15 06:41:59 2004
@@ -13,9 +13,13 @@
 (setq *swank-in-background* :fd-handler)
 
 (defmethod create-socket (port)
-  (ext:create-inet-listener port :stream
-                            :reuse-address t
-                            :host (resolve-hostname "localhost")))
+  (let ((fd (ext:create-inet-listener port :stream
+                                      :reuse-address t
+                                      :host (resolve-hostname "localhost"))))
+    #+MP
+    (when *multiprocessing-enabled*
+      (set-fd-non-blocking fd))
+    fd))
 
 (defmethod local-port (socket)
   (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
@@ -24,6 +28,7 @@
   (ext:close-socket (socket-fd socket)))
 
 (defmethod accept-connection (socket)
+  #+MP (when *multiprocessing-enabled* (mp:process-wait-until-fd-usable socket :input))
   (make-socket-io-stream (ext:accept-tcp-connection socket)))
 
 (defmethod add-input-handler (socket fn)
@@ -37,6 +42,9 @@
          (input  (make-slime-input-stream input-fn output)))
     (values input output)))
 
+(defmethod spawn (fn &key (name "Anonymous"))
+  (mp:make-process fn :name name))
+
 ;;;
 ;;;;; Socket helpers.
 
@@ -56,6 +64,14 @@
   "Create a new input/output fd-stream for FD."
   (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
 
+(defun set-fd-non-blocking (fd)
+  (flet ((fcntl (fd cmd arg)
+           (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
+             (or flags 
+                 (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
+    (let ((flags (fcntl fd unix:F-GETFL 0)))
+      (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
+
 
 ;;;; Stream handling
 
@@ -1253,14 +1269,14 @@
 
 #+MP
 (progn
-  (defvar *I/O-lock*          (mp:make-lock "SWANK I/O lock"))
-  (defvar *conversation-lock* (mp:make-lock "SWANK conversation lock"))
-
   (defvar *known-processes* '()         ; FIXME: leakage. -luke
     "List of processes that have been assigned IDs.
      The ID is the position in the list.")
 
   (defmethod startup-multiprocessing ()
+    (setq *swank-in-background* :spawn)
+    ;; Threads magic: this never returns! But top-level becomes
+    ;; available again.
     (mp::startup-idle-and-top-level-loops))
 
   (defmethod thread-id ()
@@ -1280,20 +1296,13 @@
   (defmethod thread-name (thread-id)
     (mp:process-name (lookup-thread thread-id)))
 
-  (defmethod call-with-I/O-lock (function)
-    (mp:with-lock-held (*I/O-lock*)
-      (funcall function)))
+  (defmethod make-lock (&key name)
+    (mp:make-lock name))
 
-  (defmethod call-with-conversation-lock (function)
-    (mp:with-lock-held (*conversation-lock*)
+  (defmethod call-with-lock-held (lock function)
+    (mp:with-lock-held (lock)
       (funcall function)))
-
-  (defmethod wait-goahead ()
-    (mp:disable-process (mp:current-process))
-    (mp:process-yield))
-
-  (defmethod give-goahead (thread-id)
-    (mp:enable-process (lookup-thread thread-id))))
+)
 
 
 ;;;; Epilogue