[Openmcl-cvs-notifications] r15155 - in /trunk/source: level-1/l1-aprims.lisp level-1/l1-lisp-threads.lisp level-1/l1-processes.lisp lib/macros.lisp
gb at clozure.com
gb at clozure.com
Fri Dec 23 19:11:50 CST 2011
Author: gb
Date: Fri Dec 23 19:11:50 2011
New Revision: 15155
Log:
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.
Modified:
trunk/source/level-1/l1-aprims.lisp
trunk/source/level-1/l1-lisp-threads.lisp
trunk/source/level-1/l1-processes.lisp
trunk/source/lib/macros.lisp
Modified: trunk/source/level-1/l1-aprims.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-aprims.lisp (original)
+++ trunk/source/level-1/l1-aprims.lisp Fri Dec 23 19:11:50 2011
@@ -55,8 +55,6 @@
=
(def-standard-initial-binding *package*)
(def-standard-initial-binding *random-state* (initial-random-state))
-(def-standard-initial-binding *whostate* "Reset")
-(setq *whostate* "Reset")
(def-standard-initial-binding *error-print-length* 20)
(def-standard-initial-binding *error-print-level* 8)
=
Modified: trunk/source/level-1/l1-lisp-threads.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-lisp-threads.lisp (original)
+++ trunk/source/level-1/l1-lisp-threads.lisp Fri Dec 23 19:11:50 2011
@@ -1189,10 +1189,9 @@
(when (eql 0 (%fixnum-ref catch target::catch-frame.db-link))
(setf (%fixnum-ref catch target::catch-frame.db-link) bsp)))))
(let* ((thread (new-lisp-thread-from-tcr (%current-tcr) "foreign")))
- (setq *current-lisp-thread* thread
- *current-process*
- (make-process "foreign" :thread thread)
- *whostate* "Foreign thread callback")))
+ (setf *current-lisp-thread* thread
+ *current-process* (make-process "foreign" :thread thread)
+ (car (process-whostate-cell *current-process*)) "Foreign thread =
callback")))
=
;;; Remove the foreign thread's lisp-thread and lisp process from
;;; the global lists.
Modified: trunk/source/level-1/l1-processes.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-processes.lisp (original)
+++ trunk/source/level-1/l1-processes.lisp Fri Dec 23 19:11:50 2011
@@ -139,7 +139,9 @@
(dribble-stream :initform nil)
(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))
=
(defparameter *print-process-whostate* t "make it optional")
@@ -227,34 +229,10 @@
;;; here.
(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 '*whostat=
e*))
- (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))
=
=
=
@@ -378,8 +356,8 @@
(let* ((*current-process* process))
(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)
process))
@@ -418,7 +396,7 @@
(without-interrupts
(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)))
(when semaphore (signal-semaphore semaphore)))
Modified: trunk/source/lib/macros.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/lib/macros.lisp (original)
+++ trunk/source/lib/macros.lisp Fri Dec 23 19:11:50 2011
@@ -3240,8 +3240,15 @@
=
=
(defmacro with-process-whostate ((whostate) &body body)
- `(let* ((*whostate* ,whostate))
- , at body))
+ (let* ((cell (gensym))
+ (old (gensym)))
+ `(let* ((,cell (process-whostate-cell *current-process*))
+ (,old (car ,cell)))
+ (unwind-protect
+ (progn
+ (setf (car ,cell) ,whostate)
+ , at body)
+ (setf (car ,cell) ,old)))))
=
=
(defmacro with-read-lock ((lock) &body body)
More information about the Openmcl-cvs-notifications
mailing list