/[cmucl]/src/code/multi-proc.lisp
ViewVC logotype

Contents of /src/code/multi-proc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.46 - (show annotations)
Mon Apr 19 02:18:04 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.45: +36 -36 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;; -*- Mode: Lisp; Package: Multiprocessing -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written by Douglas T. Crosher and has been placed in
5 ;;; the Public domain, and is provided 'as is'.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/multi-proc.lisp,v 1.46 2010/04/19 02:18:04 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Stack-group and multi-process support for CMUCL x86.
13 ;;;
14
15 (in-package "MULTIPROCESSING")
16 (intl:textdomain "cmucl-mp")
17
18 (sys:register-lisp-runtime-feature :mp)
19
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21 ;;;; Handle the binding stack.
22
23 ;;; Undo all the bindings in the bind stack, restoring the global
24 ;;; values.
25 (defun unbind-binding-stack ()
26 (declare (optimize (speed 3) (safety 0)))
27 (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap))
28 (binding-stack
29 (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned)))
30 (size (sys:sap- binding-stack-pointer binding-stack)))
31 (declare (type (unsigned-byte 29) size))
32 (do ((binding size))
33 ((zerop binding))
34 (declare (type (unsigned-byte 29) binding))
35 (decf binding 8)
36 (let* ((value
37 (kernel:make-lisp-obj
38 (sys:sap-int (sys:sap-ref-sap binding-stack binding))))
39 (symbol
40 (kernel:make-lisp-obj
41 (sys:sap-int (sys:sap-ref-sap binding-stack (+ binding 4))))))
42 (cond ((symbolp symbol)
43 (let ((symbol-value (c::%primitive c:fast-symbol-value symbol)))
44 #+nil
45 (format t "Undoing: ~s ~s <-> ~s~%" symbol value symbol-value)
46 (kernel:%set-symbol-value symbol value)
47 (setf (sys:sap-ref-sap binding-stack binding)
48 (sys:int-sap (kernel:get-lisp-obj-address
49 symbol-value)))))
50 (t
51 #+nil
52 (format t "Ignoring undoing: ~s ~s~%" symbol value)))))))
53
54 ;;; Re-apply the bindings in a binding stack after an
55 ;;; unbind-binding-stack.
56 (defun rebind-binding-stack ()
57 (declare (optimize (speed 3) (safety 0)))
58 (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap))
59 (binding-stack
60 (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned)))
61 (size (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 (kernel:make-lisp-obj
68 (sys:sap-int (sys:sap-ref-sap binding-stack binding))))
69 (symbol
70 (kernel:make-lisp-obj
71 (sys:sap-int (sys:sap-ref-sap binding-stack (+ binding 4))))))
72 (cond ((symbolp symbol)
73 (let ((symbol-value (c::%primitive c:fast-symbol-value symbol)))
74 #+nil
75 (format t "Rebinding: ~s ~s <-> ~s~%"
76 symbol value symbol-value)
77 (kernel:%set-symbol-value symbol value)
78 (setf (sys:sap-ref-sap binding-stack binding)
79 (sys:int-sap (kernel:get-lisp-obj-address
80 symbol-value)))))
81 (t
82 #+nil
83 (format t "Ignoring rebinding: ~s ~s~%" symbol value)))))))
84
85 (defun save-binding-stack (binding-save-stack)
86 (declare (type (simple-array t (*)) binding-save-stack)
87 (optimize (speed 3) (safety 0)))
88 (let* ((binding-stack-pointer (kernel:binding-stack-pointer-sap))
89 (binding-stack
90 (sys:int-sap (alien:extern-alien "binding_stack" alien:unsigned)))
91 (size (sys:sap- binding-stack-pointer binding-stack))
92 (vector-size (truncate size 4)))
93 (declare (type (unsigned-byte 29) size))
94 ;; Grow binding-save-stack if necessary.
95 (when (< (length binding-save-stack) vector-size)
96 (setq binding-save-stack
97 (adjust-array binding-save-stack vector-size :element-type t)))
98 ;; Save the stack.
99 (do ((binding 0 (+ 4 binding))
100 (index 0 (1+ index)))
101 ((= binding size))
102 (declare (type (unsigned-byte 29) binding index))
103 (setf (aref binding-save-stack index)
104 (kernel:make-lisp-obj
105 (sys:sap-int (sys:sap-ref-sap binding-stack binding)))))
106 (values binding-save-stack vector-size)))
107
108 (defun restore-binding-stack (new-binding-stack size)
109 (declare (type (simple-array t (*)) new-binding-stack)
110 (type (unsigned-byte 29) size)
111 (optimize (speed 3) (safety 0)))
112 (let* ((binding-stack-size (* size 4))
113 (binding-stack (alien:extern-alien "binding_stack" alien:unsigned)))
114 (declare (type (unsigned-byte 32) binding-stack-size binding-stack))
115 (setf (kernel:binding-stack-pointer-sap)
116 (sys:int-sap (+ binding-stack binding-stack-size)))
117 (do ((binding 0 (+ 4 binding))
118 (index 0 (1+ index)))
119 ((= binding binding-stack-size))
120 (declare (type (unsigned-byte 29) binding index))
121 (setf (sys:sap-ref-sap (sys:int-sap binding-stack) binding)
122 (sys:int-sap (kernel:get-lisp-obj-address
123 (aref new-binding-stack index))))))
124 (values))
125
126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
127 ;;;; Alien-stack
128
129 ;;; The Top of the Alien-stack.
130 (declaim (type (unsigned-byte 32) *alien-stack-top*))
131 (defvar *alien-stack-top* 0)
132
133 ;;; Save the alien-stack.
134 (defun save-alien-stack (save-stack)
135 (declare (type (simple-array (unsigned-byte 32) (*)) save-stack)
136 (optimize (speed 3) (safety 0)))
137 (let* ((alien-stack (kernel:get-lisp-obj-address x86::*alien-stack*))
138 (size (- *alien-stack-top* alien-stack))
139 (vector-size (ceiling size 4)))
140 (declare (type (unsigned-byte 32) alien-stack)
141 (type (unsigned-byte 29) size))
142 #+nil
143 (format t "alien-stack ~x; size ~x~%" alien-stack size)
144 ;; Grow save-stack if necessary.
145 (when (< (length save-stack) vector-size)
146 (setq save-stack
147 (adjust-array save-stack vector-size
148 :element-type '(unsigned-byte 32))))
149 ;; Save the stack.
150 (do ((index 0 (1+ index)))
151 ((>= index vector-size))
152 (declare (type (unsigned-byte 29) index))
153 (setf (aref save-stack index)
154 (sys:sap-ref-32 (sys:int-sap *alien-stack-top*)
155 (* 4 (- (1+ index))))))
156 (values save-stack vector-size alien-stack)))
157
158 (defun restore-alien-stack (save-stack size alien-stack)
159 (declare (type (simple-array (unsigned-byte 32) (*)) save-stack)
160 (type (unsigned-byte 29) size)
161 (type (unsigned-byte 32) alien-stack)
162 (optimize (speed 3) (safety 0)))
163 (setf x86::*alien-stack* (kernel:make-lisp-obj alien-stack))
164 (do ((index 0 (1+ index)))
165 ((>= index size))
166 (declare (type (unsigned-byte 29) index))
167 (setf (sys:sap-ref-32 (sys:int-sap *alien-stack-top*) (* 4 (- (1+ index))))
168 (aref save-stack index)))
169 (values))
170
171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
172 ;;;; Interrupt contexts.
173
174 ;;; Save the interrupt contexts.
175 (defun save-interrupt-contexts (save-vector)
176 (declare (type (simple-array (unsigned-byte 32) (*)) save-vector)
177 (optimize (speed 3) (safety 0)))
178 (let* ((size lisp::*free-interrupt-context-index*))
179 (declare (type (unsigned-byte 29) size))
180 ;; Grow save-stack if necessary.
181 (when (< (length save-vector) size)
182 (setq save-vector
183 (adjust-array save-vector size :element-type '(unsigned-byte 32))))
184 (alien:with-alien
185 ((lisp-interrupt-contexts (array alien:unsigned nil) :extern))
186 (dotimes (index size)
187 (setf (aref save-vector index)
188 (alien:deref lisp-interrupt-contexts index))))
189 save-vector))
190
191 ;;; Restore the interrupt contexts.
192 (defun restore-interrupt-contexts (save-vector)
193 (declare (type (simple-array (unsigned-byte 32) (*)) save-vector)
194 (optimize (speed 3) (safety 0)))
195 (let* ((size lisp::*free-interrupt-context-index*))
196 (declare (type (unsigned-byte 29) size))
197 (alien:with-alien
198 ((lisp-interrupt-contexts (array alien:unsigned nil) :extern))
199 (dotimes (index size)
200 (setf (alien:deref lisp-interrupt-contexts index)
201 (aref save-vector index)))))
202 (values))
203
204 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
205 ;;;;
206
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 (*)) x86::*control-stacks*))
213 (defvar x86::*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-function
221 (lambda (stack-group stream depth)
222 (declare (type stack-group stack-group)
223 (stream stream)
224 (ignore depth))
225 (print-unreadable-object (stack-group stream :identity t)
226 (format stream "Stack-group ~a, ~a"
227 (stack-group-name stack-group)
228 (stack-group-state stack-group))))))
229 ;; Must have a name.
230 (name "Anonymous" :type simple-base-string)
231 ;; State: :active or :inactive.
232 (state :inactive :type (member :active :inactive))
233 ;; The control stack; an index into *control-stacks*.
234 (control-stack-id nil :type (or kernel:index null))
235 ;; Binding stack.
236 (binding-stack nil :type (or (simple-array t (*)) null))
237 ;; Twice the number of bindings.
238 (binding-stack-size 0 :type (unsigned-byte 29))
239 ;; Current catch block, on the control stack.
240 (current-catch-block 0 :type fixnum)
241 ;; Unwind protect block, on the control stack.
242 (current-unwind-protect-block 0 :type fixnum)
243 ;; Alien stack
244 (alien-stack nil :type (or (simple-array (unsigned-byte 32) (*)) null))
245 (alien-stack-size 0 :type (unsigned-byte 29))
246 (alien-stack-pointer 0 :type (unsigned-byte 32))
247 ;; Eval-stack
248 (eval-stack nil :type (or (simple-array t (*)) null))
249 (eval-stack-top 0 :type fixnum)
250 ;;
251 ;; Interrupt contexts
252 (interrupt-contexts nil :type (or (simple-array (unsigned-byte 32) (*))
253 null))
254 ;; Resumer
255 (resumer nil :type (or stack-group null)))
256
257 ;;; The current stack group.
258 (declaim (type (or stack-group null) *current-stack-group*))
259 (defvar *current-stack-group* nil)
260
261 (declaim (type (or stack-group null) *initial-stack-group*))
262 (defvar *initial-stack-group* nil)
263
264 ;;; Process defstruct is up here because stack group functions refer
265 ;;; to process slots in assertions, but are also compiled at high
266 ;;; optimization... so if the process structure changes, all hell
267 ;;; could break loose.
268
269 (defstruct (process
270 (:constructor %make-process)
271 (:predicate processp)
272 (:print-function
273 (lambda (process stream depth)
274 (declare (type process process) (stream stream) (ignore depth))
275 (print-unreadable-object (process stream :identity t)
276 (format stream "Process ~a" (process-name process))))))
277 (name "Anonymous" :type simple-base-string)
278 (state :killed :type (member :killed :active :inactive))
279 (%whostate nil :type (or null simple-base-string))
280 (initial-function nil :type (or null function))
281 (initial-args nil :type list)
282 (wait-function nil :type (or null function))
283 (wait-function-args nil :type list)
284 (%run-reasons nil :type list)
285 (%arrest-reasons nil :type list)
286 ;; The real time after which the wait will timeout.
287 (wait-timeout nil :type (or null double-float))
288 (wait-return-value nil :type t)
289 (interrupts '() :type list)
290 (stack-group nil :type (or null stack-group))
291 ;;
292 ;; The real and run times when the current process was last
293 ;; scheduled or yielded.
294 (scheduled-real-time (get-real-time) :type double-float)
295 (scheduled-run-time (get-run-time) :type double-float)
296 ;;
297 ;; Accrued real and run times in seconds.
298 (%real-time 0d0 :type double-float)
299 (%run-time 0d0 :type double-float)
300 (property-list nil :type list)
301 (initial-bindings nil :type list))
302
303
304 ;;; Init-Stack-Groups -- Interface
305 ;;;
306 ;;; Setup the initial stack group.
307 ;;;
308 (defun init-stack-groups ()
309 ;; Grab the top of the alien-stack; it's currently stored at the top
310 ;; of the control stack.
311 (setf *alien-stack-top*
312 (sys:sap-ref-32
313 (sys:int-sap (alien:extern-alien "control_stack_end" alien:unsigned))
314 -4))
315 ;; Initialise the *control-stacks* vector.
316 (setq x86::*control-stacks*
317 (make-array 10 :element-type '(or null (unsigned-byte 32))
318 :initial-element nil))
319 ;; Setup a control-stack for the initial stack-group.
320 (setf (aref x86::*control-stacks* 0)
321 (make-array 0 :element-type '(unsigned-byte 32)
322 :initial-element 0))
323 ;; Make and return the initial stack group.
324 (setf *current-stack-group*
325 (%make-stack-group
326 :name "Initial"
327 :state :active
328 :control-stack-id 0
329 :binding-stack #()
330 :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
331 :interrupt-contexts (make-array 0 :element-type '(unsigned-byte 32))
332 :eval-stack #()))
333 (setf *initial-stack-group* *current-stack-group*))
334
335 ;;; Inactivate-Stack-Group -- Internal
336 ;;;
337 ;;; Inactivate the stack group, cleaning its slot and freeing the
338 ;;; control stack.
339 ;;;
340 (defun inactivate-stack-group (stack-group)
341 (declare (type stack-group stack-group))
342 (setf (stack-group-state stack-group) :inactive)
343 (let ((cs-id (stack-group-control-stack-id stack-group)))
344 (when (and cs-id (aref x86::*control-stacks* cs-id))
345 (setf (aref x86::*control-stacks* cs-id) nil)))
346 (setf (stack-group-control-stack-id stack-group) nil)
347 (setf (stack-group-binding-stack stack-group) nil)
348 (setf (stack-group-binding-stack-size stack-group) 0)
349 (setf (stack-group-current-catch-block stack-group) 0)
350 (setf (stack-group-current-unwind-protect-block stack-group) 0)
351 (setf (stack-group-alien-stack stack-group) nil)
352 (setf (stack-group-alien-stack-size stack-group) 0)
353 (setf (stack-group-alien-stack-pointer stack-group) 0)
354 (setf (stack-group-eval-stack stack-group) nil)
355 (setf (stack-group-eval-stack-top stack-group) 0)
356 (setf (stack-group-resumer stack-group) nil))
357
358 ;;; Scrub-Stack-Group-Stacks -- Internal
359 ;;;
360 ;;; Scrub the binding and eval stack of the give stack-group.
361 ;;;
362 (defun scrub-stack-group-stacks (stack-group)
363 (declare (type stack-group stack-group)
364 (optimize (speed 3) (safety 0)))
365 ;; Binding stack.
366 (let ((binding-save-stack (stack-group-binding-stack stack-group)))
367 (when binding-save-stack
368 (let ((size
369 ;; The stored binding stack for the current stack group
370 ;; can be completely scrubbed.
371 (if (eq stack-group *current-stack-group*)
372 0
373 (stack-group-binding-stack-size stack-group)))
374 (len (length binding-save-stack)))
375 ;; Scrub the remainder of the binding stack.
376 (do ((index size (+ index 1)))
377 ((>= index len))
378 (declare (type (unsigned-byte 29) index))
379 (setf (aref binding-save-stack index) 0)))))
380 ;; If this is the current stack group then update the stored
381 ;; eval-stack and eval-stack-top before scrubbing.
382 (when (eq stack-group *current-stack-group*)
383 ;; Updare the stored vector, flushing an old vector if a new one
384 ;; has been allocated.
385 (setf (stack-group-eval-stack stack-group) lisp::*eval-stack*)
386 ;; Ensure that the stack-top is valid.
387 (setf (stack-group-eval-stack-top stack-group) lisp::*eval-stack-top*))
388 ;; Scrub the eval stack.
389 (let ((eval-stack (stack-group-eval-stack stack-group)))
390 (when eval-stack
391 (let ((eval-stack-top (stack-group-eval-stack-top stack-group))
392 (len (length eval-stack)))
393 (do ((i eval-stack-top (1+ i)))
394 ((= i len))
395 (declare (type kernel:index i))
396 (setf (svref eval-stack i) nil))))))
397
398 ;;; Initial-binding-stack -- Internal
399 ;;;
400 ;;; Generate the initial bindings for a newly created stack-group.
401 ;;; This function may be redefined to return a vector with other bindings
402 ;;; but *interrupts-enabled* and *gc-inhibit* must be the last two.
403 ;;;
404 (defun initial-binding-stack ()
405 (vector
406 (find-package "COMMON-LISP-USER") '*package*
407 ;; Other bindings may be added here.
408 nil 'unix::*interrupts-enabled*
409 t 'lisp::*gc-inhibit*))
410
411 ;;; Make-Stack-Group -- Interface
412 ;;;
413 ;;; Fork a new stack-group from the *current-stack-group*. Execution
414 ;;; continues with the *current-stack-group* returning the new stack
415 ;;; group. Control may be transfer to the child by stack-group-resume
416 ;;; and it executes the initial-function.
417 ;;;
418 (defun make-stack-group (name initial-function &optional
419 (resumer *current-stack-group*)
420 (inherit t))
421 (declare (type simple-base-string name)
422 (type function initial-function)
423 (type stack-group resumer))
424 (flet ((allocate-control-stack ()
425 (let* (;; Allocate a new control-stack ID.
426 (control-stack-id (position nil x86::*control-stacks*))
427 ;; Find the required stack size.
428 (control-stack-end
429 (alien:extern-alien "control_stack_end" alien:unsigned))
430 (control-stack-pointer (kernel:control-stack-pointer-sap))
431 (control-stack-size
432 (- control-stack-end (sys:sap-int control-stack-pointer)))
433 ;; Saved control stack needs three extra words. The
434 ;; stack pointer will be stored in the first
435 ;; element, and the frame pointer and return address
436 ;; push onto the bottom of the stack.
437 (control-stack
438 (make-array (+ (ceiling control-stack-size 4) 3)
439 :element-type '(unsigned-byte 32)
440 :initial-element 0)))
441 (declare (type (unsigned-byte 29) control-stack-size))
442 (unless control-stack-id
443 ;; Need to extend the *control-stacks* vector.
444 (setq control-stack-id (length x86::*control-stacks*))
445 (setq x86::*control-stacks*
446 (adjust-array x86::*control-stacks*
447 (* 2 (length x86::*control-stacks*))
448 :element-type '(or null (unsigned-byte 32))
449 :initial-element nil)))
450 (setf (aref x86::*control-stacks* control-stack-id) control-stack)
451 (values control-stack control-stack-id)))
452 ;; Allocate a stack group inheriting stacks and bindings from
453 ;; the current stack group.
454 (allocate-child-stack-group (control-stack-id)
455 ;; Save the interrupt-contexts while the size is still
456 ;; bound.
457 (let ((interrupt-contexts
458 (save-interrupt-contexts
459 (make-array 0 :element-type '(unsigned-byte 32)))))
460 ;; Save the binding stack. Note that
461 ;; *interrutps-enabled* could be briefly set during the
462 ;; unbinding and re-binding process so signals are
463 ;; blocked.
464 (let ((old-sigs (unix:unix-sigblock
465 (unix:sigmask :sigint :sigalrm))))
466 (declare (type (unsigned-byte 32) old-sigs))
467 (unbind-binding-stack)
468 (multiple-value-bind (binding-stack binding-stack-size)
469 (save-binding-stack #())
470 (rebind-binding-stack)
471 (unix:unix-sigsetmask old-sigs)
472 ;; Save the Alien stack
473 (multiple-value-bind (alien-stack alien-stack-size
474 alien-stack-pointer)
475 (save-alien-stack
476 (make-array 0 :element-type '(unsigned-byte 32)))
477 ;; Allocate a stack-group structure.
478 (%make-stack-group
479 :name name
480 :state :active
481 :control-stack-id control-stack-id
482 ;; Save the Eval stack.
483 :eval-stack (copy-seq (the simple-vector
484 kernel:*eval-stack*))
485 :eval-stack-top kernel:*eval-stack-top*
486 ;; Misc stacks.
487 :current-catch-block lisp::*current-catch-block*
488 :current-unwind-protect-block
489 lisp::*current-unwind-protect-block*
490 ;; Alien stack.
491 :alien-stack alien-stack
492 :alien-stack-size alien-stack-size
493 :alien-stack-pointer alien-stack-pointer
494 ;; Interrupt contexts
495 :interrupt-contexts interrupt-contexts
496 ;; Binding stack.
497 :binding-stack binding-stack
498 :binding-stack-size binding-stack-size
499 ;; Resumer
500 :resumer resumer))))))
501 ;; Allocate a new stack group with fresh stacks and bindings.
502 (allocate-new-stack-group (control-stack-id)
503 (let ((binding-stack (initial-binding-stack)))
504 ;; Allocate a stack-group structure.
505 (%make-stack-group
506 :name name
507 :state :active
508 :control-stack-id control-stack-id
509 ;; Eval stack. Needs at least one element be because
510 ;; push doubles the size when full.
511 :eval-stack (make-array 32)
512 :eval-stack-top 0
513 ;; Misc stacks.
514 :current-catch-block 0
515 :current-unwind-protect-block 0
516 ;; Alien stack.
517 :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
518 :alien-stack-size 0
519 :alien-stack-pointer *alien-stack-top*
520 ;; Interrupt contexts
521 :interrupt-contexts (make-array 0 :element-type
522 '(unsigned-byte 32))
523 ;; Binding stack - some initial bindings.
524 :binding-stack binding-stack
525 :binding-stack-size (length binding-stack)
526 ;; Resumer
527 :resumer resumer))))
528 (let ((child-stack-group nil))
529 (let ((unix::*interrupts-enabled* nil)
530 (lisp::*gc-inhibit* t))
531 (multiple-value-bind (control-stack control-stack-id)
532 (allocate-control-stack)
533 (setq child-stack-group
534 (if inherit
535 (allocate-child-stack-group control-stack-id)
536 (allocate-new-stack-group control-stack-id)))
537 ;; Fork the control-stack
538 (if (x86:control-stack-fork control-stack inherit)
539 ;; Current-stack-group returns the child-stack-group.
540 child-stack-group
541 ;; Child starts.
542 (unwind-protect
543 (progn
544 (setq *current-stack-group* child-stack-group)
545 (assert (eq *current-stack-group*
546 (process-stack-group *current-process*)))
547 ;; Enable interrupts and GC.
548 (setf unix::*interrupts-enabled* t)
549 (setf lisp::*gc-inhibit* nil)
550 (when unix::*interrupt-pending*
551 (unix::do-pending-interrupt))
552 (when lisp::*need-to-collect-garbage*
553 (lisp::maybe-gc))
554 (funcall initial-function))
555 (let ((resumer (stack-group-resumer child-stack-group)))
556 ;; Disable interrupts and GC.
557 (setf unix::*interrupts-enabled* nil)
558 (setf lisp::*gc-inhibit* t)
559 (inactivate-stack-group child-stack-group)
560 ;; Verify the resumer.
561 (unless (and resumer
562 (eq (stack-group-state resumer) :active))
563 (format t "*Resuming stack-group ~s instead of ~s~%"
564 *initial-stack-group* resumer)
565 (setq resumer *initial-stack-group*))
566 ;; Restore the resumer state.
567 (setq *current-stack-group* resumer)
568 ;; Eval-stack
569 (setf kernel:*eval-stack* (stack-group-eval-stack resumer))
570 (setf kernel:*eval-stack-top*
571 (stack-group-eval-stack-top resumer))
572 ;; The binding stack. Note that
573 ;; *interrutps-enabled* could be briefly set during
574 ;; the unbinding and re-binding process so signals
575 ;; are blocked.
576 (let ((old-sigs (unix:unix-sigblock
577 (unix:sigmask :sigint :sigalrm))))
578 (declare (type (unsigned-byte 32) old-sigs))
579 (unbind-binding-stack)
580 (restore-binding-stack
581 (stack-group-binding-stack resumer)
582 (stack-group-binding-stack-size resumer))
583 (rebind-binding-stack)
584 (unix:unix-sigsetmask old-sigs))
585 ;; Misc stacks.
586 (setf lisp::*current-catch-block*
587 (stack-group-current-catch-block resumer))
588 (setf lisp::*current-unwind-protect-block*
589 (stack-group-current-unwind-protect-block resumer))
590 ;; The Alien stack
591 (restore-alien-stack
592 (stack-group-alien-stack resumer)
593 (stack-group-alien-stack-size resumer)
594 (stack-group-alien-stack-pointer resumer))
595 ;; Interrupt-contexts.
596 (restore-interrupt-contexts
597 (stack-group-interrupt-contexts resumer))
598 ;;
599 (let ((new-control-stack
600 (aref x86::*control-stacks*
601 (stack-group-control-stack-id resumer))))
602 (declare (type (simple-array (unsigned-byte 32) (*))
603 new-control-stack))
604 (x86:control-stack-return new-control-stack)))))))
605 (when (and unix::*interrupts-enabled* unix::*interrupt-pending*)
606 (unix::do-pending-interrupt))
607 (when (and lisp::*need-to-collect-garbage* (not lisp::*gc-inhibit*))
608 (lisp::maybe-gc))
609 child-stack-group)))
610
611
612 ;;; Stack-Group-Resume -- Interface
613 ;;;
614 ;;; Transfer control to the given stack-group, resuming its execution,
615 ;;; and saving the *current-stack-group*.
616 ;;;
617 (defun stack-group-resume (new-stack-group)
618 (declare (type stack-group new-stack-group)
619 (optimize (speed 3)))
620 (assert (and (eq (stack-group-state new-stack-group) :active)
621 (not (eq new-stack-group *current-stack-group*))))
622 (assert (eq new-stack-group (process-stack-group *current-process*)))
623 (let ((unix::*interrupts-enabled* nil)
624 (lisp::*gc-inhibit* t))
625 (let* (;; Save the current stack-group on its stack.
626 (stack-group *current-stack-group*)
627 ;; Find the required stack size.
628 (control-stack-end
629 (alien:extern-alien "control_stack_end" alien:unsigned))
630 (control-stack-pointer (kernel:control-stack-pointer-sap))
631 (control-stack-size (- control-stack-end
632 (sys:sap-int control-stack-pointer)))
633 ;; Stack-save array needs three extra elements. The stack
634 ;; pointer will be stored in the first, and the frame
635 ;; pointer and return address push onto the bottom of the
636 ;; stack.
637 (save-stack-size (+ (ceiling control-stack-size 4) 3))
638 ;; The save-stack vector.
639 (control-stack (aref x86::*control-stacks*
640 (stack-group-control-stack-id stack-group))))
641 (declare (type (unsigned-byte 29) control-stack-size save-stack-size)
642 (type (simple-array (unsigned-byte 32) (*)) control-stack))
643 ;; Increase the save-stack size if necessary.
644 (when (> save-stack-size (length control-stack))
645 (setf control-stack (adjust-array control-stack save-stack-size
646 :element-type '(unsigned-byte 32)
647 :initial-element 0))
648 (setf (aref x86::*control-stacks*
649 (stack-group-control-stack-id stack-group))
650 control-stack))
651
652 ;; Eval-stack
653 (setf (stack-group-eval-stack stack-group) kernel:*eval-stack*)
654 (setf (stack-group-eval-stack-top stack-group) kernel:*eval-stack-top*)
655 (setf kernel:*eval-stack* (stack-group-eval-stack new-stack-group))
656 (setf kernel:*eval-stack-top*
657 (stack-group-eval-stack-top new-stack-group))
658
659 ;; Misc stacks.
660 (setf (stack-group-current-catch-block stack-group)
661 lisp::*current-catch-block*)
662 (setf (stack-group-current-unwind-protect-block stack-group)
663 lisp::*current-unwind-protect-block*)
664 (setf lisp::*current-catch-block*
665 (stack-group-current-catch-block new-stack-group))
666 (setf lisp::*current-unwind-protect-block*
667 (stack-group-current-unwind-protect-block new-stack-group))
668
669 ;; Save the interrupt-contexts.
670 (setf (stack-group-interrupt-contexts stack-group)
671 (save-interrupt-contexts
672 (stack-group-interrupt-contexts stack-group)))
673
674 ;; The binding stack. Note that *interrutps-enabled* could be
675 ;; briefly set during the unbinding and re-binding process so
676 ;; signals are blocked.
677 (let ((old-sigs (unix:unix-sigblock (unix:sigmask :sigint :sigalrm))))
678 (declare (type (unsigned-byte 32) old-sigs))
679 (unbind-binding-stack)
680 (multiple-value-bind (stack size)
681 (save-binding-stack (stack-group-binding-stack stack-group))
682 (setf (stack-group-binding-stack stack-group) stack)
683 (setf (stack-group-binding-stack-size stack-group) size))
684 (restore-binding-stack (stack-group-binding-stack new-stack-group)
685 (stack-group-binding-stack-size
686 new-stack-group))
687 (rebind-binding-stack)
688 (unix:unix-sigsetmask old-sigs))
689
690 ;; Restore the interrupt-contexts.
691 (restore-interrupt-contexts
692 (stack-group-interrupt-contexts new-stack-group))
693
694 ;; The Alien stack
695 (multiple-value-bind (save-stack size alien-stack)
696 (save-alien-stack (stack-group-alien-stack stack-group))
697 (setf (stack-group-alien-stack stack-group) save-stack)
698 (setf (stack-group-alien-stack-size stack-group) size)
699 (setf (stack-group-alien-stack-pointer stack-group) alien-stack))
700 (restore-alien-stack (stack-group-alien-stack new-stack-group)
701 (stack-group-alien-stack-size new-stack-group)
702 (stack-group-alien-stack-pointer new-stack-group))
703 ;;
704 (let ((new-control-stack
705 (aref x86::*control-stacks*
706 (stack-group-control-stack-id new-stack-group))))
707 (declare (type (simple-array (unsigned-byte 32) (*))
708 new-control-stack))
709 (x86:control-stack-resume control-stack new-control-stack))
710 ;; Thread returns.
711 (setq *current-stack-group* stack-group)))
712 (assert (eq *current-stack-group* (process-stack-group *current-process*)))
713 (when (and unix::*interrupts-enabled* unix::*interrupt-pending*)
714 (unix::do-pending-interrupt))
715 (when (and lisp::*need-to-collect-garbage* (not lisp::*gc-inhibit*))
716 (lisp::maybe-gc))
717 (values))
718
719 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
720 ;;;; Double-float timing functions for use by the scheduler.
721
722 ;;; These timer functions use double-floats for accuracy. In most
723 ;;; cases consing is avoided.
724
725 ;;; Get-Real-Time
726 ;;;
727 (declaim (inline get-real-time))
728 ;;;
729 (defun get-real-time ()
730 "Return the real time in seconds."
731 (declare (optimize (speed 3) (safety 0)))
732 (multiple-value-bind (ignore seconds useconds)
733 (unix:unix-gettimeofday)
734 (declare (ignore ignore)
735 (type (unsigned-byte 32) seconds useconds))
736 (+ (coerce seconds 'double-float)
737 (* (coerce useconds 'double-float) 1d-6))))
738
739 ;;; Get-Run-Time
740 ;;;
741 (declaim (inline get-run-time))
742 ;;;
743 (defun get-run-time ()
744 "Return the run time in seconds"
745 (declare (optimize (speed 3) (safety 0)))
746 (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
747 (unix:unix-fast-getrusage unix:rusage_self)
748 (declare (ignore ignore)
749 (type (unsigned-byte 31) utime-sec stime-sec)
750 (type (mod 1000000) utime-usec stime-usec))
751 (+ (coerce utime-sec 'double-float) (coerce stime-sec 'double-float)
752 (* (+ (coerce utime-usec 'double-float)
753 (coerce stime-usec 'double-float))
754 1d-6))))
755
756 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
757 ;;;; Multi-process support. The interface is based roughly on the
758 ;;;; CLIM-SYS spec. and support needed for cl-http.
759
760 (defvar *multi-processing* t)
761
762 ;;; Process-Whostate -- Public
763 ;;;
764 (defun process-whostate (process)
765 "Return the process state which is either Run, Killed, or a wait reason."
766 (cond ((eq (process-state process) :killed)
767 "Killed")
768 ((process-wait-function process)
769 (or (process-%whostate process) "Run"))
770 (t
771 "Run")))
772
773 ;;; Process-Active-P -- Public
774 ;;;
775 (declaim (inline process-active-p))
776 (defun process-active-p (process)
777 (and (eq (process-state process) :active)
778 (process-%run-reasons process)
779 (not (process-%arrest-reasons process))))
780
781 ;;; Process-Alive-P -- Public
782 ;;;
783 (declaim (inline process-alive-p))
784 (defun process-alive-p (process)
785 (let ((state (process-state process)))
786 (or (eq state :active) (eq state :inactive))))
787
788 ;;; A dummy initial process is defined so that locks will work before
789 ;;; multi-processing has been started.
790 (declaim (type process *current-process*))
791 (defvar *current-process*
792 (%make-process :name "Startup" :state :inactive :stack-group nil))
793
794 ;;; Current-Process -- Public
795 ;;;
796 (declaim (inline current-process))
797 (defun current-process ()
798 "Returns the current process."
799 *current-process*)
800
801 (declaim (list *all-processes*))
802 (defvar *all-processes* nil
803 "A list of all alive processes.")
804
805 ;;; All-Processes -- Public
806 ;;;
807 (declaim (inline all-processes))
808 (defun all-processes ()
809 "Return a list of all the live processes."
810 *all-processes*)
811
812 (declaim (type (or null process) *initial-process*))
813 (defvar *initial-process* nil)
814
815 ;;; Without-scheduling -- Public
816 ;;;
817 ;;; Disable scheduling while the body is executed. Scheduling is
818 ;;; typically inhibited when process state is being modified.
819 ;;;
820 (defvar *inhibit-scheduling* t)
821 ;;;
822 (defmacro without-scheduling (&body body)
823 "Execute the body the scheduling disabled."
824 `(let ((inhibit *inhibit-scheduling*))
825 (unwind-protect
826 (progn
827 (setf *inhibit-scheduling* t)
828 ,@body)
829 (setf *inhibit-scheduling* inhibit))))
830
831 (defmacro atomic-incf (reference &optional (delta 1))
832 "Increaments the reference by delta in a single atomic operation"
833 `(without-scheduling
834 (incf ,reference ,delta)))
835
836 (defmacro atomic-decf (reference &optional (delta 1))
837 "Decrements the reference by delta in a single atomic operation"
838 `(without-scheduling
839 (decf ,reference ,delta)))
840
841 (defmacro atomic-push (obj place)
842 "Atomically push object onto place."
843 `(without-scheduling
844 (push ,obj ,place)))
845
846 (defmacro atomic-pop (place)
847 "Atomically pop place."
848 `(without-scheduling
849 (pop ,place)))
850
851 ;;; If a process other than the initial process throws to the
852 ;;; %end-of-the-world then *quitting-lisp* is set to the exit value,
853 ;;; after which further process creation blocks. If the initial
854 ;;; process is running the idle loop then it will perform the exit
855 ;;; when it runs.
856 ;;;
857 (defvar *quitting-lisp* nil)
858
859 ;;; Update-Process-Timers -- Internal
860 ;;;
861 ;;; Update the processes times for the current and new process before
862 ;;; a process switch.
863 ;;;
864 (defun update-process-timers (current-process new-process)
865 (declare (type process current-process new-process)
866 (optimize (speed 3) (safety 0)))
867 (let ((real-time (get-real-time)))
868 (incf (process-%real-time current-process)
869 (- real-time (process-scheduled-real-time current-process)))
870 (setf (process-scheduled-real-time current-process) real-time)
871 (setf (process-scheduled-real-time new-process) real-time))
872 (let ((run-time (get-run-time)))
873 (incf (process-%run-time current-process)
874 (- run-time (process-scheduled-run-time current-process)))
875 (setf (process-scheduled-run-time current-process) run-time)
876 (setf (process-scheduled-run-time new-process) run-time))
877 (values))
878
879 (defun apply-with-bindings (function args bindings)
880 (if bindings
881 (progv
882 (mapcar #'car bindings)
883 (mapcar #'(lambda (binding)
884 (eval (cdr binding)))
885 bindings)
886 (apply function args))
887 (apply function args)))
888
889
890 ;;; Make-Process -- Public
891 ;;;
892 (defun make-process (function &key
893 (name "Anonymous")
894 (run-reasons (list :enable))
895 (arrest-reasons nil)
896 (initial-bindings nil))
897 "Make a process which will run FUNCTION when it starts up. By
898 default the process is created in a runnable (active) state.
899 If FUNCTION is NIL, the process is started in a killed state; it may
900 be restarted later with process-preset.
901
902 :NAME
903 A name for the process displayed in process listings.
904
905 :RUN-REASONS
906 Initial value for process-run-reasons; defaults to (:ENABLE). A
907 process needs a at least one run reason to be runnable. Together with
908 arrest reasons, run reasons provide an alternative to process-wait for
909 controling whether or not a process is runnable. To get the default
910 behavior of MAKE-PROCESS in Allegro Common Lisp, which is to create a
911 process which is active but not runnable, initialize RUN-REASONS to
912 NIL.
913
914 :ARREST-REASONS
915 Initial value for process-arrest-reasons; defaults to NIL. A
916 process must have no arrest reasons in order to be runnable.
917
918 :INITIAL-BINDINGS
919 An alist of initial special bindings for the process. At
920 startup the new process has a fresh set of special bindings
921 with a default binding of *package* setup to the CL-USER
922 package. INITIAL-BINDINGS specifies additional bindings for
923 the process. The cdr of each alist element is evaluated in
924 the fresh dynamic environment and then bound to the car of the
925 element."
926 (declare (type (or null function) function))
927 (cond (*quitting-lisp*
928 ;; No more processes if about to quit lisp.
929 (process-wait "Quitting Lisp" #'(lambda () nil)))
930 ((null function)
931 ;; If function is nil then create a dead process; can be
932 ;; restarted with process-preset.
933 (%make-process :initial-function nil :name name :state :killed
934 :%run-reasons run-reasons
935 :%arrest-reasons arrest-reasons
936 :initial-bindings initial-bindings))
937 (t
938 ;; Create a stack-group.
939 (let ((process
940 (%make-process
941 :name name
942 :state :active
943 :initial-function function
944 :%run-reasons run-reasons
945 :%arrest-reasons arrest-reasons
946 :initial-bindings initial-bindings
947 :stack-group
948 (make-stack-group
949 name
950 #'(lambda ()
951 (unwind-protect
952 (catch '%end-of-the-process
953 ;; Catch throws to the %end-of-the-world.
954 (setf *quitting-lisp*
955 (catch 'lisp::%end-of-the-world
956 (with-simple-restart
957 (destroy "Destroy the process")
958 (setf *inhibit-scheduling* nil)
959 (apply-with-bindings function
960 nil
961 initial-bindings))
962 ;; Normal exit.
963 (throw '%end-of-the-process nil))))
964 (setf *inhibit-scheduling* t)
965 ;; About to return to the resumer's
966 ;; stack-group, which in this case is the
967 ;; initial process's stack-group.
968 (setf (process-state *current-process*) :killed)
969 (setf *all-processes*
970 (delete *current-process* *all-processes*))
971 (setf (process-%whostate *current-process*) nil)
972 (setf (process-%run-reasons *current-process*) nil)
973 (setf (process-%arrest-reasons *current-process*) nil)
974 (setf (process-wait-function-args *current-process*)
975 nil)
976 (setf (process-wait-function *current-process*) nil)
977 (setf (process-wait-timeout *current-process*) nil)
978 (setf (process-wait-return-value *current-process*)
979 nil)
980 (setf (process-interrupts *current-process*) nil)
981 (update-process-timers *current-process*
982 *initial-process*)
983 (setf *current-process* *initial-process*)))
984 *initial-stack-group* nil))))
985 (atomic-push process *all-processes*)
986 process))))
987
988 (defun process-run-reasons (process)
989 (process-%run-reasons process))
990
991 (defun process-add-run-reason (process object)
992 (atomic-push object (process-%run-reasons process)))
993
994 (defun process-revoke-run-reason (process object)
995 (let ((run-reasons (without-scheduling
996 (setf (process-%run-reasons process)
997 (delete object (process-%run-reasons process))))))
998 (when (and (null run-reasons) (eq process mp::*current-process*))
999 (process-yield))))
1000
1001
1002 (defun process-arrest-reasons (process)
1003 (process-%arrest-reasons process))
1004
1005 (defun process-add-arrest-reason (process object)
1006 (atomic-push object (process-%arrest-reasons process))
1007 (when (eq process mp::*current-process*)
1008 (process-yield)))
1009
1010 (defun process-revoke-arrest-reason (process object)
1011 (without-scheduling
1012 (setf (process-%arrest-reasons process)
1013 (delete object (process-%arrest-reasons process)))))
1014
1015 ;;; Process-Interrupt -- Public
1016 ;;;
1017 (defun process-interrupt (process function)
1018 "Interrupt process and cause it to evaluate function."
1019 ;; Place the interrupt function at the end of process's interrupts
1020 ;; queue, to be called the next time the process is scheduled.
1021 (without-scheduling
1022 (setf (process-interrupts process)
1023 (append (list function) (process-interrupts process))))
1024 (process-yield))
1025
1026
1027 ;;; Destroy-Process -- Public
1028 ;;;
1029 (defun destroy-process (process)
1030 "Destroy a process. The process is sent a interrupt which throws to
1031 the end of the process allowing it to unwind gracefully."
1032 (declare (type process process))
1033 (assert (not (eq process *current-process*)))
1034 (without-scheduling
1035 (unless (eq (process-state process) :killed)
1036 ;; Place a throw to end-of-the-world at the start of process's
1037 ;; interrupts queue, to be called the next time the process is
1038 ;; scheduled.
1039 (push #'(lambda ()
1040 (throw '%end-of-the-process nil))
1041 (process-interrupts process))
1042 ;; Ensure that the process is active so that it can accept this
1043 ;; interrupt.
1044 (setf (process-state process) :active)))
1045 ;; Should we wait until it's dead?
1046 (process-yield))
1047
1048 (defun restart-process (process)
1049 "Restart process by unwinding it to its initial state and calling its
1050 initial function."
1051 (destroy-process process)
1052 (if *inhibit-scheduling* ;Called inside without-scheduling?
1053 (assert (eq (process-state process) :killed))
1054 (process-wait "Waiting for process to die"
1055 #'(lambda ()
1056 (eq (process-state process) :killed))))
1057 ;; No more processes if about to quit lisp.
1058 (when *quitting-lisp*
1059 (process-wait "Quitting Lisp" #'(lambda () nil)))
1060 ;; Create a new stack-group.
1061 (without-scheduling
1062 (setf (process-stack-group process)
1063 (make-stack-group
1064 (process-name process)
1065 #'(lambda ()
1066 (unwind-protect
1067 (catch '%end-of-the-process
1068 ;; Catch throws to the %end-of-the-world.
1069 (setf *quitting-lisp*
1070 (catch 'lisp::%end-of-the-world
1071 (with-simple-restart
1072 (destroy "Destroy the process")
1073 (setf *inhibit-scheduling* nil)
1074 (apply-with-bindings
1075 (process-initial-function process)
1076 (process-initial-args process)
1077 (process-initial-bindings process)))
1078 ;; Normal exit.
1079 (throw '%end-of-the-process nil))))
1080 (setf *inhibit-scheduling* t)
1081 ;; About to return to the resumer's stack-group, which
1082 ;; in this case is the initial process's stack-group.
1083 (setf (process-state *current-process*) :killed)
1084 (setf *all-processes*
1085 (delete *current-process* *all-processes*))
1086 (setf (process-%whostate *current-process*) nil)
1087 (setf (process-%run-reasons *current-process*) nil)
1088 (setf (process-%arrest-reasons *current-process*) nil)
1089 (setf (process-wait-function-args *current-process*)
1090 nil)
1091 (setf (process-wait-function *current-process*) nil)
1092 (setf (process-wait-timeout *current-process*) nil)
1093 (setf (process-wait-return-value *current-process*) nil)
1094 (setf (process-interrupts *current-process*) nil)
1095 (update-process-timers *current-process* *initial-process*)
1096 (setf *current-process* *initial-process*)))
1097 *initial-stack-group* nil))
1098 (setf (process-%whostate process) nil)
1099 (setf (process-wait-function-args process) nil)
1100 (setf (process-wait-function process) nil)
1101 (setf (process-wait-timeout process) nil)
1102 (setf (process-wait-return-value process) nil)
1103 (setf (process-interrupts process) nil)
1104 (setf (process-scheduled-real-time process) (get-real-time))
1105 (setf (process-scheduled-run-time process) (get-run-time))
1106 (setf (process-%real-time process) 0d0)
1107 (setf (process-%run-time process) 0d0)
1108 (setf (process-state process) :active)
1109 (push process *all-processes*))
1110 process)
1111
1112
1113 ;;; Process-Preset
1114 (defun process-preset (process function &rest args)
1115 "Restart process, unwinding it to its initial state and calls
1116 function with args."
1117 (setf (process-initial-function process) function)
1118 (setf (process-initial-args process) args)
1119 (restart-process process))
1120
1121
1122 ;;; Disable-Process -- Public
1123 ;;;
1124 (defun disable-process (process)
1125 "Disable process from being runnable until enabled."
1126 (without-scheduling
1127 (assert (not (eq (process-state process) :killed)))
1128 (setf (process-state process) :inactive)))
1129
1130 ;;; Enable-Process -- Public
1131 ;;;
1132 (defun enable-process (process)
1133 "Allow process to become runnable again after it has been disabled."
1134 (without-scheduling
1135 (assert (not (eq (process-state process) :killed)))
1136 (setf (process-state process) :active)))
1137
1138 ;;; Process-Wait -- Public.
1139 ;;;
1140 (defun process-wait (whostate predicate &rest args)
1141 "Causes the process to wait until predicate returns True. Processes
1142 can only call process-wait when scheduling is enabled, and the predicate
1143 can not call process-wait. Since the predicate may be evaluated may
1144 times by the scheduler it should be relative fast native compiled code.
1145 The single True predicate value is returned."
1146 (assert (not *inhibit-scheduling*))
1147 (assert (not (process-wait-function *current-process*)))
1148 ;; Don't need the disable scheduling here because the scheduler
1149 ;; doesn't mess with the whostate or timeout until the function is
1150 ;; setup, unless the process is interrupted in which case the
1151 ;; scheduler restores the state when execution resumers here.
1152 (setf (process-%whostate *current-process*) whostate)
1153 (setf (process-wait-timeout *current-process*) nil)
1154 (setf (process-wait-function-args *current-process*) args)
1155 (setf (process-wait-function *current-process*) predicate)
1156 (process-yield)
1157 (process-wait-return-value *current-process*))
1158
1159 ;;; Process-Wait-With-Timeout -- Public
1160 ;;;
1161 (defun process-wait-with-timeout (whostate timeout predicate &rest args)
1162 (declare (type (or fixnum float) timeout))
1163 "Causes the process to wait until predicate returns True, or the
1164 number of seconds specified by timeout has elapsed. The timeout may
1165 be a fixnum or a float in seconds. The single True predicate value is
1166 returned, or NIL if the timeout was reached."
1167 (assert (not *inhibit-scheduling*))
1168 (assert (not (process-wait-function *current-process*)))
1169 ;; Don't need the disable scheduling here because the scheduler
1170 ;; doesn't mess with the whostate or timeout until the function is
1171 ;; setup, unless the process is interrupted in which case the
1172 ;; scheduler restores the state when execution resumers here.
1173 (setf (process-%whostate *current-process*) whostate)
1174 (let ((timeout (etypecase timeout
1175 (fixnum
1176 (coerce timeout 'double-float))
1177 (single-float
1178 (coerce timeout 'double-float))
1179 (double-float
1180 (coerce timeout 'double-float)))))
1181 (declare (double-float timeout))
1182 (setf (process-wait-timeout *current-process*)
1183 (+ timeout (get-real-time)))
1184 (setf (process-wait-function-args *current-process*) args)
1185 (setf (process-wait-function *current-process*) predicate))
1186 (process-yield)
1187 (process-wait-return-value *current-process*))
1188
1189 ;;; The remaining processes in the scheduling queue for this cycle,
1190 ;;; the remainder of *all-processes*. The *current-process* is the
1191 ;;; first element of this list.
1192 (defvar *remaining-processes* nil)
1193
1194 ;;; The idle process will only run when there are no other runnable
1195 ;;; processes.
1196 (defvar *idle-process* nil)
1197
1198 ;;; Run-Idle-Process-P -- Internal.
1199 ;;;
1200 ;;; Decide when to allow the idle process to run.
1201 ;;;
1202 (defun run-idle-process-p ()
1203 ;; Check if there are any other runnable processes.
1204 (dolist (process *all-processes* t)
1205 (when (and (not (eq process *idle-process*))
1206 (process-active-p process)
1207 (not (process-wait-function process)))
1208 (return nil))))
1209
1210 ;;; Shutdown-multi-processing -- Internal.
1211 ;;;
1212 (defun shutdown-multi-processing ()
1213 "Try to gracefully destroy all the processes giving them some
1214 chance to unwinding, before shutting down multi-processing. This is
1215 currently necessary before a purify and is performed before a save-lisp.
1216 Multi-processing can be restarted by calling init-multi-processing."
1217 (when *initial-process*
1218 (assert (eq *current-process* *initial-process*) ()
1219 "Only the *initial-process* can shutdown multi-processing")
1220
1221 (let ((destroyed-processes nil))
1222 (do ((cnt 0 (1+ cnt)))
1223 ((> cnt 10))
1224 (declare (type kernel:index cnt))
1225 (dolist (process *all-processes*)
1226 (when (and (not (eq process *current-process*))
1227 (process-active-p process)
1228 (not (member process destroyed-processes)))
1229 (destroy-process process)
1230 (push process destroyed-processes)))
1231 (unless (rest *all-processes*)
1232 (return))
1233 (format t (intl:ngettext "Destroyed ~d process; remaining ~d~%"
1234 "Destroyed ~d processes; remaining ~d~%"
1235 (length destroyed-processes))
1236 (length destroyed-processes) (length *all-processes*))
1237 (process-yield)))
1238
1239 (start-sigalrm-yield 0 0) ; Off with the interrupts.
1240 ;; Reset the multi-processing state.
1241 (setf *inhibit-scheduling* t)
1242 (setf *initial-process* nil)
1243 (setf *idle-process* nil)
1244 (setf *current-process*
1245 (%make-process :name "Startup" :state :inactive :stack-group nil))
1246 (setf *all-processes* nil)
1247 (setf *remaining-processes* nil)
1248 ;; Cleanup the stack groups.
1249 (setf x86::*control-stacks*
1250 (make-array 0 :element-type '(or null (unsigned-byte 32))
1251 :initial-element nil))
1252 (setf *current-stack-group* nil)
1253 (setf *initial-stack-group* nil)))
1254
1255 ;;; Idle-Process-Loop -- Internal
1256 ;;;
1257 ;;; A useful idle process loop, waiting on events using the select
1258 ;;; based event server, which is assumed to be setup to call
1259 ;;; process-yielding periodically.
1260 ;;;
1261 (declaim (double-float *idle-loop-timeout*))
1262 (defvar *idle-loop-timeout* 0.1d0)
1263 ;;;
1264 (defun idle-process-loop ()
1265 "An idle loop to be run by the initial process. The select based event
1266 server is called with a timeout calculated from the minimum of the
1267 *idle-loop-timeout* and the time to the next process wait timeout.
1268 To avoid this delay when there are runnable processes the *idle-process*
1269 should be setup to the *initial-process*. If one of the processes quits
1270 by throwing to %end-of-the-world then *quitting-lisp* will have been
1271 set to the exit value which is noted by the idle loop which tries to
1272 exit gracefully destroying all the processes and giving them a chance
1273 to unwind."
1274 (declare (optimize (speed 3)))
1275 (assert (eq *current-process* *initial-process*) ()
1276 "Only the *initial-process* is intended to run the idle loop")
1277 ;; Ensure the *idle-process* is setup.
1278 (unless *idle-process*
1279 (setf *idle-process* *current-process*))
1280 ;; Adjust the process name.
1281 (setf (process-name *current-process*) "Idle Loop")
1282 (do ()
1283 (*quitting-lisp*)
1284 ;; Calculate the wait period.
1285 (let ((real-time (get-real-time))
1286 (timeout *idle-loop-timeout*))
1287 (declare (double-float timeout))
1288 (dolist (process *all-processes*)
1289 (when (process-active-p process)
1290 (let ((wait-timeout (process-wait-timeout process)))
1291 (when wait-timeout
1292 (let ((delta (- wait-timeout real-time)))
1293 (when (< delta timeout)
1294 (x86::double-float-reg-bias timeout)
1295 (setf timeout delta)))))))
1296 (when (> timeout 1d-5)
1297 (sys:serve-all-events timeout))
1298 (process-yield)))
1299 (shutdown-multi-processing)
1300 (throw 'lisp::%end-of-the-world *quitting-lisp*))
1301
1302 ;;; Process-Yield -- Public
1303 ;;;
1304 ;;; The Scheduler.
1305 ;;;
1306 (defun process-yield ()
1307 (declare (optimize (speed 3)))
1308 "Allow other processes to run."
1309 (unless *inhibit-scheduling*
1310 ;; Catch any FP exceptions before entering the scheduler.
1311 #+x87 (kernel:float-wait)
1312 ;; Inhibit recursive entry of the scheduler.
1313 (setf *inhibit-scheduling* t)
1314 (assert (eq (first *remaining-processes*) *current-process*))
1315 (assert (eq *current-stack-group* (process-stack-group *current-process*)))
1316 (loop
1317 ;; Rotate the queue.
1318 (setf *remaining-processes*
1319 (or (rest *remaining-processes*) *all-processes*))
1320
1321 (let ((next (first *remaining-processes*)))
1322 ;; Shouldn't see any :killed porcesses here.
1323 (assert (process-alive-p next))
1324
1325 (cond
1326 ;; New process at the head of the queue?
1327 ((eq next *current-process*))
1328 ;; Ignore inactive processes.
1329 ((not (process-active-p next)))
1330 ;; If the next process has pending interrupts then return to
1331 ;; it to execute these.
1332 ((process-interrupts next)
1333 (update-process-timers *current-process* next)
1334 (setf *current-process* next)
1335 (stack-group-resume (process-stack-group next)))
1336 (t
1337 ;; If not waiting then return.
1338 (let ((wait-fn (process-wait-function next))
1339 (wait-fn-args (process-wait-function-args next)))
1340 (cond
1341 ((null wait-fn)
1342 ;; Skip the idle process if there are other runnable
1343 ;; processes.
1344 (when (or (not (eq next *idle-process*))
1345 (run-idle-process-p))
1346 (update-process-timers *current-process* next)
1347 (setf *current-process* next)
1348 (stack-group-resume (process-stack-group next))))
1349 (t
1350 ;; Check the wait function in the current context
1351 ;; saving a stack-group switch; although
1352 ;; *current-process* is setup.
1353 (let ((current-process *current-process*))
1354 (setf *current-process* next)
1355 ;; Predicate true?
1356 (let ((wait-return-value (apply wait-fn wait-fn-args)))
1357 (cond (wait-return-value
1358 ;; Flush the wait.
1359 (setf (process-wait-return-value next)
1360 wait-return-value)
1361 (setf (process-wait-timeout next) nil)
1362 (setf (process-wait-function next) nil)
1363 (setf (process-%whostate next) nil)
1364 (update-process-timers current-process next)
1365 (stack-group-resume (process-stack-group next)))
1366 (t
1367 ;; Timeout?
1368 (let ((timeout (process-wait-timeout next)))
1369 (when (and timeout (> (get-real-time) timeout))
1370 ;; Flush the wait.
1371 (setf (process-wait-return-value next) nil)
1372 (setf (process-wait-timeout next) nil)
1373 (setf (process-wait-function next) nil)
1374 (setf (process-%whostate next) nil)
1375 (update-process-timers current-process next)
1376 (stack-group-resume
1377 (process-stack-group next)))))))
1378 ;; Restore the *current-process*.
1379 (setf *current-process* current-process))))))))
1380
1381 ;; May have just returned, or have cycled the queue.
1382 (let ((next (first *remaining-processes*)))
1383 ;; Tolerate :killed processes on the *remaining-processes* list
1384 ;; saving their deletion from this list when killed; will be
1385 ;; corrected when it cycles back to *all-processes*.
1386 (when (and (process-active-p next)
1387 ;; Current process at the head of the queue?
1388 (eq next *current-process*))
1389 ;; Run any pending interrupts.
1390 (let ((interrupt (pop (process-interrupts next))))
1391 (declare (type (or null function) interrupt))
1392 (cond (interrupt
1393 ;; Save and reset any wait reasons so that the
1394 ;; interrupt can wait. The return-value is also
1395 ;; saved and restored in case a process is
1396 ;; interrupted before it is read.
1397 (let ((wait-function (process-wait-function next))
1398 (wait-timeout (process-wait-timeout next))
1399 (whostate (process-%whostate next))
1400 (wait-return-value (process-wait-return-value next)))
1401 (setf (process-wait-function next) nil)
1402 (setf (process-wait-timeout next) nil)
1403 (setf (process-%whostate next) nil)
1404 (setf (process-wait-return-value next) nil)
1405 ;; Allow recursive scheduling during the interrupt
1406 ;; processing. Only one interrupt is processed on
1407 ;; each scheduler queue cycle. The process doesn't
1408 ;; return until there are no interrupts.
1409 (setf *inhibit-scheduling* nil)
1410 (funcall interrupt)
1411 (setf *inhibit-scheduling* t)
1412 ;; Restore any wait reasons.
1413 (setf (process-wait-function next) wait-function)
1414 (setf (process-wait-timeout next) wait-timeout)
1415 (setf (process-%whostate next) whostate)
1416 (setf (process-wait-return-value next) wait-return-value)))
1417 (t
1418 ;; Check the wait function.
1419 (let ((wait-fn (process-wait-function next)))
1420 (cond
1421 ((null wait-fn)
1422 (when (or (not (eq next *idle-process*))
1423 (run-idle-process-p))
1424 (return)))
1425 (t
1426 ;; Predicate true?
1427 (let ((return-value (funcall wait-fn)))
1428 (when return-value
1429 ;; Flush the wait.
1430 (setf (process-wait-return-value next) return-value)
1431 (setf (process-wait-timeout next) nil)
1432 (setf (process-wait-function next) nil)
1433 (setf (process-%whostate next) nil)
1434 (return)))
1435 ;; Timeout?
1436 (let ((timeout (process-wait-timeout next)))
1437 (when (and timeout (> (get-real-time) timeout))
1438 ;; Flush the wait.
1439 (setf (process-wait-return-value next) nil)
1440 (setf (process-wait-timeout next) nil)
1441 (setf (process-wait-function next) nil)
1442 (setf (process-%whostate next) nil)
1443 (return))))))))))))
1444 (setf *inhibit-scheduling* nil)))
1445
1446 ;;; Process-Real-Time
1447 ;;;
1448 ;;; The real time in seconds accrued while the process was scheduled.
1449 ;;;
1450 (defun process-real-time (process)
1451 "Return the accrued real time elapsed while the given process was
1452 scheduled. The returned time is a double-float in seconds."
1453 (declare (type process process))
1454 (if (eq process *current-process*)
1455 (without-scheduling
1456 (let ((real-time (get-real-time)))
1457 (+ (process-%real-time process)
1458 (- real-time (process-scheduled-real-time process)))))
1459 (process-%real-time process)))
1460
1461 ;;; Process-Run-Time -- Public
1462 ;;;
1463 ;;; The run time in seconds accrued while the process was scheduled.
1464 ;;;
1465 (defun process-run-time (process)
1466 "Return the accrued run time elapsed for the given process. The returned
1467 time is a double-float in seconds."
1468 (declare (type process process))
1469 (if (eq process *current-process*)
1470 (without-scheduling
1471 (let ((run-time (get-run-time)))
1472 (+ (process-%run-time process)
1473 (- run-time (process-scheduled-run-time process)))))
1474 (process-%run-time process)))
1475
1476 ;;; Process-Idle-Time -- Public
1477 ;;;
1478 ;;; The real time in seconds elapsed since the process was last
1479 ;;; de-scheduled.
1480 ;;;
1481 (defun process-idle-time (process)
1482 "Return the real time elapsed since the given process was last
1483 descheduled. The returned time is a double-float in seconds."
1484 (declare (type process process))
1485 (if (eq process *current-process*)
1486 0
1487 (without-scheduling
1488 (let ((real-time (get-real-time)))
1489 (- real-time (process-scheduled-real-time process))))))
1490
1491 ;;; Start-Sigalrm-Yield -- Internal
1492 ;;;
1493 ;;; Start a regular interrupt to switch processes. This may not be a
1494 ;;; good idea yet as the CMUCL code is not too interrupt safe.
1495 ;;;
1496 (defun start-sigalrm-yield (&optional (sec 0) (usec 500000))
1497 "Start a regular SIGALRM interrupt which calls process-yield. An optional
1498 time in seconds and micro seconds may be provided. Note that CMUCL code
1499 base is not too interrupt safe so this may cause problems."
1500 (declare (fixnum sec usec))
1501 ;; Disable the gencgc pointer filter to improve interrupt safety.
1502 #+(and gencgc nil)
1503 (setf (alien:extern-alien "enable_pointer_filter" alien:unsigned) 0)
1504 (flet ((sigalrm-handler (signal code scp)
1505 (declare (ignore signal code scp))
1506 (cond ((<= lisp::*free-interrupt-context-index* 1)
1507 #+nil (format t ".~%")
1508 (process-yield))
1509 (t
1510 #+nil (format t "-~%")))))
1511 (sys:enable-interrupt :sigalrm #'sigalrm-handler))
1512 (unix:unix-setitimer :real sec usec 0 1)
1513 (values))
1514
1515 ;;; Init-Multi-Processing -- Internal.
1516 ;;;
1517 ;;; Startup multi-processing, initialising the initial process. This
1518 ;;; must be called before use of the other multi-process functions.
1519 ;;;
1520 (defun init-multi-processing ()
1521 (unless *initial-process*
1522 (init-stack-groups)
1523 (setf *initial-process*
1524 (%make-process
1525 :name "Initial"
1526 :state :active
1527 :%run-reasons (list :enable)
1528 :stack-group *initial-stack-group*))
1529 (setf *current-process* *initial-process*)
1530 (setf *all-processes* (list *initial-process*))
1531 (setf *remaining-processes* *all-processes*)
1532 ;;
1533 #+nil (start-sigalrm-yield)
1534 (setf *inhibit-scheduling* nil)))
1535
1536 (pushnew 'init-multi-processing ext:*after-save-initializations*)
1537
1538 ;;; Scrub-all-processes-stacks -- Internal
1539 ;;;
1540 ;;; Scrub the stored stacks of all the processes.
1541 ;;;
1542 (defun scrub-all-processes-stacks ()
1543 (sys:without-interrupts
1544 (dolist (process *all-processes*)
1545 (let ((stack-group (process-stack-group process)))
1546 (when stack-group
1547 (scrub-stack-group-stacks stack-group))))))
1548 ;;;
1549 (pushnew 'scrub-all-processes-stacks ext:*before-gc-hooks*)
1550
1551
1552 ;;; Process-Wait-Until-FD-Usable -- Public.
1553 ;;;
1554 ;;; Wait until FD is usable for DIRECTION.
1555 ;;;
1556 (defun process-wait-until-fd-usable (fd direction &optional timeout)
1557 "Wait until FD is usable for DIRECTION and return True. DIRECTION should be
1558 either :INPUT or :OUTPUT. TIMEOUT, if supplied, is the number of seconds to
1559 wait before giving up and returing NIL."
1560 (declare (type kernel:index fd)
1561 (type (or real null) timeout)
1562 (optimize (speed 3)))
1563 (if (or (eq *current-process* *initial-process*)
1564 ;; Can't call process-wait if the scheduling is inhibited.
1565 *inhibit-scheduling*)
1566 ;; The initial-process calls the event server to block.
1567 (sys:wait-until-fd-usable fd direction timeout)
1568 ;; Other processes use process-wait.
1569 (flet ((fd-usable-for-input ()
1570 (declare (optimize (speed 3) (safety 1)))
1571 (alien:with-alien ((read-fds (alien:struct unix:fd-set)))
1572 (unix:fd-zero read-fds)
1573 (unix:fd-set fd read-fds)
1574 (multiple-value-bind (value err)
1575 (unix:unix-fast-select
1576 (1+ fd) (alien:addr read-fds) nil nil 0 0)
1577 ;; Return true when input is available or there is
1578 ;; an error other than an interrupt.
1579 (and (not (eql value 0))
1580 (or value (not (eql err unix:eintr)))))))
1581 (fd-usable-for-output ()
1582 (declare (optimize (speed 3) (safety 1)))
1583 (alien:with-alien ((write-fds (alien:struct unix:fd-set)))
1584 (unix:fd-zero write-fds)
1585 (unix:fd-set fd write-fds)
1586 (multiple-value-bind (value err)
1587 (unix:unix-fast-select
1588 (1+ fd) nil (alien:addr write-fds) nil 0 0)
1589 ;; Return true when ready for output or there is an
1590 ;; error other than an interrupt.
1591 (and (not (eql value 0))
1592 (or value (not (eql err unix:eintr))))))))
1593
1594 (ecase direction
1595 (:input
1596 (or (fd-usable-for-input)
1597 ;; Wait until input possible.
1598 (sys:with-fd-handler (fd :input
1599 #'(lambda (fd)
1600 (declare (ignore fd)
1601 (optimize (speed 3)
1602 (safety 0)))
1603 (mp:process-yield)))
1604 (if timeout
1605 (mp:process-wait-with-timeout "Input Wait" timeout
1606 #'fd-usable-for-input)
1607 (mp:process-wait "Input Wait" #'fd-usable-for-input)))))
1608 (:output
1609 (or (fd-usable-for-output)
1610 ;; Wait until output possible.
1611 (sys:with-fd-handler (fd :output
1612 #'(lambda (fd)
1613 (declare (ignore fd)
1614 (optimize (speed 3)
1615 (safety 0)))
1616 (mp:process-yield)))
1617 (if timeout
1618 (mp:process-wait-with-timeout "Output Wait" timeout
1619 #'fd-usable-for-output)
1620 (mp:process-wait "Output Wait"
1621 #'fd-usable-for-output)))))))))
1622
1623
1624 ;;; Sleep -- Public
1625 ;;;
1626 ;;; Redefine the sleep function to call process-wait-with-timeout,
1627 ;;; rather than blocking.
1628 ;;;
1629 (defun sleep (n)
1630 "This function causes execution to be suspended for N seconds. N may
1631 be any non-negative, non-complex number."
1632 (when (or (not (realp n))
1633 (minusp n))
1634 (error "Invalid argument to SLEEP: ~S.~%~
1635 Must be a non-negative, non-complex number."
1636 n))
1637 (cond ((or (eq *current-process* *initial-process*)
1638 ;; Can't call process-wait if the scheduling is inhibited.
1639 *inhibit-scheduling*)
1640 ;; The initial-process may block.
1641 (multiple-value-bind (sec usec)
1642 (if (integerp n)
1643 (values n 0)
1644 (multiple-value-bind (sec frac)(truncate n)
1645 (values sec (truncate frac 1e-6))))
1646 (unix:unix-select 0 0 0 0 sec usec))
1647 nil)
1648 (t
1649 (process-wait-with-timeout "Sleep" n (constantly nil)))))
1650
1651
1652
1653 ;;; With-Timeout-Internal -- Internal
1654 ;;;
1655 (defun with-timeout-internal (timeout function timeout-function)
1656 (catch 'timer-interrupt
1657 (let* ((current-process mp:*current-process*)
1658 (timer-process (mp:make-process
1659 #'(lambda ()
1660 (sleep timeout)
1661 (mp:process-interrupt
1662 current-process
1663 #'(lambda () (throw 'timer-interrupt nil))))
1664 :name "Timeout timer")))
1665 (unwind-protect
1666 (return-from with-timeout-internal (funcall function))
1667 (mp:destroy-process timer-process))))
1668 (funcall timeout-function))
1669
1670 ;;; With-Timeout -- Public
1671 ;;;
1672 (defmacro with-timeout ((timeout &body timeout-forms) &body body)
1673 "Executes body and returns the values of the last form in body. However, if
1674 the execution takes longer than timeout seconds, abort it and evaluate
1675 timeout-forms, returning the values of last form."
1676 `(flet ((fn () . ,body)
1677 (tf () . ,timeout-forms))
1678 (with-timeout-internal ,timeout #'fn #'tf)))
1679
1680
1681 ;;; Show-Processes -- Public
1682 ;;;
1683 (defun show-processes (&optional verbose)
1684 "Show the all the processes, their whostate, and state. If the optional
1685 verbose argument is true then the run, real, and idle times are also
1686 shown."
1687 (fresh-line)
1688 (dolist (process *all-processes*)
1689 (when (eq process *current-process*)
1690 (format t "-> "))
1691 (format t "~s ~s ~a~%" process (process-whostate process)
1692 (process-state process))
1693 (when verbose
1694 (format t "~4TRun time: ~,3f; Real time: ~,3f; Idle time: ~,3f~%"
1695 (process-run-time process)
1696 (process-real-time process)
1697 (process-idle-time process)))))
1698
1699
1700 ;;; Top-Level -- Internal
1701 ;;;
1702 (defun top-level ()
1703 "Top-level READ-EVAL-PRINT loop for processes."
1704 (let ((* nil) (** nil) (*** nil)
1705 (- nil) (+ nil) (++ nil) (+++ nil)
1706 (/// nil) (// nil) (/ nil)
1707 (magic-eof-cookie (cons :eof nil)))
1708 (loop
1709 (with-simple-restart (abort "Return to Top-Level.")
1710 (catch 'lisp::top-level-catcher
1711 (unix:unix-sigsetmask 0)
1712 (let ((lisp::*in-top-level-catcher* t))
1713 (loop
1714 (sys:scrub-control-stack)
1715 (fresh-line)
1716 (princ (if (functionp ext:*prompt*)
1717 (funcall ext:*prompt*)
1718 ext:*prompt*))
1719 (force-output)
1720 (let ((form (read *standard-input* nil magic-eof-cookie)))
1721 (cond ((not (eq form magic-eof-cookie))
1722 (let ((results
1723 (multiple-value-list
1724 (ext:interactive-eval form))))
1725 (dolist (result results)
1726 (fresh-line)
1727 (prin1 result))))
1728 (t
1729 (throw '%end-of-the-process nil)))))))))))
1730
1731 ;;; Startup-Idle-and-Top-Level-Loops -- Internal
1732 ;;;
1733 (defun startup-idle-and-top-level-loops ()
1734 "Enter the idle loop, starting a new process to run the top level loop.
1735 The awaking of sleeping processes is timed better with the idle loop process
1736 running, and starting a new process for the top level loop supports a
1737 simultaneous interactive session. Such an initialisation will likely be the
1738 default when there is better MP debug support etc."
1739 (assert (eq *current-process* *initial-process*) ()
1740 "Only the *initial-process* is intended to run the idle loop")
1741 (init-multi-processing) ; Initialise in case MP had been shutdown.
1742 ;; Start a new Top Level loop.
1743 (make-process #'top-level :name "Top Level Loop")
1744 ;; Enter the idle loop.
1745 (idle-process-loop))
1746
1747 ;;; Start-Lisp-Connection-Listener
1748 ;;;
1749 ;;; Create a process to listen for connections on a TCP port and start
1750 ;;; a new top-level process for each connection.
1751 ;;;
1752 (defun start-lisp-connection-listener (&key (port 1025)
1753 (password (random (expt 2 24))))
1754 (declare (type (unsigned-byte 16) port))
1755 "Create a Lisp connection listener, listening on a TCP port for new
1756 connections and starting a new top-level loop for each. If a password
1757 is not given then one will be generated and reported. A search is
1758 performed for the first free port starting at the given port which
1759 defaults to 1025."
1760 (labels (;; The session top level read eval. loop.
1761 (start-top-level (fd)
1762 (let ((stream (sys:make-fd-stream fd :input t :output t)))
1763 (unwind-protect
1764 (let* ((*terminal-io* stream)
1765 (*standard-input*
1766 (make-synonym-stream '*terminal-io*))
1767 (*standard-output* *standard-input*)
1768 (*error-output* *standard-input*)
1769 (*debug-io* *standard-input*)
1770 (*query-io* *standard-input*)
1771 (*trace-output* *standard-input*))
1772 ;;
1773 (format t "Enter password: ")
1774 (finish-output)
1775 (let* ((*read-eval* nil)
1776 (read-password
1777 (handler-case
1778 (read)
1779 (error () (return-from start-top-level)))))
1780 (unless (equal read-password password)
1781 (return-from start-top-level)))
1782 (ext:print-herald)
1783 ;;
1784 (top-level))
1785 (handler-case
1786 (close stream)
1787 (error ())))))
1788 ;;
1789 ;; Turn internet address into string format
1790 (ip-address-string (address)
1791 (format nil "~D.~D.~D.~D"
1792 (ldb (byte 8 24) address)
1793 (ldb (byte 8 16) address)
1794 (ldb (byte 8 8) address)
1795 (ldb (byte 8 0) address)))
1796 ;;
1797 ;; The body of the connection listener.
1798 (listener ()
1799 (declare (optimize (speed 3)))
1800 (let ((fd nil))
1801 (unwind-protect
1802 (progn
1803 ;; Start the listener.
1804 (do ()
1805 (fd)
1806 (handler-case
1807 (setf fd (ext:create-inet-listener port))
1808 (error () (incf port))))
1809
1810 (setf (process-name *current-process*)
1811 (format nil "Lisp connection listener on port ~d"
1812 port))
1813
1814 (format t "~&;;; Started lisp connection listener on ~
1815 port ~d with password ~d~%"
1816 port password)
1817
1818 (loop
1819 ;; Wait for new connections.
1820 (process-wait-until-fd-usable fd :input)
1821 (multiple-value-bind (new-fd remote-host)
1822 (ext:accept-tcp-connection fd)
1823 (let ((host-entry (ext:lookup-host-entry
1824 remote-host)))
1825 (make-process
1826 #'(lambda ()
1827 (start-top-level new-fd))
1828 :name (format nil "Lisp session from ~A"
1829 (if host-entry
1830 (ext:host-entry-name host-entry)
1831 (ip-address-string
1832 remote-host))))))))
1833 ;; Close the listener stream.
1834 (when fd
1835 (unix:unix-close fd))))))
1836
1837 ;; Make the listening thread.
1838 (make-process #'listener)))
1839
1840 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1841 ;;;; Simple Locking.
1842
1843 ;;;
1844 (defstruct (lock
1845 (:constructor nil)
1846 (:print-function %print-lock))
1847 (name nil :type (or null simple-base-string))
1848 (process nil :type (or null process)))
1849
1850 (defstruct (recursive-lock
1851 (:include lock)
1852 (:constructor make-recursive-lock (&optional name))))
1853
1854 (defstruct (error-check-lock
1855 (:include lock)
1856 (:constructor make-error-check-lock (&optional name))))
1857
1858 (defun make-lock (&optional name &key (kind :recursive))
1859 (ecase kind
1860 (:recursive (make-recursive-lock name))
1861 (:error-check (make-error-check-lock name))))
1862
1863 (defun %print-lock (lock stream depth)
1864 (declare (type lock lock) (stream stream) (ignore depth))
1865 (print-unreadable-object (lock stream :identity t)
1866 (write-string (etypecase lock
1867 (recursive-lock "Recursive-lock")
1868 (error-check-lock "Error-Check-lock"))
1869 stream)
1870 (let ((name (lock-name lock)))
1871 (when name
1872 (format stream " ~a" name)))
1873 (let ((process (lock-process lock)))
1874 (cond (process
1875 (format stream ", held by ~s" process))
1876 (t
1877 (write-string ", free" stream))))))
1878
1879 ;;; Lock-Wait -- Internal
1880 ;;;
1881 ;;; Wait for the lock to be free and acquire it for the
1882 ;;; *current-process*.
1883 ;;;
1884 (defun lock-wait (lock whostate)
1885 (declare (type lock lock))
1886 (process-wait whostate
1887 #'(lambda ()
1888 (declare (optimize (speed 3)))
1889 #-i486
1890 (unless (lock-process lock)
1891 (setf (lock-process lock) *current-process*))
1892 #+i486
1893 (null (kernel:%instance-set-conditional
1894 lock 2 nil *current-process*)))))
1895
1896 ;;; Lock-Wait-With-Timeout -- Internal
1897 ;;;
1898 ;;; Wait with a timeout for the lock to be free and acquire it for the
1899 ;;; *current-process*.
1900 ;;;
1901 (defun lock-wait-with-timeout (lock whostate timeout)
1902 (declare (type lock lock))
1903 (process-wait-with-timeout
1904 whostate timeout
1905 #'(lambda ()
1906 (declare (optimize (speed 3)))
1907 #-i486
1908 (unless (lock-process lock)
1909 (setf (lock-process lock) *current-process*))
1910 #+i486
1911 (null (kernel:%instance-set-conditional
1912 lock 2 nil *current-process*)))))
1913
1914 ;;; Seize-lock -- Internal
1915 ;;;
1916 ;;; Atomically seize a lock if it's free.
1917 ;;;
1918 #-i486
1919 (defun seize-lock (lock)
1920 (declare (type lock lock)
1921 (optimize (speed 3)))
1922 (sys:without-interrupts
1923 (unless (lock-process lock)
1924 (setf (lock-process lock) *current-process*))))
1925
1926 ;;; With-Lock-Held -- Public
1927 ;;;
1928 (defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
1929 &key (wait t) timeout)
1930 &body body)
1931 "Execute the body with the lock held. If the lock is held by another
1932 process then the current process waits until the lock is released or
1933 an optional timeout is reached. The optional wait timeout is a time in
1934 seconds acceptable to process-wait-with-timeout. The results of the
1935 body are return upon success and NIL is return if the timeout is
1936 reached. When the wait key is NIL and the lock is held by another
1937 process then NIL is return immediately without processing the body."
1938 (let ((have-lock (gensym)))
1939 `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
1940 (unwind-protect
1941 ,(cond ((and timeout wait)
1942 `(progn
1943 (when (and (error-check-lock-p ,lock) ,have-lock)
1944 (error "Dead lock"))
1945 (when (or ,have-lock
1946 #+i486 (null (kernel:%instance-set-conditional
1947 ,lock 2 nil *current-process*))
1948 #-i486 (seize-lock ,lock)
1949 (if ,timeout
1950 (lock-wait-with-timeout
1951 ,lock ,whostate ,timeout)
1952 (lock-wait ,lock ,whostate)))
1953 ,@body)))
1954 (wait
1955 `(progn
1956 (when (and (error-check-lock-p ,lock) ,have-lock)
1957 (error "Dead lock"))
1958 (unless (or ,have-lock
1959 #+i486 (null (kernel:%instance-set-conditional
1960 ,lock 2 nil *current-process*))
1961 #-i486 (seize-lock ,lock))
1962 (lock-wait ,lock ,whostate))
1963 ,@body))
1964 (t
1965 `(when (or (and (recursive-lock-p ,lock) ,have-lock)
1966 #+i486 (null (kernel:%instance-set-conditional
1967 ,lock 2 nil *current-process*))
1968 #-i486 (seize-lock ,lock))
1969 ,@body)))
1970 (unless ,have-lock
1971 #+i486 (kernel:%instance-set-conditional
1972 ,lock 2 *current-process* nil)
1973 #-i486 (when (eq (lock-process ,lock) *current-process*)
1974 (setf (lock-process ,lock) nil)))))))

  ViewVC Help
Powered by ViewVC 1.1.5