GopherProxy

	timpl-genera.lisp - clic - Clic is an command line interactive client for gophe…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	timpl-genera.lisp (4041B)
	---
	1 ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: BORDEAUX-THREADS…
	2
	3 #\|
	4 Distributed under the MIT license (see LICENSE file)
	5 \|#
	6
	7 (in-package #:bordeaux-threads)
	8
	9 (deftype thread ()
	10 'process:process)
	11
	12 ;;; Thread Creation
	13
	14 (defun %make-thread (function name)
	15 (process:process-run-function name function))
	16
	17 (defun current-thread ()
	18 scl:current-process)
	19
	20 (defun threadp (object)
	21 (process:process-p object))
	22
	23 (defun thread-name (thread)
	24 (process:process-name thread))
	25
	26 ;;; Resource contention: locks and recursive locks
	27
	28 (defstruct (lock (:constructor make-lock-internal))
	29 lock
	30 lock-argument)
	31
	32 (defun make-lock (&optional name)
	33 (let ((lock (process:make-lock (or name "Anonymous lock"))))
	34 (make-lock-internal :lock lock
	35 :lock-argument nil)))
	36
	37 (defun acquire-lock (lock &optional (wait-p t))
	38 (check-type lock lock)
	39 (setf (lock-lock-argument lock) (process:make-lock-argument (lock-lock…
	40 (if wait-p
	41 (process:lock (lock-lock lock) (lock-lock-argument lock))
	42 (process:with-no-other-processes
	43 (when (process:lock-lockable-p (lock-lock lock))
	44 (process:lock (lock-lock lock) (lock-lock-argument lock))))))
	45
	46 (defun release-lock (lock)
	47 (check-type lock lock)
	48 (process:unlock (lock-lock lock) (scl:shiftf (lock-lock-argument lock)…
	49
	50 (defmacro with-lock-held ((place) &body body)
	51 `(process:with-lock ((lock-lock ,place))
	52 ,@body))
	53
	54 (defstruct (recursive-lock (:constructor make-recursive-lock-internal))
	55 lock
	56 lock-arguments)
	57
	58 (defun make-recursive-lock (&optional name)
	59 (make-recursive-lock-internal :lock (process:make-lock (or name "Anony…
	60 :recursive t)
	61 :lock-arguments nil))
	62
	63 (defun acquire-recursive-lock (lock)
	64 (check-type lock recursive-lock)
	65 (process:lock (recursive-lock-lock lock)
	66 (car (push (process:make-lock-argument (recursive-lock-l…
	67 (recursive-lock-lock-arguments lock)))))
	68
	69 (defun release-recursive-lock (lock)
	70 (check-type lock recursive-lock)
	71 (process:unlock (recursive-lock-lock lock) (pop (recursive-lock-lock-a…
	72
	73 (defmacro with-recursive-lock-held ((place) &body body)
	74 `(process:with-lock ((recursive-lock-lock ,place))
	75 ,@body))
	76
	77 ;;; Resource contention: condition variables
	78
	79 (eval-when (:compile-toplevel :load-toplevel :execute)
	80 (defstruct (condition-variable (:constructor %make-condition-variable))
	81 name
	82 (waiters nil))
	83 )
	84
	85 (defun make-condition-variable (&key name)
	86 (%make-condition-variable :name name))
	87
	88 (defun condition-wait (condition-variable lock)
	89 (check-type condition-variable condition-variable)
	90 (check-type lock lock)
	91 (process:with-no-other-processes
	92 (let ((waiter (cons scl:current-process nil)))
	93 (process:atomic-updatef (condition-variable-waiters condition-vari…
	94 #'(lambda (waiters)
	95 (append waiters (scl:ncons waiter))))
	96 (process:without-lock ((lock-lock lock))
	97 (process:process-block (format nil "Waiting~@[ on ~A~]"
	98 (condition-variable-name condit…
	99 #'(lambda (waiter)
	100 (not (null (cdr waiter))))
	101 waiter)))))
	102
	103 (defun condition-notify (condition-variable)
	104 (check-type condition-variable condition-variable)
	105 (let ((waiter (process:atomic-pop (condition-variable-waiters conditio…
	106 (when waiter
	107 (setf (cdr waiter) t)
	108 (process:wakeup (car waiter))))
	109 (values))
	110
	111 (defun thread-yield ()
	112 (scl:process-allow-schedule))
	113
	114 ;;; Introspection/debugging
	115
	116 (defun all-threads ()
	117 process:all-processes)
	118
	119 (defun interrupt-thread (thread function &rest args)
	120 (declare (dynamic-extent args))
	121 (apply #'process:process-interrupt thread function args))
	122
	123 (defun destroy-thread (thread)
	124 (signal-error-if-current-thread thread)
	125 (process:process-kill thread :without-aborts :force))
	126
	127 (defun thread-alive-p (thread)
	128 (process:process-active-p thread))
	129
	130 (defun join-thread (thread)
	131 (process:process-wait (format nil "Join ~S" thread)
	132 #'(lambda (thread)
	133 (not (process:process-active-p thread)))
	134 thread))
	135
	136 (mark-supported)