136 lines
3.9 KiB
Common Lisp
136 lines
3.9 KiB
Common Lisp
;;;; -*- 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)
|