Changeset 15155 for trunk/source/level-1/l1-processes.lisp

Timestamp:

Dec 24, 2011, 1:11:50 AM (8 years ago)

Author:

gb

Message:

Keep process-whostate in a (CONS) cell in a slot in the PROCESS
object, not in a thread-local binding (so that we don't have to
suspend a process to print it.)

WITH-PROCESS-WHOSTATE needs to access this slot once and RPLACA it a
couple of times and needs to use UNWIND-PROTECT.

File:

• trunk/source/level-1/l1-processes.lisp (modified) (4 diffs)

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

@@ -140 +140 @@
      (dribble-saved-terminal-io :initform nil)
      (result :initform (cons nil nil)
-             :reader process-result))
+             :reader process-result)
+     (whostate-cell :initform (list "Reset")
+                    :reader process-whostate-cell))
   (:primary-p t))
 
@@ -228 +230 @@
 (defun process-whostate (p)
   "Return a string which describes the status of a specified process."
-    (let* ((ip *initial-process*))
-      (cond ((eq p *current-process*)
-             (if (%tcr-binding-location (%current-tcr) '*whostate*)
-               *whostate*
-               (if (eq p ip)
-                 "Active"
-                 "Reset")))
-            (t
-             (without-interrupts
-              (with-lock-grabbed (*kernel-exception-lock*)
-               (with-lock-grabbed (*kernel-tcr-area-lock*)
-                 (let* ((tcr (process-tcr p)))
-                   (if tcr
-                     (unwind-protect
-                          (let* ((loc nil))
-                            (%suspend-tcr tcr)
-                            (setq loc (%tcr-binding-location tcr '*whostate*))
-                            (if loc
-                              (%fixnum-ref loc)
-                              (if (eq p ip)
-                                "Active"
-                                "Reset")))
-                       (%resume-tcr tcr))
-                     "Exhausted")))))))))
+  (car (process-whostate-cell p)))
 
 (defun (setf process-whostate) (new p)
-  (unless (process-exhausted-p p)
-    (setf (symbol-value-in-process '*whostate* p) new)))
+  (setf (car (process-whostate-cell p)) new))
 
 
@@ -379 +357 @@
             (add-to-all-processes process)
             (with-initial-bindings (process-initial-bindings process)
-              (setq *whostate* "Active")
-              (run-process-initial-form process initial-form))))
+              (with-process-whostate ("Active")
+                (run-process-initial-form process initial-form)))))
       process
       initial-form)
@@ -419 +397 @@
    (if (eq kill :shutdown)
      (progn
-       (setq *whostate* "Shutdown")
+       (setf (car (process-whostate-cell process)) "Shutdown")
        (add-to-shutdown-processes process)))
    (let* ((semaphore (process-termination-semaphore process)))