From: Chris Hanson Date: Thu, 1 Jul 1993 22:19:24 +0000 (+0000) Subject: Added mechanism to stop threads and restart them. When a X-Git-Tag: 20090517-FFI~8222 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=21516f0acdb3fb14bcf9efc0a9f7f02e4cbc386a;p=mit-scheme.git Added mechanism to stop threads and restart them. When a derived-thread error is signalled, the signalling thread stops itself to allow debugging to occur. The debugger recognizes such stopped threads and restarts them appropriately when the user requests a continuation. Also changed the handling of the thread timer to vary the period of the timer in cases where the next desired timer event is longer than the default timer interval. --- diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index d3bab4948..79548f5b9 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: debug.scm,v 14.33 1993/03/16 22:13:00 gjr Exp $ +$Id: debug.scm,v 14.34 1993/07/01 22:19:19 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -64,6 +64,13 @@ MIT in each case. |# (lambda (port) (debugger-presentation port (lambda () + (let ((thread (dstate/other-thread dstate))) + (if thread + (begin + (write-string "This error occurred in another thread: " + port) + (write thread port) + (newline port)))) (let ((n (count-subproblems dstate))) (write-string "There " port) (write-string (if (= n 1) "is" "are") port) @@ -722,11 +729,7 @@ MIT in each case. |# (define (enter-subproblem dstate port subproblem) (let ((invalid-expression? (invalid-expression? (dstate/expression dstate))) - (environment (get-evaluation-environment dstate port)) - (return - (lambda (value) - (hook/debugger-before-return) - ((stack-frame->continuation subproblem) value)))) + (environment (get-evaluation-environment dstate port))) (let ((value (let ((expression (prompt-for-expression @@ -741,19 +744,47 @@ MIT in each case. |# (debug/scode-eval (dstate/expression dstate) environment) (debug/eval expression environment))))) - (if debugger:print-return-values? + (if (or (not debugger:print-return-values?) + (begin + (newline port) + (write-string "That evaluates to:" port) + (newline port) + (write value port) + (prompt-for-confirmation "Confirm" port))) (begin - (newline port) - (write-string "That evaluates to:" port) - (newline port) - (write value port) - (if (prompt-for-confirmation "Confirm" port) (return value))) - (return value))))) + (hook/debugger-before-return) + (let ((thread (dstate/other-thread dstate))) + (if (not thread) + ((stack-frame->continuation subproblem) value) + (begin + (restart-thread thread #t + (lambda () + ((stack-frame->continuation subproblem) value))) + (if (prompt-for-confirmation + "Thread restarted; exit debugger" + port) + (standard-exit-command dstate port)))))))))) + +(define (dstate/thread dstate) + (let ((condition (dstate/condition dstate))) + (and condition + (condition/derived-thread? condition) + (access-condition condition 'THREAD)))) + +(define (dstate/other-thread dstate) + (let ((thread + (let ((condition (dstate/condition dstate))) + (and condition + (condition/derived-thread? condition) + (access-condition condition 'THREAD))))) + (and thread + (not (eq? thread (current-thread))) + thread))) (define hook/debugger-before-return) (define (default/debugger-before-return) '()) - + (define *dstate*) (define *port*) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 8a1b42cb6..c9cedb7e3 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.33 1993/04/27 08:43:07 cph Exp $ +$Id: error.scm,v 14.34 1993/07/01 22:19:21 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -536,7 +536,7 @@ MIT in each case. |# (lambda () (unblock-thread-events) (error:derived-thread thread condition))) - (suspend-current-thread)) + (stop-current-thread)) (repl/start (push-repl 'INHERIT 'INHERIT condition '() "error>"))))) (define (standard-warning-handler condition) @@ -665,6 +665,8 @@ MIT in each case. |# (define error:wrong-type-argument) (define error:wrong-type-datum) +(define condition/derived-thread?) + (define (condition-type/error? type) (guarantee-condition-type type 'CONDITION-TYPE/ERROR?) (%condition-type/error? type)) @@ -866,7 +868,6 @@ MIT in each case. |# (newline port) (write-condition-report (access-condition condition 'CONDITION) port)))) - (set! error:derived-port (let ((make-condition (condition-constructor condition-type:derived-port-error @@ -888,7 +889,6 @@ MIT in each case. |# (newline port) (write-condition-report (access-condition condition 'CONDITION) port)))) - (set! error:derived-file (let ((make-condition (condition-constructor condition-type:derived-file-error @@ -910,7 +910,6 @@ MIT in each case. |# (newline port) (write-condition-report (access-condition condition 'CONDITION) port)))) - (set! error:derived-thread (let ((make-condition (condition-constructor condition-type:derived-thread-error @@ -921,6 +920,8 @@ MIT in each case. |# (%condition/restarts condition) thread condition))))) + (set! condition/derived-thread? + (condition-predicate condition-type:derived-thread-error)) (set! condition-type:file-operation-error (make-condition-type 'FILE-OPERATION-ERROR condition-type:file-error @@ -942,7 +943,6 @@ MIT in each case. |# (write-string "No such " port) (write-string noun port)))) (write-string "." port))))) - (set! error:file-operation (let ((get-verb (condition-accessor condition-type:file-operation-error 'VERB)) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 80f88cc5f..1facfa74d 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.181 1993/06/29 22:58:20 cph Exp $ +$Id: runtime.pkg,v 14.182 1993/07/01 22:19:23 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -585,6 +585,7 @@ MIT in each case. |# condition-type:wrong-type-datum condition-type? condition/continuation + condition/derived-thread? condition/error? condition/get condition/properties @@ -2468,14 +2469,15 @@ MIT in each case. |# permanently-register-input-thread-event register-input-thread-event register-timer-event + restart-thread set-thread-timer-interval! signal-thread-event sleep-current-thread start-thread-timer + stop-current-thread stop-thread-timer suspend-current-thread thread-continuation - thread-dead? thread-execution-state thread-mutex-owner thread-mutex? diff --git a/v7/src/runtime/thread.scm b/v7/src/runtime/thread.scm index 0837dfb01..88e0697d1 100644 --- a/v7/src/runtime/thread.scm +++ b/v7/src/runtime/thread.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: thread.scm,v 1.13 1993/04/28 22:31:46 hal Exp $ +$Id: thread.scm,v 1.14 1993/07/01 22:19:24 cph Exp $ Copyright (c) 1991-1993 Massachusetts Institute of Technology @@ -45,6 +45,7 @@ MIT in each case. |# ;; RUNNING ;; RUNNING-WITHOUT-PREEMPTION ;; WAITING + ;; STOPPED ;; DEAD (next #f) @@ -88,12 +89,6 @@ MIT in each case. |# (define no-exit-value-marker (list 'NO-EXIT-VALUE-MARKER)) - -(define-integrable (thread-waiting? thread) - (eq? 'WAITING (thread/execution-state thread))) - -(define-integrable (thread-dead? thread) - (eq? 'DEAD (thread/execution-state thread))) (define thread-population) (define first-running-thread) @@ -109,7 +104,6 @@ MIT in each case. |# (set! thread-timer-running? #f) (set! timer-records #f) (set! timer-interval 100) - (set! last-real-time #f) (initialize-input-blocking) (add-event-receiver! event:after-restore initialize-input-blocking) (detach-thread (make-thread #f)) @@ -178,7 +172,7 @@ MIT in each case. |# (guarantee-thread thread thread-continuation) (without-interrupts (lambda () - (and (thread-waiting? thread) + (and (eq? 'WAITING (thread/execution-state thread)) (thread/continuation thread))))) (define (thread-running thread) @@ -242,6 +236,25 @@ MIT in each case. |# (set-thread/block-events?! thread block-events?) event)))) +(define (stop-current-thread) + (without-interrupts + (lambda () + (let ((thread (current-thread))) + (call-with-current-continuation + (lambda (continuation) + (set-thread/continuation! thread continuation) + (thread-not-running thread 'STOPPED))))))) + +(define (restart-thread thread discard-events? event) + (guarantee-thread thread restart-thread) + (without-interrupts + (lambda () + (if (not (eq? 'STOPPED (thread/execution-state thread))) + (error:bad-range-argument thread restart-thread)) + (if discard-events? (ring/discard-all (thread/pending-events thread))) + (if event (%signal-thread-event thread event)) + (thread-running thread)))) + (define (disallow-preempt-current-thread) (set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION)) @@ -584,7 +597,7 @@ MIT in each case. |# (unblock-thread-events))) (without-interrupts (lambda () - (if (thread-dead? thread) + (if (eq? 'DEAD (thread/execution-state thread)) (signal-thread-dead thread "signal event to" signal-thread-event thread event)) (%signal-thread-event thread event) @@ -595,7 +608,7 @@ MIT in each case. |# (define (%signal-thread-event thread event) (ring/enqueue (thread/pending-events thread) event) (if (and (not (thread/block-events? thread)) - (thread-waiting? thread)) + (eq? 'WAITING (thread/execution-state thread))) (%thread-running thread))) (define (handle-thread-events thread) @@ -615,7 +628,6 @@ MIT in each case. |# ;;;; Timer Events -(define last-real-time) (define timer-records) (define timer-interval) @@ -653,35 +665,14 @@ MIT in each case. |# (define (deliver-timer-events) (let ((time (real-time-clock))) - (if (and last-real-time - (< time last-real-time)) - ;; The following adjustment is correct, assuming that the - ;; real-time timer wraps around to 0, and assuming that there - ;; has been no GC or OS time slice between the time when the - ;; timer interrupt was delivered and the time when REAL-TIME-CLOCK - ;; was called above. - (let ((wrap-value (+ last-real-time - (if (not timer-interval) - 0 - (- timer-interval time))))) - (let update ((record timer-records)) - (if record - (begin - (set-timer-record/time! - record - (- (timer-record/time record) wrap-value)) - (update (timer-record/next record))))))) - (set! last-real-time time) - (let loop ((record timer-records)) - (if (or (not record) (< time (timer-record/time record))) - (set! timer-records record) - (begin - (let ((thread (timer-record/thread record)) - (event (timer-record/event record))) - (set-timer-record/thread! record #f) - (set-timer-record/event! record #f) - (%signal-thread-event thread event)) - (loop (timer-record/next record)))))) + (do ((record timer-records (timer-record/next record))) + ((or (not record) (< time (timer-record/time record))) + (set! timer-records record)) + (let ((thread (timer-record/thread record)) + (event (timer-record/event record))) + (set-timer-record/thread! record #f) + (set-timer-record/event! record #f) + (%signal-thread-event thread event)))) unspecific) (define (deregister-timer-event registration) @@ -714,7 +705,7 @@ MIT in each case. |# (set! timer-records next)) (loop next prev)) (loop next record)))))) - + (define (thread-timer-interval) timer-interval) @@ -735,18 +726,28 @@ MIT in each case. |# (without-interrupts %stop-thread-timer)) (define (%maybe-toggle-thread-timer) - (if (and timer-interval - (or (let ((current-thread first-running-thread)) - (and current-thread - (or (thread/next current-thread) - input-registrations))) - (threads-pending-timer-events?))) - (if (not thread-timer-running?) - (begin - ((ucode-primitive real-timer-set) timer-interval timer-interval) - (set! thread-timer-running? true) - unspecific)) - (%stop-thread-timer))) + (let ((use-timer-interval? + (and timer-interval + (let ((current-thread first-running-thread)) + (and current-thread + (or (thread/next current-thread) + input-registrations)))))) + (if (or use-timer-interval? timer-records) + (begin + (let ((interval + (if use-timer-interval? + timer-interval + (let ((next-event-interval + (- (timer-record/time timer-records) + (real-time-clock)))) + (if (or (not timer-interval) + (> next-event-interval timer-interval)) + next-event-interval + timer-interval))))) + ((ucode-primitive real-timer-set) interval interval)) + (set! thread-timer-running? true) + unspecific) + (%stop-thread-timer)))) (define (%stop-thread-timer) (if thread-timer-running? diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 80f88cc5f..1facfa74d 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.181 1993/06/29 22:58:20 cph Exp $ +$Id: runtime.pkg,v 14.182 1993/07/01 22:19:23 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -585,6 +585,7 @@ MIT in each case. |# condition-type:wrong-type-datum condition-type? condition/continuation + condition/derived-thread? condition/error? condition/get condition/properties @@ -2468,14 +2469,15 @@ MIT in each case. |# permanently-register-input-thread-event register-input-thread-event register-timer-event + restart-thread set-thread-timer-interval! signal-thread-event sleep-current-thread start-thread-timer + stop-current-thread stop-thread-timer suspend-current-thread thread-continuation - thread-dead? thread-execution-state thread-mutex-owner thread-mutex?