1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
;;;
;;; Code freely lifted from various places with compatible license
;;; terms. Most of this code is copyright Gilbert Baumann
;;; <unk6@rz.uni-karlsruhe.de>. The bugs are copyright Walter
;;; C. Pelissero <walter@pelissero.de>.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :sclf)
(defun make-lock (&optional name)
(mp:make-lock name))
(defun make-recursive-lock (&optional name)
(mp:make-lock name :kind :recursive))
(defmacro with-lock-held ((lock &key whostate (wait t) timeout) &body forms)
`(mp:with-lock-held (,lock ,(or whostate "Lock Wait")
:wait wait
,@(when timeout (list :timeout timeout)))
,@forms))
(defmacro with-recursive-lock-held ((lock &key wait timeout) &body forms)
`(mp:with-lock-held (,lock
,@(when wait (list :wait wait))
,@(when timeout (list :timeout timeout)))
,@forms))
(defstruct condition-variable
(lock (make-lock "condition variable"))
(value nil)
(process-queue nil))
(defun %release-lock (lock) ; copied from with-lock-held in multiproc.lisp
#+i486 (kernel:%instance-set-conditional
lock 2 mp:*current-process* nil)
#-i486 (when (eq (lock-process lock) mp:*current-process*)
(setf (lock-process lock) nil)))
(defun condition-wait (cv lock &optional timeout)
(declare (ignore timeout)) ;For now
(loop
(let ((cv-lock (condition-variable-lock cv)))
(with-lock-held (cv-lock)
(when (condition-variable-value cv)
(setf (condition-variable-value cv) nil)
(return-from condition-wait t))
(setf (condition-variable-process-queue cv)
(nconc (condition-variable-process-queue cv)
(list mp:*current-process*)))
(%release-lock lock))
(mp:process-add-arrest-reason mp:*current-process* cv)
(let ((cv-val nil))
(with-lock-held (cv-lock)
(setq cv-val (condition-variable-value cv))
(when cv-val
(setf (condition-variable-value cv) nil)))
(when cv-val
(mp::lock-wait lock "waiting for condition variable lock")
(return-from condition-wait t))))))
(defun condition-notify (cv)
(with-lock-held ((condition-variable-lock cv))
(let ((proc (pop (condition-variable-process-queue cv))))
;; The waiting process may have released the CV lock but not
;; suspended itself yet
(when proc
(loop
for activep = (mp:process-active-p proc)
while activep
do (mp:process-yield))
(setf (condition-variable-value cv) t)
(mp:process-revoke-arrest-reason proc cv))))
;; Give the other process a chance
(mp:process-yield))
(defun process-execute (process function)
(mp:process-preset process function)
;; For some obscure reason process-preset doesn't make the process
;; runnable. I'm sure it's me who didn't understand how
;; multiprocessing works under CMUCL, despite the vast documentation
;; available.
(mp:enable-process process)
(mp:process-add-run-reason process :enable))
(defun destroy-process (process)
;; silnetly ignore a process that is trying to destroy itself
(unless (eq (mp:current-process)
process)
(mp:destroy-process process)))
(defun restart-process (process)
(mp:restart-process process)
(mp:enable-process process)
(mp:process-add-run-reason process :enable))
(defun process-alive-p (process)
(mp:process-alive-p process))
(defun process-join (process)
(error "PROCESS-JOIN not support under CMUCL."))
|
