Tmux etc

sbcl/.quicklisp/dists/quicklisp/software/bordeaux-threads-v0.8.7/src/impl-genera.lisp

@@ -0,0 +1,136 @@
+;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS; Base: 10; -*-
+
+#|
+Distributed under the MIT license (see LICENSE file)
+|#
+
+(in-package #:bordeaux-threads)
+
+(deftype thread ()
+  'process:process)
+
+;;; Thread Creation
+
+(defun %make-thread (function name)
+  (process:process-run-function name function))
+
+(defun current-thread ()
+  scl:*current-process*)
+
+(defun threadp (object)
+  (process:process-p object))
+
+(defun thread-name (thread)
+  (process:process-name thread))
+
+;;; Resource contention: locks and recursive locks
+
+(defstruct (lock (:constructor make-lock-internal))
+  lock
+  lock-argument)
+
+(defun make-lock (&optional name)
+  (let ((lock (process:make-lock (or name "Anonymous lock"))))
+    (make-lock-internal :lock lock
+			:lock-argument nil)))
+
+(defun acquire-lock (lock &optional (wait-p t))
+  (check-type lock lock)
+  (setf (lock-lock-argument lock) (process:make-lock-argument (lock-lock lock)))
+  (if wait-p
+      (process:lock (lock-lock lock) (lock-lock-argument lock))
+      (process:with-no-other-processes
+	(when (process:lock-lockable-p (lock-lock lock))
+	  (process:lock (lock-lock lock) (lock-lock-argument lock))))))
+
+(defun release-lock (lock)
+  (check-type lock lock)
+  (process:unlock (lock-lock lock) (scl:shiftf (lock-lock-argument lock) nil)))
+
+(defmacro with-lock-held ((place) &body body)
+  `(process:with-lock ((lock-lock ,place))
+     ,@body))
+
+(defstruct (recursive-lock (:constructor make-recursive-lock-internal))
+  lock
+  lock-arguments)
+
+(defun make-recursive-lock (&optional name)
+  (make-recursive-lock-internal :lock (process:make-lock (or name "Anonymous recursive lock")
+							 :recursive t)
+				:lock-arguments nil))
+
+(defun acquire-recursive-lock (lock)
+  (check-type lock recursive-lock)
+  (process:lock (recursive-lock-lock lock)
+		(car (push (process:make-lock-argument (recursive-lock-lock lock))
+			   (recursive-lock-lock-arguments lock)))))
+
+(defun release-recursive-lock (lock)
+  (check-type lock recursive-lock)
+  (process:unlock (recursive-lock-lock lock) (pop (recursive-lock-lock-arguments lock))))
+
+(defmacro with-recursive-lock-held ((place) &body body)
+  `(process:with-lock ((recursive-lock-lock ,place))
+     ,@body))
+
+;;; Resource contention: condition variables
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defstruct (condition-variable (:constructor %make-condition-variable))
+  name
+  (waiters nil))
+)
+
+(defun make-condition-variable (&key name)
+  (%make-condition-variable :name name))
+
+(defun condition-wait (condition-variable lock)
+  (check-type condition-variable condition-variable)
+  (check-type lock lock)
+  (process:with-no-other-processes
+    (let ((waiter (cons scl:*current-process* nil)))
+      (process:atomic-updatef (condition-variable-waiters condition-variable)
+			      #'(lambda (waiters)
+				  (append waiters (scl:ncons waiter))))
+      (process:without-lock ((lock-lock lock))
+	  (process:process-block (format nil "Waiting~@[ on ~A~]"
+					 (condition-variable-name condition-variable))
+				 #'(lambda (waiter)
+				     (not (null (cdr waiter))))
+				 waiter)))))
+
+(defun condition-notify (condition-variable)
+  (check-type condition-variable condition-variable)
+  (let ((waiter (process:atomic-pop (condition-variable-waiters condition-variable))))
+    (when waiter
+      (setf (cdr waiter) t)
+      (process:wakeup (car waiter))))
+  (values))
+
+(defun thread-yield ()
+  (scl:process-allow-schedule))
+
+;;; Introspection/debugging
+
+(defun all-threads ()
+  process:*all-processes*)
+
+(defun interrupt-thread (thread function &rest args)
+  (declare (dynamic-extent args))
+  (apply #'process:process-interrupt thread function args))
+
+(defun destroy-thread (thread)
+  (signal-error-if-current-thread thread)
+  (process:process-kill thread :without-aborts :force))
+
+(defun thread-alive-p (thread)
+  (process:process-active-p thread))
+
+(defun join-thread (thread)
+  (process:process-wait (format nil "Join ~S" thread)
+			#'(lambda (thread)
+			    (not (process:process-active-p thread)))
+			thread))
+
+(mark-supported)