impl-abcl.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-abcl.lisp (4319B)
---
1 ;;;; -*- indent-tabs-mode: nil -*-
2
3 #|
4 Copyright 2006, 2007 Greg Pfeil
5
6 Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011.
7
8 Distributed under the MIT license (see LICENSE file)
9 |#
10
11 (in-package #:bordeaux-threads)
12
13 ;;; the implementation of the Armed Bear thread interface can be found in
14 ;;; src/org/armedbear/lisp/LispThread.java
15
16 (deftype thread ()
17 'threads:thread)
18
19 ;;; Thread Creation
20
21 (defun %make-thread (function name)
22 (threads:make-thread function :name name))
23
24 (defun current-thread ()
25 (threads:current-thread))
26
27 (defun thread-name (thread)
28 (threads:thread-name thread))
29
30 (defun threadp (object)
31 (typep object 'thread))
32
33 ;;; Resource contention: locks and recursive locks
34
35 (defstruct mutex name lock)
36 (defstruct (mutex-recursive (:include mutex)))
37
38 ;; Making methods constants in this manner avoids the runtime expense of
39 ;; introspection involved in JCALL with string arguments.
40 (defconstant +lock+
41 (jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
42 (defconstant +try-lock+
43 (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
44 (defconstant +is-held-by-current-thread+
45 (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread"))
46 (defconstant +unlock+
47 (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
48 (defconstant +get-hold-count+
49 (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
50
51 (deftype lock () 'mutex)
52
53 (deftype recursive-lock () 'mutex-recursive)
54
55 (defun lock-p (object)
56 (typep object 'mutex))
57
58 (defun recursive-lock-p (object)
59 (typep object 'mutex-recursive))
60
61 (defun make-lock (&optional name)
62 (make-mutex
63 :name (or name "Anonymous lock")
64 :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
65
66 (defun acquire-lock (lock &optional (wait-p t))
67 (check-type lock mutex)
68 (when (jcall +is-held-by-current-thread+ (mutex-lock lock))
69 (error "Non-recursive lock being reacquired by owner."))
70 (cond
71 (wait-p
72 (jcall +lock+ (mutex-lock lock))
73 t)
74 (t (jcall +try-lock+ (mutex-lock lock)))))
75
76 (defun release-lock (lock)
77 (check-type lock mutex)
78 (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
79 (error "Attempt to release lock not held by calling thread."))
80 (jcall +unlock+ (mutex-lock lock))
81 (values))
82
83 (defun make-recursive-lock (&optional name)
84 (make-mutex-recursive
85 :name (or name "Anonymous lock")
86 :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
87
88 (defun acquire-recursive-lock (lock &optional (wait-p t))
89 (check-type lock mutex-recursive)
90 (cond
91 (wait-p
92 (jcall +lock+ (mutex-recursive-lock lock))
93 t)
94 (t (jcall +try-lock+ (mutex-recursive-lock lock)))))
95
96 (defun release-recursive-lock (lock)
97 (check-type lock mutex-recursive)
98 (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
99 (error "Attempt to release lock not held by calling thread."))
100 (jcall +unlock+ (mutex-lock lock))
101 (values))
102
103 ;;; Resource contention: condition variables
104
105 (defun thread-yield ()
106 (java:jstatic "yield" "java.lang.Thread"))
107
108 (defstruct condition-variable
109 (name "Anonymous condition variable"))
110
111 (defun condition-wait (condition lock &key timeout)
112 (threads:synchronized-on condition
113 (release-lock lock)
114 (if timeout
115 ;; Since giving a zero time value to threads:object-wait means
116 ;; an indefinite wait, use some arbitrary small number.
117 (threads:object-wait condition
118 (if (zerop timeout)
119 least-positive-single-float
120 timeout))
121 (threads:object-wait condition)))
122 (acquire-lock lock)
123 t)
124
125 (defun condition-notify (condition)
126 (threads:synchronized-on condition
127 (threads:object-notify condition)))
128
129 ;;; Introspection/debugging
130
131 (defun all-threads ()
132 (let ((threads ()))
133 (threads:mapcar-threads (lambda (thread)
134 (push thread threads)))
135 (reverse threads)))
136
137 (defun interrupt-thread (thread function &rest args)
138 (apply #'threads:interrupt-thread thread function args))
139
140 (defun destroy-thread (thread)
141 (signal-error-if-current-thread thread)
142 (threads:destroy-thread thread))
143
144 (defun thread-alive-p (thread)
145 (threads:thread-alive-p thread))
146
147 (defun join-thread (thread)
148 (threads:thread-join thread))
149
150 (mark-supported)