Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv2/api-locks.lisp

KindCoveredAll%
expression588 5.7
branch04 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Base: 10; Package: BORDEAUX-THREADS-2 -*-
2
 ;;;; The above modeline is required for Genera. Do not change.
3
 
4
 (in-package :bordeaux-threads-2)
5
 
6
 (defun native-lock-p (object)
7
   (typep object 'native-lock))
8
 
9
 (defclass lock ()
10
   ((name :initarg :name :reader lock-name)
11
    (native-lock :initarg :native-lock :reader lock-native-lock))
12
   (:documentation "Wrapper for a native non-recursive lock."))
13
 
14
 (defmethod print-object ((lock lock) stream)
15
   (print-unreadable-object (lock stream :type t :identity t)
16
     (format stream "~S" (lock-name lock))))
17
 
18
 (defun lockp (object)
19
   "Returns T if OBJECT is a non-recursive lock; returns NIL otherwise."
20
   (typep object 'lock))
21
 
22
 (defun make-lock (&key name)
23
   "Creates a lock (a mutex) whose name is NAME."
24
   (check-type name (or null string))
25
   (make-instance 'lock
26
                  :name name
27
                  :native-lock (%make-lock name)))
28
 
29
 (defun acquire-lock (lock &key (wait t) timeout)
30
   "Acquire the lock LOCK for the calling thread.
31
 
32
   WAIT governs what happens if the lock is not available: if WAIT
33
   is true, the calling thread will wait until the lock is available
34
   and then acquire it; if WAIT is NIL, ACQUIRE-LOCK will return
35
   immediately.
36
 
37
   If WAIT is true, TIMEOUT may specify a maximum amount of seconds to
38
   wait for the lock to become available.
39
 
40
   ACQUIRE-LOCK returns T if the lock was acquired and NIL
41
   otherwise.
42
 
43
   This specification does not define what happens if a thread
44
   attempts to acquire a lock that it already holds. For applications
45
   that require locks to be safe when acquired recursively, see instead
46
   MAKE-RECURSIVE-LOCK and friends."
47
   (check-type timeout (or null (real 0)))
48
   (%acquire-lock (lock-native-lock lock) (bool wait) timeout))
49
 
50
 (defun release-lock (lock)
51
   "Release LOCK. It is an error to call this unless
52
   the lock has previously been acquired (and not released) by the same
53
   thread. If other threads are waiting for the lock, the
54
   ACQUIRE-LOCK call in one of them will now be able to continue.
55
 
56
   Returns the lock."
57
   (%release-lock (lock-native-lock lock))
58
   lock)
59
 
60
 (defmacro with-lock-held ((place &key timeout)
61
                           &body body &environment env)
62
   "Evaluates BODY with the lock named by PLACE, the value of which
63
   is a lock created by MAKE-LOCK. Before the forms in BODY are
64
   evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the
65
   forms in BODY have been evaluated, or if a non-local control transfer
66
   is caused (e.g. by THROW or SIGNAL), the lock is released as if by
67
   RELEASE-LOCK.
68
 
69
   Note that if the debugger is entered, it is unspecified whether the
70
   lock is released at debugger entry or at debugger exit when execution
71
   is restarted."
72
   (declare (ignorable place timeout))
73
   (if (fboundp '%with-lock)
74
       (macroexpand-1
75
        `(%with-lock ((lock-native-lock ,place) ,timeout)
76
           ,@body)
77
        env)
78
       `(when (acquire-lock ,place :wait t :timeout ,timeout)
79
          (unwind-protect
80
               (locally ,@body)
81
            (release-lock ,place)))))
82
 
83
 (defun native-recursive-lock-p (object)
84
   (typep object 'native-recursive-lock))
85
 
86
 (defclass recursive-lock ()
87
   ((name :initarg :name :reader lock-name)
88
    (native-lock :initarg :native-lock :reader lock-native-lock))
89
   (:documentation "Wrapper for a native recursive lock."))
90
 
91
 (defmethod print-object ((lock recursive-lock) stream)
92
   (print-unreadable-object (lock stream :type t :identity t)
93
     (format stream "~S" (lock-name lock))))
94
 
95
 (defun recursive-lock-p (object)
96
   "Returns T if OBJECT is a recursive lock; returns NIL otherwise."
97
   (typep object 'recursive-lock))
98
 
99
 (defun make-recursive-lock (&key name)
100
   "Create and return a recursive lock whose name is NAME.
101
 
102
   A recursive lock differs from an ordinary lock in that a thread that
103
   already holds the recursive lock can acquire it again without
104
   blocking. The thread must then release the lock twice before it
105
   becomes available for another thread (acquire and release operations
106
   must be balanced)."
107
   (check-type name (or null string))
108
   (make-instance 'recursive-lock
109
                  :name name
110
                  :native-lock (%make-recursive-lock name)))
111
 
112
 (defun acquire-recursive-lock (lock &key (wait t) timeout)
113
   "Acquire the lock LOCK for the calling thread.
114
 
115
   WAIT governs what happens if the lock is not available: if WAIT is
116
   true, the calling thread will wait until the lock is available and
117
   then acquire it; if WAIT is NIL, ACQUIRE-RECURSIVE-LOCK will return
118
   immediately.
119
 
120
   If WAIT is true, TIMEOUT may specify a maximum amount of seconds to
121
   wait for the lock to become available.
122
 
123
   ACQUIRE-LOCK returns true if the lock was acquired and NIL
124
   otherwise.
125
 
126
   This operation will return immediately if the lock is already owned
127
   by the current thread. Acquire and release operations must be
128
   balanced."
129
   (check-type lock recursive-lock)
130
   (check-type timeout (or null (real 0)))
131
   (%acquire-recursive-lock (lock-native-lock lock) (bool wait) timeout))
132
 
133
 (defun release-recursive-lock (lock)
134
   "Release LOCK. It is an error to call this unless
135
   the lock has previously been acquired (and not released) by the same
136
   thread.
137
 
138
   Returns the lock."
139
   (%release-recursive-lock (lock-native-lock lock))
140
   lock)
141
 
142
 (defmacro with-recursive-lock-held ((place &key timeout)
143
                                     &body body &environment env)
144
   "Evaluates BODY with the recursive lock named by PLACE, which is a
145
   reference to a recursive lock created by MAKE-RECURSIVE-LOCK.
146
   See WITH-LOCK-HELD."
147
   (declare (ignorable place timeout))
148
   (if (fboundp '%with-recursive-lock)
149
       (macroexpand-1
150
        `(%with-recursive-lock ((lock-native-lock ,place) ,timeout)
151
           ,@body)
152
        env)
153
       `(when (acquire-recursive-lock ,place :wait t :timeout ,timeout)
154
          (unwind-protect
155
               (locally ,@body)
156
            (release-recursive-lock ,place)))))