Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 479 lines (390 sloc) 15.77 kB
fab0b31 Add multiprocessing support.
Helmut Eller authored
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
f912c9c New file.
Helmut Eller authored
2 ;;;
3 ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4 ;;;
5 ;;; Created 2003, Helmut Eller
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
8 ;;; are disclaimed. This code was written for "Allegro CL Trial
9 ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
f912c9c New file.
Helmut Eller authored
10 ;;;
11
8052a9e Minor modifications.
Helmut Eller authored
12 (in-package :swank-backend)
13
f912c9c New file.
Helmut Eller authored
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require :sock)
aa65d6e Implemented.
Luke Gorrie authored
16 (require :process)
17
18 (import
19 '(excl:fundamental-character-output-stream
20 excl:stream-write-char
21 excl:stream-force-output
22 excl:fundamental-character-input-stream
23 excl:stream-read-char
24 excl:stream-listen
25 excl:stream-unread-char
26 excl:stream-clear-input
27 excl:stream-line-column
28 excl:stream-read-char-no-hang)))
f912c9c New file.
Helmut Eller authored
29
fab0b31 Add multiprocessing support.
Helmut Eller authored
30 ;;;; TCP Server
f912c9c New file.
Helmut Eller authored
31
8052a9e Minor modifications.
Helmut Eller authored
32 (defimplementation preferred-communication-style ()
33 :spawn)
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
34
39861f4 (create-socket): Take interface as argument.
Helmut Eller authored
35 (defimplementation create-socket (host port)
36 (socket:make-socket :connect :passive :local-port port
37 :local-host host :reuse-address t))
bba6c65 (format-condition-for-emacs): Replaced with debugger-condition-for-em…
Helmut Eller authored
38
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
39 (defimplementation local-port (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
40 (socket:local-port socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
41
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
42 (defimplementation close-socket (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
43 (close socket))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
44
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
45 (defimplementation accept-connection (socket)
7b493c0 (create-socket, local-port, close-socket, accept-connection)
Helmut Eller authored
46 (socket:accept-connection socket :wait t))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
47
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
48 ;; The following defitinions are workarounds for the buggy
49 ;; no-applicable-method function in Allegro 5. We have to provide an
50 ;; implementation.
0aa2d02 (emacs-connected): Pass the redirected stream as argument, so that the
Helmut Eller authored
51 (defimplementation emacs-connected (stream)
c153745 (make-stream-interactive): Set interactive-stream-p slot on the stream
Luke Gorrie authored
52 (declare (ignore stream))
53 (install-advice))
139b96f (excl:stream-read-char-no-hang): Import it.
Helmut Eller authored
54
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
55 (defimplementation format-sldb-condition (c)
56 (princ-to-string c))
57
58 (defimplementation condition-references (c)
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
59 (declare (ignore c))
58bc7fb (format-sldb-condition, condition-references): Add workarounds for
Helmut Eller authored
60 '())
61
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
62 (defimplementation call-with-syntax-hooks (fn)
63 (funcall fn))
64
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
65 ;;;; Unix signals
66
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
67 (defimplementation call-without-interrupts (fn)
6fa3b33 (arglist-string): Refactor common code to swank.lisp.
Helmut Eller authored
68 (excl:without-interrupts (funcall fn)))
69
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
70 (defimplementation getpid ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
71 (excl::getpid))
72
6827452 (lisp-implementation-type-name): Implement it.
Helmut Eller authored
73 (defimplementation lisp-implementation-type-name ()
74 "allegro")
75
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
76 (defimplementation set-default-directory (directory)
77 (excl:chdir directory)
bbc42ef (find-fspec-location): Better handling of methods. Reported by Bill
Helmut Eller authored
78 (namestring (setf *default-pathname-defaults*
79 (truename (merge-pathnames directory)))))
38b61c2 Allegro specific version of set-default-directory
Peter Seibel authored
80
167a03c (default-directory, call-with-syntax-hooks): Add implementations as
Helmut Eller authored
81 (defimplementation default-directory ()
82 (excl:chdir))
83
fab0b31 Add multiprocessing support.
Helmut Eller authored
84 ;;;; Misc
f912c9c New file.
Helmut Eller authored
85
8052a9e Minor modifications.
Helmut Eller authored
86 (defimplementation arglist (symbol)
d589600 (arglist): Return :not-available if arglist lookup fails with an
Luke Gorrie authored
87 (handler-case (excl:arglist symbol)
88 (simple-error () :not-available)))
8052a9e Minor modifications.
Helmut Eller authored
89
90 (defimplementation macroexpand-all (form)
91 (excl::walk form))
f912c9c New file.
Helmut Eller authored
92
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
93 (defimplementation describe-symbol-for-emacs (symbol)
f912c9c New file.
Helmut Eller authored
94 (let ((result '()))
95 (flet ((doc (kind &optional (sym symbol))
96 (or (documentation sym kind) :not-documented))
97 (maybe-push (property value)
98 (when value
99 (setf result (list* property value result)))))
100 (maybe-push
101 :variable (when (boundp symbol)
102 (doc 'variable)))
103 (maybe-push
104 :function (if (fboundp symbol)
105 (doc 'function)))
106 (maybe-push
107 :class (if (find-class symbol nil)
108 (doc 'class)))
109 result)))
110
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
111 (defimplementation describe-definition (symbol namespace)
112 (ecase namespace
113 (:variable
114 (describe symbol))
115 ((:function :generic-function)
116 (describe (symbol-function symbol)))
117 (:class
118 (describe (find-class symbol)))))
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
119
c153745 (make-stream-interactive): Set interactive-stream-p slot on the stream
Luke Gorrie authored
120 (defimplementation make-stream-interactive (stream)
121 (setf (interactive-stream-p stream) t))
122
fab0b31 Add multiprocessing support.
Helmut Eller authored
123 ;;;; Debugger
124
f912c9c New file.
Helmut Eller authored
125 (defvar *sldb-topframe*)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
126
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
127 (defimplementation call-with-debugging-environment (debugger-loop-fn)
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
128 (let ((*sldb-topframe* (excl::int-newest-frame))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
129 (excl::*break-hook* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
130 (funcall debugger-loop-fn)))
f912c9c New file.
Helmut Eller authored
131
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
132 (defun next-frame (frame)
133 (let ((next (excl::int-next-older-frame frame)))
134 (cond ((not next) nil)
135 ((debugger:frame-visible-p next) next)
136 (t (next-frame next)))))
137
f912c9c New file.
Helmut Eller authored
138 (defun nth-frame (index)
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
139 (do ((frame *sldb-topframe* (next-frame frame))
f912c9c New file.
Helmut Eller authored
140 (i index (1- i)))
141 ((zerop i) frame)))
142
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
143 (defimplementation compute-backtrace (start end)
f912c9c New file.
Helmut Eller authored
144 (let ((end (or end most-positive-fixnum)))
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
145 (loop for f = (nth-frame start) then (next-frame f)
f912c9c New file.
Helmut Eller authored
146 for i from start below end
147 while f
3dc039d (nth-frame): Skip frames where frame-visible-p is false.
Helmut Eller authored
148 collect f)))
f912c9c New file.
Helmut Eller authored
149
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
150 (defimplementation print-frame (frame stream)
151 (debugger:output-frame stream frame :moderate))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
152
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
153 (defimplementation frame-locals (index)
f912c9c New file.
Helmut Eller authored
154 (let ((frame (nth-frame index)))
155 (loop for i from 0 below (debugger:frame-number-vars frame)
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
156 collect (list :name (debugger:frame-var-name frame i)
f912c9c New file.
Helmut Eller authored
157 :id 0
de3dd96 See ChangeLog entry 2004-03-05 Marco Baringer
Marco Baringer authored
158 :value (debugger:frame-var-value frame i)))))
f912c9c New file.
Helmut Eller authored
159
2b0dd28 (frame-var-value): New backend function.
Helmut Eller authored
160 (defimplementation frame-var-value (frame var)
161 (let ((frame (nth-frame frame)))
162 (debugger:frame-var-value frame var)))
163
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
164 (defimplementation frame-catch-tags (index)
f912c9c New file.
Helmut Eller authored
165 (declare (ignore index))
166 nil)
167
8052a9e Minor modifications.
Helmut Eller authored
168 (defimplementation disassemble-frame (index)
169 (disassemble (debugger:frame-function (nth-frame index))))
170
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
171 (defimplementation frame-source-location-for-emacs (index)
33236b4 From Matthew Danish:
Luke Gorrie authored
172 (let* ((frame (nth-frame index))
173 (expr (debugger:frame-expression frame))
174 (fspec (first expr)))
175 (second (first (fspec-definition-locations fspec)))))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
176
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
177 (defimplementation eval-in-frame (form frame-number)
178 (debugger:eval-form-in-context
179 form
180 (debugger:environment-of-frame (nth-frame frame-number))))
181
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
182 (defimplementation return-from-frame (frame-number form)
183 (let ((frame (nth-frame frame-number)))
184 (multiple-value-call #'debugger:frame-return
185 frame (debugger:eval-form-in-context
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
186 form
187 (debugger:environment-of-frame frame)))))
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
188
8052a9e Minor modifications.
Helmut Eller authored
189 ;;; XXX doesn't work for frames with arguments
4303a24 (return-from-frame, restart-name): Implement interface (partly).
Helmut Eller authored
190 (defimplementation restart-frame (frame-number)
191 (let ((frame (nth-frame frame-number)))
192 (debugger:frame-retry frame (debugger:frame-function frame))))
193
fab0b31 Add multiprocessing support.
Helmut Eller authored
194 ;;;; Compiler hooks
195
f912c9c New file.
Helmut Eller authored
196 (defvar *buffer-name* nil)
197 (defvar *buffer-start-position*)
198 (defvar *buffer-string*)
aa65d6e Implemented.
Luke Gorrie authored
199 (defvar *compile-filename* nil)
f912c9c New file.
Helmut Eller authored
200
201 (defun handle-compiler-warning (condition)
202 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
203 (signal (make-condition
204 'compiler-condition
205 :original-condition condition
206 :severity :warning
207 :message (format nil "~A" condition)
208 :location (cond (*buffer-name*
209 (make-location
210 (list :buffer *buffer-name*)
211 (list :position *buffer-start-position*)))
212 (loc
213 (destructuring-bind (file . pos) loc
214 (make-location
215 (list :file (namestring (truename file)))
216 (list :position (1+ pos)))))
aa65d6e Implemented.
Luke Gorrie authored
217 (*compile-filename*
f912c9c New file.
Helmut Eller authored
218 (make-location
219 (list :file *compile-filename*)
aa65d6e Implemented.
Luke Gorrie authored
220 (list :position 1)))
221 (t
222 (list :error "No error location available.")))))))
f912c9c New file.
Helmut Eller authored
223
aa65d6e Implemented.
Luke Gorrie authored
224 (defimplementation call-with-compilation-hooks (function)
f912c9c New file.
Helmut Eller authored
225 (handler-bind ((warning #'handle-compiler-warning))
aa65d6e Implemented.
Luke Gorrie authored
226 (funcall function)))
227
228 (defimplementation swank-compile-file (*compile-filename* load-p)
229 (with-compilation-hooks ()
f912c9c New file.
Helmut Eller authored
230 (let ((*buffer-name* nil))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
231 (compile-file *compile-filename* :load-after-compile load-p))))
f912c9c New file.
Helmut Eller authored
232
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
233 (defun call-with-temp-file (fn)
234 (let ((tmpname (system:make-temp-file-name)))
235 (unwind-protect
236 (with-open-file (file tmpname :direction :output :if-exists :error)
237 (funcall fn file tmpname))
238 (delete-file tmpname))))
239
240 (defun compile-from-temp-file (string)
241 (call-with-temp-file
242 (lambda (stream filename)
243 (write-string string stream)
244 (finish-output stream)
245 (let ((binary-filename (compile-file filename :load-after-compile t)))
246 (when binary-filename
247 (delete-file binary-filename))))))
248
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
249 (defimplementation swank-compile-string (string &key buffer position)
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
250 ;; We store the source buffer in excl::*source-pathname* as a string
251 ;; of the form <buffername>:<start-offset>. Quite ugly encoding, but
252 ;; the fasl file is corrupted if we use some other datatype.
aa65d6e Implemented.
Luke Gorrie authored
253 (with-compilation-hooks ()
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
254 (let ((*buffer-name* buffer)
f912c9c New file.
Helmut Eller authored
255 (*buffer-start-position* position)
256 (*buffer-string* string))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
257 (compile-from-temp-file
258 (format nil "~S ~S~%~A"
259 `(in-package ,(package-name *package*))
260 `(eval-when (:compile-toplevel :load-toplevel)
261 (setq excl::*source-pathname*
262 (format nil "~A:~D" ',buffer ',position)))
263 string)))))
f912c9c New file.
Helmut Eller authored
264
fab0b31 Add multiprocessing support.
Helmut Eller authored
265 ;;;; Definition Finding
266
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
267 (defun fspec-primary-name (fspec)
268 (etypecase fspec
269 (symbol (string fspec))
270 (list (string (second fspec)))))
271
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
272 (defun find-fspec-location (fspec type)
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
273 (let ((file (excl:source-file fspec)))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
274 (etypecase file
275 (pathname
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
276 (let* ((start (scm:find-definition-in-file fspec type file))
277 (pos (if start
278 (list :position (1+ start))
279 (list :function-name (fspec-primary-name fspec)))))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
280 (make-location (list :file (namestring (truename file)))
56d2e6d (fspec-primary-name): New function.
Helmut Eller authored
281 pos)))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
282 ((member :top-level)
283 (list :error (format nil "Defined at toplevel: ~A" fspec)))
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
284 (string
285 (let ((pos (position #\: file)))
286 (make-location
287 (list :buffer (subseq file 0 pos))
288 (list :position (parse-integer (subseq file (1+ pos)))))))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
289 (null
33236b4 From Matthew Danish:
Luke Gorrie authored
290 (list :error (format nil "Unknown source location for ~A" fspec))))))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
291
437f909 Remove stupid conflicts.
Helmut Eller authored
292 (defun fspec-definition-locations (fspec)
f912c9c New file.
Helmut Eller authored
293 (let ((defs (excl::find-multiple-definitions fspec)))
8052a9e Minor modifications.
Helmut Eller authored
294 (loop for (fspec type) in defs
295 collect (list fspec (find-fspec-location fspec type)))))
296
297 (defimplementation find-definitions (symbol)
298 (fspec-definition-locations symbol))
fab0b31 Add multiprocessing support.
Helmut Eller authored
299
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
300 ;;;; XREF
f912c9c New file.
Helmut Eller authored
301
8052a9e Minor modifications.
Helmut Eller authored
302 (defmacro defxref (name relation name1 name2)
303 `(defimplementation ,name (x)
304 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
305
306 (defxref who-calls :calls :wild x)
307 (defxref who-references :uses :wild x)
308 (defxref who-binds :binds :wild x)
309 (defxref who-macroexpands :macro-calls :wild x)
310 (defxref who-sets :sets :wild x)
311 (defxref list-callees :calls x :wild)
312
313 (defun xref-result (fspecs)
314 (loop for fspec in fspecs
315 append (fspec-definition-locations fspec)))
c9ef56e (create-swank-server): Add support for BACKGROUND and CLOSE argument.
Helmut Eller authored
316
1a07e24 (swank-compile-string): Use a temporary file and set
Helmut Eller authored
317 ;; list-callers implemented by groveling through all fbound symbols.
318 ;; Only symbols are considered. Functions in the constant pool are
319 ;; searched recursevly. Closure environments are ignored at the
320 ;; moment (constants in methods are therefore not found).
321
322 (defun map-function-constants (function fn depth)
323 "Call FN with the elements of FUNCTION's constant pool."
324 (do ((i 0 (1+ i))
325 (max (excl::function-constant-count function)))
326 ((= i max))
327 (let ((c (excl::function-constant function i)))
328 (cond ((and (functionp c)
329 (not (eq c function))
330 (plusp depth))
331 (map-function-constants c fn (1- depth)))
332 (t
333 (funcall fn c))))))
334
335 (defun in-constants-p (fn symbol)
336 (map-function-constants
337 fn
338 (lambda (c) (if (eq c symbol) (return-from in-constants-p t)))
339 3))
340
341 (defun function-callers (name)
342 (let ((callers '()))
343 (do-all-symbols (sym)
344 (when (fboundp sym)
345 (let ((fn (fdefinition sym)))
346 (when (in-constants-p fn name)
347 (push sym callers)))))
348 callers))
349
350 (defimplementation list-callers (name)
351 (xref-result (function-callers name)))
352
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
353 ;;;; Inspecting
354
355 (defmethod inspected-parts (o)
356 (let* ((class (class-of o))
357 (slots (clos:class-slots class)))
358 (values (format nil "~A~% is a ~A" o class)
359 (mapcar (lambda (slot)
360 (let ((name (clos:slot-definition-name slot)))
c2d3f88 Implement changed backend interface and remove references to front en…
Helmut Eller authored
361 (cons (princ-to-string name)
32e42f9 Use `unbound-slot-filler' for unbound inspector slots.
Luke Gorrie authored
362 (if (slot-boundp o name)
363 (slot-value o name)
364 (make-unbound-slot-filler)))))
aeada84 (thread-alive-p): Add default implementation.
Helmut Eller authored
365 slots))))
366
367 ;;;; Multithreading
fab0b31 Add multiprocessing support.
Helmut Eller authored
368
c153745 (make-stream-interactive): Set interactive-stream-p slot on the stream
Luke Gorrie authored
369 (defvar *swank-thread* nil
370 "Bound to true in any thread with an ancestor created by SPAWN.
371 Such threads always use Emacs for debugging and user interaction.")
372
373 (defvar *inherited-bindings*
374 '(*debugger-hook*
375 *standard-output* *error-output* *trace-output*
376 *standard-input*
377 *debug-io* *query-io* *terminal-io*)
378 "Variables whose values are inherited by children of Swank threads.")
379
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
380 (defimplementation startup-multiprocessing ()
fab0b31 Add multiprocessing support.
Helmut Eller authored
381 (mp:start-scheduler))
382
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
383 (defimplementation spawn (fn &key name)
c153745 (make-stream-interactive): Set interactive-stream-p slot on the stream
Luke Gorrie authored
384 (mp:process-run-function name
385 (lambda ()
386 (let ((*swank-thread* t))
387 (funcall fn)))))
388
bc2e761 *** empty log message ***
Luke Gorrie authored
389 #+(version>= 6)
c153745 (make-stream-interactive): Set interactive-stream-p slot on the stream
Luke Gorrie authored
390 (excl:def-fwrapper make-process/inherit (&key &allow-other-keys)
391 "Advice for MP:MAKE-PROCESS.
392 New threads that have a Swank thread for an ancestor will inherit
393 debugging and I/O bindings from their parent."
394 (let ((process (excl:call-next-fwrapper)))
395 (when *swank-thread*
396 (push (cons '*swank-thread* t)
397 (mp:process-initial-bindings process))
398 (dolist (variable *inherited-bindings*)
399 (push (cons variable (symbol-value variable))
400 (mp:process-initial-bindings process))))
401 process))
402
403 (defun install-advice ()
bc2e761 *** empty log message ***
Luke Gorrie authored
404 #+(version>= 6)
c153745 (make-stream-interactive): Set interactive-stream-p slot on the stream
Luke Gorrie authored
405 (excl:fwrap 'mp:make-process 'make-process/inherit 'make-process/inherit))
fab0b31 Add multiprocessing support.
Helmut Eller authored
406
12da821 (thread-id, find-thread): New backend function.
Helmut Eller authored
407 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
408 (defvar *thread-id-counter* 0)
409
410 (defimplementation thread-id (thread)
411 (mp:with-process-lock (*id-lock*)
412 (or (getf (mp:process-property-list thread) 'id)
413 (setf (getf (mp:process-property-list thread) 'id)
414 (incf *thread-id-counter*)))))
415
416 (defimplementation find-thread (id)
417 (find id mp:*all-processes*
418 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
419
64ff730 Update for modified thread interface.
Helmut Eller authored
420 (defimplementation thread-name (thread)
421 (mp:process-name thread))
fab0b31 Add multiprocessing support.
Helmut Eller authored
422
64ff730 Update for modified thread interface.
Helmut Eller authored
423 (defimplementation thread-status (thread)
424 (format nil "~A ~D" (mp:process-whostate thread)
425 (mp:process-priority thread)))
fab0b31 Add multiprocessing support.
Helmut Eller authored
426
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
427 (defimplementation make-lock (&key name)
fab0b31 Add multiprocessing support.
Helmut Eller authored
428 (mp:make-process-lock :name name))
429
72f16c0 Replace defmethod with defimplementation.
Helmut Eller authored
430 (defimplementation call-with-lock-held (lock function)
fab0b31 Add multiprocessing support.
Helmut Eller authored
431 (mp:with-process-lock (lock) (funcall function)))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
432
433 (defimplementation current-thread ()
434 mp:*current-process*)
435
436 (defimplementation all-threads ()
64ff730 Update for modified thread interface.
Helmut Eller authored
437 (copy-list mp:*all-processes*))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
438
439 (defimplementation interrupt-thread (thread fn)
440 (mp:process-interrupt thread fn))
441
52dc1fc (kill-thread): Implemented.
Helmut Eller authored
442 (defimplementation kill-thread (thread)
443 (mp:process-kill thread))
444
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
445 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
446
447 (defstruct (mailbox (:conc-name mailbox.))
448 (mutex (mp:make-process-lock :name "process mailbox"))
449 (queue '() :type list))
450
451 (defun mailbox (thread)
452 "Return THREAD's mailbox."
453 (mp:with-process-lock (*mailbox-lock*)
454 (or (getf (mp:process-property-list thread) 'mailbox)
455 (setf (getf (mp:process-property-list thread) 'mailbox)
456 (make-mailbox)))))
457
458 (defimplementation send (thread message)
459 (let* ((mbox (mailbox thread))
460 (mutex (mailbox.mutex mbox)))
cbaae0c (send): Wait a bit if there are already many message in the mailbox.
Helmut Eller authored
461 (mp:process-wait-with-timeout
462 "yielding before sending" 0.1
463 (lambda ()
464 (mp:with-process-lock (mutex)
95e3c25 (send): Fix misplaced parens. (From Bill Clementson)
Helmut Eller authored
465 (< (length (mailbox.queue mbox)) 10))))
92d6085 Use signal driven IO for CMUCL and SBCL. Use one thread per request
Helmut Eller authored
466 (mp:with-process-lock (mutex)
467 (setf (mailbox.queue mbox)
468 (nconc (mailbox.queue mbox) (list message))))))
469
470 (defimplementation receive ()
471 (let* ((mbox (mailbox mp:*current-process*))
472 (mutex (mailbox.mutex mbox)))
473 (mp:process-wait "receive" #'mailbox.queue mbox)
474 (mp:with-process-lock (mutex)
475 (pop (mailbox.queue mbox)))))
9decabc See ChangeLog entry 2004-04-06 Marco Baringer
Marco Baringer authored
476
477 (defimplementation quit-lisp ()
478 (excl:exit 0 :quiet t))
Something went wrong with that request. Please try again.