Changeset 10220 for release

Timestamp:

Jul 27, 2008, 11:35:02 AM (16 years ago)

Author:

Gary Byers

Message:

Propagate recent changes from trunk:

l1-aprims.lisp: static value of *WHOSTATE* is "Reset".
l1-io.lisp: use stack-allocated temporary buffer in WRITE-PNAME.
l1-lisp-threads.lisp: in THREAD-ENABLE, default "wait" to 1 day.
l1-processes.lisp: PROCESS-WHOSTATE detects and handles static binding

of *WHOSTATE*. PROCESS-ENABLE waits for 1 day, which is effectively
infinite and avoids word-size issues.

Location:

release/1.2/source/level-1

Files:

• l1-aprims.lisp (modified) (1 diff)
• l1-io.lisp (modified) (4 diffs)
• l1-lisp-threads.lisp (modified) (1 diff)
• l1-processes.lisp (modified) (2 diffs)

release/1.2/source/level-1/l1-aprims.lisp

@@ -50 +50 @@
 (def-standard-initial-binding *lock-conses* (make-list 20)))
 (def-standard-initial-binding *whostate* "Reset")
-(setq *whostate* "Active")
+(setq *whostate* "Reset")
 (def-standard-initial-binding *error-print-length* 20)
 (def-standard-initial-binding *error-print-level* 8)

release/1.2/source/level-1/l1-io.lisp

@@ -986 +986 @@
 
 
-(defvar *pname-buffer* (%cons-pool "12345678901234567890"))
-
 (defun write-pname (name case stream)
   (declare (type simple-string name) (stream stream)
@@ -1023 +1021 @@
                            (return nil))
                          (setq sofar c-case))))))))
-        (declare (dynamic-extent slashify? single-case-p))
+        (declare (dynamic-extent #'slashify? #'single-case-p))
         (block alice
           (let ((len (length name))
@@ -1065 +1063 @@
             (let* ((outbuf-len (+ len len))
                    (outbuf-ptr -1)
-                   (pool *pname-buffer*)
-                   (outbuf (pool.data pool)))
-              (declare (fixnum outbuf-ptr) (simple-string outbuf))
-              (setf (pool.data pool) nil)   ; grab it.
-              (unless (and outbuf (>= (length outbuf) outbuf-len))
-                (setq outbuf (make-array outbuf-len :element-type 'character)))
+                   (outbuf (make-string outbuf-len)))
+              (declare (fixnum outbuf-ptr outbuf-len)
+                       (dynamic-extent outbuf)
+                       (simple-string outbuf))
               (dotimes (pos (the fixnum len))
                 (declare (type fixnum pos))
@@ -1085 +1081 @@
                     (setf (schar outbuf (incf outbuf-ptr)) #\\))
                   (setf (schar outbuf (incf outbuf-ptr)) char)))
-              (write-string outbuf stream :start  0 :end (1+ outbuf-ptr))
-              (setf (pool.data pool) outbuf)))))))
+              (write-string outbuf stream :start  0 :end (1+ outbuf-ptr))))))))
 
 #|

release/1.2/source/level-1/l1-lisp-threads.lisp

@@ -395 +395 @@
         (cons function args)))
 
-(defun thread-enable (thread termination-semaphore allocation-quantum &optional (timeout most-positive-fixnum))
+(defun thread-enable (thread termination-semaphore allocation-quantum &optional (timeout (* 60 60 24)))
   (let* ((tcr (or (lisp-thread.tcr thread) (new-tcr-for-thread thread))))
     (with-macptrs (s)

release/1.2/source/level-1/l1-processes.lisp

@@ -217 +217 @@
   (if (process-exhausted-p p)
     "Exhausted"
-    (symbol-value-in-process '*whostate* p)))
+    (let* ((loc nil))
+    (if (eq p *current-process*)
+      (setq loc (%tcr-binding-location (%current-tcr) '*whostate*))
+      (let* ((tcr (process-tcr p)))
+        (without-interrupts
+         (unwind-protect
+              (progn
+                (%suspend-tcr tcr)
+                (setq loc (%tcr-binding-location tcr '*whostate*)))
+           (%resume-tcr tcr)))))
+    (if loc
+      (%fixnum-ref loc)
+      (if (eq p *initial-process*)
+        "Active"
+        "Reset")))))
 
 (defun (setf process-whostate) (new p)
@@ -252 +266 @@
 
 
-(defun process-enable (p &optional (wait 1))
+(defun process-enable (p &optional (wait (* 60 60 24) wait-p))
   "Begin executing the initial function of a specified process."
   (setq p (require-type p 'process))
   (not-in-current-process p 'process-enable)
+  (when wait-p
+    (check-type wait (unsigned-byte 32)))
   (unless (car (process-initial-form p))
     (error "Process ~s has not been preset.  Use PROCESS-PRESET to preset the process." p))