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

Last change on this file since 11757 was 11757, checked in by gb, 11 years ago

In the DEFCLASS for PROCESS, make the THREAD slot have an initform
of NIL.

In MAKE-PROCESS, don't pass the :thread initarg to MAKE-INSTANCE;
if the new instance has a null thread, initialize it. (This is
basically a hack to allow subclasses of PROCESS to initialize
their thread/tcr in a non-default way, without requiring MAKE-PROCESS
or its callers to know the details.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.3 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(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
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            (multiple-value-bind (syms values)
381                (initial-bindings (process-initial-bindings process))
382              (progv syms values
383                (setq *whostate* "Active")
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
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)
401                      (setq exited t)
402                      nil)
403                    (abort-break () :report "Reset this thread")
404                    (abort () :report "Kill this thread" (setq exited t)))
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.
410    (if (or kill exited) 
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)
415        (tcr-set-preset-state (process-tcr process))))
416    nil))
417
418;;; Separated from run-process-initial-form just so I can change it easily.
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
424       (setq *whostate* "Shutdown")
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))
430    (setf (process-whostate process) "Dead")
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
441(defun require-global-symbol (s &optional env)
442  (let* ((s (require-type s 'symbol))
443         (bits (%symbol-bits s)))
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)))))))
448      (error "~s not defined with ~s" s 'defstatic))
449    s))
450
451
452(defmethod print-object ((s lock) stream)
453  (print-unreadable-object (s stream :type t :identity t)
454    (let* ((val (uvref s target::lock._value-cell))
455           (name (uvref s target::lock.name-cell)))
456      (when name
457        (format stream "~s " name))
458      (if (typep val 'macptr)
459        (format stream "[ptr @ #x~x]"
460                (%ptr-to-int val))))))
461
462(defun lockp (l)
463  (eq target::subtag-lock (typecode l)))
464
465(set-type-predicate 'lock 'lockp)
466
467(defun recursive-lock-p (l)
468  (and (eq target::subtag-lock (typecode l))
469       (eq 'recursive-lock (%svref l target::lock.kind-cell))))
470
471(defun read-write-lock-p (l)
472  (and (eq target::subtag-lock (typecode l))
473       (eq 'read-write-lock (%svref l target::lock.kind-cell))))
474
475(setf (type-predicate 'recursive-lock) 'recursive-lock-p
476      (type-predicate 'read-write-lock) 'read-write-lock-p)
477
478
479(defun grab-lock (lock &optional flag)
480  "Wait until a given lock can be obtained, then obtain it."
481  (%lock-recursive-lock-object lock flag))
482
483(defun release-lock (lock)
484  "Relinquish ownership of a given lock."
485  (%unlock-recursive-lock-object lock))
486
487(defun try-lock (lock &optional flag)
488  "Obtain the given lock, but only if it is not necessary to wait for it."
489  (%try-recursive-lock-object lock flag))
490
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)))
495
496(defun clear-lock-acquisition-status (thing)
497  (if (istruct-typep thing 'lock-acquisition)
498    (setf (lock-acquisition.status thing) nil)
499    (report-bad-arg thing 'lock-acquisition)))
500
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
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)))
509
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
519(defun process-wait (whostate function &rest args)
520  "Causes the current lisp process (thread) to wait for a given
521predicate to return true."
522  (declare (dynamic-extent args))
523  (or (apply function args)
524      (with-process-whostate (whostate)
525        (loop
526          (when (apply function args)
527            (return))
528          ;; Sleep for a tick
529          #-windows-target
530          (%nanosleep 0 *ns-per-tick*)
531          #+windows-target
532          (%windows-sleep 5)))))
533
534
535
536(defun process-wait-with-timeout (whostate time function &rest args)
537  "Cause the current thread to wait for a given predicate to return true,
538or for a timeout to expire."
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)
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."
555  (let* ((p (require-type process 'process)))
556    (if (eq p *current-process*)
557      (progn
558        (apply function args)
559        t)
560      (thread-interrupt
561       (process-thread p)
562       process
563       #'apply
564       function args))))
565
566(defmethod process-debug-condition ((p process) condition frame-pointer)
567  (declare (ignore condition frame-pointer)))
568
569
570
571
572;;; This one is in the Symbolics documentation
573(defun process-allow-schedule ()
574  "Used for cooperative multitasking; probably never necessary."
575  (process-yield *current-process*))
576
577
578;;; something unique that users won't get their hands on
579(defun process-reset-tag (process)
580  (process-splice process))
581
582(defun process-run-function (name-or-keywords function &rest args)
583  "Create a process, preset it, and enable it."
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)
598                            (use-standard-initial-bindings t)
599                            (termination-semaphore nil)
600                            (allocation-quantum (default-allocation-quantum)))
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
610                                  :initial-bindings initial-bindings
611                                  :termination-semaphore termination-semaphore
612                                  :allocation-quantum allocation-quantum)))
613      (process-preset process #'(lambda () (apply function args)))
614      (process-enable process)
615      process)))
616
617(defmethod process-reset ((process process) &optional kill)
618  "Cause a specified process to cleanly exit from any ongoing computation."
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
629(defmethod process-yield ((p process))
630  #+windows-target (#_Sleep 0)
631  #-windows-target (#_sched_yield))
632
633
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*)
645    (prepare-to-quit)
646    (%set-toplevel thunk)
647    (fresh-line *stdout*)
648    (finish-output *stdout*)
649    (toplevel)))
650
651
652
653(defmethod process-kill ((process process))
654  "Cause a specified process to cleanly exit from any ongoing
655computation, and then exit."
656  (and (process-interrupt process #'%process-reset :kill)
657       (setf (process-kill-issued process) t)))
658
659(defun process-abort (process &optional condition)
660  "Cause a specified process to process an abort condition, as if it
661had invoked abort."
662  (process-interrupt process
663                     #'(lambda ()
664                         (abort condition))))
665
666(defmethod process-reset-and-enable ((process process))
667  (not-in-current-process process 'process-reset-and-enable)
668  (process-reset process)
669  (process-enable process))
670
671(defmethod process-kill-issued ((process process))
672  (cdr (process-splice process)))
673
674(defmethod (setf process-kill-issued) (val (process process))
675  (setf (cdr (process-splice process)) val))
676
677(defun tcr->process (tcr)
678  (dolist (p (all-processes))
679    (when (eq tcr (process-tcr p))
680      (return p))))
681
682(defun current-process-allocation-quantum ()
683  (process-allocation-quantum *current-process*))
684
685(defun (setf current-process-allocation-quantum) (new)
686  (if (valid-allocation-quantum-p new)
687    (with-macptrs (tcrp)
688      (%setf-macptr-to-object tcrp (%current-tcr))
689      (setf (slot-value *current-process* 'allocation-quantum) new
690            (%get-natural tcrp target::tcr.log2-allocation-quantum)
691            (1- (integer-length new)))
692      new)
693    (report-bad-arg new '(satisfies valid-allocation-quantum-p))))
694
695
696(def-standard-initial-binding *backtrace-contexts* nil)
697
698(defmethod exit-interactive-process ((p process))
699  (unless (eq p *initial-process*)
700    (when (eq p *current-process*)
701      (process-kill p))))
702
703(defclass tty-listener (process)
704    ())
705
706(defmethod exit-interactive-process ((p tty-listener))
707  (when (eq p *current-process*)
708    (quit)))
709
710(defmethod process-stop-dribbling ((p process))
711  (with-slots (dribble-stream dribble-saved-terminal-io) p
712    (when dribble-stream
713      (close dribble-stream)
714      (setq dribble-stream nil))
715    (when dribble-saved-terminal-io
716      (setq *terminal-io* dribble-saved-terminal-io
717            dribble-saved-terminal-io nil))))
718
719(defmethod process-dribble ((p process) path)
720  (with-slots (dribble-stream dribble-saved-terminal-io) p
721    (process-stop-dribbling p)
722    (when path
723      (let* ((in (two-way-stream-input-stream *terminal-io*))
724             (out (two-way-stream-output-stream *terminal-io*))
725             (f (open path :direction :output :if-exists :append 
726                      :if-does-not-exist :create)))
727        (without-interrupts
728         (setq dribble-stream f
729               dribble-saved-terminal-io *terminal-io*
730               *terminal-io* (make-echoing-two-way-stream
731                              (make-echo-stream in f)
732                              (make-broadcast-stream out f)))))
733      path)))
734
735(defmethod join-process ((p process) &key default)
736  (wait-on-semaphore (process-termination-semaphore p) nil "join-process")
737  (let ((result (process-result p)))
738    (cond ((car result) (values-list (cdr result)))
739          (t default))))
740
741
Note: See TracBrowser for help on using the repository browser.