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

Last change on this file since 12205 was 12205, checked in by gz, 10 years ago

Merge r11495, r12082: new options in ccl:quit.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.4 KB
RevLine 
[6]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 ()
[2438]35    "Obtain a fresh list of all known Lisp threads."
[6]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
[1729]79;;; Done with a queue-fixup so that it will be the last thing
80;;; that happens on startup.
[6]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
[3311]105
[3307]106(defun valid-allocation-quantum-p (x)
[3311]107  (and (>= x *host-page-size*)
[3307]108       (<= x (default-allocation-quantum))
109       (= (logcount x) 1)))
110
[6]111 
112(let* ((psn -1))
113  (defun %new-psn () (incf psn)))
114
115(defclass process ()
116    ((name :initform nil :initarg :name :accessor process-name)
[11757]117     (thread :initarg :thread :initform nil :accessor process-thread)
[6]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)
[690]126     (total-run-time :initform nil :accessor %process-total-run-time)
127     (ui-object :initform (application-ui-object *application*)
[2704]128                :accessor process-ui-object)
[5608]129     (termination-semaphore :initform nil
130                            :initarg :termination-semaphore
[2704]131                            :accessor process-termination-semaphore
[3307]132                            :type (or null semaphore))
133     (allocation-quantum :initform (default-allocation-quantum)
134                         :initarg :allocation-quantum
135                         :reader process-allocation-quantum
[6194]136                         :type (satisfies valid-allocation-quantum-p))
137     (dribble-stream :initform nil)
[7330]138     (dribble-saved-terminal-io :initform nil)
139     (result :initform (cons nil nil)
140             :reader process-result))
[6]141  (:primary-p t))
142
[11225]143(defparameter *print-process-whostate* t "make it optional")
144
[6]145(defmethod print-object ((p process) s)
146  (print-unreadable-object (p s :type t :identity t)
[11225]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)))))
[6]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 ())
[690]167                          (use-standard-initial-bindings t)
[2704]168                          (class (find-class 'process))
[3311]169                          (termination-semaphore ())
170                          (allocation-quantum (default-allocation-quantum)))
[2438]171  "Create and return a new process."
[6]172  (let* ((p (make-instance
[690]173             class
[6]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
[2704]180                                        initial-bindings))
[5608]181             :termination-semaphore (or termination-semaphore
182                                        (make-semaphore))
[3311]183             :allocation-quantum allocation-quantum)))
[11757]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)))))
[6]189    (add-to-all-processes p)
190    (setf (car (process-splice p)) p)
191    p))
192
193
[6194]194(defstatic *initial-process*
[6]195    (let* ((p (make-process
196               "Initial"
197               :thread *initial-lisp-thread*
198               :priority 0)))
199      p))
200
201
[2438]202(defvar *current-process* *initial-process*
203  "Bound in each process, to that process itself.")
[6]204
[6194]205(defstatic *interactive-abort-process* *initial-process*)
[6]206
207
208
209
210(defun process-tcr (p)
[4884]211  (lisp-thread.tcr (process-thread p)))
[6]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 
[10461]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.
[6]224(defun process-whostate (p)
[2438]225  "Return a string which describes the status of a specified process."
[10461]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")))))))))
[6]250
[7949]251(defun (setf process-whostate) (new p)
252  (unless (process-exhausted-p p)
253    (setf (symbol-value-in-process '*whostate* p) new)))
[6]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)
[8130]274  (if (eq process *current-process*)
275    (symbol-value sym)
[10461]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))))
[6]288
289(defun (setf symbol-value-in-process) (value sym process)
[8130]290  (if (eq process *current-process*)
291    (setf (symbol-value sym) value)
[10461]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)))))))
[6]298
299
[11744]300(defmethod process-enable ((p process) &optional (wait (* 60 60 24) wait-p))
[2438]301  "Begin executing the initial function of a specified process."
[6]302  (not-in-current-process p 'process-enable)
[10253]303  (when wait-p
304    (check-type wait (unsigned-byte 32)))
[6]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)))
[10253]308    (do* ((total-wait wait (+ total-wait wait)))
[3307]309         ((thread-enable thread (process-termination-semaphore p) (1- (integer-length (process-allocation-quantum p)))  wait)
[11744]310          (process-tcr-enable p (lisp-thread.tcr thread))
[6]311          p)
312      (cerror "Keep trying."
313              "Unable to enable process ~s; have been trying for ~s seconds."
314              p total-wait))))
315
[11744]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    ))
[6]320
[2704]321(defmethod (setf process-termination-semaphore) :after (new (p process))
322  (with-macptrs (tcrp)
323    (%setf-macptr-to-object tcrp (process-tcr p))
324    (unless (%null-ptr-p tcrp)
325      (setf (%get-ptr tcrp target::tcr.termination-semaphore)
326            (if new
327              (semaphore-value new)
328              (%null-ptr))))
329    new))
330
[6]331(defun process-resume (p)
[2438]332  "Resume a specified process which had previously been suspended
333by process-suspend."
[6]334  (setq p (require-type p 'process))
[10426]335  (let* ((tcr (process-tcr p)))
336    (and tcr (%resume-tcr tcr))))
[6]337
338(defun process-suspend (p)
[2438]339  "Suspend a specified process."
[6]340  (setq p (require-type p 'process))
[4674]341  (if (eq p *current-process*)
342    (error "Suspending the current process can't work.  ~&(If the documentation claims otherwise, it's incorrect.)")
[10426]343    (let* ((tcr (process-tcr p)))
344      (and tcr (%suspend-tcr tcr)))))
[6]345
346(defun process-suspend-count (p)
[2438]347  "Return the number of currently-pending suspensions applicable to
348a given process."
[6]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 
[1729]359;;; Used by process-run-function
[11744]360(defmethod process-preset ((p process) function &rest args)
[2438]361  "Set the initial function and arguments of a specified process."
[11744]362  (let* ((f (require-type function 'function))
[6]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)
[11744]369    (%process-preset-internal p)))
[6]370
[11744]371(defmethod %process-preset-internal ((process process))
[2936]372   (let* ((initial-form (process-initial-form process))
[4557]373         (thread (process-thread process)))
[6]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            (multiple-value-bind (syms values)
381                (initial-bindings (process-initial-bindings process))
382              (progv syms values
[7949]383                (setq *whostate* "Active")
[6]384                (run-process-initial-form process initial-form)))))
385      process
386      initial-form)
387     process))
388
389
390(defun run-process-initial-form (process initial-form)
391  (let* ((exited nil)
392         (kill (handler-case
393                   (restart-case
[7330]394                    (let ((values
395                           (multiple-value-list
396                            (apply (car initial-form)
397                                   (cdr (the list initial-form)))))
398                          (result (process-result process)))
399                      (setf (cdr result) values
400                            (car result) t)
[6]401                      (setq exited t)
402                      nil)
[11135]403                    (abort-break () :report "Reset this thread")
404                    (abort () :report "Kill this thread" (setq exited t)))
[6]405                 (process-reset (condition)
406                   (process-reset-kill condition)))))
407    ;; We either exited from the initial form normally, were told to
408    ;; exit prematurely, or are being reset and should enter the
409    ;; "awaiting preset" state.
[513]410    (if (or kill exited) 
[6]411      (unless (eq kill :toplevel)
412        (process-initial-form-exited process (or kill t)))
413      (progn
414        (thread-change-state (process-thread process) :run :reset)
[7949]415        (tcr-set-preset-state (process-tcr process))))
[6]416    nil))
417
[1729]418;;; Separated from run-process-initial-form just so I can change it easily.
[6]419(defun process-initial-form-exited (process kill)
420  ;; Enter the *initial-process* and have it finish us up
421  (without-interrupts
422   (if (eq kill :shutdown)
423     (progn
[7949]424       (setq *whostate* "Shutdown")
[6]425       (add-to-shutdown-processes process)))
426   (maybe-finish-process-kill process kill)))
427
428(defun maybe-finish-process-kill (process kill)
429  (when (and kill (neq kill :shutdown))
[7949]430    (setf (process-whostate process) "Dead")
[6]431    (remove-from-all-processes process)
432    (let ((thread (process-thread process)))
433      (unless (or (eq thread *current-lisp-thread*)
434                  (thread-exhausted-p thread))
435        (kill-lisp-thread thread))))
436  nil)
437
438
439 
440
[464]441(defun require-global-symbol (s &optional env)
[6]442  (let* ((s (require-type s 'symbol))
443         (bits (%symbol-bits s)))
[464]444    (unless (or (logbitp $sym_vbit_global bits)
445                (let* ((defenv (if env (definition-environment env))))
446                  (if defenv
447                    (eq :global (%cdr (assq s (defenv.specials defenv)))))))
[6194]448      (error "~s not defined with ~s" s 'defstatic))
[6]449    s))
450
451
452(defmethod print-object ((s lock) stream)
453  (print-unreadable-object (s stream :type t :identity t)
[1729]454    (let* ((val (uvref s target::lock._value-cell))
455           (name (uvref s target::lock.name-cell)))
[6]456      (when name
[4607]457        (format stream "~s " name))
[6]458      (if (typep val 'macptr)
459        (format stream "[ptr @ #x~x]"
460                (%ptr-to-int val))))))
461
462(defun lockp (l)
[1729]463  (eq target::subtag-lock (typecode l)))
[6]464
465(set-type-predicate 'lock 'lockp)
466
467(defun recursive-lock-p (l)
[1729]468  (and (eq target::subtag-lock (typecode l))
469       (eq 'recursive-lock (%svref l target::lock.kind-cell))))
[6]470
471(defun read-write-lock-p (l)
[1729]472  (and (eq target::subtag-lock (typecode l))
473       (eq 'read-write-lock (%svref l target::lock.kind-cell))))
[6]474
475(setf (type-predicate 'recursive-lock) 'recursive-lock-p
476      (type-predicate 'read-write-lock) 'read-write-lock-p)
477
478
[2569]479(defun grab-lock (lock &optional flag)
[2438]480  "Wait until a given lock can be obtained, then obtain it."
[7729]481  (%lock-recursive-lock-object lock flag))
[6]482
483(defun release-lock (lock)
[2438]484  "Relinquish ownership of a given lock."
[7729]485  (%unlock-recursive-lock-object lock))
[6]486
[2569]487(defun try-lock (lock &optional flag)
[2438]488  "Obtain the given lock, but only if it is not necessary to wait for it."
[7729]489  (%try-recursive-lock-object lock flag))
[6]490
[2569]491(defun lock-acquisition-status (thing)
492  (if (istruct-typep thing 'lock-acquisition)
493    (lock-acquisition.status thing)
494    (report-bad-arg thing 'lock-acquisition)))
[2344]495
[2569]496(defun clear-lock-acquisition-status (thing)
[2596]497  (if (istruct-typep thing 'lock-acquisition)
[2569]498    (setf (lock-acquisition.status thing) nil)
[2596]499    (report-bad-arg thing 'lock-acquisition)))
[2344]500
[2569]501(defmethod print-object ((l lock-acquisition) stream)
502  (print-unreadable-object (l stream :type t :identity t)
503    (format stream "[status = ~s]" (lock-acquisition-status l))))
504
[2605]505(defun semaphore-notification-status (thing)
506  (if (istruct-typep thing 'semaphore-notification)
507    (semaphore-notification.status thing)
508    (report-bad-arg thing 'semaphore-notification)))
[2569]509
[2605]510(defun clear-semaphore-notification-status (thing)
511  (if (istruct-typep thing 'semaphore-notification)
512    (setf (semaphore-notification.status thing) nil)
513    (report-bad-arg thing 'semaphore-notification)))
514
515(defmethod print-object ((l semaphore-notification) stream)
516  (print-unreadable-object (l stream :type t :identity t)
517    (format stream "[status = ~s]" (semaphore-notification-status l))))
518
[6]519(defun process-wait (whostate function &rest args)
[2438]520  "Causes the current lisp process (thread) to wait for a given
521predicate to return true."
[6]522  (declare (dynamic-extent args))
523  (or (apply function args)
[2344]524      (with-process-whostate (whostate)
525        (loop
526          (when (apply function args)
527            (return))
528          ;; Sleep for a tick
[10876]529          #-windows-target
530          (%nanosleep 0 *ns-per-tick*)
531          #+windows-target
532          (%windows-sleep 5)))))
[6]533
534
[2344]535
[6]536(defun process-wait-with-timeout (whostate time function &rest args)
[2438]537  "Cause the current thread to wait for a given predicate to return true,
538or for a timeout to expire."
[6]539  (declare (dynamic-extent args))
540  (cond ((null time)  (apply #'process-wait whostate function args) t)
541        (t (let* ((win nil)
542                  (when (+ (get-tick-count) time))
543                  (f #'(lambda () (let ((val (apply function args)))
544                                    (if val
545                                      (setq win val)
546                                      (> (get-tick-count) when))))))
547             (declare (dynamic-extent f))
548             (process-wait whostate f)
549             win))))
550
551
552(defmethod process-interrupt ((process process) function &rest args)
[2438]553  "Arrange for the target process to invoke a specified function at
554some point in the near future, and then return to what it was doing."
[6]555  (let* ((p (require-type process 'process)))
556    (if (eq p *current-process*)
[2605]557      (progn
558        (apply function args)
559        t)
560      (thread-interrupt
561       (process-thread p)
562       process
563       #'apply
564       function args))))
[6]565
[6942]566(defmethod process-debug-condition ((p process) condition frame-pointer)
567  (declare (ignore condition frame-pointer)))
[6]568
569
[6942]570
571
[1729]572;;; This one is in the Symbolics documentation
[6]573(defun process-allow-schedule ()
[2438]574  "Used for cooperative multitasking; probably never necessary."
[11744]575  (process-yield *current-process*))
[6]576
577
[1729]578;;; something unique that users won't get their hands on
[6]579(defun process-reset-tag (process)
580  (process-splice process))
581
582(defun process-run-function (name-or-keywords function &rest args)
[2438]583  "Create a process, preset it, and enable it."
[6]584  (if (listp name-or-keywords)
585    (%process-run-function name-or-keywords function args)
586    (let ((keywords (list :name name-or-keywords)))
587      (declare (dynamic-extent keywords))
588      (%process-run-function keywords function args))))
589
590(defun %process-run-function (keywords function args)
591  (destructuring-bind (&key (name "Anonymous")
592                            (priority  0)
593                            (stack-size *default-control-stack-size*)
594                            (vstack-size *default-value-stack-size*)
595                            (tstack-size *default-temp-stack-size*)
596                            (initial-bindings ())
597                            (persistent nil)
[2704]598                            (use-standard-initial-bindings t)
[3311]599                            (termination-semaphore nil)
600                            (allocation-quantum (default-allocation-quantum)))
[6]601                      keywords
602    (setq priority (require-type priority 'fixnum))
603    (let* ((process (make-process name
604                                  :priority priority
605                                  :stack-size stack-size
606                                  :vstack-size vstack-size
607                                  :tstack-size tstack-size
608                                  :persistent persistent
609                                  :use-standard-initial-bindings use-standard-initial-bindings
[2704]610                                  :initial-bindings initial-bindings
[3311]611                                  :termination-semaphore termination-semaphore
612                                  :allocation-quantum allocation-quantum)))
[6]613      (process-preset process #'(lambda () (apply function args)))
614      (process-enable process)
615      process)))
616
617(defmethod process-reset ((process process) &optional kill)
[2438]618  "Cause a specified process to cleanly exit from any ongoing computation."
[6]619  (setq process (require-type process 'process))
620  (unless (memq kill '(nil :kill :shutdown))
621    (setq kill (require-type kill '(member nil :kill :shutdown))))
622  (if (eq process *current-process*)
623    (%process-reset kill)
624    (if (process-exhausted-p process)
625      (maybe-finish-process-kill process kill)
626      (progn
627        (process-interrupt process '%process-reset kill)))))
628
[11744]629(defmethod process-yield ((p process))
630  #+windows-target (#_Sleep 0)
631  #-windows-target (#_sched_yield))
[6]632
[11744]633
[6]634(defun %process-reset (kill)
635  (signal 'process-reset :kill kill)
636  (maybe-finish-process-kill *current-process* kill))
637
638;;; By default, it's just fine with the current process
639;;; if the application/user wants to quit.
640(defmethod process-verify-quit ((process process))
641  t)
642
643(defmethod process-exit-application ((process process) thunk)
644  (when (eq process *initial-process*)
[12205]645    (with-standard-abort-handling "Exit Lisp"
646      (prepare-to-quit)
647      (fresh-line *stdout*)
648      (finish-output *stdout*))
[6]649    (%set-toplevel thunk)
650    (toplevel)))
651
652
[2605]653
[6]654(defmethod process-kill ((process process))
[2438]655  "Cause a specified process to cleanly exit from any ongoing
656computation, and then exit."
[2605]657  (and (process-interrupt process #'%process-reset :kill)
658       (setf (process-kill-issued process) t)))
[6]659
660(defun process-abort (process &optional condition)
[2438]661  "Cause a specified process to process an abort condition, as if it
662had invoked abort."
[6]663  (process-interrupt process
664                     #'(lambda ()
665                         (abort condition))))
666
667(defmethod process-reset-and-enable ((process process))
668  (not-in-current-process process 'process-reset-and-enable)
669  (process-reset process)
670  (process-enable process))
671
[2605]672(defmethod process-kill-issued ((process process))
673  (cdr (process-splice process)))
[6]674
[2605]675(defmethod (setf process-kill-issued) (val (process process))
676  (setf (cdr (process-splice process)) val))
677
[6]678(defun tcr->process (tcr)
679  (dolist (p (all-processes))
680    (when (eq tcr (process-tcr p))
681      (return p))))
682
[3311]683(defun current-process-allocation-quantum ()
684  (process-allocation-quantum *current-process*))
[6]685
[3311]686(defun (setf current-process-allocation-quantum) (new)
687  (if (valid-allocation-quantum-p new)
688    (with-macptrs (tcrp)
689      (%setf-macptr-to-object tcrp (%current-tcr))
690      (setf (slot-value *current-process* 'allocation-quantum) new
691            (%get-natural tcrp target::tcr.log2-allocation-quantum)
692            (1- (integer-length new)))
693      new)
694    (report-bad-arg new '(satisfies valid-allocation-quantum-p))))
695
696
[625]697(def-standard-initial-binding *backtrace-contexts* nil)
[5977]698
699(defmethod exit-interactive-process ((p process))
700  (unless (eq p *initial-process*)
701    (when (eq p *current-process*)
702      (process-kill p))))
703
704(defclass tty-listener (process)
705    ())
706
707(defmethod exit-interactive-process ((p tty-listener))
708  (when (eq p *current-process*)
709    (quit)))
[6194]710
711(defmethod process-stop-dribbling ((p process))
712  (with-slots (dribble-stream dribble-saved-terminal-io) p
713    (when dribble-stream
714      (close dribble-stream)
715      (setq dribble-stream nil))
716    (when dribble-saved-terminal-io
717      (setq *terminal-io* dribble-saved-terminal-io
718            dribble-saved-terminal-io nil))))
719
720(defmethod process-dribble ((p process) path)
721  (with-slots (dribble-stream dribble-saved-terminal-io) p
722    (process-stop-dribbling p)
723    (when path
724      (let* ((in (two-way-stream-input-stream *terminal-io*))
725             (out (two-way-stream-output-stream *terminal-io*))
726             (f (open path :direction :output :if-exists :append 
727                      :if-does-not-exist :create)))
728        (without-interrupts
729         (setq dribble-stream f
730               dribble-saved-terminal-io *terminal-io*
731               *terminal-io* (make-echoing-two-way-stream
732                              (make-echo-stream in f)
733                              (make-broadcast-stream out f)))))
734      path)))
[7330]735
[11281]736(defmethod join-process ((p process) &key default)
[7330]737  (wait-on-semaphore (process-termination-semaphore p) nil "join-process")
738  (let ((result (process-result p)))
739    (cond ((car result) (values-list (cdr result)))
[11281]740          (t default))))
[7729]741
[7853]742
Note: See TracBrowser for help on using the repository browser.