Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv1/impl-sbcl.lisp

Kind	Covered	All	%
expression	4	112	3.6
branch	0	2	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; -*- indent-tabs-mode: nil -*-

2

3

#|

4

5

6

Distributed under the MIT license (see LICENSE file)

7

|#

8

9

(in-package #:bordeaux-threads)

10

11

;;; documentation on the SBCL Threads interface can be found at

12

;;; http://www.sbcl.org/manual/Threading.html

13

14

(deftype thread ()

15

'sb-thread:thread)

16

17

;;; Thread Creation

18

19

(defun %make-thread (function name)

20

(sb-thread:make-thread function :name name))

21

22

(defun current-thread ()

23

sb-thread:*current-thread*)

24

25

(defun threadp (object)

26

(typep object 'sb-thread:thread))

27

28

(defun thread-name (thread)

29

(sb-thread:thread-name thread))

30

31

;;; Resource contention: locks and recursive locks

32

33

(deftype lock () 'sb-thread:mutex)

34

35

(deftype recursive-lock () 'sb-thread:mutex)

36

37

(defun lock-p (object)

38

(typep object 'sb-thread:mutex))

39

40

(defun recursive-lock-p (object)

41

(typep object 'sb-thread:mutex))

42

43

(defun make-lock (&optional name)

44

(sb-thread:make-mutex :name (or name "Anonymous lock")))

45

46

(defun acquire-lock (lock &optional (wait-p t))

47

#+#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or))

48

(sb-thread:grab-mutex lock :waitp wait-p)

49

#-#.(cl:if (cl:find-symbol (cl:string '#:grab-mutex) :sb-thread) '(and) '(or))

50

(sb-thread:get-mutex lock nil wait-p))

51

52

(defun release-lock (lock)

53

(sb-thread:release-mutex lock))

54

55

(defmacro with-lock-held ((place) &body body)

56

`(sb-thread:with-mutex (,place) ,@body))

57

58

(defun make-recursive-lock (&optional name)

59

(sb-thread:make-mutex :name (or name "Anonymous recursive lock")))

60

61

;;; XXX acquire-recursive-lock and release-recursive-lock are actually

62

;;; complicated because we can't use control stack tricks. We need to

63

;;; actually count something to check that the acquire/releases are

64

;;; balanced

65

66

(defmacro with-recursive-lock-held ((place) &body body)

67

`(sb-thread:with-recursive-lock (,place)

68

,@body))

69

70

;;; Resource contention: condition variables

71

72

(defun make-condition-variable (&key name)

73

(sb-thread:make-waitqueue :name (or name "Anonymous condition variable")))

74

75

(defun condition-wait (condition-variable lock &key timeout)

76

(let ((success

77

(sb-thread:condition-wait condition-variable lock :timeout timeout)))

78

(when (not success)

79

(acquire-lock lock))

80

success))

81

82

(defun condition-notify (condition-variable)

83

(sb-thread:condition-notify condition-variable))

84

85

(defun thread-yield ()

86

(sb-thread:thread-yield))

87

88

;;; Timeouts

89

90

(deftype timeout ()

91

'sb-ext:timeout)

92

93

(defmacro with-timeout ((timeout) &body body)

94

`(sb-ext:with-timeout ,timeout

95

,@body))

96

97

;;; Semaphores

98

99

(deftype semaphore ()

100

'sb-thread:semaphore)

101

102

(defun make-semaphore (&key name (count 0))

103

(sb-thread:make-semaphore :name name :count count))

104

105

(defun signal-semaphore (semaphore &key (count 1))

106

(sb-thread:signal-semaphore semaphore count))

107

108

(defun wait-on-semaphore (semaphore &key timeout)

109

(sb-thread:wait-on-semaphore semaphore :timeout timeout))

110

111

;;; Introspection/debugging

112

113

(defun all-threads ()

114

(sb-thread:list-all-threads))

115

116

(defun interrupt-thread (thread function &rest args)

117

(flet ((apply-function ()

118

(if args

119

(named-lambda %interrupt-thread-wrapper ()

120

(apply function args))

121

function)))

122

(declare (dynamic-extent #'apply-function))

123

(sb-thread:interrupt-thread thread (apply-function))))

124

125

(defun destroy-thread (thread)

126

(signal-error-if-current-thread thread)

127

(sb-thread:terminate-thread thread))

128

129

(defun thread-alive-p (thread)

130

(sb-thread:thread-alive-p thread))

131

132

(defun join-thread (thread)

133

(sb-thread:join-thread thread))

134

135

(mark-supported)