Set interrupt-mask/all whenever leaving the thread system.

Punt saving and restoring interrupt masks.  Replacing without-
interrupts with without-interruption (with-thread-events-blocked)
makes interrupts moot.  They are now strictly a behind-the-scenes
system mechanism.

diff --git a/src/runtime/intrpt.scm b/src/runtime/intrpt.scm
index e28d5fe108f70cb2046918d34c3bfec62a3dfe8f..45d408e6a77819c30e8148093b4d83e5da8e330f 100644 (file)
--- a/src/runtime/intrpt.scm
+++ b/src/runtime/intrpt.scm
@@ -115,13 +115,20 @@ USA.
   args
   (abort->nearest "Aborting! Out of memory"))
 
-(define (after-gc-interrupt-handler interrupt-code interrupt-enables)
-  interrupt-code interrupt-enables
-  (trigger-gc-daemons!)
-  ;; By clearing the interrupt after running the daemons we ignore an
-  ;; GC that occurs while we are running the daemons.  This helps
-  ;; prevent us from getting into a loop just running the daemons.
-  (clear-interrupts! interrupt-bit/after-gc))
+(define after-gc-interrupt-handler
+  (let ((running? #f))
+    (named-lambda (after-gc-interrupt-handler interrupt-code interrupt-enables)
+      (declare (ignore interrupt-code interrupt-enables))
+      (clear-interrupts! interrupt-bit/after-gc)
+      ;; By checking that this handler is not still running we ignore
+      ;; GCs that occur while we are running the daemons.  This helps
+      ;; prevent us from getting into a loop just running the daemons.
+      (if running?
+         unspecific
+         (begin
+           (set! running? #t)
+           (trigger-gc-daemons!)
+           (set! running? #f))))))
 
 (define event:console-resize)
 (define (console-resize-handler interrupt-code interrupt-enables)

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 89786f0407b5686f4cb35df34066b3ca09a58c24..882e002804bd1dda64db7f771d688a3e4bae453d 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -42,35 +42,35 @@ USA.
 (define-integrable (interrupt-mask-ok?)
   (fix:= 0 (get-interrupt-enables)))
 
+(define-integrable (lock)
+  ;; (%assert (eq? interrupt-mask/all (get-interrupt-enables)) "lock: unexpected interrupt mask")
+  (%assert (not locked?) "lock: already locked!")
+  (set-interrupt-enables! interrupt-mask/in-threads)
+  (%lock))
+
 (define (%lock)
-  (%assert (interrupt-mask-ok?) "%lock: wrong interrupt mask")
-  (%assert (not locked?) "%lock: already locked")
   (if enable-smp?
       (if (not (eq? #t ((ucode-primitive smp-lock-threads 1) #t)))
          (error "Could not lock the thread system.")))
   (set! locked? #t))
 
+(define-integrable (unlock)
+  (%assert (interrupt-mask-ok?) "unlock: wrong interrupt mask")
+  (%assert locked? "unlock: not locked")
+  (%unlock)
+  (set-interrupt-enables! interrupt-mask/all))
+
 (define (%unlock)
-  (%assert (interrupt-mask-ok?) "%unlock: wrong interrupt mask")
-  (%assert locked? "%unlock: not locked")
   (set! locked? #f)
   (if enable-smp?
       (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)))
-    (let ((value (thunk)))
-      (set-interrupt-enables! interrupt-mask)
-      value)))
-
 (define-integrable (with-thread-lock thunk)
-  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/in-threads)))
-    (%lock)
-    (let ((value (thunk)))
-      (%unlock)
-      (set-interrupt-enables! interrupt-mask)
-      value)))
+  (lock)
+  (let ((value (thunk)))
+    (unlock)
+    value))
 
 (define (with-obarray-lock thunk)
   ;; Serialize with myriad parts of the microcode that hack the
@@ -337,11 +337,10 @@ USA.
        (handle-thread-events thread)
        (%maybe-toggle-thread-timer)
        (set-thread/block-events?! thread #f)))
-  (%unlock))
+  (unlock))
 
 (define (suspend-current-thread)
-  (set-interrupt-enables! interrupt-mask/in-threads)
-  (%lock)
+  (lock)
   (%suspend-thread first-running-thread))
 
 (define (%suspend-thread thread)
@@ -354,7 +353,7 @@ USA.
       (if any-events?
          (begin
            (%maybe-toggle-thread-timer)
-           (%unlock))
+           (unlock))
          (call-with-current-continuation
           (lambda (continuation)
             (set-thread/continuation! thread continuation)
@@ -368,8 +367,7 @@ USA.
      (let ((thread first-running-thread))
        (set-thread/continuation! thread continuation)
        (maybe-save-thread-float-environment! thread)
-       (set-interrupt-enables! interrupt-mask/in-threads)
-       (%lock)
+       (lock)
        (thread-not-running thread 'STOPPED)))))
 
 (define (restart-thread thread discard-events? event)
@@ -379,19 +377,17 @@ USA.
             (prompt-for-confirmation
              "Restarting other thread; discard events in its queue")
             discard-events?)))
-    (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
-      (%lock)
-      (if (not (eq? 'STOPPED (thread/execution-state thread)))
-         (begin
-           (%unlock)
-           (set-interrupt-enables! mask)
-           (error:bad-range-argument thread restart-thread))
-         (begin
-           (if discard-events?
-               (ring/discard-all (thread/pending-events thread)))
-           (if event
-               (%signal-thread-event thread event))
-           (thread-running thread))))))
+    (lock)
+    (if (not (eq? 'STOPPED (thread/execution-state thread)))
+       (begin
+         (unlock)
+         (error:bad-range-argument thread restart-thread))
+       (begin
+         (if discard-events?
+             (ring/discard-all (thread/pending-events thread)))
+         (if event
+             (%signal-thread-event thread event))
+         (thread-running thread)))))
 \f
 (define (disallow-preempt-current-thread)
   (set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION))
@@ -411,7 +407,7 @@ USA.
     (let ((thread first-running-thread))
       (cond ((not thread)
             (%maybe-toggle-thread-timer)
-            (%unlock))
+            (unlock))
            ((thread/continuation thread)
             (run-thread thread))
            ((not (eq? 'RUNNING-WITHOUT-PREEMPTION
@@ -422,14 +418,12 @@ USA.
             (%resume-thread thread))))))
 
 (define (yield-current-thread)
-  (without-interrupts
-   (lambda ()
-     (%lock)
-     (let ((thread first-running-thread))
-       ;; Allow preemption now, since the current thread has
-       ;; volunteered to yield control.
-       (set-thread/execution-state! thread 'RUNNING)
-       (yield-thread thread)))))
+  (lock)
+  (let ((thread first-running-thread))
+    ;; Allow preemption now, since the current thread has
+    ;; volunteered to yield control.
+    (set-thread/execution-state! thread 'RUNNING)
+    (yield-thread thread)))
 
 (define (yield-thread thread #!optional fp-env)
   (%assert-locked 'yield-thread)
@@ -459,8 +453,7 @@ USA.
   (let ((thread (current-thread)))
     (set-thread/block-events?! thread #t)
     (dynamic-unwind thread (thread/root-dynamic-state thread))
-    (set-interrupt-enables! interrupt-mask/in-threads)
-    (%lock)
+    (lock)
     (ring/discard-all (thread/pending-events thread))
     (%deregister-io-thread-events thread)
     (%discard-thread-timer-records thread)
@@ -476,8 +469,8 @@ USA.
   (let ((self first-running-thread))
     (if (eq? thread self)
        (signal-thread-deadlock self "join thread" join-thread thread)
-       (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
-         (%lock)
+       (begin
+         (lock)
          (let ((value (thread/exit-value thread)))
            (cond ((eq? value no-exit-value-marker)
                   (set-thread/joined-threads!
@@ -487,15 +480,12 @@ USA.
                   (set-thread/joined-to!
                    self
                    (cons thread (thread/joined-to self)))
-                  (%unlock)
-                  (set-interrupt-enables! mask))
+                  (unlock))
                  ((eq? value detached-thread-marker)
-                  (%unlock)
-                  (set-interrupt-enables! mask)
+                  (unlock)
                   (signal-thread-detached thread))
                  (else
-                  (%unlock)
-                  (set-interrupt-enables! mask)
+                  (unlock)
                   (signal-thread-event
                    self
                    ;; Executed in the dynamic state of SELF, not THREAD(!).
@@ -503,17 +493,14 @@ USA.
 
 (define (detach-thread thread)
   (guarantee-thread thread 'DETACH-THREAD)
-  (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
-    (%lock)
-    (if (eq? (thread/exit-value thread) detached-thread-marker)
-       (begin
-         (%unlock)
-         (set-interrupt-enables! mask)
-         (signal-thread-detached thread))
-       (begin
-         (release-joined-threads thread detached-thread-marker)
-         (%unlock)
-         (set-interrupt-enables! mask))))
+  (lock)
+  (if (eq? (thread/exit-value thread) detached-thread-marker)
+      (begin
+       (unlock)
+       (signal-thread-detached thread))
+      (begin
+       (release-joined-threads thread detached-thread-marker)
+       (unlock)))
   thread)
 
 (define detached-thread-marker
@@ -582,11 +569,9 @@ USA.
        ((eq? 'PROCESS-STATUS-CHANGE result)
         (%handle-subprocess-status-change))
         ((eq? 'INTERRUPT result)
-        (%unlock)
-        (set-interrupt-enables! interrupt-mask/all)
+        (unlock)
         (handle-interrupts)
-        (set-interrupt-enables! interrupt-mask/in-threads)
-        (%lock))))
+        (lock))))
 
 (define (handle-interrupts)
   #t)
@@ -898,26 +883,25 @@ USA.
 \f
 (define (signal-thread-event thread event)
   (guarantee-thread thread 'SIGNAL-THREAD-EVENT)
-  (if (eq? thread first-running-thread)
-      (let ((block-events? (block-thread-events)))
-       (with-thread-lock
-        (lambda ()
-          (%add-pending-event thread event)))
-       (if (not block-events?)
-           (unblock-thread-events)))
-      (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
-       (%lock)
-       (if (eq? 'DEAD (thread/execution-state thread))
-           (begin
-             (%unlock)
-             (set-interrupt-enables! mask)
-             (signal-thread-dead thread "signal event to"
-                                 signal-thread-event thread event))
-           (begin
-             (%signal-thread-event thread event)
-             (%maybe-toggle-thread-timer)
-             (%unlock)
-             (set-interrupt-enables! mask))))))
+  (let ((self first-running-thread))
+    (if (eq? thread self)
+       (let ((block-events? (block-thread-events)))
+         (with-thread-lock
+          (lambda ()
+            (%add-pending-event thread event)))
+         (if (not block-events?)
+             (unblock-thread-events)))
+       (begin
+         (lock)
+         (if (eq? 'DEAD (thread/execution-state thread))
+             (begin
+               (unlock)
+               (signal-thread-dead thread "signal event to"
+                                   signal-thread-event thread event))
+             (begin
+               (%signal-thread-event thread event)
+               (%maybe-toggle-thread-timer)
+               (unlock)))))))
 
 (define (%signal-thread-event thread event)
   (%assert-locked '%signal-thread-event)
@@ -951,11 +935,9 @@ USA.
            (if event
                (let ((block? (thread/block-events? thread)))
                  (set-thread/block-events?! thread #t)
-                 (%unlock)
-                 (set-interrupt-enables! interrupt-mask/all)
+                 (unlock)
                  (event)
-                 (set-interrupt-enables! interrupt-mask/in-threads)
-                 (%lock)
+                 (lock)
                  (set-thread/block-events?! thread block?)))
            (loop #t))))))
 
@@ -1293,20 +1275,17 @@ USA.
 
 (define (lock-thread-mutex mutex)
   (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
-  (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
-    (%lock)
-    (let ((thread first-running-thread)
-         (owner (thread-mutex/owner mutex)))
-      (if (eq? owner thread)
-         (begin
-           (%unlock)
-           (set-interrupt-enables! mask)
-           (signal-thread-deadlock thread "lock thread mutex"
-                                   lock-thread-mutex mutex))
-         (begin
-           (%lock-thread-mutex mutex thread owner)
-           (%unlock)
-           (set-interrupt-enables! mask))))))
+  (lock)
+  (let ((thread first-running-thread)
+       (owner (thread-mutex/owner mutex)))
+    (if (eq? owner thread)
+       (begin
+         (unlock)
+         (signal-thread-deadlock thread "lock thread mutex"
+                                 lock-thread-mutex mutex))
+       (begin
+         (%lock-thread-mutex mutex thread owner)
+         (unlock)))))
 
 (define (%lock-thread-mutex mutex thread owner)
   (%assert-locked '%lock-thread-mutex)
@@ -1316,24 +1295,21 @@ USA.
        (ring/enqueue (thread-mutex/waiting-threads mutex) thread)
        (do () ((eq? thread (thread-mutex/owner mutex)))
          (%suspend-thread thread)
-         (%lock)))
+         (lock)))
       (set-thread-mutex/owner! mutex thread)))
 
 (define (unlock-thread-mutex mutex)
   (guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
-  (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
-    (%lock)
-    (let ((thread first-running-thread)
-         (owner (thread-mutex/owner mutex)))
-      (if (and owner (not (eq? owner thread)))
-         (begin
-           (%unlock)
-           (set-interrupt-enables! mask)
-           (error "Don't own mutex:" mutex))
-         (begin
-           (%unlock-thread-mutex mutex owner)
-           (%unlock)
-           (set-interrupt-enables! mask))))))
+  (lock)
+  (let ((thread first-running-thread)
+       (owner (thread-mutex/owner mutex)))
+    (if (and owner (not (eq? owner thread)))
+       (begin
+         (unlock)
+         (error "Don't own mutex:" mutex))
+       (begin
+         (%unlock-thread-mutex mutex owner)
+         (unlock)))))
 
 (define (%unlock-thread-mutex mutex owner)
   (%assert-locked '%unlock-thread-mutex)