impl-genera.lisp - clic - Clic is an command line interactive client for gopher… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
impl-genera.lisp (4041B) | |
--- | |
1 ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS… | |
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… | |
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)… | |
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 "Anony… | |
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-l… | |
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-a… | |
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-vari… | |
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 condit… | |
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 conditio… | |
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) |