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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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