impl-lispworks.lisp - clic - Clic is an command line interactive client for gop… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
impl-lispworks.lisp (4032B) | |
--- | |
1 ;;;; -*- indent-tabs-mode: nil -*- | |
2 | |
3 #| | |
4 Copyright 2006, 2007 Greg Pfeil | |
5 | |
6 Distributed under the MIT license (see LICENSE file) | |
7 |# | |
8 | |
9 (in-package #:bordeaux-threads) | |
10 | |
11 ;;; documentation on the LispWorks Multiprocessing interface can be foun… | |
12 ;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm | |
13 | |
14 (deftype thread () | |
15 'mp:process) | |
16 | |
17 ;;; Thread Creation | |
18 | |
19 (defun start-multiprocessing () | |
20 (mp:initialize-multiprocessing)) | |
21 | |
22 (defun %make-thread (function name) | |
23 (mp:process-run-function | |
24 name nil | |
25 (lambda () | |
26 (let ((return-values | |
27 (multiple-value-list (funcall function)))) | |
28 (setf (mp:process-property 'return-values) | |
29 return-values) | |
30 (values-list return-values))))) | |
31 | |
32 (defun current-thread () | |
33 #-#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(a… | |
34 mp:*current-process* | |
35 ;; introduced in LispWorks 5.1 | |
36 #+#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(a… | |
37 (mp:get-current-process)) | |
38 | |
39 (defun threadp (object) | |
40 (mp:process-p object)) | |
41 | |
42 (defun thread-name (thread) | |
43 (mp:process-name thread)) | |
44 | |
45 ;;; Resource contention: locks and recursive locks | |
46 | |
47 | |
48 (deftype lock () 'mp:lock) | |
49 | |
50 #-(or lispworks4 lispworks5) | |
51 (deftype recursive-lock () | |
52 '(and mp:lock (satisfies mp:lock-recursive-p))) | |
53 | |
54 (defun lock-p (object) | |
55 (typep object 'mp:lock)) | |
56 | |
57 (defun recursive-lock-p (object) | |
58 #+(or lispworks4 lispworks5) | |
59 nil | |
60 #-(or lispworks4 lispworks5) ; version 6+ | |
61 (and (typep object 'mp:lock) | |
62 (mp:lock-recursive-p object))) | |
63 | |
64 (defun make-lock (&optional name) | |
65 (mp:make-lock :name (or name "Anonymous lock") | |
66 #-(or lispworks4 lispworks5) :recursivep | |
67 #-(or lispworks4 lispworks5) nil)) | |
68 | |
69 (defun acquire-lock (lock &optional (wait-p t)) | |
70 (mp:process-lock lock nil | |
71 (cond ((null wait-p) 0) | |
72 ((numberp wait-p) wait-p) | |
73 (t nil)))) | |
74 | |
75 (defun release-lock (lock) | |
76 (mp:process-unlock lock)) | |
77 | |
78 (defmacro with-lock-held ((place) &body body) | |
79 `(mp:with-lock (,place) ,@body)) | |
80 | |
81 (defun make-recursive-lock (&optional name) | |
82 (mp:make-lock :name (or name "Anonymous recursive lock") | |
83 #-(or lispworks4 lispworks5) :recursivep | |
84 #-(or lispworks4 lispworks5) t)) | |
85 | |
86 (defun acquire-recursive-lock (lock &optional (wait-p t)) | |
87 (acquire-lock lock wait-p)) | |
88 | |
89 (defun release-recursive-lock (lock) | |
90 (release-lock lock)) | |
91 | |
92 (defmacro with-recursive-lock-held ((place) &body body) | |
93 `(mp:with-lock (,place) ,@body)) | |
94 | |
95 ;;; Resource contention: condition variables | |
96 | |
97 #+(or lispworks6 lispworks7) | |
98 (defun make-condition-variable (&key name) | |
99 (mp:make-condition-variable :name (or name "Anonymous condition variab… | |
100 | |
101 #+(or lispworks6 lispworks7) | |
102 (defun condition-wait (condition-variable lock &key timeout) | |
103 (mp:condition-variable-wait condition-variable lock :timeout timeout) | |
104 t) | |
105 | |
106 #+(or lispworks6 lispworks7) | |
107 (defun condition-notify (condition-variable) | |
108 (mp:condition-variable-signal condition-variable)) | |
109 | |
110 (defun thread-yield () | |
111 (mp:process-allow-scheduling)) | |
112 | |
113 ;;; Introspection/debugging | |
114 | |
115 (defun all-threads () | |
116 (mp:list-all-processes)) | |
117 | |
118 (defun interrupt-thread (thread function &rest args) | |
119 (apply #'mp:process-interrupt thread function args)) | |
120 | |
121 (defun destroy-thread (thread) | |
122 (signal-error-if-current-thread thread) | |
123 (mp:process-kill thread)) | |
124 | |
125 (defun thread-alive-p (thread) | |
126 (mp:process-alive-p thread)) | |
127 | |
128 (declaim (inline %join-thread)) | |
129 (defun %join-thread (thread) | |
130 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(o… | |
131 (mp:process-wait (format nil "Waiting for thread ~A to complete" threa… | |
132 (complement #'mp:process-alive-p) | |
133 thread) | |
134 #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(o… | |
135 (mp:process-join thread)) | |
136 | |
137 (defun join-thread (thread) | |
138 (%join-thread thread) | |
139 (let ((return-values | |
140 (mp:process-property 'return-values thread))) | |
141 (values-list return-values))) | |
142 | |
143 (mark-supported) |