impl-cmucl.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-cmucl.lisp (4919B) | |
--- | |
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 (deftype thread () | |
12 'mp::process) | |
13 | |
14 ;;; Thread Creation | |
15 | |
16 (defun start-multiprocessing () | |
17 (mp::startup-idle-and-top-level-loops)) | |
18 | |
19 (defun %make-thread (function name) | |
20 #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(o… | |
21 (mp:make-process function :name name) | |
22 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(o… | |
23 (mp:make-process (lambda () | |
24 (let ((return-values | |
25 (multiple-value-list (funcall function)))) | |
26 (setf (getf (mp:process-property-list mp:*current… | |
27 'return-values) | |
28 return-values) | |
29 (values-list return-values))) | |
30 :name name)) | |
31 | |
32 (defun current-thread () | |
33 mp:*current-process*) | |
34 | |
35 (defmethod threadp (object) | |
36 (mp:processp object)) | |
37 | |
38 (defun thread-name (thread) | |
39 (mp:process-name thread)) | |
40 | |
41 ;;; Resource contention: locks and recursive locks | |
42 | |
43 (deftype lock () 'mp::error-check-lock) | |
44 | |
45 (deftype recursive-lock () 'mp::recursive-lock) | |
46 | |
47 (defun lock-p (object) | |
48 (typep object 'mp::error-check-lock)) | |
49 | |
50 (defun recursive-lock-p (object) | |
51 (typep object 'mp::recursive-lock)) | |
52 | |
53 (defun make-lock (&optional name) | |
54 (mp:make-lock (or name "Anonymous lock") | |
55 :kind :error-check)) | |
56 | |
57 (defun acquire-lock (lock &optional (wait-p t)) | |
58 (if wait-p | |
59 (mp::lock-wait lock "Lock wait") | |
60 (mp::lock-wait-with-timeout lock "Lock wait" 0))) | |
61 | |
62 (defun release-lock (lock) | |
63 (setf (mp::lock-process lock) nil)) | |
64 | |
65 (defmacro with-lock-held ((place) &body body) | |
66 `(mp:with-lock-held (,place "Lock wait") ,@body)) | |
67 | |
68 (defun make-recursive-lock (&optional name) | |
69 (mp:make-lock (or name "Anonymous recursive lock") | |
70 :kind :recursive)) | |
71 | |
72 (defun acquire-recursive-lock (lock &optional (wait-p t)) | |
73 (acquire-lock lock)) | |
74 | |
75 (defun release-recursive-lock (lock) | |
76 (release-lock lock)) | |
77 | |
78 (defmacro with-recursive-lock-held ((place &key timeout) &body body) | |
79 `(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body)) | |
80 | |
81 ;;; Note that the locks _are_ recursive, but not "balanced", and only | |
82 ;;; checked if they are being held by the same process by with-lock-held. | |
83 ;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that | |
84 ;;; it will wait for recursive locks by the same process as well. | |
85 | |
86 ;;; Resource contention: condition variables | |
87 | |
88 ;;; There's some stuff in x86-vm.lisp that might be worth investigating | |
89 ;;; whether to build on. There's also process-wait and friends. | |
90 | |
91 (defstruct condition-var | |
92 "CMUCL doesn't have conditions, so we need to create our own type." | |
93 name | |
94 lock | |
95 active) | |
96 | |
97 (defun make-condition-variable (&key name) | |
98 (make-condition-var :lock (make-lock) | |
99 :name (or name "Anonymous condition variable"))) | |
100 | |
101 (defun condition-wait (condition-variable lock &key timeout) | |
102 (signal-error-if-condition-wait-timeout timeout) | |
103 (check-type condition-variable condition-var) | |
104 (with-lock-held ((condition-var-lock condition-variable)) | |
105 (setf (condition-var-active condition-variable) nil)) | |
106 (release-lock lock) | |
107 (mp:process-wait "Condition Wait" | |
108 #'(lambda () (condition-var-active condition-variable… | |
109 (acquire-lock lock) | |
110 t) | |
111 | |
112 (define-condition-wait-compiler-macro) | |
113 | |
114 (defun condition-notify (condition-variable) | |
115 (check-type condition-variable condition-var) | |
116 (with-lock-held ((condition-var-lock condition-variable)) | |
117 (setf (condition-var-active condition-variable) t)) | |
118 (thread-yield)) | |
119 | |
120 (defun thread-yield () | |
121 (mp:process-yield)) | |
122 | |
123 ;;; Timeouts | |
124 | |
125 (defmacro with-timeout ((timeout) &body body) | |
126 (once-only (timeout) | |
127 `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) | |
128 ,@body))) | |
129 | |
130 ;;; Introspection/debugging | |
131 | |
132 (defun all-threads () | |
133 (mp:all-processes)) | |
134 | |
135 (defun interrupt-thread (thread function &rest args) | |
136 (flet ((apply-function () | |
137 (if args | |
138 (lambda () (apply function args)) | |
139 function))) | |
140 (declare (dynamic-extent #'apply-function)) | |
141 (mp:process-interrupt thread (apply-function)))) | |
142 | |
143 (defun destroy-thread (thread) | |
144 (signal-error-if-current-thread thread) | |
145 (mp:destroy-process thread)) | |
146 | |
147 (defun thread-alive-p (thread) | |
148 (mp:process-active-p thread)) | |
149 | |
150 (defun join-thread (thread) | |
151 #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(o… | |
152 (mp:process-join thread) | |
153 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(o… | |
154 (progn | |
155 (mp:process-wait (format nil "Waiting for thread ~A to complete" thr… | |
156 (lambda () (not (mp:process-alive-p thread)))) | |
157 (let ((return-values | |
158 (getf (mp:process-property-list thread) 'return-values))) | |
159 (values-list return-values)))) | |
160 | |
161 (mark-supported) |