3rdparties/software/bordeaux-threads-v0.8.7/src/impl-genera.lisp (4041 bytes)
1 ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS; Base: 10; -*- 2 3 #| 4 Distributed under the MIT license (see LICENSE file) 5 |# 6 7 (in-package #:bordeaux-threads) 8 9 (deftype thread () 10 'process:process) 11 12 ;;; Thread Creation 13 14 (defun %make-thread (function name) 15 (process:process-run-function name function)) 16 17 (defun current-thread () 18 scl:*current-process*) 19 20 (defun threadp (object) 21 (process:process-p object)) 22 23 (defun thread-name (thread) 24 (process:process-name thread)) 25 26 ;;; Resource contention: locks and recursive locks 27 28 (defstruct (lock (:constructor make-lock-internal)) 29 lock 30 lock-argument) 31 32 (defun make-lock (&optional name) 33 (let ((lock (process:make-lock (or name "Anonymous lock")))) 34 (make-lock-internal :lock lock 35 :lock-argument nil))) 36 37 (defun acquire-lock (lock &optional (wait-p t)) 38 (check-type lock lock) 39 (setf (lock-lock-argument lock) (process:make-lock-argument (lock-lock lock))) 40 (if wait-p 41 (process:lock (lock-lock lock) (lock-lock-argument lock)) 42 (process:with-no-other-processes 43 (when (process:lock-lockable-p (lock-lock lock)) 44 (process:lock (lock-lock lock) (lock-lock-argument lock)))))) 45 46 (defun release-lock (lock) 47 (check-type lock lock) 48 (process:unlock (lock-lock lock) (scl:shiftf (lock-lock-argument lock) nil))) 49 50 (defmacro with-lock-held ((place) &body body) 51 `(process:with-lock ((lock-lock ,place)) 52 ,@body)) 53 54 (defstruct (recursive-lock (:constructor make-recursive-lock-internal)) 55 lock 56 lock-arguments) 57 58 (defun make-recursive-lock (&optional name) 59 (make-recursive-lock-internal :lock (process:make-lock (or name "Anonymous recursive lock") 60 :recursive t) 61 :lock-arguments nil)) 62 63 (defun acquire-recursive-lock (lock) 64 (check-type lock recursive-lock) 65 (process:lock (recursive-lock-lock lock) 66 (car (push (process:make-lock-argument (recursive-lock-lock lock)) 67 (recursive-lock-lock-arguments lock))))) 68 69 (defun release-recursive-lock (lock) 70 (check-type lock recursive-lock) 71 (process:unlock (recursive-lock-lock lock) (pop (recursive-lock-lock-arguments lock)))) 72 73 (defmacro with-recursive-lock-held ((place) &body body) 74 `(process:with-lock ((recursive-lock-lock ,place)) 75 ,@body)) 76 77 ;;; Resource contention: condition variables 78 79 (eval-when (:compile-toplevel :load-toplevel :execute) 80 (defstruct (condition-variable (:constructor %make-condition-variable)) 81 name 82 (waiters nil)) 83 ) 84 85 (defun make-condition-variable (&key name) 86 (%make-condition-variable :name name)) 87 88 (defun condition-wait (condition-variable lock) 89 (check-type condition-variable condition-variable) 90 (check-type lock lock) 91 (process:with-no-other-processes 92 (let ((waiter (cons scl:*current-process* nil))) 93 (process:atomic-updatef (condition-variable-waiters condition-variable) 94 #'(lambda (waiters) 95 (append waiters (scl:ncons waiter)))) 96 (process:without-lock ((lock-lock lock)) 97 (process:process-block (format nil "Waiting~@[ on ~A~]" 98 (condition-variable-name condition-variable)) 99 #'(lambda (waiter) 100 (not (null (cdr waiter)))) 101 waiter))))) 102 103 (defun condition-notify (condition-variable) 104 (check-type condition-variable condition-variable) 105 (let ((waiter (process:atomic-pop (condition-variable-waiters condition-variable)))) 106 (when waiter 107 (setf (cdr waiter) t) 108 (process:wakeup (car waiter)))) 109 (values)) 110 111 (defun thread-yield () 112 (scl:process-allow-schedule)) 113 114 ;;; Introspection/debugging 115 116 (defun all-threads () 117 process:*all-processes*) 118 119 (defun interrupt-thread (thread function &rest args) 120 (declare (dynamic-extent args)) 121 (apply #'process:process-interrupt thread function args)) 122 123 (defun destroy-thread (thread) 124 (signal-error-if-current-thread thread) 125 (process:process-kill thread :without-aborts :force)) 126 127 (defun thread-alive-p (thread) 128 (process:process-active-p thread)) 129 130 (defun join-thread (thread) 131 (process:process-wait (format nil "Join ~S" thread) 132 #'(lambda (thread) 133 (not (process:process-active-p thread))) 134 thread)) 135 136 (mark-supported)