source: trunk/source/level-1/l1-processes.lisp @ 12798

Last change on this file since 12798 was 12798, checked in by gb, 10 years ago

Don't copy a thread's termination semaphore to the TCR (so don't
signal it in the last stages of thread termination, possibly after
the lisp pointer to the semaphore has been GCed.)

Do try to signal it from lisp code, at least in cases where the thread
terminates normally (in PROCESS-INITIAL-FORM-EXITED).

Seems to fix ticket:598.

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