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

Last change on this file since 15141 was 15141, checked in by rme, 8 years ago

Add and export process-plist. Fixes ticket:441.

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