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
|
;; mutex.jl -- thread mutex devices
;; Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
;; $Id: mutex.jl,v 1.7 2001/08/03 03:13:08 jsh Exp $
;; This file is part of librep.
;; librep is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; librep 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 General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with librep; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(define-structure rep.threads.mutex
(export make-mutex
mutexp
obtain-mutex
maybe-obtain-mutex
release-mutex)
(open rep
rep.threads
rep.threads.utils)
(define-structure-alias mutex rep.threads.mutex)
;; Each mutex is (mutex [OWNING-THREAD [BLOCKED-THREADS...]])
(defun make-mutex ()
"Create and return a mutex object. No thread will own the new mutex."
(list 'mutex))
(defun mutexp (arg)
"Returns true if ARG is a mutex object."
(eq (car arg) 'mutex))
(defun obtain-mutex (mtx #!optional timeout)
"Obtain the mutex MTX for the current thread. Will suspend the current
thread until the mutex is available. Returns false if the timeout expired."
(without-interrupts
(if (null (cdr mtx))
(rplacd mtx (list (current-thread)))
(rplacd mtx (nconc (cdr mtx) (list (current-thread))))
(not (thread-suspend (current-thread) timeout)))))
(defun maybe-obtain-mutex (mtx)
"Attempt to obtain mutex MTX for the current thread without blocking.
Returns true if able to obtain the mutex, false otherwise."
(without-interrupts
(if (cdr mtx)
nil
(obtain-mutex mtx)
t)))
(defun release-mutex (mtx)
"Release the mutex object MTX (which should have previously been obtained
by the current thread). Returns true if the mutex has no new owner."
(or (eq (cadr mtx) (current-thread))
(error "Not owner of mutex: %S" mtx))
(without-interrupts
(rplacd mtx (cddr mtx))
(if (cdr mtx)
(progn
(thread-wake (cadr mtx))
nil)
t))))
|
