1 ;;;; stack-group and multi-process support for CMU CL x86
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
17 ;;;; Handle the binding stack.
19 ;;; Undo all the bindings in the bind stack, restoring the global
21 (defun unbind-binding-stack ()
22 (declare (optimize (speed 3) (safety 0)))
23 (let* ((binding-stack-pointer (sb!kernel:binding-stack-pointer-sap))
25 (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
27 (size (sb!sys:sap- binding-stack-pointer binding-stack)))
28 (declare (type (unsigned-byte 29) size))
31 (declare (type (unsigned-byte 29) binding))
34 (sb!kernel:make-lisp-obj
35 (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding))))
37 (sb!kernel:make-lisp-obj
38 (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack
40 (cond ((symbolp symbol)
41 (let ((symbol-value (sb!c::%primitive sb!c:fast-symbol-value
44 (format t "undoing: ~S ~S <-> ~S~%" symbol value symbol-value)
45 (sb!kernel:%set-symbol-value symbol value)
46 (setf (sb!sys:sap-ref-sap binding-stack binding)
47 (sb!sys:int-sap (sb!kernel:get-lisp-obj-address
51 (format t "ignoring undoing: ~S ~S~%" symbol value)))))))
53 ;;; Re-apply the bindings in a binding stack after an
54 ;;; unbind-binding-stack.
55 (defun rebind-binding-stack ()
56 (declare (optimize (speed 3) (safety 0)))
57 (let* ((binding-stack-pointer (sb!kernel:binding-stack-pointer-sap))
59 (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
61 (size (sb!sys:sap- binding-stack-pointer binding-stack)))
62 (declare (type (unsigned-byte 29) size))
63 (do ((binding 0 (+ 8 binding)))
65 (declare (type (unsigned-byte 29) binding))
67 (sb!kernel:make-lisp-obj
68 (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding))))
70 (sb!kernel:make-lisp-obj
71 (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack
73 (cond ((symbolp symbol)
74 (let ((symbol-value (sb!c::%primitive sb!c:fast-symbol-value
77 (format t "rebinding: ~S ~S <-> ~S~%"
78 symbol value symbol-value)
79 (sb!kernel:%set-symbol-value symbol value)
80 (setf (sb!sys:sap-ref-sap binding-stack binding)
81 (sb!sys:int-sap (sb!kernel:get-lisp-obj-address
85 (format t "ignoring rebinding: ~S ~S~%" symbol value)))))))
87 (defun save-binding-stack (binding-save-stack)
88 (declare (type (simple-array t (*)) binding-save-stack)
89 (optimize (speed 3) (safety 0)))
90 (let* ((binding-stack-pointer (sb!kernel:binding-stack-pointer-sap))
92 (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
94 (size (sb!sys:sap- binding-stack-pointer binding-stack))
95 (vector-size (truncate size 4)))
96 (declare (type (unsigned-byte 29) size))
97 ;; Grow binding-save-stack if necessary.
98 (when (< (length binding-save-stack) vector-size)
99 (setq binding-save-stack
100 (adjust-array binding-save-stack vector-size :element-type t)))
102 (do ((binding 0 (+ 4 binding))
103 (index 0 (1+ index)))
105 (declare (type (unsigned-byte 29) binding index))
106 (setf (aref binding-save-stack index)
107 (sb!kernel:make-lisp-obj
108 (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding)))))
109 (values binding-save-stack vector-size)))
111 (defun restore-binding-stack (new-binding-stack size)
112 (declare (type (simple-array t (*)) new-binding-stack)
113 (type (unsigned-byte 29) size)
114 (optimize (speed 3) (safety 0)))
115 (let* ((binding-stack-size (* size 4))
116 (binding-stack (sb!alien:extern-alien "binding_stack"
118 (declare (type (unsigned-byte 32) binding-stack-size binding-stack))
119 (setf (sb!kernel:binding-stack-pointer-sap)
120 (sb!sys:int-sap (+ binding-stack binding-stack-size)))
121 (do ((binding 0 (+ 4 binding))
122 (index 0 (1+ index)))
123 ((= binding binding-stack-size))
124 (declare (type (unsigned-byte 29) binding index))
125 (setf (sb!sys:sap-ref-sap (sb!sys:int-sap binding-stack) binding)
126 (sb!sys:int-sap (sb!kernel:get-lisp-obj-address
127 (aref new-binding-stack index))))))
132 ;;; The Top of the Alien-stack.
133 (declaim (type (unsigned-byte 32) *alien-stack-top*))
134 (defvar *alien-stack-top* 0)
136 ;;; Save the alien-stack.
137 (defun save-alien-stack (save-stack)
138 (declare (type (simple-array (unsigned-byte 32) (*)) save-stack)
139 (optimize (speed 3) (safety 0)))
140 (let* ((alien-stack (sb!kernel:get-lisp-obj-address sb!vm::*alien-stack*))
141 (size (- *alien-stack-top* alien-stack))
142 (vector-size (ceiling size 4)))
143 (declare (type (unsigned-byte 32) alien-stack)
144 (type (unsigned-byte 29) size))
146 (format t "alien-stack ~X; size ~X~%" alien-stack size)
147 ;; Grow save-stack if necessary.
148 (when (< (length save-stack) vector-size)
150 (adjust-array save-stack vector-size
151 :element-type '(unsigned-byte 32))))
153 (do ((index 0 (1+ index)))
154 ((>= index vector-size))
155 (declare (type (unsigned-byte 29) index))
156 (setf (aref save-stack index)
157 (sb!sys:sap-ref-32 (sb!sys:int-sap *alien-stack-top*)
158 (* 4 (- (1+ index))))))
159 (values save-stack vector-size alien-stack)))
161 (defun restore-alien-stack (save-stack size alien-stack)
162 (declare (type (simple-array (unsigned-byte 32) (*)) save-stack)
163 (type (unsigned-byte 29) size)
164 (type (unsigned-byte 32) alien-stack)
165 (optimize (speed 3) (safety 0)))
166 (setf sb!vm::*alien-stack* (sb!kernel:make-lisp-obj alien-stack))
167 (do ((index 0 (1+ index)))
169 (declare (type (unsigned-byte 29) index))
170 (setf (sb!sys:sap-ref-32 (sb!sys:int-sap *alien-stack-top*)
171 (* 4 (- (1+ index))))
172 (aref save-stack index)))
175 ;;;; interrupt contexts
177 ;;; Save the interrupt contexts.
178 (defun save-interrupt-contexts (save-vector)
179 (declare (type (simple-array (unsigned-byte 32) (*)) save-vector)
180 (optimize (speed 3) (safety 0)))
181 (let* ((size sb!impl::*free-interrupt-context-index*))
182 (declare (type (unsigned-byte 29) size))
183 ;; Grow save-stack if necessary.
184 (when (< (length save-vector) size)
186 (adjust-array save-vector size :element-type '(unsigned-byte 32))))
188 ((lisp-interrupt-contexts (array sb!alien:unsigned nil) :extern))
189 (dotimes (index size)
190 (setf (aref save-vector index)
191 (sb!alien:deref lisp-interrupt-contexts index))))
194 ;;; Restore the interrupt contexts.
195 (defun restore-interrupt-contexts (save-vector)
196 (declare (type (simple-array (unsigned-byte 32) (*)) save-vector)
197 (optimize (speed 3) (safety 0)))
198 (let* ((size sb!impl::*free-interrupt-context-index*))
199 (declare (type (unsigned-byte 29) size))
201 ((lisp-interrupt-contexts (array sb!alien:unsigned nil) :extern))
202 (dotimes (index size)
203 (setf (sb!alien:deref lisp-interrupt-contexts index)
204 (aref save-vector index)))))
207 ;;; The control stacks need special handling on the X86 as they
208 ;;; contain conservative roots. When placed in the *control-stacks*
209 ;;; vector they will be scavenged for conservative roots by the
210 ;;; garbage collector.
211 (declaim (type (simple-array (or null (simple-array (unsigned-byte 32) (*)))
212 (*)) sb!vm::*control-stacks*))
213 (defvar sb!vm::*control-stacks*
214 (make-array 0 :element-type '(or null (unsigned-byte 32))
215 :initial-element nil))
217 ;;; Stack-group structure.
218 (defstruct (stack-group
219 (:constructor %make-stack-group)
221 (lambda (stack-group stream)
222 (declare (type stack-group stack-group)
224 (print-unreadable-object (stack-group stream :identity t)
225 (format stream "stack-group ~A, ~A"
226 (stack-group-name stack-group)
227 (stack-group-state stack-group))))))
229 (name "Anonymous" :type simple-base-string)
230 ;; State: :active or :inactive.
231 (state :inactive :type (member :active :inactive))
232 ;; The control stack; an index into *control-stacks*.
233 (control-stack-id nil :type (or sb!int:index null))
235 (binding-stack nil :type (or (simple-array t (*)) null))
236 ;; Twice the number of bindings.
237 (binding-stack-size 0 :type (unsigned-byte 29))
238 ;; Current catch block, on the control stack.
239 (current-catch-block 0 :type fixnum)
240 ;; Unwind protect block, on the control stack.
241 (current-unwind-protect-block 0 :type fixnum)
243 (alien-stack nil :type (or (simple-array (unsigned-byte 32) (*)) null))
244 (alien-stack-size 0 :type (unsigned-byte 29))
245 (alien-stack-pointer 0 :type (unsigned-byte 32))
247 (eval-stack nil :type (or (simple-array t (*)) null))
248 (eval-stack-top 0 :type fixnum)
249 ;; Interrupt contexts
250 (interrupt-contexts nil :type (or (simple-array (unsigned-byte 32) (*))
253 (resumer nil :type (or stack-group null)))
255 ;;; The current stack group.
256 (declaim (type (or stack-group null) *current-stack-group*))
257 (defvar *current-stack-group* nil)
259 (declaim (type (or stack-group null) *initial-stack-group*))
260 (defvar *initial-stack-group* nil)
262 ;;; Setup the initial stack group.
263 (defun init-stack-groups ()
264 ;; Grab the top of the alien-stack; it's currently stored at the top
265 ;; of the control stack.
266 (setf *alien-stack-top*
268 (sb!sys:int-sap (sb!alien:extern-alien "control_stack_end"
271 ;; Initialise the *control-stacks* vector.
272 (setq sb!vm::*control-stacks*
273 (make-array 10 :element-type '(or null (unsigned-byte 32))
274 :initial-element nil))
275 ;; Setup a control-stack for the initial stack-group.
276 (setf (aref sb!vm::*control-stacks* 0)
278 :element-type '(unsigned-byte 32)
280 ;; Make and return the initial stack group.
281 (setf *current-stack-group*
287 :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
288 :interrupt-contexts (make-array 0 :element-type '(unsigned-byte 32))
290 (setf *initial-stack-group* *current-stack-group*))
292 ;;; Inactivate the stack group, cleaning its slot and freeing the
294 (defun inactivate-stack-group (stack-group)
295 (declare (type stack-group stack-group))
296 (setf (stack-group-state stack-group) :inactive)
297 (let ((cs-id (stack-group-control-stack-id stack-group)))
298 (when (and cs-id (aref sb!vm::*control-stacks* cs-id))
299 (setf (aref sb!vm::*control-stacks* cs-id) nil)))
300 (setf (stack-group-control-stack-id stack-group) nil)
301 (setf (stack-group-binding-stack stack-group) nil)
302 (setf (stack-group-binding-stack-size stack-group) 0)
303 (setf (stack-group-current-catch-block stack-group) 0)
304 (setf (stack-group-current-unwind-protect-block stack-group) 0)
305 (setf (stack-group-alien-stack stack-group) nil)
306 (setf (stack-group-alien-stack-size stack-group) 0)
307 (setf (stack-group-alien-stack-pointer stack-group) 0)
308 (setf (stack-group-eval-stack stack-group) nil)
309 (setf (stack-group-eval-stack-top stack-group) 0)
310 (setf (stack-group-resumer stack-group) nil))
312 ;;; Scrub the binding and eval stack of the give stack-group.
313 (defun scrub-stack-group-stacks (stack-group)
314 (declare (type stack-group stack-group)
315 (optimize (speed 3) (safety 0)))
317 (let ((binding-save-stack (stack-group-binding-stack stack-group)))
318 (when binding-save-stack
320 ;; The stored binding stack for the current stack group
321 ;; can be completely scrubbed.
322 (if (eq stack-group *current-stack-group*)
324 (stack-group-binding-stack-size stack-group)))
325 (len (length binding-save-stack)))
326 ;; Scrub the remainder of the binding stack.
327 (do ((index size (+ index 1)))
329 (declare (type (unsigned-byte 29) index))
330 (setf (aref binding-save-stack index) 0)))))
331 ;; If this is the current stack group then update the stored
332 ;; eval-stack and eval-stack-top before scrubbing.
333 (when (eq stack-group *current-stack-group*)
334 ;; Updare the stored vector, flushing an old vector if a new one
335 ;; has been allocated.
336 (setf (stack-group-eval-stack stack-group) sb!impl::*eval-stack*)
337 ;; Ensure that the stack-top is valid.
338 (setf (stack-group-eval-stack-top stack-group) sb!impl::*eval-stack-top*))
339 ;; Scrub the eval stack.
340 (let ((eval-stack (stack-group-eval-stack stack-group)))
342 (let ((eval-stack-top (stack-group-eval-stack-top stack-group))
343 (len (length eval-stack)))
344 (do ((i eval-stack-top (1+ i)))
346 (declare (type sb!int:index i))
347 (setf (svref eval-stack i) nil))))))
349 ;;; Generate the initial bindings for a newly created stack-group.
350 ;;; This function may be redefined to return a vector with other bindings
351 ;;; but *interrupts-enabled* and *gc-inhibit* must be the last two.
352 (defun initial-binding-stack ()
354 (find-package "COMMON-LISP-USER") '*package*
355 ;; Other bindings may be added here.
356 nil 'sb!unix::*interrupts-enabled*
357 t 'sb!impl::*gc-inhibit*))
359 ;;; Fork a new stack-group from the *current-stack-group*. Execution
360 ;;; continues with the *current-stack-group* returning the new stack
361 ;;; group. Control may be transfer to the child by stack-group-resume
362 ;;; and it executes the initial-function.
363 (defun make-stack-group (name initial-function &optional
364 (resumer *current-stack-group*)
366 (declare (type simple-base-string name)
367 (type function initial-function)
368 (type stack-group resumer))
369 (flet ((allocate-control-stack ()
370 (let* (;; Allocate a new control-stack ID.
371 (control-stack-id (position nil sb!vm::*control-stacks*))
372 ;; Find the required stack size.
374 (sb!alien:extern-alien "control_stack_end"
376 (control-stack-pointer (sb!kernel:control-stack-pointer-sap))
379 (sb!sys:sap-int control-stack-pointer)))
380 ;; Saved control stack needs three extra words. The
381 ;; stack pointer will be stored in the first
382 ;; element, and the frame pointer and return address
383 ;; push onto the bottom of the stack.
385 (make-array (+ (ceiling control-stack-size 4) 3)
386 :element-type '(unsigned-byte 32)
387 :initial-element 0)))
388 (declare (type (unsigned-byte 29) control-stack-size))
389 (unless control-stack-id
390 ;; Need to extend the *control-stacks* vector.
391 (setq control-stack-id (length sb!vm::*control-stacks*))
392 (setq sb!vm::*control-stacks*
393 (adjust-array sb!vm::*control-stacks*
394 (* 2 (length sb!vm::*control-stacks*))
395 :element-type '(or null (unsigned-byte 32))
396 :initial-element nil)))
397 (setf (aref sb!vm::*control-stacks* control-stack-id)
399 (values control-stack control-stack-id)))
400 ;; Allocate a stack group inheriting stacks and bindings from
401 ;; the current stack group.
402 (allocate-child-stack-group (control-stack-id)
403 ;; Save the interrupt-contexts while the size is still
405 (let ((interrupt-contexts
406 (save-interrupt-contexts
407 (make-array 0 :element-type '(unsigned-byte 32)))))
408 ;; Save the binding stack. Note that
409 ;; *interrutps-enabled* could be briefly set during the
410 ;; unbinding and re-binding process so signals are
412 (let ((old-sigs (sb!unix:unix-sigblock
413 (sb!unix:sigmask :sigint :sigalrm))))
414 (declare (type (unsigned-byte 32) old-sigs))
415 (unbind-binding-stack)
416 (multiple-value-bind (binding-stack binding-stack-size)
417 (save-binding-stack #())
418 (rebind-binding-stack)
419 (sb!unix:unix-sigsetmask old-sigs)
420 ;; Save the Alien stack.
422 (alien-stack alien-stack-size alien-stack-pointer)
424 (make-array 0 :element-type '(unsigned-byte 32)))
425 ;; Allocate a stack-group structure.
429 :control-stack-id control-stack-id
430 ;; Save the Eval stack.
431 :eval-stack (copy-seq (the simple-vector
432 sb!kernel:*eval-stack*))
433 :eval-stack-top sb!kernel:*eval-stack-top*
435 :current-catch-block sb!impl::*current-catch-block*
436 :current-unwind-protect-block
437 sb!impl::*current-unwind-protect-block*
439 :alien-stack alien-stack
440 :alien-stack-size alien-stack-size
441 :alien-stack-pointer alien-stack-pointer
442 ;; Interrupt contexts
443 :interrupt-contexts interrupt-contexts
445 :binding-stack binding-stack
446 :binding-stack-size binding-stack-size
448 :resumer resumer))))))
449 ;; Allocate a new stack group with fresh stacks and bindings.
450 (allocate-new-stack-group (control-stack-id)
451 (let ((binding-stack (initial-binding-stack)))
452 ;; Allocate a stack-group structure.
456 :control-stack-id control-stack-id
457 ;; Eval stack. Needs at least one element be because
458 ;; push doubles the size when full.
459 :eval-stack (make-array 32)
462 :current-catch-block 0
463 :current-unwind-protect-block 0
465 :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
467 :alien-stack-pointer *alien-stack-top*
468 ;; Interrupt contexts
469 :interrupt-contexts (make-array 0 :element-type
471 ;; Binding stack - some initial bindings.
472 :binding-stack binding-stack
473 :binding-stack-size (length binding-stack)
476 (let ((child-stack-group nil))
477 (let ((sb!unix::*interrupts-enabled* nil)
478 (sb!impl::*gc-inhibit* t))
479 (multiple-value-bind (control-stack control-stack-id)
480 (allocate-control-stack)
481 (setq child-stack-group
483 (allocate-child-stack-group control-stack-id)
484 (allocate-new-stack-group control-stack-id)))
485 ;; Fork the control-stack.
486 (if (sb!vm:control-stack-fork control-stack inherit)
487 ;; Current-stack-group returns the child-stack-group.
492 (setq *current-stack-group* child-stack-group)
493 (assert (eq *current-stack-group*
494 (process-stack-group *current-process*)))
495 ;; Enable interrupts and GC.
496 (setf sb!unix::*interrupts-enabled* t)
497 (setf sb!impl::*gc-inhibit* nil)
498 (when sb!unix::*interrupt-pending*
499 (sb!unix::do-pending-interrupt))
500 (when sb!impl::*need-to-collect-garbage*
502 (funcall initial-function))
503 (let ((resumer (stack-group-resumer child-stack-group)))
504 ;; Disable interrupts and GC.
505 (setf sb!unix::*interrupts-enabled* nil)
506 (setf sb!impl::*gc-inhibit* t)
507 (inactivate-stack-group child-stack-group)
508 ;; Verify the resumer.
510 (eq (stack-group-state resumer) :active))
511 (format t "*resuming stack-group ~S instead of ~S~%"
512 *initial-stack-group* resumer)
513 (setq resumer *initial-stack-group*))
514 ;; Restore the resumer state.
515 (setq *current-stack-group* resumer)
517 (setf sb!kernel:*eval-stack*
518 (stack-group-eval-stack resumer))
519 (setf sb!kernel:*eval-stack-top*
520 (stack-group-eval-stack-top resumer))
521 ;; The binding stack. Note that
522 ;; *interrutps-enabled* could be briefly set during
523 ;; the unbinding and re-binding process so signals
525 (let ((old-sigs (sb!unix:unix-sigblock
526 (sb!unix:sigmask :sigint :sigalrm))))
527 (declare (type (unsigned-byte 32) old-sigs))
528 (unbind-binding-stack)
529 (restore-binding-stack
530 (stack-group-binding-stack resumer)
531 (stack-group-binding-stack-size resumer))
532 (rebind-binding-stack)
533 (sb!unix:unix-sigsetmask old-sigs))
535 (setf sb!impl::*current-catch-block*
536 (stack-group-current-catch-block resumer))
537 (setf sb!impl::*current-unwind-protect-block*
538 (stack-group-current-unwind-protect-block resumer))
541 (stack-group-alien-stack resumer)
542 (stack-group-alien-stack-size resumer)
543 (stack-group-alien-stack-pointer resumer))
544 ;; Interrupt-contexts.
545 (restore-interrupt-contexts
546 (stack-group-interrupt-contexts resumer))
547 (let ((new-control-stack
548 (aref sb!vm::*control-stacks*
549 (stack-group-control-stack-id resumer))))
550 (declare (type (simple-array (unsigned-byte 32) (*))
552 (sb!vm:control-stack-return new-control-stack)))))))
553 (when (and sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending*)
554 (sb!unix::do-pending-interrupt))
555 (when (and sb!impl::*need-to-collect-garbage*
556 (not sb!impl::*gc-inhibit*))
560 ;;; Transfer control to the given stack-group, resuming its execution,
561 ;;; and saving the *current-stack-group*.
562 (defun stack-group-resume (new-stack-group)
563 (declare (type stack-group new-stack-group)
564 (optimize (speed 3)))
565 (assert (and (eq (stack-group-state new-stack-group) :active)
566 (not (eq new-stack-group *current-stack-group*))))
567 (assert (eq new-stack-group (process-stack-group *current-process*)))
568 (let ((sb!unix::*interrupts-enabled* nil)
569 (sb!impl::*gc-inhibit* t))
570 (let* (;; Save the current stack-group on its stack.
571 (stack-group *current-stack-group*)
572 ;; Find the required stack size.
574 (sb!alien:extern-alien "control_stack_end" sb!alien:unsigned))
575 (control-stack-pointer (sb!kernel:control-stack-pointer-sap))
576 (control-stack-size (- control-stack-end
577 (sb!sys:sap-int control-stack-pointer)))
578 ;; Stack-save array needs three extra elements. The stack
579 ;; pointer will be stored in the first, and the frame
580 ;; pointer and return address push onto the bottom of the
582 (save-stack-size (+ (ceiling control-stack-size 4) 3))
583 ;; the save-stack vector
584 (control-stack (aref sb!vm::*control-stacks*
585 (stack-group-control-stack-id stack-group))))
586 (declare (type (unsigned-byte 29) control-stack-size save-stack-size)
587 (type (simple-array (unsigned-byte 32) (*)) control-stack))
588 ;; Increase the save-stack size if necessary.
589 (when (> save-stack-size (length control-stack))
590 (setf control-stack (adjust-array control-stack save-stack-size
591 :element-type '(unsigned-byte 32)
593 (setf (aref sb!vm::*control-stacks*
594 (stack-group-control-stack-id stack-group))
598 (setf (stack-group-eval-stack stack-group) sb!kernel:*eval-stack*)
599 (setf (stack-group-eval-stack-top stack-group)
600 sb!kernel:*eval-stack-top*)
601 (setf sb!kernel:*eval-stack* (stack-group-eval-stack new-stack-group))
602 (setf sb!kernel:*eval-stack-top*
603 (stack-group-eval-stack-top new-stack-group))
606 (setf (stack-group-current-catch-block stack-group)
607 sb!impl::*current-catch-block*)
608 (setf (stack-group-current-unwind-protect-block stack-group)
609 sb!impl::*current-unwind-protect-block*)
610 (setf sb!impl::*current-catch-block*
611 (stack-group-current-catch-block new-stack-group))
612 (setf sb!impl::*current-unwind-protect-block*
613 (stack-group-current-unwind-protect-block new-stack-group))
615 ;; Save the interrupt-contexts.
616 (setf (stack-group-interrupt-contexts stack-group)
617 (save-interrupt-contexts
618 (stack-group-interrupt-contexts stack-group)))
620 ;; the binding stack. Note that *interrutps-enabled* could be
621 ;; briefly set during the unbinding and re-binding process so
622 ;; signals are blocked.
623 (let ((old-sigs (sb!unix:unix-sigblock (sb!unix:sigmask :sigint
625 (declare (type (unsigned-byte 32) old-sigs))
626 (unbind-binding-stack)
627 (multiple-value-bind (stack size)
628 (save-binding-stack (stack-group-binding-stack stack-group))
629 (setf (stack-group-binding-stack stack-group) stack)
630 (setf (stack-group-binding-stack-size stack-group) size))
631 (restore-binding-stack (stack-group-binding-stack new-stack-group)
632 (stack-group-binding-stack-size
634 (rebind-binding-stack)
635 (sb!unix:unix-sigsetmask old-sigs))
637 ;; Restore the interrupt-contexts.
638 (restore-interrupt-contexts
639 (stack-group-interrupt-contexts new-stack-group))
642 (multiple-value-bind (save-stack size alien-stack)
643 (save-alien-stack (stack-group-alien-stack stack-group))
644 (setf (stack-group-alien-stack stack-group) save-stack)
645 (setf (stack-group-alien-stack-size stack-group) size)
646 (setf (stack-group-alien-stack-pointer stack-group) alien-stack))
647 (restore-alien-stack (stack-group-alien-stack new-stack-group)
648 (stack-group-alien-stack-size new-stack-group)
649 (stack-group-alien-stack-pointer new-stack-group))
650 (let ((new-control-stack
651 (aref sb!vm::*control-stacks*
652 (stack-group-control-stack-id new-stack-group))))
653 (declare (type (simple-array (unsigned-byte 32) (*))
655 (sb!vm:control-stack-resume control-stack new-control-stack))
657 (setq *current-stack-group* stack-group)))
658 (assert (eq *current-stack-group* (process-stack-group *current-process*)))
659 (when (and sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending*)
660 (sb!unix::do-pending-interrupt))
661 (when (and sb!impl::*need-to-collect-garbage*
662 (not sb!impl::*gc-inhibit*))
666 ;;;; DOUBLE-FLOAT timing functions for use by the scheduler
668 ;;; These timer functions use double-floats for accuracy. In most
669 ;;; cases consing is avoided.
671 #!-sb-fluid (declaim (inline get-real-time))
672 (defun get-real-time ()
674 "Return the real time in seconds."
675 (declare (optimize (speed 3) (safety 0)))
676 (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
677 (declare (ignore ignore)
678 (type (unsigned-byte 32) seconds useconds))
679 (+ (coerce seconds 'double-float)
680 (* (coerce useconds 'double-float) 1d-6))))
682 #!-sb-fluid (declaim (inline get-run-time))
683 (defun get-run-time ()
685 "Return the run time in seconds"
686 (declare (optimize (speed 3) (safety 0)))
687 (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
688 (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
689 (declare (ignore ignore)
690 (type (unsigned-byte 31) utime-sec stime-sec)
691 ;; (Classic CMU CL had these (MOD 1000000) instead, but
692 ;; at least in Linux 2.2.12, the type doesn't seem to be
693 ;; documented anywhere and the observed behavior is to
694 ;; sometimes return 1000000 exactly.)
695 (type (integer 0 1000000) utime-usec stime-usec))
696 (+ (coerce utime-sec 'double-float) (coerce stime-sec 'double-float)
697 (* (+ (coerce utime-usec 'double-float)
698 (coerce stime-usec 'double-float))
701 ;;;; Multi-process support. The interface is based roughly on the
702 ;;;; CLIM-SYS spec. and support needed for cl-http.
704 (defvar *multi-processing* t)
707 (:constructor %make-process)
708 (:predicate processp)
710 (lambda (process stream)
711 (print-unreadable-object (process stream :identity t :type t)
712 (write-string (process-name process) stream)))))
713 (name "Anonymous" :type simple-base-string)
714 (state :killed :type (member :killed :active :inactive))
715 (%whostate nil :type (or null simple-base-string))
716 (initial-function nil :type (or null function))
717 (initial-args nil :type list)
718 (wait-function nil :type (or null function))
719 ;; The real time after which the wait will timeout.
720 (wait-timeout nil :type (or null double-float))
721 (wait-return-value nil :type t)
722 (interrupts '() :type list)
723 (stack-group nil :type (or null stack-group))
724 ;; The real and run times when the current process was last
725 ;; scheduled or yielded.
726 (scheduled-real-time (get-real-time) :type double-float)
727 (scheduled-run-time (get-run-time) :type double-float)
728 ;; Accrued real and run times in seconds.
729 (%real-time 0d0 :type double-float)
730 (%run-time 0d0 :type double-float))
732 (defun process-whostate (process)
734 "Return the process state which is either Run, Killed, or a wait reason."
735 (cond ((eq (process-state process) :killed)
737 ((process-wait-function process)
738 (or (process-%whostate process) "Run"))
742 #!-sb-fluid (declaim (inline process-active-p))
743 (defun process-active-p (process)
744 (eq (process-state process) :active))
746 #!-sb-fluid (declaim (inline process-alive-p))
747 (defun process-alive-p (process)
748 (let ((state (process-state process)))
749 (or (eq state :active) (eq state :inactive))))
751 (declaim (type (or null process) *current-process*))
752 (defvar *current-process* nil)
754 #!-sb-fluid (declaim (inline current-process))
755 (defun current-process ()
757 "Returns the current process."
760 (declaim (list *all-processes*))
761 (defvar *all-processes* nil
763 "A list of all alive processes.")
765 #!-sb-fluid (declaim (inline all-processes))
766 (defun all-processes ()
768 "Return a list of all the live processes."
771 (declaim (type (or null process) *intial-process*))
772 (defvar *initial-process* nil)
774 ;;; Disable scheduling while the body is executed. Scheduling is
775 ;;; typically inhibited when process state is being modified.
776 (defvar *inhibit-scheduling* t)
777 (defmacro without-scheduling (&body body)
779 "Execute the body the scheduling disabled."
780 `(let ((inhibit *inhibit-scheduling*))
783 (setf *inhibit-scheduling* t)
785 (setf *inhibit-scheduling* inhibit))))
787 (defmacro atomic-incf (reference &optional (delta 1))
789 "Increments the reference by delta in a single atomic operation"
791 (incf ,reference ,delta)))
793 (defmacro atomic-decf (reference &optional (delta 1))
795 "Decrements the reference by delta in a single atomic operation"
797 (decf ,reference ,delta)))
799 (defmacro atomic-push (obj place)
801 "Atomically push object onto place."
805 (defmacro atomic-pop (place)
807 "Atomically pop place."
811 ;;; If a process other than the initial process throws to the
812 ;;; %END-OF-THE-WORLD then *QUITTING-LISP* is set to the exit value,
813 ;;; after which further process creation blocks. If the initial
814 ;;; process is running the idle loop then it will perform the exit
816 (defvar *quitting-lisp* nil)
818 ;;; Update the processes times for the current and new process before
819 ;;; a process switch.
820 (defun update-process-timers (current-process new-process)
821 (declare (type process current-process new-process)
822 (optimize (speed 3) (safety 0)))
823 (let ((real-time (get-real-time)))
824 (incf (process-%real-time current-process)
825 (- real-time (process-scheduled-real-time current-process)))
826 (setf (process-scheduled-real-time current-process) real-time)
827 (setf (process-scheduled-real-time new-process) real-time))
828 (let ((run-time (get-run-time)))
829 (incf (process-%run-time current-process)
830 (- run-time (process-scheduled-run-time current-process)))
831 (setf (process-scheduled-run-time current-process) run-time)
832 (setf (process-scheduled-run-time new-process) run-time))
835 (defun make-process (function &key (name "Anonymous"))
837 "Make a process which will run function when it starts up. The process
838 may be given an optional name which defaults to Anonymous. The new
839 process has a fresh set of special bindings, with *PACKAGE* set to be
840 the COMMON-LISP-USER package."
841 (declare (type (or null function) function))
842 (cond (*quitting-lisp*
843 ;; No more processes if about to quit lisp.
844 (process-wait "Quitting Lisp" #'(lambda () nil)))
846 ;; If function is nil then create a dead process; can be
847 ;; restarted with process-preset.
848 (%make-process :initial-function nil :name name :state :killed))
850 ;; Create a stack-group.
855 :initial-function function
861 (catch '%end-of-the-process
862 ;; Catch throws to the %END-OF-THE-WORLD.
863 (setf *quitting-lisp*
864 (catch 'sb!impl::%end-of-the-world
866 (destroy "Destroy the process")
867 (setf *inhibit-scheduling* nil)
870 (throw '%end-of-the-process nil))))
871 (setf *inhibit-scheduling* t)
872 ;; About to return to the resumer's
873 ;; stack-group, which in this case is the
874 ;; initial process's stack-group.
875 (setf (process-state *current-process*) :killed)
876 (setf *all-processes*
877 (delete *current-process* *all-processes*))
878 (setf (process-%whostate *current-process*) nil)
879 (setf (process-wait-function *current-process*) nil)
880 (setf (process-wait-timeout *current-process*) nil)
881 (setf (process-wait-return-value *current-process*)
883 (setf (process-interrupts *current-process*) nil)
884 (update-process-timers *current-process*
886 (setf *current-process* *initial-process*)))
887 *initial-stack-group* nil))))
888 (atomic-push process *all-processes*)
891 (defun process-interrupt (process function)
893 "Interrupt process and cause it to evaluate function."
894 ;; Place the interrupt function at the end of process's interrupts
895 ;; queue, to be called the next time the process is scheduled.
897 (setf (process-interrupts process)
898 (append (list function) (process-interrupts process))))
901 (defun destroy-process (process)
903 "Destroy a process. The process is sent a interrupt which throws to
904 the end of the process allowing it to unwind gracefully."
905 (declare (type process process))
906 (assert (not (eq process *current-process*)))
908 (unless (eq (process-state process) :killed)
909 ;; Place a throw to end-of-the-world at the start of process's
910 ;; interrupts queue, to be called the next time the process is
913 (throw '%end-of-the-process nil))
914 (process-interrupts process))
915 ;; Ensure that the process is active so that it can accept this
917 (setf (process-state process) :active)))
918 ;; Should we wait until it's dead?
921 (defun restart-process (process)
923 "Restart process by unwinding it to its initial state and calling its
925 (destroy-process process)
926 (process-wait "Waiting for process to die"
928 (eq (process-state process) :killed)))
929 ;; No more processes if about to quit lisp.
930 (when *quitting-lisp*
931 (process-wait "Quitting Lisp" #'(lambda () nil)))
932 ;; Create a new stack-group.
934 (setf (process-stack-group process)
936 (process-name process)
939 (catch '%end-of-the-process
940 ;; Catch throws to the %END-OF-THE-WORLD.
941 (setf *quitting-lisp*
942 (catch 'sb!impl::%end-of-the-world
944 (destroy "Destroy the process")
945 (setf *inhibit-scheduling* nil)
946 (apply (process-initial-function process)
947 (process-initial-args process)))
949 (throw '%end-of-the-process nil))))
950 (setf *inhibit-scheduling* t)
951 ;; About to return to the resumer's stack-group, which
952 ;; in this case is the initial process's stack-group.
953 (setf (process-state *current-process*) :killed)
954 (setf *all-processes*
955 (delete *current-process* *all-processes*))
956 (setf (process-%whostate *current-process*) nil)
957 (setf (process-wait-function *current-process*) nil)
958 (setf (process-wait-timeout *current-process*) nil)
959 (setf (process-wait-return-value *current-process*) nil)
960 (setf (process-interrupts *current-process*) nil)
961 (update-process-timers *current-process* *initial-process*)
962 (setf *current-process* *initial-process*)))
963 *initial-stack-group* nil))
964 (setf (process-%whostate process) nil)
965 (setf (process-wait-function process) nil)
966 (setf (process-wait-timeout process) nil)
967 (setf (process-wait-return-value process) nil)
968 (setf (process-interrupts process) nil)
969 (setf (process-state process) :active)
970 (push process *all-processes*))
973 (defun process-preset (process function &rest args)
975 "Restart process, unwinding it to its initial state and calls
977 (setf (process-initial-function process) function)
978 (setf (process-initial-args process) args)
979 (restart-process process))
981 (defun disable-process (process)
983 "Disable process from being runnable until enabled."
985 (assert (not (eq (process-state process) :killed)))
986 (setf (process-state process) :inactive)))
988 (defun enable-process (process)
990 "Allow process to become runnable again after it has been disabled."
992 (assert (not (eq (process-state process) :killed)))
993 (setf (process-state process) :active)))
995 (defun process-wait (whostate predicate)
997 "Causes the process to wait until predicate returns True. Processes
998 can only call process-wait when scheduling is enabled, and the predicate
999 can not call process-wait. Since the predicate may be evaluated may
1000 times by the scheduler it should be relative fast native compiled code.
1001 The single True predicate value is returned."
1002 (assert (not *inhibit-scheduling*))
1003 (assert (not (process-wait-function *current-process*)))
1004 ;; Don't need the disable scheduling here because the scheduler
1005 ;; doesn't mess with the whostate or timeout until the function is
1006 ;; setup, unless the process is interrupted in which case the
1007 ;; scheduler restores the state when execution resumers here.
1008 (setf (process-%whostate *current-process*) whostate)
1009 (setf (process-wait-timeout *current-process*) nil)
1010 (setf (process-wait-function *current-process*) predicate)
1012 (process-wait-return-value *current-process*))
1014 (defun process-wait-with-timeout (whostate timeout predicate)
1015 (declare (type (or fixnum float) timeout))
1017 "Causes the process to wait until predicate returns True, or the
1018 number of seconds specified by timeout has elapsed. The timeout may
1019 be a fixnum or a float in seconds. The single True predicate value is
1020 returned, or NIL if the timeout was reached."
1021 (assert (not *inhibit-scheduling*))
1022 (assert (not (process-wait-function *current-process*)))
1023 ;; Don't need the disable scheduling here because the scheduler
1024 ;; doesn't mess with the whostate or timeout until the function is
1025 ;; setup, unless the process is interrupted in which case the
1026 ;; scheduler restores the state when execution resumers here.
1027 (setf (process-%whostate *current-process*) whostate)
1028 (let ((timeout (etypecase timeout
1030 (coerce timeout 'double-float))
1032 (coerce timeout 'double-float))
1034 (coerce timeout 'double-float)))))
1035 (declare (double-float timeout))
1036 (setf (process-wait-timeout *current-process*)
1037 (+ timeout (get-real-time)))
1038 (setf (process-wait-function *current-process*) predicate))
1040 (process-wait-return-value *current-process*))
1042 ;;; The remaining processes in the scheduling queue for this cycle,
1043 ;;; the remainder of *all-processes*. The *current-process* is the
1044 ;;; first element of this list.
1045 (defvar *remaining-processes* nil)
1047 ;;; The idle process will only run when there are no other runnable
1049 (defvar *idle-process* nil)
1051 ;;; Decide when to allow the idle process to run.
1052 (defun run-idle-process-p ()
1053 ;; Check whether there are any other runnable processes.
1054 (dolist (process *all-processes* t)
1055 (when (and (not (eq process *idle-process*))
1056 (process-active-p process)
1057 (not (process-wait-function process)))
1060 (defun shutdown-multi-processing ()
1062 "Try to gracefully destroy all the processes giving them some
1063 chance to unwind, before shutting down multi-processing. This is
1064 currently necessary before a purify and is performed before a save-lisp.
1065 Multi-processing can be restarted by calling init-multi-processing."
1066 (assert (eq *current-process* *initial-process*) ()
1067 "Only the *initial-process* can shutdown multi-processing")
1069 (let ((destroyed-processes nil))
1070 (do ((cnt 0 (1+ cnt)))
1072 (declare (type sb!int:index cnt))
1073 (dolist (process *all-processes*)
1074 (when (and (not (eq process *current-process*))
1075 (process-active-p process)
1076 (not (member process destroyed-processes)))
1077 (destroy-process process)
1078 (push process destroyed-processes)))
1079 (unless (rest *all-processes*)
1081 (format t "destroyed ~D process~:P; remaining ~D~%"
1082 (length destroyed-processes) (length *all-processes*))
1085 (start-sigalrm-yield 0 0) ; Off with the interrupts.
1086 ;; Reset the multi-processing state.
1087 (setf *inhibit-scheduling* t)
1088 (setf *initial-process* nil)
1089 (setf *idle-process* nil)
1090 (setf *current-process* nil)
1091 (setf *all-processes* nil)
1092 (setf *remaining-processes* nil)
1093 ;; Clean up the stack groups.
1094 (setf sb!vm::*control-stacks*
1095 (make-array 0 :element-type '(or null (unsigned-byte 32))
1096 :initial-element nil))
1097 (setf *current-stack-group* nil)
1098 (setf *initial-stack-group* nil))
1100 ;;; A useful idle process loop, waiting on events using the select
1101 ;;; based event server, which is assumed to be setup to call
1102 ;;; process-yielding periodically.
1103 (declaim (double-float *idle-loop-timeout*))
1104 (defvar *idle-loop-timeout* 0.1d0)
1105 (defun idle-process-loop ()
1107 "An idle loop to be run by the initial process. The select based event
1108 server is called with a timeout calculated from the minimum of the
1109 *idle-loop-timeout* and the time to the next process wait timeout.
1110 To avoid this delay when there are runnable processes the *idle-process*
1111 should be setup to the *initial-process*. If one of the processes quits
1112 by throwing to %end-of-the-world then *quitting-lisp* will have been
1113 set to the exit value which is noted by the idle loop which tries to
1114 exit gracefully destroying all the processes and giving them a chance
1116 (declare (optimize (speed 3)))
1117 (assert (eq *current-process* *initial-process*) ()
1118 "Only the *initial-process* is intended to run the idle loop")
1119 ;; Ensure the *idle-process* is setup.
1120 (unless *idle-process*
1121 (setf *idle-process* *current-process*))
1122 ;; Adjust the process name.
1123 (setf (process-name *current-process*) "Idle Loop")
1126 ;; Calculate the wait period.
1127 (let ((real-time (get-real-time))
1128 (timeout *idle-loop-timeout*))
1129 (declare (double-float timeout))
1130 (dolist (process *all-processes*)
1131 (when (process-active-p process)
1132 (let ((wait-timeout (process-wait-timeout process)))
1134 (let ((delta (- wait-timeout real-time)))
1135 (when (< delta timeout)
1136 (sb!vm::double-float-reg-bias timeout)
1137 (setf timeout delta)))))))
1138 (when (> timeout 1d-5)
1139 (sb!sys:serve-all-events timeout))
1141 (shutdown-multi-processing)
1142 (throw 'sb!impl::%end-of-the-world *quitting-lisp*))
1145 (defun process-yield ()
1146 (declare (optimize (speed 3)))
1148 "Allow other processes to run."
1149 (unless *inhibit-scheduling*
1150 ;; Catch any FP exceptions before entering the scheduler.
1151 (sb!kernel:float-wait)
1152 ;; Inhibit recursive entry of the scheduler.
1153 (setf *inhibit-scheduling* t)
1154 (assert (eq (first *remaining-processes*) *current-process*))
1155 (assert (eq *current-stack-group* (process-stack-group *current-process*)))
1157 ;; Rotate the queue.
1158 (setf *remaining-processes*
1159 (or (rest *remaining-processes*) *all-processes*))
1161 (let ((next (first *remaining-processes*)))
1162 ;; Shouldn't see any :killed porcesses here.
1163 (assert (process-alive-p next))
1166 ;; New process at the head of the queue?
1167 ((eq next *current-process*))
1168 ;; Ignore inactive processes.
1169 ((not (process-active-p next)))
1170 ;; If the next process has pending interrupts then return to
1171 ;; it to execute these.
1172 ((process-interrupts next)
1173 (update-process-timers *current-process* next)
1174 (setf *current-process* next)
1175 (stack-group-resume (process-stack-group next)))
1177 ;; If not waiting then return.
1178 (let ((wait-fn (process-wait-function next)))
1181 ;; Skip the idle process if there are other runnable
1183 (when (or (not (eq next *idle-process*))
1184 (run-idle-process-p))
1185 (update-process-timers *current-process* next)
1186 (setf *current-process* next)
1187 (stack-group-resume (process-stack-group next))))
1189 ;; Check the wait function in the current context
1190 ;; saving a stack-group switch; although
1191 ;; *current-process* is setup.
1192 (let ((current-process *current-process*))
1193 (setf *current-process* next)
1195 (let ((wait-return-value (funcall wait-fn)))
1196 (cond (wait-return-value
1198 (setf (process-wait-return-value next)
1200 (setf (process-wait-timeout next) nil)
1201 (setf (process-wait-function next) nil)
1202 (setf (process-%whostate next) nil)
1203 (update-process-timers current-process next)
1204 (stack-group-resume (process-stack-group next)))
1207 (let ((timeout (process-wait-timeout next)))
1208 (when (and timeout (> (get-real-time) timeout))
1210 (setf (process-wait-return-value next) nil)
1211 (setf (process-wait-timeout next) nil)
1212 (setf (process-wait-function next) nil)
1213 (setf (process-%whostate next) nil)
1214 (update-process-timers current-process next)
1216 (process-stack-group next)))))))
1217 ;; Restore the *current-process*.
1218 (setf *current-process* current-process))))))))
1220 ;; May have just returned, or have cycled the queue.
1221 (let ((next (first *remaining-processes*)))
1222 ;; Tolerate :killed processes on the *remaining-processes* list
1223 ;; saving their deletion from this list when killed; will be
1224 ;; corrected when it cycles back to *all-processes*.
1225 (when (and (process-active-p next)
1226 ;; Current process at the head of the queue?
1227 (eq next *current-process*))
1228 ;; Run any pending interrupts.
1229 (let ((interrupt (pop (process-interrupts next))))
1230 (declare (type (or null function) interrupt))
1232 ;; Save and reset any wait reasons so that the
1233 ;; interrupt can wait. The return-value is also
1234 ;; saved and restored in case a process is
1235 ;; interrupted before it is read.
1236 (let ((wait-function (process-wait-function next))
1237 (wait-timeout (process-wait-timeout next))
1238 (whostate (process-%whostate next))
1239 (wait-return-value (process-wait-return-value next)))
1240 (setf (process-wait-function next) nil)
1241 (setf (process-wait-timeout next) nil)
1242 (setf (process-%whostate next) nil)
1243 (setf (process-wait-return-value next) nil)
1244 ;; Allow recursive scheduling during the interrupt
1245 ;; processing. Only one interrupt is processed on
1246 ;; each scheduler queue cycle. The process doesn't
1247 ;; return until there are no interrupts.
1248 (setf *inhibit-scheduling* nil)
1250 (setf *inhibit-scheduling* t)
1251 ;; Restore any wait reasons.
1252 (setf (process-wait-function next) wait-function)
1253 (setf (process-wait-timeout next) wait-timeout)
1254 (setf (process-%whostate next) whostate)
1255 (setf (process-wait-return-value next) wait-return-value)))
1257 ;; Check the wait function.
1258 (let ((wait-fn (process-wait-function next)))
1261 (when (or (not (eq next *idle-process*))
1262 (run-idle-process-p))
1266 (let ((return-value (funcall wait-fn)))
1269 (setf (process-wait-return-value next) return-value)
1270 (setf (process-wait-timeout next) nil)
1271 (setf (process-wait-function next) nil)
1272 (setf (process-%whostate next) nil)
1275 (let ((timeout (process-wait-timeout next)))
1276 (when (and timeout (> (get-real-time) timeout))
1278 (setf (process-wait-return-value next) nil)
1279 (setf (process-wait-timeout next) nil)
1280 (setf (process-wait-function next) nil)
1281 (setf (process-%whostate next) nil)
1283 (setf *inhibit-scheduling* nil)))
1285 ;;; Return the real time in seconds accrued while the process was scheduled.
1286 (defun process-real-time (process)
1288 "Return the accrued real time elapsed while the given process was
1289 scheduled. The returned time is a double-float in seconds."
1290 (declare (type process process))
1291 (if (eq process *current-process*)
1293 (let ((real-time (get-real-time)))
1294 (+ (process-%real-time process)
1295 (- real-time (process-scheduled-real-time process)))))
1296 (process-%real-time process)))
1298 ;;; The run time in seconds accrued while the process was scheduled.
1299 (defun process-run-time (process)
1301 "Return the accrued run time elapsed for the given process. The returned
1302 time is a double-float in seconds."
1303 (declare (type process process))
1304 (if (eq process *current-process*)
1306 (let ((run-time (get-run-time)))
1307 (+ (process-%run-time process)
1308 (- run-time (process-scheduled-run-time process)))))
1309 (process-%run-time process)))
1311 ;;; Return the real time in seconds elapsed since the process was last
1313 (defun process-idle-time (process)
1315 "Return the real time elapsed since the given process was last
1316 descheduled. The returned time is a double-float in seconds."
1317 (declare (type process process))
1318 (if (eq process *current-process*)
1321 (let ((real-time (get-real-time)))
1322 (- real-time (process-scheduled-real-time process))))))
1324 ;;; Start a regular interrupt to switch processes. This may not be a
1325 ;;; good idea yet as the SBCL code is not too interrupt safe.
1326 (defun start-sigalrm-yield (&optional (sec 0) (usec 500000))
1328 "Start a regular SIGALRM interrupt which calls process-yield. An optional
1329 time in seconds and micro seconds may be provided. Note that SBCL code
1330 base is not too interrupt safe so this may cause problems."
1331 (declare (fixnum sec usec))
1332 ;; Disable the gencgc pointer filter to improve interrupt safety.
1334 (setf (sb!alien:extern-alien "enable_pointer_filter" sb!alien:unsigned) 0)
1335 (flet ((sigalrm-handler (signal info context)
1336 (declare (ignore signal info context))
1337 (cond ((<= sb!impl::*free-interrupt-context-index* 1)
1338 #+nil (format t ".~%")
1341 #+nil (format t "-~%")))))
1342 (sb!sys:enable-interrupt :sigalrm #'sigalrm-handler))
1343 (sb!unix:unix-setitimer :real sec usec 0 1)
1346 ;;; Startup multi-processing, initializing the initial process. This
1347 ;;; must be called before use of the other multi-process functions.
1348 (defun init-multi-processing ()
1349 (unless *initial-process*
1351 (setf *initial-process*
1355 :stack-group *initial-stack-group*))
1356 (setf *current-process* *initial-process*)
1357 (setf *all-processes* (list *initial-process*))
1358 (setf *remaining-processes* *all-processes*)
1359 #+nil (start-sigalrm-yield)
1360 (setf *inhibit-scheduling* nil)))
1362 (pushnew 'init-multi-processing sb!int:*after-save-initializations*)
1364 ;;; Scrub the stored stacks of all the processes.
1365 (defun scrub-all-processes-stacks ()
1366 (sb!sys:without-interrupts
1367 (dolist (process *all-processes*)
1368 (let ((stack-group (process-stack-group process)))
1370 (scrub-stack-group-stacks stack-group))))))
1371 (pushnew 'scrub-all-processes-stacks sb!ext:*before-gc-hooks*)
1373 ;;; Wait until FD is usable for DIRECTION.
1374 (defun process-wait-until-fd-usable (fd direction &optional timeout)
1376 "Wait until FD is usable for DIRECTION and return True. DIRECTION should be
1377 either :INPUT or :OUTPUT. TIMEOUT, if supplied, is the number of seconds to
1378 wait before giving up and returning NIL."
1379 (declare (type sb!int:index fd)
1380 (type (or real null) timeout)
1381 (optimize (speed 3)))
1382 (if (or (eq *current-process* *initial-process*)
1383 ;; Can't call process-wait if the scheduling is inhibited.
1384 *inhibit-scheduling*)
1385 ;; The initial-process calls the event server to block.
1386 (sb!sys:wait-until-fd-usable fd direction timeout)
1387 ;; Other processes use process-wait.
1388 (flet ((fd-usable-for-input ()
1389 (declare (optimize (speed 3) (safety 1)))
1390 (not (eql (sb!alien:with-alien ((read-fds
1391 (sb!alien:struct sb!unix:fd-set)))
1392 (sb!unix:fd-zero read-fds)
1393 (sb!unix:fd-set fd read-fds)
1394 (sb!unix:unix-fast-select
1395 (1+ fd) (sb!alien:addr read-fds) nil nil 0 0))
1397 (fd-usable-for-output ()
1398 (declare (optimize (speed 3) (safety 1)))
1399 (not (eql (sb!alien:with-alien ((write-fds
1400 (sb!alien:struct sb!unix:fd-set)))
1401 (sb!unix:fd-zero write-fds)
1402 (sb!unix:fd-set fd write-fds)
1403 (sb!unix:unix-fast-select
1404 (1+ fd) nil (sb!alien:addr write-fds) nil 0 0))
1409 (unless (fd-usable-for-input)
1410 ;; Wait until input possible.
1411 (sb!sys:with-fd-handler (fd :input
1413 (declare (ignore fd)
1416 (sb!mp:process-yield)))
1418 (sb!mp:process-wait-with-timeout "Input Wait"
1420 #'fd-usable-for-input)
1421 (sb!mp:process-wait "Input Wait" #'fd-usable-for-input)))))
1423 (unless (fd-usable-for-output)
1424 ;; Wait until output possible.
1425 (sb!sys:with-fd-handler (fd :output
1427 (declare (ignore fd)
1430 (sb!mp:process-yield)))
1432 (sb!mp:process-wait-with-timeout "Output Wait"
1434 #'fd-usable-for-output)
1435 (sb!mp:process-wait "Output Wait"
1436 #'fd-usable-for-output)))))))))
1438 ;;; Redefine the sleep function to call process-wait-with-timeout,
1439 ;;; rather than blocking.
1442 "This function causes execution to be suspended for N seconds. N may
1443 be any non-negative, non-complex number."
1444 (when (or (not (realp n))
1446 (error "Invalid argument to SLEEP: ~S.~%~
1447 Must be a non-negative, non-complex number."
1449 (cond ((or (eq *current-process* *initial-process*)
1450 ;; Can't call process-wait if the scheduling is inhibited.
1451 *inhibit-scheduling*)
1452 ;; The initial-process may block.
1453 (multiple-value-bind (sec usec)
1456 (multiple-value-bind (sec frac) (truncate n)
1457 (values sec (truncate frac 1e-6))))
1458 (sb!unix:unix-select 0 0 0 0 sec usec))
1461 (process-wait-with-timeout "Sleep" n (constantly nil)))))
1463 (defun show-processes (&optional verbose)
1465 "Show the all the processes, their whostate, and state. If the optional
1466 verbose argument is true then the run, real, and idle times are also
1469 (dolist (process *all-processes*)
1470 (when (eq process *current-process*)
1472 (format t "~S ~S ~A~%" process (process-whostate process)
1473 (process-state process))
1475 (format t "~4TRun time: ~,3f; Real time: ~,3f; Idle time: ~,3f~%"
1476 (process-run-time process)
1477 (process-real-time process)
1478 (process-idle-time process)))))
1482 "Top-level READ-EVAL-PRINT loop for processes."
1483 (let ((* nil) (** nil) (*** nil)
1484 (- nil) (+ nil) (++ nil) (+++ nil)
1485 (/// nil) (// nil) (/ nil)
1486 (magic-eof-cookie (cons :eof nil)))
1488 (with-simple-restart (abort "Return to Top-Level.")
1489 (catch 'sb!impl::top-level-catcher
1490 (sb!unix:unix-sigsetmask 0)
1491 (let ((sb!impl::*in-top-level-catcher* t))
1493 (sb!sys:scrub-control-stack)
1495 (princ (if (functionp sb!int:*prompt*)
1496 (funcall sb!int:*prompt*)
1499 (let ((form (read *standard-input* nil magic-eof-cookie)))
1500 (cond ((not (eq form magic-eof-cookie))
1502 (multiple-value-list
1503 (sb!int:interactive-eval form))))
1504 (dolist (result results)
1508 (throw '%end-of-the-process nil)))))))))))
1510 (defun startup-idle-and-top-level-loops ()
1512 "Enter the idle loop, starting a new process to run the top level loop.
1513 The awaking of sleeping processes is timed better with the idle loop process
1514 running, and starting a new process for the top level loop supports a
1515 simultaneous interactive session. Such an initialization will likely be the
1516 default when there is better MP debug support etc."
1517 (assert (eq *current-process* *initial-process*) ()
1518 "Only the *initial-process* is intended to run the idle loop")
1519 (init-multi-processing) ; Initialise in case MP had been shutdown.
1520 ;; Start a new Top Level loop.
1521 (make-process #'top-level :name "top level loop")
1522 ;; Enter the idle loop.
1523 (idle-process-loop))
1527 (defstruct (lock (:constructor make-lock (&optional name)))
1528 (name nil :type (or null simple-base-string))
1529 (process nil :type (or null process)))
1530 (def!method print-object ((lock lock) stream)
1531 (print-unreadable-object (lock stream :identity t)
1532 (write-string "Lock" stream)
1533 (let ((name (lock-name lock)))
1535 (format stream " ~A" name)))
1536 (let ((process (lock-process lock)))
1538 (format stream ", held by ~S" process))
1540 (write-string ", free" stream))))))
1542 ;;; Wait for the lock to be free and acquire it for the *current-process*.
1543 (defun lock-wait (lock whostate)
1544 (declare (type lock lock))
1545 (process-wait whostate
1547 (declare (optimize (speed 3)))
1549 (unless (lock-process lock)
1550 (setf (lock-process lock) *current-process*))
1552 (null (sb!kernel:%instance-set-conditional
1553 lock 2 nil *current-process*)))))
1555 ;;; Wait with a timeout for the lock to be free and acquire it for the
1556 ;;; *current-process*.
1557 (defun lock-wait-with-timeout (lock whostate timeout)
1558 (declare (type lock lock))
1559 (process-wait-with-timeout
1562 (declare (optimize (speed 3)))
1564 (unless (lock-process lock)
1565 (setf (lock-process lock) *current-process*))
1567 (null (sb!kernel:%instance-set-conditional
1568 lock 2 nil *current-process*)))))
1570 ;;; Atomically seize a lock if it's free.
1572 (defun seize-lock (lock)
1573 (declare (type lock lock)
1574 (optimize (speed 3)))
1575 (sb!sys:without-interrupts
1576 (unless (lock-process lock)
1577 (setf (lock-process lock) *current-process*))))
1579 (defmacro with-lock-held ((lock &optional (whostate "Lock Wait") &key timeout)
1583 "Execute the body with the lock held. If the lock is held by another
1584 process then the current process waits until the lock is released or a
1585 optional timeout is reached - recursive locks are allowed. The
1586 optional wait timeout is a time in seconds acceptable to
1587 process-wait-with-timeout. The results of the body are return upon
1588 success and NIL is return if the timeout is reached."
1589 (let ((have-lock (gensym)))
1590 `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
1593 `(when (cond (,have-lock)
1594 #!+mp-i486 ((null (sb!kernel:%instance-set-conditional
1595 ,lock 2 nil *current-process*)))
1596 #!-mp-i486 ((seize-lock ,lock))
1598 (lock-wait ,lock ,whostate))
1599 ((lock-wait-with-timeout
1600 ,lock ,whostate ,timeout)))
1603 (unless (or ,have-lock
1604 #!+mp-i486 (null (sb!kernel:%instance-set-conditional
1605 ,lock 2 nil *current-process*))
1606 #!-mp-i486 (seize-lock ,lock))
1607 (lock-wait ,lock ,whostate))
1610 #!+mp-i486 (sb!kernel:%instance-set-conditional
1611 ,lock 2 *current-process* nil)
1612 #!-mp-i486 (when (eq (lock-process ,lock) *current-process*)
1613 (setf (lock-process ,lock) nil)))))))