From: Chris Hanson Date: Wed, 24 Feb 1999 04:41:06 +0000 (+0000) Subject: Save "block-thread-events" flag in continuations. This guarantees X-Git-Tag: 20090517-FFI~4609 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=88d1cce1e4b61b896f25240cfa6d07b7a980322f;p=mit-scheme.git 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 636cd11c4..01c96d028 100644 --- 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?)))) + +;;; 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)) -(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 215b3e9bb..198f94dee 100644 --- 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))) - + (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)))) ;;;; 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))