1 | ;;; threads.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009-2010 Erik Huelsmann <ehuelsmann@common-lisp.net> |
---|
4 | ;;; |
---|
5 | ;;; $Id: threads.lisp 15635 2023-02-08 16:37:27Z mevenson $ |
---|
6 | ;;; |
---|
7 | ;;; This program is free software; you can redistribute it and/or |
---|
8 | ;;; modify it under the terms of the GNU General Public License |
---|
9 | ;;; as published by the Free Software Foundation; either version 2 |
---|
10 | ;;; of the License, or (at your option) any later version. |
---|
11 | ;;; |
---|
12 | ;;; This program is distributed in the hope that it will be useful, |
---|
13 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
15 | ;;; GNU General Public License for more details. |
---|
16 | ;;; |
---|
17 | ;;; You should have received a copy of the GNU General Public License |
---|
18 | ;;; along with this program; if not, write to the Free Software |
---|
19 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. |
---|
20 | ;;; |
---|
21 | ;;; As a special exception, the copyright holders of this library give you |
---|
22 | ;;; permission to link this library with independent modules to produce an |
---|
23 | ;;; executable, regardless of the license terms of these independent |
---|
24 | ;;; modules, and to copy and distribute the resulting executable under |
---|
25 | ;;; terms of your choice, provided that you also meet, for each linked |
---|
26 | ;;; independent module, the terms and conditions of the license of that |
---|
27 | ;;; module. An independent module is a module which is not derived from |
---|
28 | ;;; or based on this library. If you modify this library, you may extend |
---|
29 | ;;; this exception to your version of the library, but you are not |
---|
30 | ;;; obligated to do so. If you do not wish to do so, delete this |
---|
31 | ;;; exception statement from your version. |
---|
32 | |
---|
33 | (in-package threads) |
---|
34 | (export '(make-mailbox mailbox-send mailbox-empty-p |
---|
35 | mailbox-read mailbox-peek |
---|
36 | make-thread-lock with-thread-lock |
---|
37 | thread-function-wrapper |
---|
38 | current-thread yield |
---|
39 | make-mutex get-mutex release-mutex with-mutex |
---|
40 | get-java-thread)) |
---|
41 | |
---|
42 | ;; |
---|
43 | ;; MAKE-THREAD helper to establish restarts |
---|
44 | ;; |
---|
45 | |
---|
46 | (defun thread-function-wrapper (function) |
---|
47 | "Call FUNCTION with a simple abort restart" |
---|
48 | (restart-case |
---|
49 | (funcall function) |
---|
50 | (abort () :report "Abort thread."))) |
---|
51 | |
---|
52 | ;; |
---|
53 | ;; Mailbox implementation |
---|
54 | ;; |
---|
55 | |
---|
56 | ;; this export statement is also in autoloads.lisp |
---|
57 | (export '(make-mailbox mailbox-send mailbox-empty-p mailbox-read mailbox-peek)) |
---|
58 | |
---|
59 | (defstruct mailbox |
---|
60 | "A first-in-first out queue of messages" |
---|
61 | queue) |
---|
62 | |
---|
63 | (defun mailbox-send (mailbox item) |
---|
64 | "Sends an item into the mailbox, notifying 1 waiter |
---|
65 | to wake up for retrieval of that object." |
---|
66 | (threads:synchronized-on mailbox |
---|
67 | (push item (mailbox-queue mailbox)) |
---|
68 | (threads:object-notify mailbox))) |
---|
69 | |
---|
70 | (defun mailbox-empty-p (mailbox) |
---|
71 | "Returns non-NIL if the mailbox can be read from, NIL otherwise." |
---|
72 | ;; Because we're just checking the value of an object reference, |
---|
73 | ;; (which are atomically gotten and set) we don't need to lock |
---|
74 | ;; the mailbox before operating on it. |
---|
75 | (null (mailbox-queue mailbox))) |
---|
76 | |
---|
77 | (defun mailbox-read (mailbox) |
---|
78 | "Blocks on the mailbox until an item is available for reading. |
---|
79 | When an item is available, it is returned." |
---|
80 | (threads:synchronized-on mailbox |
---|
81 | (loop |
---|
82 | (unless (mailbox-empty-p mailbox) |
---|
83 | (return)) |
---|
84 | (object-wait mailbox)) |
---|
85 | (pop (mailbox-queue mailbox)))) |
---|
86 | |
---|
87 | (defun mailbox-peek (mailbox) |
---|
88 | "Returns two values. The second returns non-NIL when the mailbox |
---|
89 | is empty. The first is the next item to be read from the mailbox. |
---|
90 | |
---|
91 | Note that due to multi-threading, the first value returned upon |
---|
92 | peek, may be different from the one returned upon next read in the |
---|
93 | calling thread." |
---|
94 | (threads:synchronized-on mailbox |
---|
95 | (values (car (mailbox-queue mailbox)) |
---|
96 | (null (mailbox-queue mailbox))))) |
---|
97 | |
---|
98 | |
---|
99 | |
---|
100 | ;; |
---|
101 | ;; Mutex implementation |
---|
102 | ;; |
---|
103 | |
---|
104 | |
---|
105 | ;; this export statement is also in autoloads.lisp |
---|
106 | (export '(make-mutex get-mutex release-mutex)) |
---|
107 | |
---|
108 | (defstruct mutex |
---|
109 | "An object used as a mutex lock" |
---|
110 | in-use) |
---|
111 | |
---|
112 | (defun get-mutex (mutex) |
---|
113 | "Acquires the lock associated with the MUTEX" |
---|
114 | (synchronized-on mutex |
---|
115 | (loop |
---|
116 | while (mutex-in-use mutex) |
---|
117 | do (object-wait mutex)) |
---|
118 | (setf (mutex-in-use mutex) T))) |
---|
119 | |
---|
120 | (defun release-mutex (mutex) |
---|
121 | "Releases a lock associated with MUTEX" |
---|
122 | (synchronized-on mutex |
---|
123 | (setf (mutex-in-use mutex) NIL) |
---|
124 | (object-notify mutex))) |
---|
125 | |
---|
126 | (defmacro with-mutex ((mutex) &body body) |
---|
127 | "Acquires a lock on MUTEX, executes BODY, and then releases the lock" |
---|
128 | (let ((m (gensym))) |
---|
129 | `(let ((,m ,mutex)) |
---|
130 | (when (get-mutex ,m) |
---|
131 | (unwind-protect |
---|
132 | (progn |
---|
133 | ,@body) |
---|
134 | (release-mutex ,m)))))) |
---|
135 | ;; |
---|
136 | ;; Lock implementation |
---|
137 | ;; |
---|
138 | |
---|
139 | (defun make-thread-lock () |
---|
140 | "Returns an object to be used with the WITH-THREAD-LOCK macro." |
---|
141 | (gensym)) |
---|
142 | |
---|
143 | (defmacro with-thread-lock ((lock) &body body) |
---|
144 | "Acquires the LOCK, executes BODY and releases the LOCK" |
---|
145 | (let ((glock (gensym))) |
---|
146 | `(let ((,glock ,lock)) |
---|
147 | (synchronized-on ,glock |
---|
148 | ,@body)))) |
---|
149 | |
---|
150 | (defun yield () |
---|
151 | "A hint to the scheduler that the current thread is willing to yield its current use of a processor. The scheduler is free to ignore this hint. |
---|
152 | |
---|
153 | See java.lang.Thread.yield()." |
---|
154 | (java:jcall "yield" (java:jstatic "currentThread" "java.lang.Thread"))) |
---|
155 | |
---|
156 | (defun get-java-thread (&optional lisp-thread) |
---|
157 | "Without an argument, return the underlying currently executing Java thread |
---|
158 | |
---|
159 | Specified with a LISP-THREAD, return that thread's wrapped Java |
---|
160 | thread." |
---|
161 | (cdr (first |
---|
162 | (java:jcall "getParts" |
---|
163 | (if lisp-thread |
---|
164 | lisp-thread |
---|
165 | (threads:current-thread)))))) |
---|
166 | |
---|