Skip to content

Instantly share code, notes, and snippets.

@dnaeon
Forked from stassats/slime.diff
Created May 12, 2021 14:32
Show Gist options
  • Save dnaeon/a6fc7bd287a5136fb04d0c6b2f8cf714 to your computer and use it in GitHub Desktop.
Save dnaeon/a6fc7bd287a5136fb04d0c6b2f8cf714 to your computer and use it in GitHub Desktop.
diff --git a/swank/sbcl.lisp b/swank/sbcl.lisp
index a09e04b3..78038659 100644
--- a/swank/sbcl.lisp
+++ b/swank/sbcl.lisp
@@ -979,7 +979,8 @@ QUALITIES is an alist with (quality . value)"
(make-location `(:file ,(namestring
(translate-logical-pathname pathname)))
'(:position 1)
- (when (eql type :function)
+ (when (and (eql type :function)
+ (symbolp name))
`(:snippet ,(format nil "(defun ~a "
(symbol-name name))))))
(:invalid
@@ -1666,7 +1667,7 @@ stack."
(sb-thread:with-mutex (*thread-id-counter-lock*)
(incf *thread-id-counter*)))
- (defparameter *thread-id-map* (make-hash-table))
+ (defvar *thread-id-map* (make-hash-table))
;; This should be a thread -> id map but as weak keys are not
;; supported it is id -> map instead.
@@ -1741,10 +1742,33 @@ stack."
(defvar *mailboxes* (list))
(declaim (type list *mailboxes*))
+ (defun make-sem ()
+ (declare (optimize speed))
+ (sb-alien:alien-funcall
+ (sb-alien:extern-alien
+ "dispatch_semaphore_create"
+ (function sb-sys:system-area-pointer sb-alien:long))
+ 0))
+
+ (defun wait-sem (sem)
+ (declare (optimize speed))
+ (sb-alien:alien-funcall
+ (sb-alien:extern-alien "dispatch_semaphore_wait"
+ (function sb-alien:long sb-sys:system-area-pointer sb-alien:long-long))
+ sem
+ -1))
+
+ (defun signal-sem (sem)
+ (declare (optimize speed))
+ (sb-alien:alien-funcall
+ (sb-alien:extern-alien "dispatch_semaphore_signal"
+ (function sb-alien:long sb-sys:system-area-pointer))
+ sem))
+
(defstruct (mailbox (:conc-name mailbox.))
thread
(mutex (sb-thread:make-mutex))
- (waitqueue (sb-thread:make-waitqueue))
+ (sem (make-sem))
(queue '() :type list))
(defun mailbox (thread)
@@ -1756,23 +1780,21 @@ stack."
mb))))
(defimplementation wake-thread (thread)
- (let* ((mbox (mailbox thread))
- (mutex (mailbox.mutex mbox)))
- (sb-thread:with-recursive-lock (mutex)
- (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
+ (signal-sem (mailbox.sem (mailbox thread))))
+
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(sb-thread:with-mutex (mutex)
(setf (mailbox.queue mbox)
- (nconc (mailbox.queue mbox) (list message)))
- (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
-
+ (nconc (mailbox.queue mbox) (list message))))
+ (signal-sem (mailbox.sem mbox))))
+
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox))
- (waitq (mailbox.waitqueue mbox)))
+ (sem (mailbox.sem mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
@@ -1781,9 +1803,9 @@ stack."
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
- (return (car tail))))
- (when (eq timeout t) (return (values nil t)))
- (sb-thread:condition-wait waitq mutex)))))
+ (return (car tail)))))
+ (when (eq timeout t) (return (values nil t)))
+ (wait-sem sem))))
(let ((alist '())
(mutex (sb-thread:make-mutex :name "register-thread")))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment