impl-sbcl.lisp - clic - Clic is an command line interactive client for gopher w… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
impl-sbcl.lisp (3462B) | |
--- | |
1 ;;;; -*- indent-tabs-mode: nil -*- | |
2 | |
3 #| | |
4 Copyright 2006, 2007 Greg Pfeil | |
5 | |
6 Distributed under the MIT license (see LICENSE file) | |
7 |# | |
8 | |
9 (in-package #:bordeaux-threads) | |
10 | |
11 ;;; documentation on the SBCL Threads interface can be found at | |
12 ;;; http://www.sbcl.org/manual/Threading.html | |
13 | |
14 (deftype thread () | |
15 'sb-thread:thread) | |
16 | |
17 ;;; Thread Creation | |
18 | |
19 (defun %make-thread (function name) | |
20 (sb-thread:make-thread function :name name)) | |
21 | |
22 (defun current-thread () | |
23 sb-thread:*current-thread*) | |
24 | |
25 (defun threadp (object) | |
26 (typep object 'sb-thread:thread)) | |
27 | |
28 (defun thread-name (thread) | |
29 (sb-thread:thread-name thread)) | |
30 | |
31 ;;; Resource contention: locks and recursive locks | |
32 | |
33 (deftype lock () 'sb-thread:mutex) | |
34 | |
35 (deftype recursive-lock () 'sb-thread:mutex) | |
36 | |
37 (defun lock-p (object) | |
38 (typep object 'sb-thread:mutex)) | |
39 | |
40 (defun recursive-lock-p (object) | |
41 (typep object 'sb-thread:mutex)) | |
42 | |
43 (defun make-lock (&optional name) | |
44 (sb-thread:make-mutex :name (or name "Anonymous lock"))) | |
45 | |
46 (defun acquire-lock (lock &optional (wait-p t)) | |
47 #+#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and… | |
48 (sb-thread:grab-mutex lock :waitp wait-p) | |
49 #-#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and… | |
50 (sb-thread:get-mutex lock nil wait-p)) | |
51 | |
52 (defun release-lock (lock) | |
53 (sb-thread:release-mutex lock)) | |
54 | |
55 (defmacro with-lock-held ((place) &body body) | |
56 `(sb-thread:with-mutex (,place) ,@body)) | |
57 | |
58 (defun make-recursive-lock (&optional name) | |
59 (sb-thread:make-mutex :name (or name "Anonymous recursive lock"))) | |
60 | |
61 ;;; XXX acquire-recursive-lock and release-recursive-lock are actually | |
62 ;;; complicated because we can't use control stack tricks. We need to | |
63 ;;; actually count something to check that the acquire/releases are | |
64 ;;; balanced | |
65 | |
66 (defmacro with-recursive-lock-held ((place) &body body) | |
67 `(sb-thread:with-recursive-lock (,place) | |
68 ,@body)) | |
69 | |
70 ;;; Resource contention: condition variables | |
71 | |
72 (defun make-condition-variable (&key name) | |
73 (sb-thread:make-waitqueue :name (or name "Anonymous condition variable… | |
74 | |
75 (defun condition-wait (condition-variable lock &key timeout) | |
76 (sb-thread:condition-wait condition-variable lock :timeout timeout)) | |
77 | |
78 (defun condition-notify (condition-variable) | |
79 (sb-thread:condition-notify condition-variable)) | |
80 | |
81 (defun thread-yield () | |
82 (sb-thread:release-foreground)) | |
83 | |
84 ;;; Timeouts | |
85 | |
86 (deftype timeout () | |
87 'sb-ext:timeout) | |
88 | |
89 (defmacro with-timeout ((timeout) &body body) | |
90 `(sb-ext:with-timeout ,timeout | |
91 ,@body)) | |
92 | |
93 ;;; Semaphores | |
94 | |
95 (deftype semaphore () | |
96 'sb-thread:semaphore) | |
97 | |
98 (defun make-semaphore (&key name (count 0)) | |
99 (sb-thread:make-semaphore :name name :count count)) | |
100 | |
101 (defun signal-semaphore (semaphore &key (count 1)) | |
102 (sb-thread:signal-semaphore semaphore count)) | |
103 | |
104 (defun wait-on-semaphore (semaphore &key timeout) | |
105 (sb-thread:wait-on-semaphore semaphore :timeout timeout)) | |
106 | |
107 ;;; Introspection/debugging | |
108 | |
109 (defun all-threads () | |
110 (sb-thread:list-all-threads)) | |
111 | |
112 (defun interrupt-thread (thread function &rest args) | |
113 (flet ((apply-function () | |
114 (if args | |
115 (lambda () (apply function args)) | |
116 function))) | |
117 (declare (dynamic-extent #'apply-function)) | |
118 (sb-thread:interrupt-thread thread (apply-function)))) | |
119 | |
120 (defun destroy-thread (thread) | |
121 (signal-error-if-current-thread thread) | |
122 (sb-thread:terminate-thread thread)) | |
123 | |
124 (defun thread-alive-p (thread) | |
125 (sb-thread:thread-alive-p thread)) | |
126 | |
127 (defun join-thread (thread) | |
128 (sb-thread:join-thread thread)) | |
129 | |
130 (mark-supported) |