#| -*-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
(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)
(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
(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)
'())
-
+\f
(define *dstate*)
(define *port*)
#| -*-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
(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)
(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))
(newline port)
(write-condition-report (access-condition condition 'CONDITION)
port))))
-
(set! error:derived-port
(let ((make-condition
(condition-constructor condition-type:derived-port-error
(newline port)
(write-condition-report (access-condition condition 'CONDITION)
port))))
-
(set! error:derived-file
(let ((make-condition
(condition-constructor condition-type:derived-file-error
(newline port)
(write-condition-report (access-condition condition 'CONDITION)
port))))
-
(set! error:derived-thread
(let ((make-condition
(condition-constructor condition-type:derived-thread-error
(%condition/restarts condition)
thread
condition)))))
+ (set! condition/derived-thread?
+ (condition-predicate condition-type:derived-thread-error))
\f
(set! condition-type:file-operation-error
(make-condition-type 'FILE-OPERATION-ERROR condition-type:file-error
(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))
#| -*-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
;; RUNNING
;; RUNNING-WITHOUT-PREEMPTION
;; WAITING
+ ;; STOPPED
;; DEAD
(next #f)
(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)))
\f
(define thread-population)
(define first-running-thread)
(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))
(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)
(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))))
+\f
(define (disallow-preempt-current-thread)
(set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION))
(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)
(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)
\f
;;;; Timer Events
-(define last-real-time)
(define timer-records)
(define timer-interval)
(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)
\f
(define (deregister-timer-event registration)
(set! timer-records next))
(loop next prev))
(loop next record))))))
-
+\f
(define (thread-timer-interval)
timer-interval)
(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?
projects / mit-scheme.git / commitdiff