GopherProxy

	tdefault-implementations.lisp - clic - Clic is an command line interactive clie…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tdefault-implementations.lisp (14739B)
	---
	1 ;;;; -- indent-tabs-mode: nil --
	2
	3 (in-package #:bordeaux-threads)
	4
	5 ;;; Helper macros
	6
	7 (defmacro defdfun (name args doc &body body)
	8 `(eval-when (:compile-toplevel :load-toplevel :execute)
	9 (unless (fboundp ',name)
	10 (defun ,name ,args ,@body))
	11 (setf (documentation ',name 'function)
	12 (or (documentation ',name 'function) ,doc))))
	13
	14 (defmacro defdmacro (name args doc &body body)
	15 `(eval-when (:compile-toplevel :load-toplevel :execute)
	16 (unless (fboundp ',name)
	17 (defmacro ,name ,args ,@body))
	18 (setf (documentation ',name 'function)
	19 (or (documentation ',name 'function) ,doc))))
	20
	21 ;;; Thread Creation
	22
	23 (defdfun start-multiprocessing ()
	24 "If the host implementation uses user-level threads, start the
	25 scheduler and multiprocessing, otherwise do nothing.
	26 It is safe to call repeatedly."
	27 nil)
	28
	29 (defdfun make-thread (function &key name
	30 (initial-bindings default-special-bindings))
	31 "Creates and returns a thread named NAME, which will call the
	32 function FUNCTION with no arguments: when FUNCTION returns, the
	33 thread terminates. NAME defaults to \"Anonymous thread\" if unsupplied.
	34
	35 On systems that do not support multi-threading, MAKE-THREAD will
	36 signal an error.
	37
	38 The interaction between threads and dynamic variables is in some
	39 cases complex, and depends on whether the variable has only a global
	40 binding (as established by e.g. DEFVAR/DEFPARAMETER/top-level SETQ)
	41 or has been bound locally (e.g. with LET or LET*) in the calling
	42 thread.
	43
	44 - Global bindings are shared between threads: the initial value of a
	45 global variable in the new thread will be the same as in the
	46 parent, and an assignment to such a variable in any thread will be
	47 visible to all threads in which the global binding is visible.
	48
	49 - Local bindings, such as the ones introduced by INITIAL-BINDINGS,
	50 are local to the thread they are introduced in, except that
	51
	52 - Local bindings in the the caller of MAKE-THREAD may or may not be
	53 shared with the new thread that it creates: this is
	54 implementation-defined. Portable code should not depend on
	55 particular behaviour in this case, nor should it assign to such
	56 variables without first rebinding them in the new thread."
	57 (%make-thread (binding-default-specials function initial-bindings)
	58 (or name "Anonymous thread")))
	59
	60 (defdfun %make-thread (function name)
	61 "The actual implementation-dependent function that creates threads."
	62 (declare (ignore function name))
	63 (error (make-threading-support-error)))
	64
	65 (defdfun current-thread ()
	66 "Returns the thread object for the calling
	67 thread. This is the same kind of object as would be returned by
	68 MAKE-THREAD."
	69 nil)
	70
	71 (defdfun threadp (object)
	72 "Returns true if object is a thread, otherwise NIL."
	73 (declare (ignore object))
	74 nil)
	75
	76 (defdfun thread-name (thread)
	77 "Returns the name of the thread, as supplied to MAKE-THREAD."
	78 (declare (ignore thread))
	79 "Main thread")
	80
	81 ;;; Resource contention: locks and recursive locks
	82
	83 (defdfun lock-p (object)
	84 "Returns T if OBJECT is a lock; returns NIL otherwise."
	85 (declare (ignore object))
	86 nil)
	87
	88 (defdfun recursive-lock-p (object)
	89 "Returns T if OBJECT is a recursive lock; returns NIL otherwise."
	90 (declare (ignore object))
	91 nil)
	92
	93 (defdfun make-lock (&optional name)
	94 "Creates a lock (a mutex) whose name is NAME. If the system does not
	95 support multiple threads this will still return some object, but it
	96 may not be used for very much."
	97 ;; In CLIM-SYS this is a freshly consed list (NIL). I don't know if
	98 ;; there's some good reason it should be said structure or that it
	99 ;; be freshly consed - EQ comparison of locks?
	100 (declare (ignore name))
	101 (list nil))
	102
	103 (defdfun acquire-lock (lock &optional wait-p)
	104 "Acquire the lock LOCK for the calling thread.
	105 WAIT-P governs what happens if the lock is not available: if WAIT-P
	106 is true, the calling thread will wait until the lock is available
	107 and then acquire it; if WAIT-P is NIL, ACQUIRE-LOCK will return
	108 immediately. ACQUIRE-LOCK returns true if the lock was acquired and
	109 NIL otherwise.
	110
	111 This specification does not define what happens if a thread
	112 attempts to acquire a lock that it already holds. For applications
	113 that require locks to be safe when acquired recursively, see instead
	114 MAKE-RECURSIVE-LOCK and friends."
	115 (declare (ignore lock wait-p))
	116 t)
	117
	118 (defdfun release-lock (lock)
	119 "Release LOCK. It is an error to call this unless
	120 the lock has previously been acquired (and not released) by the same
	121 thread. If other threads are waiting for the lock, the
	122 ACQUIRE-LOCK call in one of them will now be able to continue.
	123
	124 This function has no interesting return value."
	125 (declare (ignore lock))
	126 (values))
	127
	128 (defdmacro with-lock-held ((place) &body body)
	129 "Evaluates BODY with the lock named by PLACE, the value of which
	130 is a lock created by MAKE-LOCK. Before the forms in BODY are
	131 evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the
	132 forms in BODY have been evaluated, or if a non-local control transfer
	133 is caused (e.g. by THROW or SIGNAL), the lock is released as if by
	134 RELEASE-LOCK.
	135
	136 Note that if the debugger is entered, it is unspecified whether the
	137 lock is released at debugger entry or at debugger exit when execution
	138 is restarted."
	139 `(when (acquire-lock ,place t)
	140 (unwind-protect
	141 (locally ,@body)
	142 (release-lock ,place))))
	143
	144 (defdfun make-recursive-lock (&optional name)
	145 "Create and return a recursive lock whose name is NAME. A recursive
	146 lock differs from an ordinary lock in that a thread that already
	147 holds the recursive lock can acquire it again without blocking. The
	148 thread must then release the lock twice before it becomes available
	149 for another thread."
	150 (declare (ignore name))
	151 (list nil))
	152
	153 (defdfun acquire-recursive-lock (lock)
	154 "As for ACQUIRE-LOCK, but for recursive locks."
	155 (declare (ignore lock))
	156 t)
	157
	158 (defdfun release-recursive-lock (lock)
	159 "Release the recursive LOCK. The lock will only
	160 become free after as many Release operations as there have been
	161 Acquire operations. See RELEASE-LOCK for other information."
	162 (declare (ignore lock))
	163 (values))
	164
	165 (defdmacro with-recursive-lock-held ((place &key timeout) &body body)
	166 "Evaluates BODY with the recursive lock named by PLACE, which is a
	167 reference to a recursive lock created by MAKE-RECURSIVE-LOCK. See
	168 WITH-LOCK-HELD etc etc"
	169 (declare (ignore timeout))
	170 `(when (acquire-recursive-lock ,place)
	171 (unwind-protect
	172 (locally ,@body)
	173 (release-recursive-lock ,place))))
	174
	175 ;;; Resource contention: condition variables
	176
	177 ;;; A condition variable provides a mechanism for threads to put
	178 ;;; themselves to sleep while waiting for the state of something to
	179 ;;; change, then to be subsequently woken by another thread which has
	180 ;;; changed the state.
	181 ;;;
	182 ;;; A condition variable must be used in conjunction with a lock to
	183 ;;; protect access to the state of the object of interest. The
	184 ;;; procedure is as follows:
	185 ;;;
	186 ;;; Suppose two threads A and B, and some kind of notional event
	187 ;;; channel C. A is consuming events in C, and B is producing them.
	188 ;;; CV is a condition-variable
	189 ;;;
	190 ;;; 1) A acquires the lock that safeguards access to C
	191 ;;; 2) A threads and removes all events that are available in C
	192 ;;; 3) When C is empty, A calls CONDITION-WAIT, which atomically
	193 ;;; releases the lock and puts A to sleep on CV
	194 ;;; 4) Wait to be notified; CONDITION-WAIT will acquire the lock again
	195 ;;; before returning
	196 ;;; 5) Loop back to step 2, for as long as threading should continue
	197 ;;;
	198 ;;; When B generates an event E, it
	199 ;;; 1) acquires the lock guarding C
	200 ;;; 2) adds E to the channel
	201 ;;; 3) calls CONDITION-NOTIFY on CV to wake any sleeping thread
	202 ;;; 4) releases the lock
	203 ;;;
	204 ;;; To avoid the "lost wakeup" problem, the implementation must
	205 ;;; guarantee that CONDITION-WAIT in thread A atomically releases the
	206 ;;; lock and sleeps. If this is not guaranteed there is the
	207 ;;; possibility that thread B can add an event and call
	208 ;;; CONDITION-NOTIFY between the lock release and the sleep - in this
	209 ;;; case the notify call would not see A, which would be left sleeping
	210 ;;; despite there being an event available.
	211
	212 (defdfun thread-yield ()
	213 "Allows other threads to run. It may be necessary or desirable to
	214 call this periodically in some implementations; others may schedule
	215 threads automatically. On systems that do not support
	216 multi-threading, this does nothing."
	217 (values))
	218
	219 (defdfun make-condition-variable (&key name)
	220 "Returns a new condition-variable object for use
	221 with CONDITION-WAIT and CONDITION-NOTIFY."
	222 (declare (ignore name))
	223 nil)
	224
	225 (defdfun condition-wait (condition-variable lock &key timeout)
	226 "Atomically release LOCK and enqueue the calling
	227 thread waiting for CONDITION-VARIABLE. The thread will resume when
	228 another thread has notified it using CONDITION-NOTIFY; it may also
	229 resume if interrupted by some external event or in other
	230 implementation-dependent circumstances: the caller must always test
	231 on waking that there is threading to be done, instead of assuming
	232 that it can go ahead.
	233
	234 It is an error to call function this unless from the thread that
	235 holds LOCK.
	236
	237 If TIMEOUT is nil or not provided, the system always reacquires LOCK
	238 before returning to the caller. In this case T is returned.
	239
	240 If TIMEOUT is non-nil, the call will return after at most TIMEOUT
	241 seconds (approximately), whether or not a notification has occurred.
	242 Either NIL or T will be returned. A return of NIL indicates that the
	243 lock is no longer held and that the timeout has expired. A return of
	244 T indicates that the lock is held, in which case the timeout may or
	245 may not have expired.
	246
	247 NOTE: The behavior of CONDITION-WAIT with TIMEOUT diverges from
	248 the POSIX function pthread_cond_timedwait. The former may return
	249 without the lock being held while the latter always returns with the
	250 lock held.
	251
	252 In an implementation that does not support multiple threads, this
	253 function signals an error."
	254 (declare (ignore condition-variable lock timeout))
	255 (error (make-threading-support-error)))
	256
	257 (defdfun condition-notify (condition-variable)
	258 "Notify at least one of the threads waiting for
	259 CONDITION-VARIABLE. It is implementation-dependent whether one or
	260 more than one (and possibly all) threads are woken, but if the
	261 implementation is capable of waking only a single thread (not all
	262 are) this is probably preferable for efficiency reasons. The order
	263 of wakeup is unspecified and does not necessarily relate to the
	264 order that the threads went to sleep in.
	265
	266 CONDITION-NOTIFY has no useful return value. In an implementation
	267 that does not support multiple threads, it has no effect."
	268 (declare (ignore condition-variable))
	269 (values))
	270
	271 ;;; Resource contention: semaphores
	272
	273 (defdfun make-semaphore (&key name (count 0))
	274 "Create a semaphore with the supplied NAME and initial counter value…
	275 (make-%semaphore :lock (make-lock name)
	276 :condition-variable (make-condition-variable :name na…
	277 :counter count))
	278
	279 (defdfun signal-semaphore (semaphore &key (count 1))
	280 "Increment SEMAPHORE by COUNT. If there are threads waiting on this
	281 semaphore, then COUNT of them are woken up."
	282 (with-lock-held ((%semaphore-lock semaphore))
	283 (incf (%semaphore-counter semaphore) count)
	284 (dotimes (v count)
	285 (condition-notify (%semaphore-condition-variable semaphore))))
	286 (values))
	287
	288 (defdfun wait-on-semaphore (semaphore &key timeout)
	289 "Decrement the count of SEMAPHORE by 1 if the count would not be negat…
	290
	291 Else blocks until the semaphore can be decremented. Returns generalized …
	292 T on success.
	293
	294 If TIMEOUT is given, it is the maximum number of seconds to wait. If the…
	295 cannot be decremented in that time, returns NIL without decrementing the…
	296 (with-lock-held ((%semaphore-lock semaphore))
	297 (if (>= (%semaphore-counter semaphore) 1)
	298 (decf (%semaphore-counter semaphore))
	299 (let ((deadline (when timeout
	300 (+ (get-internal-real-time)
	301 (* timeout internal-time-units-per-second))…
	302 ;; we need this loop because of a spurious wakeup possibility
	303 (loop until (>= (%semaphore-counter semaphore) 1)
	304 do (cond
	305 ((null (condition-wait (%semaphore-condition-variable …
	306 (%semaphore-lock semaphore)
	307 :timeout timeout))
	308 (return-from wait-on-semaphore))
	309 ;; unfortunately cv-wait may return T on timeout too
	310 ((and deadline (>= (get-internal-real-time) deadline))
	311 (return-from wait-on-semaphore))
	312 (timeout
	313 (setf timeout (/ (- deadline (get-internal-real-time))
	314 internal-time-units-per-second)))))
	315 (decf (%semaphore-counter semaphore))))))
	316
	317 (defdfun semaphore-p (object)
	318 "Returns T if OBJECT is a semaphore; returns NIL otherwise."
	319 (typep object 'semaphore))
	320
	321 ;;; Introspection/debugging
	322
	323 ;;; The following functions may be provided for debugging purposes,
	324 ;;; but are not advised to be called from normal user code.
	325
	326 (defdfun all-threads ()
	327 "Returns a sequence of all of the threads. This may not
	328 be freshly-allocated, so the caller should not modify it."
	329 (error (make-threading-support-error)))
	330
	331 (defdfun interrupt-thread (thread function)
	332 "Interrupt THREAD and cause it to evaluate FUNCTION
	333 before continuing with the interrupted path of execution. This may
	334 not be a good idea if THREAD is holding locks or doing anything
	335 important. On systems that do not support multiple threads, this
	336 function signals an error."
	337 (declare (ignore thread function))
	338 (error (make-threading-support-error)))
	339
	340 (defdfun destroy-thread (thread)
	341 "Terminates the thread THREAD, which is an object
	342 as returned by MAKE-THREAD. This should be used with caution: it is
	343 implementation-defined whether the thread runs cleanup forms or
	344 releases its locks first.
	345
	346 Destroying the calling thread is an error."
	347 (declare (ignore thread))
	348 (error (make-threading-support-error)))
	349
	350 (defdfun thread-alive-p (thread)
	351 "Returns true if THREAD is alive, that is, if
	352 DESTROY-THREAD has not been called on it."
	353 (declare (ignore thread))
	354 (error (make-threading-support-error)))
	355
	356 (defdfun join-thread (thread)
	357 "Wait until THREAD terminates. If THREAD has already terminated,
	358 return immediately. The return values of the thread function are
	359 returned."
	360 (declare (ignore thread))
	361 (error (make-threading-support-error)))