Save "block-thread-events" flag in continuations. This guarantees

that it will be properly stored no matter where the continuation is
captured.

diff --git a/v7/src/runtime/contin.scm b/v7/src/runtime/contin.scm
index 636cd11c4c46facc91c61f04687de0f5a64cd65a..01c96d028659f881865c4187eb07fc684f7f8b67 100644 (file)
--- a/v7/src/runtime/contin.scm
+++ b/v7/src/runtime/contin.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: contin.scm,v 14.8 1999/01/02 06:11:34 cph Exp $
+$Id: contin.scm,v 14.9 1999/02/24 04:40:59 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -29,28 +29,29 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
           'REENTRANT
           receiver))
 
-;; The following is not properly tail recursive because it builds the
-;; extra frame that invokes cont on the result.
-;; This is done to guarantee that the continuation is still valid,
-;; since the continuation invocation code is the code that maintains
-;; this state.  Note that any other way of verifying this information
-;; would also add a continuation frame to the stack!
+;;; The following is not properly tail recursive because it builds the
+;;; extra frame that invokes cont on the result.  This is done to
+;;; guarantee that the continuation is still valid, since the
+;;; continuation invocation code is the code that maintains this
+;;; state.  Note that any other way of verifying this information
+;;; would also add a continuation frame to the stack!
 
 (define (non-reentrant-call-with-current-continuation receiver)
   (call/cc (ucode-primitive non-reentrant-call-with-current-continuation 1)
           'UNUSED
-          (lambda (cont)
-            (cont (receiver cont)))))
+          (lambda (cont) (cont (receiver cont)))))
 
 (define (call/cc primitive type receiver)
   (primitive
    (lambda (control-point)
      (let ((continuation
-           (make-continuation type control-point (get-dynamic-state))))
+           (make-continuation type
+                              control-point
+                              (get-dynamic-state)
+                              (get-thread-event-block))))
        (%%within-continuation
        continuation
-       (lambda ()
-         (receiver continuation)))))))
+       (lambda () (receiver continuation)))))))
 
 (define-integrable (%%within-continuation continuation thunk)
   ((ucode-primitive within-control-point 2)
@@ -60,21 +61,29 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (%within-continuation continuation thread-switch? thunk)
   (%%within-continuation
    continuation
-   (let ((dynamic-state (continuation/dynamic-state continuation)))
+   (let ((restore-state (state-restoration-procedure continuation)))
      (lambda ()
-       (set-dynamic-state! dynamic-state thread-switch?)
+       (restore-state thread-switch?)
        (thunk)))))
 
 (define (invocation-method/reentrant continuation value)
   (%%within-continuation
    continuation
-   (let ((dynamic-state (continuation/dynamic-state continuation)))
+   (let ((restore-state (state-restoration-procedure continuation)))
      (lambda ()
-       (set-dynamic-state! dynamic-state false)
+       (restore-state #f)
        value))))
 
-;; These two are correctly locked for multiprocessing, but not for
-;; multiprocessors.
+(define (state-restoration-procedure continuation)
+  (let ((dynamic-state (continuation/dynamic-state continuation))
+       (block-thread-events?
+        (continuation/block-thread-events? continuation)))
+    (lambda (thread-switch?)
+      (set-dynamic-state! dynamic-state thread-switch?)
+      (set-thread-event-block! block-thread-events?))))
+\f
+;;; These two are correctly locked for multiprocessing, but not for
+;;; multiprocessors.
 
 (define (within-continuation continuation thunk)
   (if (not (continuation? continuation))
@@ -84,14 +93,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        (lambda ()
         (let ((method (continuation/invocation-method continuation)))
           (if (eq? method invocation-method/reentrant)
-              true
+              #t
               (and (eq? method invocation-method/unused)
                    (begin
                      (set-continuation/invocation-method!
                       continuation
                       invocation-method/used)
-                     true))))))
-      (%within-continuation continuation false thunk)
+                     #t))))))
+      (%within-continuation continuation #f thunk)
       (error "Reentering used continuation" continuation)))
 
 (define (invocation-method/unused continuation value)
@@ -109,14 +118,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   value
   (error "Reentering used continuation" continuation))
 \f
-(define (make-continuation type control-point dynamic-state)
+(define (make-continuation type control-point dynamic-state
+                          block-thread-events?)
   (make-entity
    (case type
      ((REENTRANT) invocation-method/reentrant)
      ((UNUSED) invocation-method/unused)
      ((USED) invocation-method/used)
      (else (error "Illegal continuation type" type)))
-   (make-%continuation control-point dynamic-state)))
+   (make-%continuation control-point dynamic-state block-thread-events?)))
 
 (define (continuation/type continuation)
   (let ((invocation-method (continuation/invocation-method continuation)))
@@ -128,12 +138,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (continuation? object)
   (and (entity? object)
        (if (%continuation? (entity-extra object))
-          true
+          #t
           (continuation? (entity-procedure object)))))
 
 (define (guarantee-continuation continuation)
   (if (not (continuation? continuation))
-      (error:wrong-type-argument continuation "continuation" false))
+      (error:wrong-type-argument continuation "continuation" #f))
   continuation)
 
 (define-integrable (continuation/invocation-method continuation)
@@ -150,5 +160,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define-structure (%continuation (constructor make-%continuation)
                                 (conc-name %continuation/))
-  (control-point false read-only true)
-  (dynamic-state false read-only true))
\ No newline at end of file
+  (control-point #f read-only #t)
+  (dynamic-state #f read-only #t)
+  (block-thread-events? #f read-only #t))
\ No newline at end of file

diff --git a/v7/src/runtime/thread.scm b/v7/src/runtime/thread.scm
index 215b3e9bbe72e722e013b2842bc8910b4b91fb27..198f94dee6b36acb3699595b6bcbde87ef378478 100644 (file)
--- a/v7/src/runtime/thread.scm
+++ b/v7/src/runtime/thread.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: thread.scm,v 1.25 1999/02/23 21:31:46 cph Exp $
+$Id: thread.scm,v 1.26 1999/02/24 04:41:06 cph Exp $
 
 Copyright (c) 1991-1999 Massachusetts Institute of Technology
 
@@ -129,14 +129,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (call-with-current-continuation
    (lambda (return)
      (%within-continuation (or root-continuation root-continuation-default)
-                          true
+                          #t
        (lambda ()
         (fluid-let ((state-space:local (make-state-space)))
           (call-with-current-continuation
            (lambda (continuation)
              (let ((thread (make-thread continuation)))
                (%within-continuation (let ((k return)) (set! return #f) k)
-                                     true
+                                     #t
                                      (lambda () thread)))))
           (set-interrupt-enables! interrupt-mask/all)
           (exit-current-thread (thunk))))))))
@@ -202,7 +202,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (thread-not-running thread state)
   (set-thread/execution-state! thread state)
   (let ((thread* (thread/next thread)))
-    (set-thread/next! thread false)
+    (set-thread/next! thread #f)
     (set! first-running-thread thread*))
   (run-first-thread))
 
@@ -222,12 +222,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        (%resume-current-thread thread)))))
 
 (define (%resume-current-thread thread)
-  (if (thread/block-events? thread)
-      (%maybe-toggle-thread-timer)
-      (let ((event (handle-thread-events thread)))
-       (set-thread/block-events?! thread #f)
-       (%maybe-toggle-thread-timer)
-       (if (eq? #t event) #f event))))
+  (if (not (thread/block-events? thread))
+      (begin
+       (handle-thread-events thread)
+       (set-thread/block-events?! thread #f)))
+  (%maybe-toggle-thread-timer))
 
 (define (suspend-current-thread)
   (without-interrupts %suspend-current-thread))
@@ -238,18 +237,13 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
       (let ((block-events? (thread/block-events? thread)))
        (set-thread/block-events?! thread #f)
        (maybe-signal-input-thread-events)
-       (let ((event
-              (let ((event (handle-thread-events thread)))
-                (if (eq? #t event)
-                    (begin
-                      (set-thread/block-events?! thread #f)
-                      (call-with-current-continuation
-                       (lambda (continuation)
-                         (set-thread/continuation! thread continuation)
-                         (thread-not-running thread 'WAITING))))
-                    event))))
+       (let ((any-events? (handle-thread-events thread)))
          (set-thread/block-events?! thread block-events?)
-         event)))))
+         (if (not events?)
+             (call-with-current-continuation
+              (lambda (continuation)
+                (set-thread/continuation! thread continuation)
+                (thread-not-running thread 'WAITING)))))))))
 
 (define (stop-current-thread)
   (without-interrupts
@@ -314,7 +308,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        (call-with-current-continuation
         (lambda (continuation)
           (set-thread/continuation! thread continuation)
-          (set-thread/next! thread false)
+          (set-thread/next! thread #f)
           (set-thread/next! last-running-thread thread)
           (set! last-running-thread thread)
           (set! first-running-thread next)
@@ -636,7 +630,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
      (let ((thread first-running-thread))
        (if thread
           (let ((result (thread/block-events? thread)))
-            (set-thread/block-events?! thread true)
+            (set-thread/block-events?! thread #t)
             result)
           #f)))))
 
@@ -648,6 +642,22 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
         (handle-thread-events thread)
         (set-thread/block-events?! thread #f))))))
 
+(define (get-thread-event-block)
+  (without-interrupts
+   (lambda ()
+     (let ((thread first-running-thread))
+       (if thread
+          (thread/block-events? thread)
+          'NO-CURRENT-THREAD)))))
+
+(define (set-thread-event-block! block?)
+  (if (boolean? block?)
+      (without-interrupts
+       (lambda ()
+        (let ((thread first-running-thread))
+          (if thread
+              (set-thread/block-events? thread block?)))))))
+
 (define (signal-thread-event thread event)
   (guarantee-thread thread signal-thread-event)
   (let ((self first-running-thread))
@@ -671,21 +681,19 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (if (and (not (thread/block-events? thread))
           (eq? 'WAITING (thread/execution-state thread)))
       (%thread-running thread)))
-
+\f
 (define (handle-thread-events thread)
-  (let loop ((result #t))
+  (let loop ((any-events? #f))
     (let ((event (ring/dequeue (thread/pending-events thread) #t)))
       (if (eq? #t event)
-         result
+         any-events?
          (begin
            (if event
                (begin
-                 (set-thread/block-events?! thread true)
+                 (set-thread/block-events?! thread #t)
                  (event)
                  (set-interrupt-enables! interrupt-mask/gc-ok)))
-           (loop (if (or (eq? #f result) (eq? #t result))
-                     event
-                     result)))))))
+           (loop #t))))))
 
 (define (allow-thread-event-delivery)
   (without-interrupts
@@ -709,14 +717,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define-structure (timer-record
                   (conc-name timer-record/))
-  (time false read-only false)
+  (time #f read-only #t)
   thread
   event
   next)
 
 (define (register-timer-event interval event)
   (let ((time (+ (real-time-clock) interval)))
-    (let ((new-record (make-timer-record time (current-thread) event false)))
+    (let ((new-record (make-timer-record time (current-thread) event #f)))
       (without-interrupts
        (lambda ()
         (let loop ((record timer-records) (prev false))
@@ -800,7 +808,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (if (not (or (false? interval)
               (and (exact-integer? interval)
                    (> interval 0))))
-      (error:wrong-type-argument interval false 'SET-THREAD-TIMER-INTERVAL!))
+      (error:wrong-type-argument interval #f 'SET-THREAD-TIMER-INTERVAL!))
   (without-interrupts
     (lambda ()
       (set! timer-interval interval)
@@ -855,7 +863,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (if thread-timer-running?
       (begin
        ((ucode-primitive real-timer-clear))
-       (set! thread-timer-running? false)
+       (set! thread-timer-running? #f)
        ((ucode-primitive clear-interrupts!) interrupt-bit/timer))))
 \f
 ;;;; Mutexes
@@ -966,7 +974,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   item)
 
 (define (make-ring)
-  (let ((link (make-link false false false)))
+  (let ((link (make-link #f #f #f)))
     (set-link/prev! link link)
     (set-link/next! link link)
     link))