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

Last change on this file since 14619 was 14619, checked in by rme, 9 years ago

Merge shrink-tcr branch. This enables the 32-bit Windows lisp to run
on 64-bit Windows.

On 32-bit x86 ports, we expect to use a segment register to point to a
block of thread-local data called the TCR (thread context record).
This has always been kind of a bother on 32-bit Windows: we have been
using a kludge that allows us to use the %es segment register
(conditionalized on WIN32_ES_HACK).

Unfortunately, 64-bit Windows doesn't support using an LDT. This is
why the 32-bit lisp wouldn't run on 64-bit Windows.

The new scheme is to use some of the TlsSlots? (part of the Windows
TEB) for the most important parts of the TCR, and to introduce an "aux
vector" for the remaining TCR slots. Since %fs points to the TEB, we
can make this work. We reserve the last 34 (of 64) slots for our use,
and will die if we don't get them.

Microsoft's documentation says not to access the TlsSlots? directly
(you're supposed to use TlsGetValue/TlsSetValue?), so we're treading on
undocumented ground. Frankly, we've done worse.

This change introduces some ugliness. In lisp kernel C files, there's
a TCR_AUX(tcr) macro that expands to "tcr->aux" on win32, and to "tcr"
elsewhere.

If lisp or lap code has a pointer to a TCR, it's necessary to subtract
off target::tcr-bias (which on Windows/x86 is #xe10, the offset from
%fs to the TlsSlots? in the Windows TEB). We also sometimes have to load
target::tcr.aux to get at data which has been moved there.

These changes should only affect Windows/x86. The story on the other
platforms is just the same as before.

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