impl-scl.lisp - clic - Clic is an command line interactive client for gopher wr… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
impl-scl.lisp (2681B) | |
--- | |
1 ;;;; -*- indent-tabs-mode: nil -*- | |
2 | |
3 #| | |
4 Copyright 2008 Scieneer Pty Ltd | |
5 | |
6 Distributed under the MIT license (see LICENSE file) | |
7 |# | |
8 | |
9 (in-package #:bordeaux-threads) | |
10 | |
11 (deftype thread () | |
12 'thread:thread) | |
13 | |
14 (defun %make-thread (function name) | |
15 (thread:thread-create function :name name)) | |
16 | |
17 (defun current-thread () | |
18 thread:*thread*) | |
19 | |
20 (defun threadp (object) | |
21 (typep object 'thread:thread)) | |
22 | |
23 (defun thread-name (thread) | |
24 (thread:thread-name thread)) | |
25 | |
26 ;;; Resource contention: locks and recursive locks | |
27 | |
28 (deftype lock () 'thread:lock) | |
29 | |
30 (deftype recursive-lock () 'thread:recursive-lock) | |
31 | |
32 (defun lock-p (object) | |
33 (typep object 'thread:lock)) | |
34 | |
35 (defun recursive-lock-p (object) | |
36 (typep object 'thread:recursive-lock)) | |
37 | |
38 (defun make-lock (&optional name) | |
39 (thread:make-lock (or name "Anonymous lock"))) | |
40 | |
41 (defun acquire-lock (lock &optional (wait-p t)) | |
42 (thread::acquire-lock lock nil wait-p)) | |
43 | |
44 (defun release-lock (lock) | |
45 (thread::release-lock lock)) | |
46 | |
47 (defmacro with-lock-held ((place) &body body) | |
48 `(thread:with-lock-held (,place) ,@body)) | |
49 | |
50 (defun make-recursive-lock (&optional name) | |
51 (thread:make-lock (or name "Anonymous recursive lock") | |
52 :type :recursive)) | |
53 | |
54 ;;; XXX acquire-recursive-lock and release-recursive-lock are actually | |
55 ;;; complicated because we can't use control stack tricks. We need to | |
56 ;;; actually count something to check that the acquire/releases are | |
57 ;;; balanced | |
58 | |
59 (defmacro with-recursive-lock-held ((place) &body body) | |
60 `(thread:with-lock-held (,place) | |
61 ,@body)) | |
62 | |
63 ;;; Resource contention: condition variables | |
64 | |
65 (defun make-condition-variable (&key name) | |
66 (thread:make-cond-var (or name "Anonymous condition variable"))) | |
67 | |
68 (defun condition-wait (condition-variable lock &key timeout) | |
69 (if timeout | |
70 (thread:cond-var-timedwait condition-variable lock timeout) | |
71 (thread:cond-var-wait condition-variable lock)) | |
72 t) | |
73 | |
74 (defun condition-notify (condition-variable) | |
75 (thread:cond-var-broadcast condition-variable)) | |
76 | |
77 (defun thread-yield () | |
78 (mp:process-yield)) | |
79 | |
80 ;;; Introspection/debugging | |
81 | |
82 (defun all-threads () | |
83 (mp:all-processes)) | |
84 | |
85 (defun interrupt-thread (thread function &rest args) | |
86 (flet ((apply-function () | |
87 (if args | |
88 (lambda () (apply function args)) | |
89 function))) | |
90 (declare (dynamic-extent #'apply-function)) | |
91 (thread:thread-interrupt thread (apply-function)))) | |
92 | |
93 (defun destroy-thread (thread) | |
94 (thread:destroy-thread thread)) | |
95 | |
96 (defun thread-alive-p (thread) | |
97 (mp:process-alive-p thread)) | |
98 | |
99 (defun join-thread (thread) | |
100 (mp:process-wait (format nil "Waiting for thread ~A to complete" threa… | |
101 (lambda () (not (mp:process-alive-p thread))))) | |
102 | |
103 (mark-supported) |