impl-cmucl.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-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) '(or))
21 (mp:make-process function :name name)
22 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
23 (mp:make-process (lambda ()
24 (let ((return-values
25 (multiple-value-list (funcall function))))
26 (setf (getf (mp:process-property-list mp:*current-process*)
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) '(or))
152 (mp:process-join thread)
153 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or))
154 (progn
155 (mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
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)