/[slime]/slime/swank-sbcl.lisp
ViewVC logotype

Diff of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.56 by heller, Fri Jan 23 21:03:11 2004 UTC revision 1.56.2.1 by heller, Sat Jan 31 11:26:02 2004 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-  <;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2  ;;;  ;;;
3  ;;; swank-sbcl.lisp --- SLIME backend for SBCL.  ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4  ;;;  ;;;
# Line 38  Line 38 
38    
39  (eval-when (:compile-toplevel :load-toplevel :execute)  (eval-when (:compile-toplevel :load-toplevel :execute)
40    (require 'sb-bsd-sockets)    (require 'sb-bsd-sockets)
41    (require 'sb-introspect))    (require 'sb-introspect)
42      )
43    
44  (declaim (optimize (debug 3)))  (declaim (optimize (debug 3)))
45  (in-package :swank)  (in-package :swank)
# Line 58  Line 59 
59    
60  ;;; TCP Server  ;;; TCP Server
61    
62  (setq *swank-in-background* :fd-handler)  (setq *swank-in-background* :sigio)
63    
64  (defimplementation create-socket (port)  (defimplementation create-socket (port)
65    (let ((socket (make-instance 'sb-bsd-sockets:inet-socket    (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
# Line 78  Line 79 
79  (defimplementation accept-connection (socket)  (defimplementation accept-connection (socket)
80    (make-socket-io-stream (accept socket)))    (make-socket-io-stream (accept socket)))
81    
82    (defvar *sigio-handlers* '()
83      "List of (key . fn) pairs to be called on SIGIO.")
84    
85    (defun sigio-handler (signal code scp)
86      (mapc (lambda (handler) (funcall (cdr handler))) *sigio-handlers*))
87    
88    
89    (defun set-sigio-handler ()
90      (sb-sys:enable-interrupt sb-unix:SIGIO (lambda (signal code scp)
91                                               (sigio-handler signal code scp))))
92    
93    (set-sigio-handler)
94    
95    #+linux
96    (progn
97      (defconstant +o_async+ 8192)
98      (defconstant +f_setown+ 8)
99      (defconstant +f_setfl+ 4))
100    
101  (defimplementation add-input-handler (socket fn)  (defimplementation add-input-handler (socket fn)
102    (sb-sys:add-fd-handler (socket-fd  socket)    (let ((fd (socket-fd socket)))
103                           :input (lambda (fd)      (format *debug-io* "Adding sigio handler: ~S ~%" fd)
104                                    (declare (ignore fd))      (let ((fcntl (sb-alien:extern-alien "fcntl"
105                                    (funcall fn))))                                          (function sb-alien:int sb-alien:int
106                                                      sb-alien:int sb-alien:int))))
107          ;; XXX error checking
108          (sb-alien:alien-funcall fcntl fd +f_setfl+ +o_async+)
109          (sb-alien:alien-funcall fcntl fd +f_setown+ (sb-unix:unix-getpid))
110          (push (cons fd fn) *sigio-handlers*))))
111    
112  (defimplementation remove-input-handlers (socket)  (defimplementation remove-input-handlers (socket)
113    (sb-sys:invalidate-descriptor (socket-fd socket))    (let ((fd (socket-fd socket)))
114        (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
115        (sb-sys:invalidate-descriptor fd))
116    (close socket))    (close socket))
117    
118  (defun socket-fd (socket)  (defun socket-fd (socket)
# Line 553  stack." Line 580  stack."
580    (defimplementation thread-name (thread-id)    (defimplementation thread-name (thread-id)
581      (format nil "Thread ~S" thread-id))      (format nil "Thread ~S" thread-id))
582    
583    (defimplementation make-lock (&key name)  ;;  (defimplementation make-lock (&key name)
584      (sb-thread:make-mutex :name name))  ;;    (sb-thread:make-mutex :name name))
585    
586    ;;  (defimplementation call-with-lock-held (lock function)
587    ;;    (sb-thread:with-mutex (lock) (funcall function)))
588    
589      (defimplementation current-thread ()
590        (sb-thread:current-thread-id))
591    
592      (defun all-threads ()
593        (sb-thread::mapcar-threads
594         (lambda (sap)
595           (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
596                                     sb-vm::thread-pid-slot)))))
597    
598      (defimplementation interrupt-thread (thread fn)
599        (sb-thread:interrupt-thread thread fn))
600    
601      ;; XXX there is some deadlock / race condition here
602    
603      (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
604      (defvar *mailboxes* (list))
605    
606      (defstruct (mailbox (:conc-name mailbox.))
607        thread
608        (mutex (sb-thread:make-mutex))
609        (waitqueue  (sb-thread:make-waitqueue))
610        (queue '() :type list))
611    
612      (defun mailbox (thread)
613        "Return THREAD's mailbox."
614        (sb-thread:with-mutex (*mailbox-lock*)
615          (or (find thread *mailboxes* :key #'mailbox.thread)
616              (let ((mb (make-mailbox :thread thread)))
617                (push mb *mailboxes*)
618                mb))))
619    
620      (defimplementation send (thread message)
621        (let* ((mbox (mailbox thread))
622               (mutex (mailbox.mutex mbox)))
623          (sb-thread:with-mutex (mutex)
624            (setf (mailbox.queue mbox)
625                  (nconc (mailbox.queue mbox) (list message)))
626            (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
627    
628      (defimplementation receive ()
629        (let* ((mbox (mailbox (sb-thread:current-thread-id)))
630               (mutex (mailbox.mutex mbox)))
631          (sb-thread:with-mutex (mutex)
632            (loop
633             (let ((q (mailbox.queue mbox)))
634               (cond (q (return (pop (mailbox.queue mbox))))
635                     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
636                                                  mutex))))))))
637    
638    (defimplementation call-with-lock-held (lock function)    )
     (sb-thread:with-mutex (lock) (funcall function)))  
 )  
639    
640  ;;; Local Variables:  ;;; Local Variables:
641  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))  ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))

Legend:
Removed from v.1.56  
changed lines
  Added in v.1.56.2.1

  ViewVC Help
Powered by ViewVC 1.1.5