Check for no-current-thread. Lose condition-type.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 6b331db3bf57d63126664c00f97cc3f303817c4c..9ceeeb10161bc33ea573d2971306efd3ee3b042c 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5035,7 +5035,6 @@ USA.
   (export ()
          assert-thread-mutex-owned
          block-thread-events
-         condition-type:no-current-thread
          condition-type:thread-control-error
          condition-type:thread-dead
          condition-type:thread-deadlock

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 40356879b2444b00a5db5ab082f85ced6dbbfa16..a05a3acda9302b11b1176f3237d38283e6099801 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -46,7 +46,7 @@ USA.
   (%assert (interrupt-mask-ok?) "%lock: wrong interrupt mask")
   (%assert (not locked?) "%lock: already locked")
   (if enable-smp?
-      (if (not ((ucode-primitive smp-lock-threads 1) #t))
+      (if (not (eq? #t ((ucode-primitive smp-lock-threads 1) #t)))
          (error "Could not lock the thread system.")))
   (set! locked? #t))
 
@@ -55,8 +55,8 @@ USA.
   (%assert locked? "%unlock: not locked")
   (set! locked? #f)
   (if enable-smp?
-      (if (not ((ucode-primitive smp-lock-threads 1) #f))
-         (%assert #f "%unlock: failed"))))
+      (if (not (eq? #t ((ucode-primitive smp-lock-threads 1) #f)))
+         (%outf-error "%unlock: failed"))))
 
 (define-integrable (without-interrupts thunk)
   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/in-threads)))
@@ -76,12 +76,14 @@ USA.
   ;; Serialize with myriad parts of the microcode that hack the
   ;; obarray element of the fixed-objects vector.
   (if enable-smp?
-      (if ((ucode-primitive smp-lock-obarray 1) #t)
-         (let ((value (thunk)))
-           (if ((ucode-primitive smp-lock-obarray 1) #f)
-               value
-               (%assert "with-obarray-lock: unlock failed")))
-         (%assert "with-obarray-lock: lock failed"))
+      (without-interrupts
+       (lambda ()
+        (if (eq? #t ((ucode-primitive smp-lock-obarray 1) #t))
+            (let ((value (thunk)))
+              (if (eq? #t ((ucode-primitive smp-lock-obarray 1) #f))
+                  value
+                  (%outf-error "with-obarray-lock: unlock failed")))
+            (%outf-error "with-obarray-lock: lock failed"))))
       (without-interrupts thunk)))
 \f
 (define-structure (thread
@@ -263,25 +265,19 @@ USA.
 \f
 (define (current-thread)
   (or first-running-thread
-      (let ((thread (console-thread)))
-       (if thread
-           (call-with-current-continuation
-            (lambda (continuation)
-              (let ((condition
-                     (make-condition condition-type:no-current-thread
-                                     continuation '() '())))
-                (signal-thread-event thread
-                  (lambda ()
-                    (error condition)))))))
-       (%lock)
-       (run-first-thread))))
+      (begin
+       (%outf-error "current-thread: no current thread")
+       #f)))
 
 (define (call-with-current-thread return? procedure)
   (%assert (interrupt-mask-ok?)
           "call-with-current-thread: wrong interrupt mask")
   (let ((thread first-running-thread))
     (cond (thread (procedure thread))
-         ((not return?) (%lock) (run-first-thread)))))
+         ((not return?)
+          (%outf-error "call-with-current-thread: starting one up")
+          (%lock)
+          (run-first-thread)))))
 
 (define (console-thread)
   (thread-mutex-owner (port/thread-mutex console-i/o-port)))
@@ -372,6 +368,7 @@ USA.
             (thread-not-running thread 'WAITING)))))))
 
 (define (stop-current-thread)
+  (%assert first-running-thread "stop-current-thread: no current thread")
   (without-interrupts
    (lambda ()
      (call-with-current-thread #f
@@ -514,7 +511,7 @@ USA.
 
 (define (detach-thread thread)
   (guarantee-thread thread 'DETACH-THREAD)
-  (let ((mask (set-interrupt-enables! interrupts-mask/in-threads)))
+  (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
     (%lock)
     (if (eq? (thread/exit-value thread) detached-thread-marker)
        (begin
@@ -907,12 +904,15 @@ USA.
   (let ((thread first-running-thread))
     (if thread
        (thread/block-events? thread)
-       #f)))
+       (begin
+         (%outf-error "get-thread-event-block: no current thread")
+         #f))))
 
 (define (set-thread-event-block! block?)
   (let ((thread first-running-thread))
     (if thread
-       (set-thread/block-events?! thread block?)))
+       (set-thread/block-events?! thread block?)
+       (%outf-error "set-thread-event-block!: no current thread")))
   unspecific)
 \f
 (define (signal-thread-event thread event)
@@ -925,19 +925,22 @@ USA.
             (%add-pending-event thread event)))
          (if (not block-events?)
              (unblock-thread-events)))
-       (begin
+       (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
+         (%lock)
          (if (eq? 'DEAD (thread/execution-state thread))
-             (signal-thread-dead thread "signal event to"
-                                 signal-thread-event thread event))
-         (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
-           (%lock)
-           (%signal-thread-event thread event)
-           (if (and (not self) first-running-thread)
-               (run-thread first-running-thread)
-               (begin
-                 (%maybe-toggle-thread-timer)
-                 (%unlock)
-                 (set-interrupt-enables! mask))))))))
+             (begin
+               (%unlock)
+               (set-interrupt-enables! mask)
+               (signal-thread-dead thread "signal event to"
+                                   signal-thread-event thread event))
+             (begin
+               (%signal-thread-event thread event)
+               (if (and (not self) first-running-thread)
+                   (run-thread first-running-thread)
+                   (begin
+                     (%maybe-toggle-thread-timer)
+                     (%unlock)
+                     (set-interrupt-enables! mask)))))))))
 
 (define (%signal-thread-event thread event)
   (%assert-locked '%signal-thread-event)
@@ -1477,7 +1480,6 @@ USA.
 (define condition-type:thread-dead)
 (define signal-thread-dead)
 (define thread-dead/verb)
-(define condition-type:no-current-thread)
 
 (define (initialize-error-conditions!)
   (set! condition-type:thread-control-error
@@ -1543,12 +1545,6 @@ USA.
   (set! thread-dead/verb
        (condition-accessor condition-type:thread-dead 'VERB))
 
-  (set! condition-type:no-current-thread
-       (make-condition-type 'NO-CURRENT-THREAD condition-type:control-error
-           '()
-         (lambda (condition port)
-           condition
-           (write-string "No current thread!" port))))
   unspecific)
 
 #;(define-syntax %assert
@@ -1574,9 +1570,9 @@ USA.
 
 (define (%assert-locked* caller)
   (if (not locked?)
-      (%outf-error caller" not locked"))
+      (%outf-error caller": not locked"))
   (if (not (interrupt-mask-ok?))
-      (%outf-error caller" can be interrupted")))
+      (%outf-error caller": can be interrupted")))
 
 (define (%outf-error . msg)
   ((ucode-primitive outf-error 1)