source: branches/working-0711/ccl/level-1/l1-processes.lisp @ 11101

Last change on this file since 11101 was 11101, checked in by gz, 13 years ago

Another round of changes from the trunk, mostly just mods in internal mechanisms in support of various recent ports.

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