impl-genera.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
impl-genera.lisp (4041B)
---
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)