src/code/multi-proc.lisp

   1 ;;;; stack-group and multi-process support for CMU CL x86
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package "SB!MP")
  13
  14 (file-comment
  15   "$Header$")
  16 \f
  17 ;;;; Handle the binding stack.
  18
  19 ;;; Undo all the bindings in the bind stack, restoring the global
  20 ;;; values.
  21 (defun unbind-binding-stack ()
  22   (declare (optimize (speed 3) (safety 0)))
  23   (let* ((binding-stack-pointer (sb!kernel:binding-stack-pointer-sap))
  24          (binding-stack
  25           (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
  26                                                  sb!alien:unsigned)))
  27          (size (sb!sys:sap- binding-stack-pointer binding-stack)))
  28     (declare (type (unsigned-byte 29) size))
  29     (do ((binding size))
  30         ((zerop binding))
  31       (declare (type (unsigned-byte 29) binding))
  32       (decf binding 8)
  33       (let* ((value
  34               (sb!kernel:make-lisp-obj
  35                (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding))))
  36              (symbol
  37               (sb!kernel:make-lisp-obj
  38                (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack
  39                                                    (+ binding 4))))))
  40         (cond ((symbolp symbol)
  41                (let ((symbol-value (sb!c::%primitive sb!c:fast-symbol-value
  42                                                      symbol)))
  43                  #+nil
  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
  48                                         symbol-value)))))
  49               (t
  50                #+nil
  51                (format t "ignoring undoing: ~S ~S~%" symbol value)))))))
  52
  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))
  58          (binding-stack
  59           (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
  60                                                  sb!alien:unsigned)))
  61          (size (sb!sys:sap- binding-stack-pointer binding-stack)))
  62     (declare (type (unsigned-byte 29) size))
  63     (do ((binding 0 (+ 8 binding)))
  64         ((= binding size))
  65       (declare (type (unsigned-byte 29) binding))
  66       (let* ((value
  67               (sb!kernel:make-lisp-obj
  68                (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding))))
  69              (symbol
  70               (sb!kernel:make-lisp-obj
  71                (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack
  72                                                    (+ binding 4))))))
  73         (cond ((symbolp symbol)
  74                (let ((symbol-value (sb!c::%primitive sb!c:fast-symbol-value
  75                                                      symbol)))
  76                  #+nil
  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
  82                                         symbol-value)))))
  83               (t
  84                #+nil
  85                (format t "ignoring rebinding: ~S ~S~%" symbol value)))))))
  86
  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))
  91          (binding-stack
  92           (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
  93                                                  sb!alien:unsigned)))
  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)))
 101     ;; Save the stack.
 102     (do ((binding 0 (+ 4 binding))
 103          (index 0 (1+ index)))
 104         ((= binding size))
 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)))
 110
 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"
 117                                                sb!alien:unsigned)))
 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))))))
 128   (values))
 129 \f
 130 ;;;; alien stack
 131
 132 ;;; The Top of the Alien-stack.
 133 (declaim (type (unsigned-byte 32) *alien-stack-top*))
 134 (defvar *alien-stack-top* 0)
 135
 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))
 145     #+nil
 146     (format t "alien-stack ~X; size ~X~%" alien-stack size)
 147     ;; Grow save-stack if necessary.
 148     (when (< (length save-stack) vector-size)
 149       (setq save-stack
 150             (adjust-array save-stack vector-size
 151                           :element-type '(unsigned-byte 32))))
 152     ;; Save the stack.
 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)))
 160
 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)))
 168       ((>= index size))
 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)))
 173   (values))
 174 \f
 175 ;;;; interrupt contexts
 176
 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)
 185       (setq save-vector
 186             (adjust-array save-vector size :element-type '(unsigned-byte 32))))
 187     (sb!alien:with-alien
 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))))
 192     save-vector))
 193
 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))
 200     (sb!alien:with-alien
 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)))))
 205   (values))
 206 \f
 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))
 216
 217 ;;; Stack-group structure.
 218 (defstruct (stack-group
 219              (:constructor %make-stack-group)
 220              (:print-object
 221               (lambda (stack-group stream)
 222                 (declare (type stack-group stack-group)
 223                          (stream stream))
 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))))))
 228   ;; Must have a name.
 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!kernel:index null))
 234   ;; Binding stack.
 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)
 242   ;; Alien stack
 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))
 246   ;; Eval-stack
 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) (*))
 251                                     null))
 252   ;; Resumer
 253   (resumer nil :type (or stack-group null)))
 254
 255 ;;; The current stack group.
 256 (declaim (type (or stack-group null) *current-stack-group*))
 257 (defvar *current-stack-group* nil)
 258
 259 (declaim (type (or stack-group null) *initial-stack-group*))
 260 (defvar *initial-stack-group* nil)
 261
 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*
 267         (sb!sys:sap-ref-32
 268          (sb!sys:int-sap (sb!alien:extern-alien "control_stack_end"
 269                                                 sb!alien:unsigned))
 270          -4))
 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)
 277         (make-array 0
 278                     :element-type '(unsigned-byte 32)
 279                     :initial-element 0))
 280   ;; Make and return the initial stack group.
 281   (setf *current-stack-group*
 282         (%make-stack-group
 283          :name "initial"
 284          :state :active
 285          :control-stack-id 0
 286          :binding-stack #()
 287          :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
 288          :interrupt-contexts (make-array 0 :element-type '(unsigned-byte 32))
 289          :eval-stack #()))
 290   (setf *initial-stack-group* *current-stack-group*))
 291
 292 ;;; Inactivate the stack group, cleaning its slot and freeing the
 293 ;;; control stack.
 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))
 311
 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)))
 316   ;; Binding stack.
 317   (let ((binding-save-stack (stack-group-binding-stack stack-group)))
 318     (when binding-save-stack
 319       (let ((size
 320              ;; The stored binding stack for the current stack group
 321              ;; can be completely scrubbed.
 322              (if (eq stack-group *current-stack-group*)
 323                  0
 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)))
 328             ((>= index len))
 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)))
 341     (when eval-stack
 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)))
 345             ((= i len))
 346           (declare (type sb!kernel:index i))
 347           (setf (svref eval-stack i) nil))))))
 348
 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 ()
 353   (vector
 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*))
 358
 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*)
 365                               (inherit t))
 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.
 373                   (control-stack-end
 374                    (sb!alien:extern-alien "control_stack_end"
 375                                           sb!alien:unsigned))
 376                   (control-stack-pointer (sb!kernel:control-stack-pointer-sap))
 377                   (control-stack-size
 378                    (- control-stack-end
 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.
 384                   (control-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)
 398                    control-stack)
 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
 404            ;; bound.
 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
 411              ;; blocked.
 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.
 421                  (multiple-value-bind
 422                      (alien-stack alien-stack-size alien-stack-pointer)
 423                      (save-alien-stack
 424                       (make-array 0 :element-type '(unsigned-byte 32)))
 425                    ;; Allocate a stack-group structure.
 426                    (%make-stack-group
 427                     :name name
 428                     :state :active
 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*
 434                     ;; Misc stacks.
 435                     :current-catch-block sb!impl::*current-catch-block*
 436                     :current-unwind-protect-block
 437                     sb!impl::*current-unwind-protect-block*
 438                     ;; Alien stack.
 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
 444                     ;; Binding stack.
 445                     :binding-stack binding-stack
 446                     :binding-stack-size binding-stack-size
 447                     ;; Resumer
 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.
 453              (%make-stack-group
 454               :name name
 455               :state :active
 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)
 460               :eval-stack-top 0
 461               ;; Misc stacks.
 462               :current-catch-block 0
 463               :current-unwind-protect-block 0
 464               ;; Alien stack.
 465               :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
 466               :alien-stack-size 0
 467               :alien-stack-pointer *alien-stack-top*
 468               ;; Interrupt contexts
 469               :interrupt-contexts (make-array 0 :element-type
 470                                               '(unsigned-byte 32))
 471               ;; Binding stack - some initial bindings.
 472               :binding-stack binding-stack
 473               :binding-stack-size (length binding-stack)
 474               ;; Resumer
 475               :resumer resumer))))
 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
 482                 (if inherit
 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.
 488               child-stack-group
 489               ;; Child starts.
 490               (unwind-protect
 491                    (progn
 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*
 501                        (sb!impl::maybe-gc))
 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.
 509                   (unless (and 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)
 516                   ;; Eval-stack
 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
 524                   ;; are blocked.
 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))
 534                   ;; Misc stacks.
 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))
 539                   ;; The Alien stack
 540                   (restore-alien-stack
 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) (*))
 551                                    new-control-stack))
 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*))
 557         (sb!impl::maybe-gc))
 558       child-stack-group)))
 559
 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.
 573            (control-stack-end
 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
 581            ;; stack.
 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)
 592                                           :initial-element 0))
 593         (setf (aref sb!vm::*control-stacks*
 594                     (stack-group-control-stack-id stack-group))
 595               control-stack))
 596
 597       ;; eval-stack
 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))
 604
 605       ;; misc stacks
 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))
 614
 615       ;; Save the interrupt-contexts.
 616       (setf (stack-group-interrupt-contexts stack-group)
 617             (save-interrupt-contexts
 618              (stack-group-interrupt-contexts stack-group)))
 619
 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
 624                                                               :sigalrm))))
 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
 633                                 new-stack-group))
 634         (rebind-binding-stack)
 635         (sb!unix:unix-sigsetmask old-sigs))
 636
 637       ;; Restore the interrupt-contexts.
 638       (restore-interrupt-contexts
 639        (stack-group-interrupt-contexts new-stack-group))
 640
 641       ;; The Alien stack
 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) (*))
 654                        new-control-stack))
 655         (sb!vm:control-stack-resume control-stack new-control-stack))
 656       ;; Thread returns.
 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*))
 663     (sb!impl::maybe-gc))
 664   (values))
 665 \f
 666 ;;;; DOUBLE-FLOAT timing functions for use by the scheduler
 667
 668 ;;; These timer functions use double-floats for accuracy. In most
 669 ;;; cases consing is avoided.
 670
 671 #!-sb-fluid (declaim (inline get-real-time))
 672 (defun get-real-time ()
 673   #!+sb-doc
 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))))
 681
 682 #!-sb-fluid (declaim (inline get-run-time))
 683 (defun get-run-time ()
 684   #!+sb-doc
 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))
 699           1d-6))))
 700 \f
 701 ;;;; Multi-process support. The interface is based roughly on the
 702 ;;;; CLIM-SYS spec. and support needed for cl-http.
 703
 704 (defvar *multi-processing* t)
 705
 706 (defstruct (process
 707              (:constructor %make-process)
 708              (:predicate processp)
 709              (:print-object
 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))
 731
 732 (defun process-whostate (process)
 733   #!+sb-doc
 734   "Return the process state which is either Run, Killed, or a wait reason."
 735   (cond ((eq (process-state process) :killed)
 736          "Killed")
 737         ((process-wait-function process)
 738          (or (process-%whostate process) "Run"))
 739         (t
 740          "Run")))
 741
 742 #!-sb-fluid (declaim (inline process-active-p))
 743 (defun process-active-p (process)
 744   (eq (process-state process) :active))
 745
 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))))
 750
 751 (declaim (type (or null process) *current-process*))
 752 (defvar *current-process* nil)
 753
 754 #!-sb-fluid (declaim (inline current-process))
 755 (defun current-process ()
 756   #!+sb-doc
 757   "Returns the current process."
 758   *current-process*)
 759
 760 (declaim (list *all-processes*))
 761 (defvar *all-processes* nil
 762   #!+sb-doc
 763   "A list of all alive processes.")
 764
 765 #!-sb-fluid (declaim (inline all-processes))
 766 (defun all-processes ()
 767   #!+sb-doc
 768   "Return a list of all the live processes."
 769   *all-processes*)
 770
 771 (declaim (type (or null process) *intial-process*))
 772 (defvar *initial-process* nil)
 773
 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)
 778   #!+sb-doc
 779   "Execute the body the scheduling disabled."
 780   `(let ((inhibit *inhibit-scheduling*))
 781     (unwind-protect
 782          (progn
 783            (setf *inhibit-scheduling* t)
 784            ,@body)
 785       (setf *inhibit-scheduling* inhibit))))
 786
 787 (defmacro atomic-incf (reference &optional (delta 1))
 788   #!+sb-doc
 789   "Increments the reference by delta in a single atomic operation"
 790   `(without-scheduling
 791     (incf ,reference ,delta)))
 792
 793 (defmacro atomic-decf (reference &optional (delta 1))
 794   #!+sb-doc
 795   "Decrements the reference by delta in a single atomic operation"
 796   `(without-scheduling
 797     (decf ,reference ,delta)))
 798
 799 (defmacro atomic-push (obj place)
 800   #!+sb-doc
 801   "Atomically push object onto place."
 802   `(without-scheduling
 803     (push ,obj ,place)))
 804
 805 (defmacro atomic-pop (place)
 806   #!+sb-doc
 807   "Atomically pop place."
 808   `(without-scheduling
 809     (pop ,place)))
 810
 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
 815 ;;; when it runs.
 816 (defvar *quitting-lisp* nil)
 817
 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))
 833   (values))
 834
 835 (defun make-process (function &key (name "Anonymous"))
 836   #!+sb-doc
 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)))
 845         ((null function)
 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))
 849         (t
 850          ;; Create a stack-group.
 851          (let ((process
 852                 (%make-process
 853                  :name name
 854                  :state :active
 855                  :initial-function function
 856                  :stack-group
 857                  (make-stack-group
 858                   name
 859                   #'(lambda ()
 860                       (unwind-protect
 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
 865                                      (with-simple-restart
 866                                          (destroy "Destroy the process")
 867                                        (setf *inhibit-scheduling* nil)
 868                                        (funcall function))
 869                                      ;; Normal exit.
 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*)
 882                               nil)
 883                         (setf (process-interrupts *current-process*) nil)
 884                         (update-process-timers *current-process*
 885                                                *initial-process*)
 886                         (setf *current-process* *initial-process*)))
 887                   *initial-stack-group* nil))))
 888            (atomic-push process *all-processes*)
 889            process))))
 890
 891 (defun process-interrupt (process function)
 892   #!+sb-doc
 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.
 896   (without-scheduling
 897    (setf (process-interrupts process)
 898          (append (list function) (process-interrupts process))))
 899   (process-yield))
 900
 901 (defun destroy-process (process)
 902   #!+sb-doc
 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*)))
 907   (without-scheduling
 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
 911      ;; scheduled.
 912      (push #'(lambda ()
 913                (throw '%end-of-the-process nil))
 914            (process-interrupts process))
 915      ;; Ensure that the process is active so that it can accept this
 916      ;; interrupt.
 917      (setf (process-state process) :active)))
 918   ;; Should we wait until it's dead?
 919   (process-yield))
 920
 921 (defun restart-process (process)
 922   #!+sb-doc
 923   "Restart process by unwinding it to its initial state and calling its
 924   initial function."
 925   (destroy-process process)
 926   (process-wait "Waiting for process to die"
 927                 #'(lambda ()
 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.
 933   (without-scheduling
 934    (setf (process-stack-group process)
 935          (make-stack-group
 936           (process-name process)
 937           #'(lambda ()
 938               (unwind-protect
 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
 943                              (with-simple-restart
 944                                  (destroy "Destroy the process")
 945                                (setf *inhibit-scheduling* nil)
 946                                (apply (process-initial-function process)
 947                                       (process-initial-args process)))
 948                              ;; Normal exit.
 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*))
 971   process)
 972
 973 (defun process-preset (process function &rest args)
 974   #!+sb-doc
 975   "Restart process, unwinding it to its initial state and calls
 976   function with args."
 977   (setf (process-initial-function process) function)
 978   (setf (process-initial-args process) args)
 979   (restart-process process))
 980
 981 (defun disable-process (process)
 982   #!+sb-doc
 983   "Disable process from being runnable until enabled."
 984   (without-scheduling
 985    (assert (not (eq (process-state process) :killed)))
 986    (setf (process-state process) :inactive)))
 987
 988 (defun enable-process (process)
 989   #!+sb-doc
 990   "Allow process to become runnable again after it has been disabled."
 991   (without-scheduling
 992    (assert (not (eq (process-state process) :killed)))
 993    (setf (process-state process) :active)))
 994
 995 (defun process-wait (whostate predicate)
 996   #!+sb-doc
 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)
1011   (process-yield)
1012   (process-wait-return-value *current-process*))
1013
1014 (defun process-wait-with-timeout (whostate timeout predicate)
1015   (declare (type (or fixnum float) timeout))
1016   #!+sb-doc
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
1029                    (fixnum
1030                     (coerce timeout 'double-float))
1031                    (single-float
1032                     (coerce timeout 'double-float))
1033                    (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))
1039   (process-yield)
1040   (process-wait-return-value *current-process*))
1041
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)
1046
1047 ;;; The idle process will only run when there are no other runnable
1048 ;;; processes.
1049 (defvar *idle-process* nil)
1050
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)))
1058       (return nil))))
1059
1060 (defun shutdown-multi-processing ()
1061   #!+sb-doc
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")
1068
1069   (let ((destroyed-processes nil))
1070     (do ((cnt 0 (1+ cnt)))
1071         ((> cnt 10))
1072       (declare (type sb!kernel: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*)
1080         (return))
1081       (format t "destroyed ~D process~:P; remaining ~D~%"
1082               (length destroyed-processes) (length *all-processes*))
1083       (process-yield)))
1084
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))
1099
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 ()
1106   #!+sb-doc
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
1115   to unwind."
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")
1124   (do ()
1125       (*quitting-lisp*)
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)))
1133             (when wait-timeout
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))
1140       (process-yield)))
1141   (shutdown-multi-processing)
1142   (throw 'sb!impl::%end-of-the-world *quitting-lisp*))
1143
1144 ;;; the scheduler
1145 (defun process-yield ()
1146   (declare (optimize (speed 3)))
1147   #!+sb-doc
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*)))
1156     (loop
1157      ;; Rotate the queue.
1158      (setf *remaining-processes*
1159            (or (rest *remaining-processes*) *all-processes*))
1160
1161      (let ((next (first *remaining-processes*)))
1162        ;; Shouldn't see any :killed porcesses here.
1163        (assert (process-alive-p next))
1164
1165        (cond
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)))
1176          (t
1177           ;; If not waiting then return.
1178           (let ((wait-fn (process-wait-function next)))
1179             (cond
1180               ((null wait-fn)
1181                ;; Skip the idle process if there are other runnable
1182                ;; processes.
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))))
1188               (t
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)
1194                  ;; Predicate true?
1195                  (let ((wait-return-value (funcall wait-fn)))
1196                    (cond (wait-return-value
1197                           ;; Flush the wait.
1198                           (setf (process-wait-return-value next)
1199                                 wait-return-value)
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)))
1205                          (t
1206                           ;; Timeout?
1207                           (let ((timeout (process-wait-timeout next)))
1208                             (when (and timeout (> (get-real-time) timeout))
1209                               ;; Flush the wait.
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)
1215                               (stack-group-resume
1216                                (process-stack-group next)))))))
1217                  ;; Restore the *current-process*.
1218                  (setf *current-process* current-process))))))))
1219
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))
1231            (cond (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)
1249                     (funcall interrupt)
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)))
1256                  (t
1257                   ;; Check the wait function.
1258                   (let ((wait-fn (process-wait-function next)))
1259                     (cond
1260                       ((null wait-fn)
1261                        (when (or (not (eq next *idle-process*))
1262                                  (run-idle-process-p))
1263                          (return)))
1264                       (t
1265                        ;; Predicate true?
1266                        (let ((return-value (funcall wait-fn)))
1267                          (when return-value
1268                            ;; Flush the wait.
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)
1273                            (return)))
1274                        ;; Timeout?
1275                        (let ((timeout (process-wait-timeout next)))
1276                          (when (and timeout (> (get-real-time) timeout))
1277                            ;; Flush the wait.
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)
1282                            (return))))))))))))
1283     (setf *inhibit-scheduling* nil)))
1284
1285 ;;; Return the real time in seconds accrued while the process was scheduled.
1286 (defun process-real-time (process)
1287   #!+sb-doc
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*)
1292       (without-scheduling
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)))
1297
1298 ;;; The run time in seconds accrued while the process was scheduled.
1299 (defun process-run-time (process)
1300   #!+sb-doc
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*)
1305       (without-scheduling
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)))
1310
1311 ;;; Return the real time in seconds elapsed since the process was last
1312 ;;; de-scheduled.
1313 (defun process-idle-time (process)
1314   #!+sb-doc
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*)
1319       0
1320       (without-scheduling
1321        (let ((real-time (get-real-time)))
1322          (- real-time (process-scheduled-real-time process))))))
1323
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))
1327   #!+sb-doc
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.
1333   #!+(and gencgc nil)
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 ".~%")
1339                   (process-yield))
1340                  (t
1341                   #+nil (format t "-~%")))))
1342     (sb!sys:enable-interrupt :sigalrm #'sigalrm-handler))
1343   (sb!unix:unix-setitimer :real sec usec 0 1)
1344   (values))
1345
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*
1350     (init-stack-groups)
1351     (setf *initial-process*
1352           (%make-process
1353            :name "initial"
1354            :state :active
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)))
1361
1362 (pushnew 'init-multi-processing sb!int:*after-save-initializations*)
1363
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)))
1369        (when stack-group
1370          (scrub-stack-group-stacks stack-group))))))
1371 (pushnew 'scrub-all-processes-stacks sb!ext:*before-gc-hooks*)
1372
1373 ;;; Wait until FD is usable for DIRECTION.
1374 (defun process-wait-until-fd-usable (fd direction &optional timeout)
1375   #!+sb-doc
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!kernel: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))
1396                          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))
1405                          0))))
1406
1407         (ecase direction
1408           (:input
1409            (unless (fd-usable-for-input)
1410              ;; Wait until input possible.
1411              (sb!sys:with-fd-handler (fd :input
1412                                       #'(lambda (fd)
1413                                           (declare (ignore fd)
1414                                                    (optimize (speed 3)
1415                                                              (safety 0)))
1416                                           (sb!mp:process-yield)))
1417                (if timeout
1418                    (sb!mp:process-wait-with-timeout "Input Wait"
1419                                                     timeout
1420                                                     #'fd-usable-for-input)
1421                    (sb!mp:process-wait "Input Wait" #'fd-usable-for-input)))))
1422           (:output
1423            (unless (fd-usable-for-output)
1424              ;; Wait until output possible.
1425              (sb!sys:with-fd-handler (fd :output
1426                                       #'(lambda (fd)
1427                                           (declare (ignore fd)
1428                                                    (optimize (speed 3)
1429                                                              (safety 0)))
1430                                           (sb!mp:process-yield)))
1431                (if timeout
1432                    (sb!mp:process-wait-with-timeout "Output Wait"
1433                                                     timeout
1434                                                     #'fd-usable-for-output)
1435                    (sb!mp:process-wait "Output Wait"
1436                                        #'fd-usable-for-output)))))))))
1437
1438 ;;; Redefine the sleep function to call process-wait-with-timeout,
1439 ;;; rather than blocking.
1440 (defun sleep (n)
1441   #!+sb-doc
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))
1445             (minusp n))
1446     (error "Invalid argument to SLEEP: ~S.~%~
1447             Must be a non-negative, non-complex number."
1448            n))
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)
1454              (if (integerp n)
1455                  (values n 0)
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))
1459          nil)
1460         (t
1461          (process-wait-with-timeout "Sleep" n (constantly nil)))))
1462
1463 (defun show-processes (&optional verbose)
1464   #!+sb-doc
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
1467   shown."
1468   (fresh-line)
1469   (dolist (process *all-processes*)
1470     (when (eq process *current-process*)
1471       (format t "* "))
1472     (format t "~S ~S ~A~%" process (process-whostate process)
1473             (process-state process))
1474     (when verbose
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)))))
1479
1480 (defun top-level ()
1481   #!+sb-doc
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)))
1487     (loop
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))
1492             (loop
1493               (sb!sys:scrub-control-stack)
1494               (fresh-line)
1495               (princ (if (functionp sb!int:*prompt*)
1496                          (funcall sb!int:*prompt*)
1497                          sb!int:*prompt*))
1498               (force-output)
1499               (let ((form (read *standard-input* nil magic-eof-cookie)))
1500                 (cond ((not (eq form magic-eof-cookie))
1501                        (let ((results
1502                               (multiple-value-list
1503                                   (sb!int:interactive-eval form))))
1504                          (dolist (result results)
1505                            (fresh-line)
1506                            (prin1 result))))
1507                       (t
1508                        (throw '%end-of-the-process nil)))))))))))
1509
1510 (defun startup-idle-and-top-level-loops ()
1511   #!+sb-doc
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))
1524 \f
1525 ;;;; simple locking
1526
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)))
1534       (when name
1535         (format stream " ~A" name)))
1536     (let ((process (lock-process lock)))
1537       (cond (process
1538              (format stream ", held by ~S" process))
1539             (t
1540              (write-string ", free" stream))))))
1541
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
1546                 #'(lambda ()
1547                     (declare (optimize (speed 3)))
1548                     #!-mp-i486
1549                     (unless (lock-process lock)
1550                       (setf (lock-process lock) *current-process*))
1551                     #!+mp-i486
1552                     (null (sb!kernel:%instance-set-conditional
1553                            lock 2 nil *current-process*)))))
1554
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
1560    whostate timeout
1561    #'(lambda ()
1562        (declare (optimize (speed 3)))
1563        #!-mp-i486
1564        (unless (lock-process lock)
1565          (setf (lock-process lock) *current-process*))
1566        #!+mp-i486
1567        (null (sb!kernel:%instance-set-conditional
1568               lock 2 nil *current-process*)))))
1569
1570 ;;; Atomically seize a lock if it's free.
1571 #!-mp-i486
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*))))
1578
1579 (defmacro with-lock-held ((lock &optional (whostate "Lock Wait") &key timeout)
1580                           &body body)
1581
1582   #!+sb-doc
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*)))
1591       (unwind-protect
1592            ,(if timeout
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))
1597                              ((null ,timeout)
1598                               (lock-wait ,lock ,whostate))
1599                              ((lock-wait-with-timeout
1600                                ,lock ,whostate ,timeout)))
1601                   ,@body)
1602                 `(progn
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))
1608                   ,@body))
1609         (unless ,have-lock
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)))))))