1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | |
---|
19 | ;; L1-processes.lisp |
---|
20 | |
---|
21 | (cl:in-package "CCL") |
---|
22 | |
---|
23 | |
---|
24 | (let* ((all-processes ()) |
---|
25 | (shutdown-processes ()) |
---|
26 | (all-processes-lock (make-lock))) |
---|
27 | (defun add-to-all-processes (p) |
---|
28 | (with-lock-grabbed (all-processes-lock) |
---|
29 | (pushnew p all-processes :test #'eq) |
---|
30 | p)) |
---|
31 | (defun remove-from-all-processes (p) |
---|
32 | (with-lock-grabbed (all-processes-lock) |
---|
33 | (setq all-processes (delete p all-processes)) |
---|
34 | t)) |
---|
35 | (defun all-processes () |
---|
36 | "Obtain a fresh list of all known Lisp threads." |
---|
37 | (with-lock-grabbed (all-processes-lock) |
---|
38 | (copy-list all-processes))) |
---|
39 | (defun shutdown-processes () |
---|
40 | (with-lock-grabbed (all-processes-lock) |
---|
41 | (copy-list shutdown-processes))) |
---|
42 | (defun %clear-shutdown-proceses () |
---|
43 | (setq shutdown-processes nil)) |
---|
44 | (defun add-to-shutdown-processes (p) |
---|
45 | (with-lock-grabbed (all-processes-lock) |
---|
46 | (pushnew p shutdown-processes :test #'eq)) |
---|
47 | t) |
---|
48 | (defun pop-shutdown-processes () |
---|
49 | (with-lock-grabbed (all-processes-lock) |
---|
50 | (pop shutdown-processes))) |
---|
51 | (defun find-process (id) |
---|
52 | (etypecase id |
---|
53 | (process id) |
---|
54 | (integer (with-lock-grabbed (all-processes-lock) |
---|
55 | (find id all-processes |
---|
56 | :key #'(lambda (p) |
---|
57 | (process-serial-number p))))) |
---|
58 | (string (with-lock-grabbed (all-processes-lock) |
---|
59 | (find id all-processes |
---|
60 | :key #'(lambda (p) |
---|
61 | (process-name p)) |
---|
62 | :test #'equal)))))) |
---|
63 | |
---|
64 | |
---|
65 | |
---|
66 | (defun not-in-current-process (p operation) |
---|
67 | (if (eq p *current-process*) |
---|
68 | (error "The current process (~s) can't perform the ~a operation on itself." |
---|
69 | p operation))) |
---|
70 | |
---|
71 | (defun startup-shutdown-processes () |
---|
72 | (let* ((p)) |
---|
73 | (loop |
---|
74 | (unless (setq p (pop-shutdown-processes)) (return)) |
---|
75 | (new-tcr-for-thread (process-thread p)) |
---|
76 | (%process-preset-internal p) |
---|
77 | (process-enable p) |
---|
78 | ))) |
---|
79 | |
---|
80 | ;;; Done with a queue-fixup so that it will be the last thing |
---|
81 | ;;; that happens on startup. |
---|
82 | (queue-fixup |
---|
83 | (pushnew 'startup-shutdown-processes *lisp-system-pointer-functions*)) |
---|
84 | |
---|
85 | |
---|
86 | |
---|
87 | |
---|
88 | |
---|
89 | |
---|
90 | |
---|
91 | (defun wrap-initial-bindings (alist) |
---|
92 | (mapcar #'(lambda (pair) |
---|
93 | (destructuring-bind (symbol . valform) pair |
---|
94 | (cons (require-type symbol 'symbol) |
---|
95 | (cond ((symbolp valform) |
---|
96 | (constantly (symbol-value valform))) |
---|
97 | ((typep valform 'function) valform) |
---|
98 | ((consp valform) |
---|
99 | (if (eq (car valform) 'quote) |
---|
100 | (constantly (cadr valform)) |
---|
101 | #'(lambda () (apply (car valform) (cdr valform))))) |
---|
102 | (t |
---|
103 | (constantly valform)))))) |
---|
104 | alist)) |
---|
105 | |
---|
106 | |
---|
107 | (defun valid-allocation-quantum-p (x) |
---|
108 | (and (>= x *host-page-size*) |
---|
109 | (<= x (default-allocation-quantum)) |
---|
110 | (= (logcount x) 1))) |
---|
111 | |
---|
112 | |
---|
113 | (let* ((psn -1)) |
---|
114 | (defun %new-psn () (incf psn))) |
---|
115 | |
---|
116 | (defclass process () |
---|
117 | ((name :initform nil :initarg :name :accessor process-name) |
---|
118 | (thread :initarg :thread :initform nil :accessor process-thread) |
---|
119 | (initial-form :initform (cons nil nil) :reader process-initial-form) |
---|
120 | (priority :initform 0 :initarg :priority :accessor process-priority) |
---|
121 | (persistent :initform nil :initarg :persistent :reader process-persistent) |
---|
122 | (splice :initform (cons nil nil) :accessor process-splice) |
---|
123 | (initial-bindings :initform nil :initarg :initial-bindings |
---|
124 | :accessor process-initial-bindings) |
---|
125 | (serial-number :initform (%new-psn) :accessor process-serial-number) |
---|
126 | (creation-time :initform (get-tick-count) :reader process-creation-time) |
---|
127 | (total-run-time :initform nil :accessor %process-total-run-time) |
---|
128 | (ui-object :initform (application-ui-object *application*) |
---|
129 | :accessor process-ui-object) |
---|
130 | (termination-semaphore :initform nil |
---|
131 | :initarg :termination-semaphore |
---|
132 | :accessor process-termination-semaphore |
---|
133 | :type (or null semaphore)) |
---|
134 | (allocation-quantum :initform (default-allocation-quantum) |
---|
135 | :initarg :allocation-quantum |
---|
136 | :reader process-allocation-quantum |
---|
137 | :type (satisfies valid-allocation-quantum-p)) |
---|
138 | (dribble-stream :initform nil) |
---|
139 | (dribble-saved-terminal-io :initform nil) |
---|
140 | (result :initform (cons nil nil) |
---|
141 | :reader process-result)) |
---|
142 | (:primary-p t)) |
---|
143 | |
---|
144 | (defparameter *print-process-whostate* t "make it optional") |
---|
145 | |
---|
146 | (defmethod print-object ((p process) s) |
---|
147 | (print-unreadable-object (p s :type t :identity t) |
---|
148 | (format s "~a(~d)" (process-name p) |
---|
149 | (process-serial-number p)) |
---|
150 | (when *print-process-whostate* |
---|
151 | (format s " [~a]" (process-whostate p))))) |
---|
152 | |
---|
153 | (defvar *process-class* (find-class 'process)) |
---|
154 | |
---|
155 | (defun processp (p) |
---|
156 | (memq *process-class* (class-precedence-list (class-of p)))) |
---|
157 | |
---|
158 | (set-type-predicate 'process 'processp) |
---|
159 | |
---|
160 | (defun make-process (name &key |
---|
161 | thread |
---|
162 | persistent |
---|
163 | (priority 0) |
---|
164 | (stack-size *default-control-stack-size*) |
---|
165 | (vstack-size *default-value-stack-size*) |
---|
166 | (tstack-size *default-temp-stack-size*) |
---|
167 | (initial-bindings ()) |
---|
168 | (use-standard-initial-bindings t) |
---|
169 | (class (find-class 'process)) |
---|
170 | (termination-semaphore ()) |
---|
171 | (allocation-quantum (default-allocation-quantum))) |
---|
172 | "Create and return a new process." |
---|
173 | (let* ((p (make-instance |
---|
174 | class |
---|
175 | :name name |
---|
176 | :priority priority |
---|
177 | :persistent persistent |
---|
178 | :initial-bindings (append (if use-standard-initial-bindings |
---|
179 | (standard-initial-bindings)) |
---|
180 | (wrap-initial-bindings |
---|
181 | initial-bindings)) |
---|
182 | :termination-semaphore (or termination-semaphore |
---|
183 | (make-semaphore)) |
---|
184 | :allocation-quantum allocation-quantum))) |
---|
185 | (with-slots ((lisp-thread thread)) p |
---|
186 | (unless lisp-thread |
---|
187 | (setq lisp-thread |
---|
188 | (or thread |
---|
189 | (new-thread name stack-size vstack-size tstack-size))))) |
---|
190 | (add-to-all-processes p) |
---|
191 | (setf (car (process-splice p)) p) |
---|
192 | p)) |
---|
193 | |
---|
194 | |
---|
195 | (defstatic *initial-process* |
---|
196 | (let* ((p (make-process |
---|
197 | "Initial" |
---|
198 | :thread *initial-lisp-thread* |
---|
199 | :priority 0))) |
---|
200 | p)) |
---|
201 | |
---|
202 | |
---|
203 | (defvar *current-process* *initial-process* |
---|
204 | "Bound in each process, to that process itself.") |
---|
205 | |
---|
206 | (defstatic *interactive-abort-process* *initial-process*) |
---|
207 | |
---|
208 | |
---|
209 | |
---|
210 | |
---|
211 | (defun process-tcr (p) |
---|
212 | (lisp-thread.tcr (process-thread p))) |
---|
213 | |
---|
214 | |
---|
215 | |
---|
216 | (defun process-exhausted-p (p) |
---|
217 | (let* ((thread (process-thread p))) |
---|
218 | (or (null thread) |
---|
219 | (thread-exhausted-p thread)))) |
---|
220 | |
---|
221 | ;;; This should be way more concerned about being correct and thread-safe |
---|
222 | ;;; than about being quick: it's generally only called while printing |
---|
223 | ;;; or debugging, and there are all kinds of subtle race conditions |
---|
224 | ;;; here. |
---|
225 | (defun process-whostate (p) |
---|
226 | "Return a string which describes the status of a specified process." |
---|
227 | (let* ((ip *initial-process*)) |
---|
228 | (cond ((eq p *current-process*) |
---|
229 | (if (%tcr-binding-location (%current-tcr) '*whostate*) |
---|
230 | *whostate* |
---|
231 | (if (eq p ip) |
---|
232 | "Active" |
---|
233 | "Reset"))) |
---|
234 | (t |
---|
235 | (without-interrupts |
---|
236 | (with-lock-grabbed (*kernel-exception-lock*) |
---|
237 | (with-lock-grabbed (*kernel-tcr-area-lock*) |
---|
238 | (let* ((tcr (process-tcr p))) |
---|
239 | (if tcr |
---|
240 | (unwind-protect |
---|
241 | (let* ((loc nil)) |
---|
242 | (%suspend-tcr tcr) |
---|
243 | (setq loc (%tcr-binding-location tcr '*whostate*)) |
---|
244 | (if loc |
---|
245 | (%fixnum-ref loc) |
---|
246 | (if (eq p ip) |
---|
247 | "Active" |
---|
248 | "Reset"))) |
---|
249 | (%resume-tcr tcr)) |
---|
250 | "Exhausted"))))))))) |
---|
251 | |
---|
252 | (defun (setf process-whostate) (new p) |
---|
253 | (unless (process-exhausted-p p) |
---|
254 | (setf (symbol-value-in-process '*whostate* p) new))) |
---|
255 | |
---|
256 | |
---|
257 | |
---|
258 | (defun process-total-run-time (p) |
---|
259 | (or (%process-total-run-time p) |
---|
260 | (thread-total-run-time (process-thread p)))) |
---|
261 | |
---|
262 | |
---|
263 | |
---|
264 | |
---|
265 | (defun initial-bindings (alist) |
---|
266 | (let* ((symbols ()) |
---|
267 | (values ())) |
---|
268 | (dolist (a alist (values (nreverse symbols) (nreverse values))) |
---|
269 | (push (car a) symbols) |
---|
270 | (push (funcall (cdr a)) values)))) |
---|
271 | |
---|
272 | |
---|
273 | |
---|
274 | (defun symbol-value-in-process (sym process) |
---|
275 | (if (eq process *current-process*) |
---|
276 | (symbol-value sym) |
---|
277 | (let* ((val |
---|
278 | (without-interrupts |
---|
279 | (with-lock-grabbed (*kernel-exception-lock*) |
---|
280 | (with-lock-grabbed (*kernel-tcr-area-lock*) |
---|
281 | (let* ((tcr (process-tcr process))) |
---|
282 | (if tcr |
---|
283 | (symbol-value-in-tcr sym tcr) |
---|
284 | (%sym-global-value sym)))))))) |
---|
285 | (if (eq val (%unbound-marker)) |
---|
286 | ;; This might want to be a CELL-ERROR. |
---|
287 | (error "~S is unbound in ~S." sym process) |
---|
288 | val)))) |
---|
289 | |
---|
290 | (defun (setf symbol-value-in-process) (value sym process) |
---|
291 | (if (eq process *current-process*) |
---|
292 | (setf (symbol-value sym) value) |
---|
293 | (with-lock-grabbed (*kernel-exception-lock*) |
---|
294 | (with-lock-grabbed (*kernel-tcr-area-lock*) |
---|
295 | (let* ((tcr (process-tcr process))) |
---|
296 | (if tcr |
---|
297 | (setf (symbol-value-in-tcr sym tcr) value) |
---|
298 | (%set-sym-global-value sym value))))))) |
---|
299 | |
---|
300 | |
---|
301 | (defmethod process-enable ((p process) &optional (wait (* 60 60 24) wait-p)) |
---|
302 | "Begin executing the initial function of a specified process." |
---|
303 | (not-in-current-process p 'process-enable) |
---|
304 | (when wait-p |
---|
305 | (check-type wait (unsigned-byte 32))) |
---|
306 | (unless (car (process-initial-form p)) |
---|
307 | (error "Process ~s has not been preset. Use PROCESS-PRESET to preset the process." p)) |
---|
308 | (let* ((thread (process-thread p))) |
---|
309 | (do* ((total-wait wait (+ total-wait wait))) |
---|
310 | ((thread-enable thread (process-termination-semaphore p) (1- (integer-length (process-allocation-quantum p))) wait) |
---|
311 | (process-tcr-enable p (lisp-thread.tcr thread)) |
---|
312 | p) |
---|
313 | (cerror "Keep trying." |
---|
314 | "Unable to enable process ~s; have been trying for ~s seconds." |
---|
315 | p total-wait)))) |
---|
316 | |
---|
317 | (defmethod process-tcr-enable ((process process) tcr) |
---|
318 | (when (and tcr (not (eql 0 tcr))) |
---|
319 | #+(and windows-target x8632-target) |
---|
320 | (let ((aux (%fixnum-ref tcr (- target::tcr.aux target::tcr-bias)))) |
---|
321 | (%signal-semaphore-ptr (%fixnum-ref-macptr aux target::tcr-aux.activate))) |
---|
322 | #-(and windows-target x8632-target) |
---|
323 | (%signal-semaphore-ptr (%fixnum-ref-macptr tcr target::tcr.activate)) |
---|
324 | )) |
---|
325 | |
---|
326 | |
---|
327 | |
---|
328 | (defun process-resume (p) |
---|
329 | "Resume a specified process which had previously been suspended |
---|
330 | by process-suspend." |
---|
331 | (setq p (require-type p 'process)) |
---|
332 | (let* ((tcr (process-tcr p))) |
---|
333 | (and tcr (%resume-tcr tcr)))) |
---|
334 | |
---|
335 | (defun process-suspend (p) |
---|
336 | "Suspend a specified process." |
---|
337 | (setq p (require-type p 'process)) |
---|
338 | (if (eq p *current-process*) |
---|
339 | (error "Suspending the current process can't work. ~&(If the documentation claims otherwise, it's incorrect.)") |
---|
340 | (let* ((tcr (process-tcr p))) |
---|
341 | (and tcr (%suspend-tcr tcr))))) |
---|
342 | |
---|
343 | (defun process-suspend-count (p) |
---|
344 | "Return the number of currently-pending suspensions applicable to |
---|
345 | a given process." |
---|
346 | (setq p (require-type p 'process)) |
---|
347 | (let* ((thread (process-thread p))) |
---|
348 | (if thread |
---|
349 | (lisp-thread-suspend-count thread)))) |
---|
350 | |
---|
351 | (defun process-active-p (p) |
---|
352 | (setq p (require-type p 'process)) |
---|
353 | (and (eql 0 (process-suspend-count p)) |
---|
354 | (not (process-exhausted-p p)))) |
---|
355 | |
---|
356 | ;;; Used by process-run-function |
---|
357 | (defmethod process-preset ((p process) function &rest args) |
---|
358 | "Set the initial function and arguments of a specified process." |
---|
359 | (let* ((f (require-type function 'function)) |
---|
360 | (initial-form (process-initial-form p))) |
---|
361 | (declare (type cons initial-form)) |
---|
362 | (not-in-current-process p 'process-preset) |
---|
363 | ; Not quite right ... |
---|
364 | (rplaca initial-form f) |
---|
365 | (rplacd initial-form args) |
---|
366 | (%process-preset-internal p))) |
---|
367 | |
---|
368 | (defmethod %process-preset-internal ((process process)) |
---|
369 | (let* ((initial-form (process-initial-form process)) |
---|
370 | (thread (process-thread process))) |
---|
371 | (declare (type cons initial-form)) |
---|
372 | (thread-preset |
---|
373 | thread |
---|
374 | #'(lambda (process initial-form) |
---|
375 | (let* ((*current-process* process)) |
---|
376 | (add-to-all-processes process) |
---|
377 | (with-initial-bindings (process-initial-bindings process) |
---|
378 | (setq *whostate* "Active") |
---|
379 | (run-process-initial-form process initial-form)))) |
---|
380 | process |
---|
381 | initial-form) |
---|
382 | process)) |
---|
383 | |
---|
384 | |
---|
385 | (defun run-process-initial-form (process initial-form) |
---|
386 | (let* ((exited nil) |
---|
387 | (kill (handler-case |
---|
388 | (restart-case |
---|
389 | (let ((values |
---|
390 | (multiple-value-list |
---|
391 | (apply (car initial-form) |
---|
392 | (cdr (the list initial-form))))) |
---|
393 | (result (process-result process))) |
---|
394 | (setf (cdr result) values |
---|
395 | (car result) t) |
---|
396 | (setq exited t) |
---|
397 | nil) |
---|
398 | (abort-break () :report "Reset this thread") |
---|
399 | (abort () :report "Kill this thread" (setq exited t))) |
---|
400 | (process-reset (condition) |
---|
401 | (process-reset-kill condition))))) |
---|
402 | ;; We either exited from the initial form normally, were told to |
---|
403 | ;; exit prematurely, or are being reset and should enter the |
---|
404 | ;; "awaiting preset" state. |
---|
405 | (if (or kill exited) |
---|
406 | (unless (eq kill :toplevel) |
---|
407 | (process-initial-form-exited process (or kill t))) |
---|
408 | (progn |
---|
409 | (thread-change-state (process-thread process) :run :reset) |
---|
410 | (tcr-set-preset-state (process-tcr process)))) |
---|
411 | nil)) |
---|
412 | |
---|
413 | ;;; Separated from run-process-initial-form just so I can change it easily. |
---|
414 | (defun process-initial-form-exited (process kill) |
---|
415 | (without-interrupts |
---|
416 | (if (eq kill :shutdown) |
---|
417 | (progn |
---|
418 | (setq *whostate* "Shutdown") |
---|
419 | (add-to-shutdown-processes process))) |
---|
420 | (let* ((semaphore (process-termination-semaphore process))) |
---|
421 | (when semaphore (signal-semaphore semaphore))) |
---|
422 | (maybe-finish-process-kill process kill))) |
---|
423 | |
---|
424 | (defun maybe-finish-process-kill (process kill) |
---|
425 | (when (and kill (neq kill :shutdown)) |
---|
426 | (setf (process-whostate process) "Dead") |
---|
427 | (remove-from-all-processes process) |
---|
428 | (let ((thread (process-thread process))) |
---|
429 | (unless (or (eq thread *current-lisp-thread*) |
---|
430 | (thread-exhausted-p thread)) |
---|
431 | (kill-lisp-thread thread)))) |
---|
432 | nil) |
---|
433 | |
---|
434 | |
---|
435 | |
---|
436 | |
---|
437 | (defun require-global-symbol (s &optional env) |
---|
438 | (let* ((s (require-type s 'symbol)) |
---|
439 | (bits (%symbol-bits s))) |
---|
440 | (unless (or (logbitp $sym_vbit_global bits) |
---|
441 | (let* ((defenv (if env (definition-environment env)))) |
---|
442 | (if defenv |
---|
443 | (eq :global (%cdr (assq s (defenv.specials defenv))))))) |
---|
444 | (error "~s not defined with ~s" s 'defstatic)) |
---|
445 | s)) |
---|
446 | |
---|
447 | |
---|
448 | (defmethod print-object ((s lock) stream) |
---|
449 | (print-unreadable-object (s stream :type t :identity t) |
---|
450 | (let* ((val (uvref s target::lock._value-cell)) |
---|
451 | (name (uvref s target::lock.name-cell))) |
---|
452 | (when name |
---|
453 | (format stream "~s " name)) |
---|
454 | (if (typep val 'macptr) |
---|
455 | (format stream "[ptr @ #x~x]" |
---|
456 | (%ptr-to-int val)))))) |
---|
457 | |
---|
458 | (defun lockp (l) |
---|
459 | (eq target::subtag-lock (typecode l))) |
---|
460 | |
---|
461 | (set-type-predicate 'lock 'lockp) |
---|
462 | |
---|
463 | (defun recursive-lock-p (l) |
---|
464 | (and (eq target::subtag-lock (typecode l)) |
---|
465 | (eq 'recursive-lock (%svref l target::lock.kind-cell)))) |
---|
466 | |
---|
467 | (defun read-write-lock-p (l) |
---|
468 | (and (eq target::subtag-lock (typecode l)) |
---|
469 | (eq 'read-write-lock (%svref l target::lock.kind-cell)))) |
---|
470 | |
---|
471 | (setf (type-predicate 'recursive-lock) 'recursive-lock-p |
---|
472 | (type-predicate 'read-write-lock) 'read-write-lock-p) |
---|
473 | |
---|
474 | |
---|
475 | (defun grab-lock (lock &optional flag) |
---|
476 | "Wait until a given lock can be obtained, then obtain it." |
---|
477 | (%lock-recursive-lock-object lock flag)) |
---|
478 | |
---|
479 | (defun release-lock (lock) |
---|
480 | "Relinquish ownership of a given lock." |
---|
481 | (%unlock-recursive-lock-object lock)) |
---|
482 | |
---|
483 | (defun try-lock (lock &optional flag) |
---|
484 | "Obtain the given lock, but only if it is not necessary to wait for it." |
---|
485 | (%try-recursive-lock-object lock flag)) |
---|
486 | |
---|
487 | (defun lock-acquisition-status (thing) |
---|
488 | (if (istruct-typep thing 'lock-acquisition) |
---|
489 | (lock-acquisition.status thing) |
---|
490 | (report-bad-arg thing 'lock-acquisition))) |
---|
491 | |
---|
492 | (defun clear-lock-acquisition-status (thing) |
---|
493 | (if (istruct-typep thing 'lock-acquisition) |
---|
494 | (setf (lock-acquisition.status thing) nil) |
---|
495 | (report-bad-arg thing 'lock-acquisition))) |
---|
496 | |
---|
497 | (defmethod print-object ((l lock-acquisition) stream) |
---|
498 | (print-unreadable-object (l stream :type t :identity t) |
---|
499 | (format stream "[status = ~s]" (lock-acquisition-status l)))) |
---|
500 | |
---|
501 | (defun semaphore-notification-status (thing) |
---|
502 | (if (istruct-typep thing 'semaphore-notification) |
---|
503 | (semaphore-notification.status thing) |
---|
504 | (report-bad-arg thing 'semaphore-notification))) |
---|
505 | |
---|
506 | (defun clear-semaphore-notification-status (thing) |
---|
507 | (if (istruct-typep thing 'semaphore-notification) |
---|
508 | (setf (semaphore-notification.status thing) nil) |
---|
509 | (report-bad-arg thing 'semaphore-notification))) |
---|
510 | |
---|
511 | (defmethod print-object ((l semaphore-notification) stream) |
---|
512 | (print-unreadable-object (l stream :type t :identity t) |
---|
513 | (format stream "[status = ~s]" (semaphore-notification-status l)))) |
---|
514 | |
---|
515 | (defun process-wait (whostate function &rest args) |
---|
516 | "Causes the current lisp process (thread) to wait for a given |
---|
517 | predicate to return true." |
---|
518 | (declare (dynamic-extent args)) |
---|
519 | (or (apply function args) |
---|
520 | (with-process-whostate (whostate) |
---|
521 | (loop |
---|
522 | (when (apply function args) |
---|
523 | (return)) |
---|
524 | ;; Sleep for a tick |
---|
525 | #-windows-target |
---|
526 | (%nanosleep 0 *ns-per-tick*) |
---|
527 | #+windows-target |
---|
528 | (%windows-sleep 5))))) |
---|
529 | |
---|
530 | |
---|
531 | |
---|
532 | (defun process-wait-with-timeout (whostate time function &rest args) |
---|
533 | "Cause the current thread to wait for a given predicate to return true, |
---|
534 | or for a timeout to expire." |
---|
535 | (declare (dynamic-extent args)) |
---|
536 | (cond ((null time) (apply #'process-wait whostate function args) t) |
---|
537 | (t (let* ((win nil) |
---|
538 | (when (+ (get-tick-count) time)) |
---|
539 | (f #'(lambda () (let ((val (apply function args))) |
---|
540 | (if val |
---|
541 | (setq win val) |
---|
542 | (> (get-tick-count) when)))))) |
---|
543 | (declare (dynamic-extent f)) |
---|
544 | (process-wait whostate f) |
---|
545 | win)))) |
---|
546 | |
---|
547 | |
---|
548 | (defmethod process-interrupt ((process process) function &rest args) |
---|
549 | "Arrange for the target process to invoke a specified function at |
---|
550 | some point in the near future, and then return to what it was doing." |
---|
551 | (let* ((p (require-type process 'process))) |
---|
552 | (if (eq p *current-process*) |
---|
553 | (progn |
---|
554 | (apply function args) |
---|
555 | t) |
---|
556 | (thread-interrupt |
---|
557 | (process-thread p) |
---|
558 | process |
---|
559 | #'apply |
---|
560 | function args)))) |
---|
561 | |
---|
562 | (defmethod process-debug-condition ((p process) condition frame-pointer) |
---|
563 | (declare (ignore condition frame-pointer))) |
---|
564 | |
---|
565 | |
---|
566 | |
---|
567 | |
---|
568 | ;;; This one is in the Symbolics documentation |
---|
569 | (defun process-allow-schedule () |
---|
570 | "Used for cooperative multitasking; probably never necessary." |
---|
571 | (process-yield *current-process*)) |
---|
572 | |
---|
573 | |
---|
574 | ;;; something unique that users won't get their hands on |
---|
575 | (defun process-reset-tag (process) |
---|
576 | (process-splice process)) |
---|
577 | |
---|
578 | (defun process-run-function (name-or-keywords function &rest args) |
---|
579 | "Create a process, preset it, and enable it." |
---|
580 | (if (listp name-or-keywords) |
---|
581 | (%process-run-function name-or-keywords function args) |
---|
582 | (let ((keywords (list :name name-or-keywords))) |
---|
583 | (declare (dynamic-extent keywords)) |
---|
584 | (%process-run-function keywords function args)))) |
---|
585 | |
---|
586 | (defun %process-run-function (keywords function args) |
---|
587 | (destructuring-bind (&key (name "Anonymous") |
---|
588 | (priority 0) |
---|
589 | (stack-size *default-control-stack-size*) |
---|
590 | (vstack-size *default-value-stack-size*) |
---|
591 | (tstack-size *default-temp-stack-size*) |
---|
592 | (initial-bindings ()) |
---|
593 | (persistent nil) |
---|
594 | (use-standard-initial-bindings t) |
---|
595 | (termination-semaphore nil) |
---|
596 | (allocation-quantum (default-allocation-quantum))) |
---|
597 | keywords |
---|
598 | (setq priority (require-type priority 'fixnum)) |
---|
599 | (let* ((process (make-process name |
---|
600 | :priority priority |
---|
601 | :stack-size stack-size |
---|
602 | :vstack-size vstack-size |
---|
603 | :tstack-size tstack-size |
---|
604 | :persistent persistent |
---|
605 | :use-standard-initial-bindings use-standard-initial-bindings |
---|
606 | :initial-bindings initial-bindings |
---|
607 | :termination-semaphore termination-semaphore |
---|
608 | :allocation-quantum allocation-quantum))) |
---|
609 | (process-preset process #'(lambda () (apply function args))) |
---|
610 | (process-enable process) |
---|
611 | process))) |
---|
612 | |
---|
613 | (defmethod process-reset ((process process) &optional kill) |
---|
614 | "Cause a specified process to cleanly exit from any ongoing computation." |
---|
615 | (setq process (require-type process 'process)) |
---|
616 | (unless (memq kill '(nil :kill :shutdown)) |
---|
617 | (setq kill (require-type kill '(member nil :kill :shutdown)))) |
---|
618 | (if (eq process *current-process*) |
---|
619 | (%process-reset kill) |
---|
620 | (if (process-exhausted-p process) |
---|
621 | (maybe-finish-process-kill process kill) |
---|
622 | (progn |
---|
623 | (process-interrupt process '%process-reset kill))))) |
---|
624 | |
---|
625 | (defmethod process-yield ((p process)) |
---|
626 | #+windows-target (#_Sleep 0) |
---|
627 | #-windows-target (#_sched_yield)) |
---|
628 | |
---|
629 | |
---|
630 | (defun %process-reset (kill) |
---|
631 | (signal 'process-reset :kill kill) |
---|
632 | (maybe-finish-process-kill *current-process* kill)) |
---|
633 | |
---|
634 | ;;; By default, it's just fine with the current process |
---|
635 | ;;; if the application/user wants to quit. |
---|
636 | (defmethod process-verify-quit ((process process)) |
---|
637 | t) |
---|
638 | |
---|
639 | (defmethod process-exit-application ((process process) thunk) |
---|
640 | (when (eq process *initial-process*) |
---|
641 | (with-standard-abort-handling "Exit Lisp" |
---|
642 | (prepare-to-quit) |
---|
643 | ;; We may have abruptly terminated a thread which owned the |
---|
644 | ;; output lock on a stream we want to flush. Don't block |
---|
645 | ;; waiting on the lock if so. |
---|
646 | (flet ((flush-stream (s) |
---|
647 | (let* ((lock (ioblock-outbuf-lock (basic-stream-ioblock s))) |
---|
648 | (locked (make-lock-acquisition))) |
---|
649 | (declare (dynamic-extent locked)) |
---|
650 | (when (or (null lock) |
---|
651 | (%try-recursive-lock-object lock locked)) |
---|
652 | (unwind-protect |
---|
653 | (progn |
---|
654 | (fresh-line s) |
---|
655 | (finish-output s)) |
---|
656 | (when (lock-acquisition.status locked) |
---|
657 | (release-lock lock))))))) |
---|
658 | (flush-stream *stdout*) |
---|
659 | (flush-stream *stderr*))) |
---|
660 | (%set-toplevel thunk) |
---|
661 | (toplevel))) |
---|
662 | |
---|
663 | |
---|
664 | |
---|
665 | (defmethod process-kill ((process process)) |
---|
666 | "Cause a specified process to cleanly exit from any ongoing |
---|
667 | computation, and then exit." |
---|
668 | (and (process-interrupt process #'%process-reset :kill) |
---|
669 | (setf (process-kill-issued process) t))) |
---|
670 | |
---|
671 | (defun process-abort (process &optional condition) |
---|
672 | "Cause a specified process to process an abort condition, as if it |
---|
673 | had invoked abort." |
---|
674 | (process-interrupt process |
---|
675 | #'(lambda () |
---|
676 | (abort condition)))) |
---|
677 | |
---|
678 | (defmethod process-reset-and-enable ((process process)) |
---|
679 | (not-in-current-process process 'process-reset-and-enable) |
---|
680 | (process-reset process) |
---|
681 | (process-enable process)) |
---|
682 | |
---|
683 | (defmethod process-kill-issued ((process process)) |
---|
684 | (cdr (process-splice process))) |
---|
685 | |
---|
686 | (defmethod (setf process-kill-issued) (val (process process)) |
---|
687 | (setf (cdr (process-splice process)) val)) |
---|
688 | |
---|
689 | (defun tcr->process (tcr) |
---|
690 | (dolist (p (all-processes)) |
---|
691 | (when (eq tcr (process-tcr p)) |
---|
692 | (return p)))) |
---|
693 | |
---|
694 | (defun current-process-allocation-quantum () |
---|
695 | (process-allocation-quantum *current-process*)) |
---|
696 | |
---|
697 | (defun (setf current-process-allocation-quantum) (new) |
---|
698 | (if (valid-allocation-quantum-p new) |
---|
699 | (with-macptrs (tcrp) |
---|
700 | (%setf-macptr-to-object tcrp (%current-tcr)) |
---|
701 | #+(and windows-target x8632-target) |
---|
702 | (let ((aux (%get-ptr tcrp (- target::tcr.aux target::tcr-bias)))) |
---|
703 | (setf (%get-natural aux target::tcr-aux.log2-allocation-quantum) |
---|
704 | (1- (integer-length new)))) |
---|
705 | #-(and windows-target x8632-target) |
---|
706 | (setf (%get-natural tcrp target::tcr.log2-allocation-quantum) |
---|
707 | (1- (integer-length new))) |
---|
708 | (setf (slot-value *current-process* 'allocation-quantum) new) |
---|
709 | new) |
---|
710 | (report-bad-arg new '(satisfies valid-allocation-quantum-p)))) |
---|
711 | |
---|
712 | |
---|
713 | (def-standard-initial-binding *backtrace-contexts* nil) |
---|
714 | |
---|
715 | (defmethod exit-interactive-process ((p process)) |
---|
716 | (unless (eq p *initial-process*) |
---|
717 | (when (eq p *current-process*) |
---|
718 | (process-kill p)))) |
---|
719 | |
---|
720 | (defclass tty-listener (process) |
---|
721 | ()) |
---|
722 | |
---|
723 | (defmethod exit-interactive-process ((p tty-listener)) |
---|
724 | (when (eq p *current-process*) |
---|
725 | (quit))) |
---|
726 | |
---|
727 | (defmethod process-stop-dribbling ((p process)) |
---|
728 | (with-slots (dribble-stream dribble-saved-terminal-io) p |
---|
729 | (when dribble-stream |
---|
730 | (close dribble-stream) |
---|
731 | (setq dribble-stream nil)) |
---|
732 | (when dribble-saved-terminal-io |
---|
733 | (setq *terminal-io* dribble-saved-terminal-io |
---|
734 | dribble-saved-terminal-io nil)))) |
---|
735 | |
---|
736 | (defmethod process-dribble ((p process) path) |
---|
737 | (with-slots (dribble-stream dribble-saved-terminal-io) p |
---|
738 | (process-stop-dribbling p) |
---|
739 | (when path |
---|
740 | (let* ((in (two-way-stream-input-stream *terminal-io*)) |
---|
741 | (out (two-way-stream-output-stream *terminal-io*)) |
---|
742 | (f (open path :direction :output :if-exists :append |
---|
743 | :if-does-not-exist :create))) |
---|
744 | (without-interrupts |
---|
745 | (setq dribble-stream f |
---|
746 | dribble-saved-terminal-io *terminal-io* |
---|
747 | *terminal-io* (make-echoing-two-way-stream |
---|
748 | (make-echo-stream in f) |
---|
749 | (make-broadcast-stream out f))))) |
---|
750 | path))) |
---|
751 | |
---|
752 | (defmethod join-process ((p process) &key default) |
---|
753 | (wait-on-semaphore (process-termination-semaphore p) nil "join-process") |
---|
754 | (let ((result (process-result p))) |
---|
755 | (cond ((car result) (values-list (cdr result))) |
---|
756 | (t default)))) |
---|
757 | |
---|
758 | (defun call-in-process (f process) |
---|
759 | (let* ((return-values nil) |
---|
760 | (done (make-semaphore))) |
---|
761 | (process-interrupt process |
---|
762 | #'(lambda () |
---|
763 | (unwind-protect |
---|
764 | (progn |
---|
765 | (setq return-values |
---|
766 | (multiple-value-list (funcall f)))) |
---|
767 | (signal-semaphore done)))) |
---|
768 | (wait-on-semaphore done) |
---|
769 | (apply #'values return-values))) |
---|
770 | |
---|
771 | (defun call-in-initial-process (f) |
---|
772 | (call-in-process f *initial-process*)) |
---|
773 | |
---|