#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.29 1991/11/26 07:05:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.30 1992/02/25 22:54:36 cph Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(if hook
(fluid-let ((standard-error-hook false))
(hook condition))))
- (repl/start (push-repl 'INHERIT 'INHERIT condition '() "error>")))
+ (let ((thread (current-thread))
+ (owner (thread-mutex-owner (port/thread-mutex (nearest-cmdl/port)))))
+ (if (and owner (not (eq? thread owner)))
+ (begin
+ (signal-thread-event owner
+ (lambda ()
+ (unblock-thread-events)
+ (error:derived-thread thread condition)))
+ (suspend-current-thread))
+ (repl/start (push-repl 'INHERIT 'INHERIT condition '() "error>")))))
(define (standard-warning-handler condition)
(let ((hook standard-warning-hook))
(define condition-type:datum-out-of-range)
(define condition-type:derived-file-error)
(define condition-type:derived-port-error)
+(define condition-type:derived-thread-error)
(define condition-type:divide-by-zero)
(define condition-type:error)
(define condition-type:file-error)
(define condition-type:simple-condition)
(define condition-type:simple-error)
(define condition-type:simple-warning)
+(define condition-type:thread-error)
(define condition-type:unassigned-variable)
(define condition-type:unbound-variable)
(define condition-type:variable-error)
(define error:no-such-restart)
(define error:derived-file)
(define error:derived-port)
+(define error:derived-thread)
(define error:wrong-number-of-arguments)
(define error:wrong-type-argument)
(define error:wrong-type-datum)
(write-string "." port))))))
(set! condition-type:port-error (anonymous-error 'PORT-ERROR 'PORT))
(set! condition-type:file-error (anonymous-error 'FILE-ERROR 'FILENAME))
- (set! condition-type:cell-error (anonymous-error 'CELL-ERROR 'LOCATION)))
+ (set! condition-type:cell-error (anonymous-error 'CELL-ERROR 'LOCATION))
+ (set! condition-type:thread-error (anonymous-error 'THREAD-ERROR 'THREAD)))
(set! condition-type:derived-port-error
(make-condition-type 'DERIVED-PORT-ERROR condition-type:port-error
(lambda (condition port)
(write-string "The port " port)
(write (access-condition condition 'PORT) port)
- (write-string " received an error:" port)
+ (write-string " signalled an error:" port)
(newline port)
(write-condition-report (access-condition condition 'CONDITION)
port))))
(lambda (condition port)
(write-string "The file " port)
(write (access-condition condition 'FILENAME) port)
- (write-string " received an error:" port)
+ (write-string " signalled an error:" port)
(newline port)
(write-condition-report (access-condition condition 'CONDITION)
port))))
(%condition/restarts condition)
filename
condition)))))
+
+ (set! condition-type:derived-thread-error
+ (make-condition-type 'DERIVED-THREAD-ERROR condition-type:thread-error
+ '(CONDITION)
+ (lambda (condition port)
+ (write-string "The thread " port)
+ (write (access-condition condition 'THREAD) port)
+ (write-string " signalled an error:" port)
+ (newline port)
+ (write-condition-report (access-condition condition 'CONDITION)
+ port))))
+
+ (set! error:derived-thread
+ (let ((make-condition
+ (condition-constructor condition-type:derived-thread-error
+ '(THREAD CONDITION))))
+ (lambda (thread condition)
+ (guarantee-condition condition 'ERROR:DERIVED-THREAD)
+ (error (make-condition (%condition/continuation condition)
+ (%condition/restarts condition)
+ thread
+ condition)))))
\f
(set! condition-type:file-operation-error
(make-condition-type 'FILE-OPERATION-ERROR condition-type:file-error
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.9 1992/02/08 15:08:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.10 1992/02/25 22:55:20 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
(fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
(set! index:termination-vector
(fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES))
- (set! keyboard-thread false)
(set! hook/clean-input/flush-typeahead false)
(set! hook/clean-input/keep-typeahead false)
(set! hook/^B-interrupt false)
;;;; Keyboard Interrupts
(define keyboard-interrupt-vector)
-(define keyboard-thread)
(define hook/clean-input/flush-typeahead)
(define hook/clean-input/keep-typeahead)
(define hook/^B-interrupt)
(define hook/^U-interrupt)
(define hook/^X-interrupt)
-(define (keyboard-interrupt-thread)
- keyboard-thread)
-
-(define (set-keyboard-interrupt-thread! thread)
- (if (not (or (not thread) (thread? thread)))
- (error:wrong-type-argument thread
- "thread or #f"
- set-keyboard-interrupt-thread!))
- (set! keyboard-thread thread)
- unspecific)
-
(define (external-interrupt-handler interrupt-code interrupt-mask)
interrupt-code interrupt-mask
(clear-interrupts! interrupt-bit/kbd)
(define (^B-interrupt-handler char)
(if hook/^B-interrupt
(hook/^B-interrupt))
- (if (and (or (not hook/clean-input/keep-typeahead)
- (hook/clean-input/keep-typeahead char))
- keyboard-thread)
- (signal-thread-event keyboard-thread cmdl-interrupt/breakpoint)))
+ (signal-interrupt hook/clean-input/keep-typeahead
+ char
+ cmdl-interrupt/breakpoint))
(define (^G-interrupt-handler char)
(if hook/^G-interrupt
(hook/^G-interrupt))
- (if (and (or (not hook/clean-input/flush-typeahead)
- (hook/clean-input/flush-typeahead char))
- keyboard-thread)
- (signal-thread-event keyboard-thread cmdl-interrupt/abort-top-level)))
+ (signal-interrupt hook/clean-input/flush-typeahead
+ char
+ cmdl-interrupt/abort-top-level))
(define (^U-interrupt-handler char)
(if hook/^U-interrupt
(hook/^U-interrupt))
- (if (and (or (not hook/clean-input/flush-typeahead)
- (hook/clean-input/flush-typeahead char))
- keyboard-thread)
- (signal-thread-event keyboard-thread cmdl-interrupt/abort-previous)))
+ (signal-interrupt hook/clean-input/flush-typeahead
+ char
+ cmdl-interrupt/abort-previous))
(define (^X-interrupt-handler char)
(if hook/^X-interrupt
(hook/^X-interrupt))
- (if (and (or (not hook/clean-input/flush-typeahead)
- (hook/clean-input/flush-typeahead char))
- keyboard-thread)
- (signal-thread-event keyboard-thread cmdl-interrupt/abort-nearest)))
+ (signal-interrupt hook/clean-input/flush-typeahead
+ char
+ cmdl-interrupt/abort-nearest))
+
+(define (signal-interrupt hook/clean-input char interrupt)
+ (if (or (not hook/clean-input)
+ (hook/clean-input char))
+ (let ((thread (thread-mutex-owner (port/thread-mutex console-i/o-port))))
+ (if thread
+ (signal-thread-event thread interrupt)))))
\f
(define (install)
(without-interrupts
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.33 1992/02/08 15:08:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.34 1992/02/25 22:55:38 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
;; Condition System
(RUNTIME ERROR-HANDLER)
(RUNTIME MICROCODE-ERRORS)
+ ;; Threads
+ (RUNTIME THREAD)
;; I/O
(RUNTIME GENERIC-I/O-PORT)
(RUNTIME FILE-I/O-PORT)
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
(RUNTIME REP)
- (RUNTIME THREAD)
;; Debugging
(RUNTIME COMPILER-INFO)
(RUNTIME ADVICE)
)
(package/add-child! system-global-package 'USER user-initial-environment)
-(set-keyboard-interrupt-thread! (current-thread))
(start-thread-timer)
(initial-top-level-repl)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/port.scm,v 1.2 1991/11/26 07:06:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/port.scm,v 1.3 1992/02/25 22:55:53 cph Exp $
-Copyright (c) 1991 Massachusetts Institute of Technology
+Copyright (c) 1991-92 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define port-rtd
(make-record-type "port"
'(STATE
+ THREAD-MUTEX
OPERATION-NAMES
CUSTOM-OPERATIONS
;; input operations:
(define port? (record-predicate port-rtd))
(define port/state (record-accessor port-rtd 'STATE))
(define set-port/state! (record-updater port-rtd 'STATE))
+(define port/thread-mutex (record-accessor port-rtd 'THREAD-MUTEX))
(define port/operation-names (record-accessor port-rtd 'OPERATION-NAMES))
(define set-port/operation-names! (record-updater port-rtd 'OPERATION-NAMES))
(define port/custom-operations (record-accessor port-rtd 'CUSTOM-OPERATIONS))
(define make-port
(let ((constructor
- (record-constructor port-rtd
- '(STATE OPERATION-NAMES CUSTOM-OPERATIONS))))
+ (record-constructor
+ port-rtd
+ '(STATE THREAD-MUTEX OPERATION-NAMES CUSTOM-OPERATIONS))))
(lambda (operations state procedure-name input? output?)
(let ((port
(constructor state
+ (make-thread-mutex)
'()
(parse-operations-list operations procedure-name))))
(install-input-operations! port input?)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.23 1992/02/08 15:08:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.24 1992/02/25 22:56:08 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
((cmdl/driver cmdl) cmdl)))))))))))))
(if operation
(operation cmdl thunk)
- (thunk))))
+ (with-thread-mutex-locked (port/thread-mutex (cmdl/port cmdl))
+ thunk))))
(define *nearest-cmdl*)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.133 1992/02/08 15:08:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.134 1992/02/25 22:56:37 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
condition-type:datum-out-of-range
condition-type:derived-file-error
condition-type:derived-port-error
+ condition-type:derived-thread-error
condition-type:divide-by-zero
condition-type:error
condition-type:file-error
condition-type:simple-condition
condition-type:simple-error
condition-type:simple-warning
+ condition-type:thread-error
condition-type:unassigned-variable
condition-type:unbound-variable
condition-type:variable-error
error:datum-out-of-range
error:derived-file
error:derived-port
+ error:derived-thread
error:divide-by-zero
error:file-operation
error:no-such-restart
port/set-output-blocking-mode
port/set-output-terminal-mode
port/state
+ port/thread-mutex
port/with-input-blocking-mode
port/with-input-terminal-mode
port/with-output-blocking-mode
(define-package (runtime interrupt-handler)
(files "intrpt")
(parent ())
- (export ()
- keyboard-interrupt-thread
- set-keyboard-interrupt-thread!)
(export (runtime emacs-interface)
hook/^G-interrupt
hook/clean-input/flush-typeahead)
(parent ())
(export ()
block-thread-events
+ condition-type:thread-dead
condition-type:thread-deadlock
condition-type:thread-detached
- condition-type:thread-error
+ condition-type:thread-control-error
create-thread
current-thread
detach-thread
suspend-current-thread
thread-continuation
thread-dead?
+ thread-mutex-owner
thread-mutex?
thread-timer-interval
thread?
try-lock-thread-mutex
unblock-thread-events
unlock-thread-mutex
+ with-thread-mutex-locked
yield-current-thread)
(export (runtime interrupt-handler)
thread-timer-interrupt-handler)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/thread.scm,v 1.1 1992/02/08 15:32:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/thread.scm,v 1.2 1992/02/25 22:56:21 cph Exp $
Copyright (c) 1991-92 Massachusetts Institute of Technology
(waiting-threads (make-ring) read-only true)
(owner false))
+(define-integrable (guarantee-thread-mutex mutex procedure)
+ (declare (integrate-operator thread-mutex?))
+ (if (not (thread-mutex? mutex))
+ (error:wrong-type-argument mutex "thread-mutex" procedure)))
+
+(define (thread-mutex-owner mutex)
+ (guarantee-thread-mutex mutex thread-mutex-owner)
+ (thread-mutex/owner mutex))
+
(define (lock-thread-mutex mutex)
+ (guarantee-thread-mutex mutex lock-thread-mutex)
(without-interrupts
(lambda ()
(let ((thread (current-thread))
(signal-thread-deadlock thread "lock thread mutex"
lock-thread-mutex mutex))
(else
- (ring/enqueue (thread-mutex/waiting-threads mutex) thread)
- (do ()
- ((eq? thread (thread-mutex/owner mutex)))
- (suspend-current-thread))))))))
+ (%lock-thread-mutex mutex thread)))))))
+
+(define-integrable (%lock-thread-mutex mutex thread)
+ (ring/enqueue (thread-mutex/waiting-threads mutex) thread)
+ (do () ((eq? thread (thread-mutex/owner mutex)))
+ (suspend-current-thread)))
(define (try-lock-thread-mutex mutex)
+ (guarantee-thread-mutex mutex try-lock-thread-mutex)
(without-interrupts
(lambda ()
(and (not (thread-mutex/owner mutex))
true)))))
(define (unlock-thread-mutex mutex)
+ (guarantee-thread-mutex mutex unlock-thread-mutex)
(without-interrupts
(lambda ()
(if (not (eq? (thread-mutex/owner mutex) (current-thread)))
(error "Don't own mutex:" mutex))
- (let ((thread (ring/dequeue (thread-mutex/waiting-threads mutex) false)))
- (set-thread-mutex/owner! mutex thread)
- (if thread
- (signal-thread-event thread false))))))
+ (%unlock-thread-mutex mutex))))
+
+(define-integrable (%unlock-thread-mutex mutex)
+ (let ((thread (ring/dequeue (thread-mutex/waiting-threads mutex) false)))
+ (set-thread-mutex/owner! mutex thread)
+ (if thread
+ (signal-thread-event thread false))))
+
+(define (with-thread-mutex-locked mutex thunk)
+ (guarantee-thread-mutex mutex lock-thread-mutex)
+ (let ((thread (current-thread))
+ (grabbed-lock?))
+ (dynamic-wind
+ (lambda ()
+ (let ((owner (thread-mutex/owner mutex)))
+ (if (eq? owner thread)
+ (begin
+ (set! grabbed-lock? false)
+ unspecific)
+ (begin
+ (set! grabbed-lock? true)
+ (if owner
+ (%lock-thread-mutex mutex thread)
+ (set-thread-mutex/owner! mutex thread))))))
+ thunk
+ (lambda ()
+ (if (and grabbed-lock? (eq? (thread-mutex/owner mutex) thread))
+ (%unlock-thread-mutex mutex))))))
\f
;;;; Circular Rings
\f
;;;; Error Conditions
-(define condition-type:thread-error)
-(define thread-error/thread)
+(define condition-type:thread-control-error)
+(define thread-control-error/thread)
(define condition-type:thread-deadlock)
(define signal-thread-deadlock)
(define thread-deadlock/description)
(define thread-dead/verb)
(define (initialize-error-conditions!)
- (set! condition-type:thread-error
- (make-condition-type 'THREAD-ERROR condition-type:control-error
+ (set! condition-type:thread-control-error
+ (make-condition-type 'THREAD-CONTROL-ERROR condition-type:control-error
'(THREAD)
(lambda (condition port)
(write-string "Anonymous error associated with " port)
- (write (thread-error/thread condition) port)
+ (write (thread-control-error/thread condition) port)
(write-string "." port))))
- (set! thread-error/thread
- (condition-accessor condition-type:thread-error 'THREAD))
+ (set! thread-control-error/thread
+ (condition-accessor condition-type:thread-control-error 'THREAD))
(set! condition-type:thread-deadlock
- (make-condition-type 'THREAD-DEADLOCK condition-type:thread-error
+ (make-condition-type 'THREAD-DEADLOCK
+ condition-type:thread-control-error
'(DESCRIPTION OPERATOR OPERAND)
(lambda (condition port)
(write-string "Deadlock detected while trying to " port)
(condition-accessor condition-type:thread-deadlock 'OPERAND))
(set! condition-type:thread-detached
- (make-condition-type 'THREAD-DETACHED condition-type:thread-error '()
+ (make-condition-type 'THREAD-DETACHED
+ condition-type:thread-control-error
+ '()
(lambda (condition port)
(write-string "Attempt to join detached thread: " port)
- (write-string (thread-error/thread condition) port)
+ (write-string (thread-control-error/thread condition) port)
(write-string "." port))))
(set! signal-thread-detached
(condition-signaller condition-type:thread-detached
standard-error-handler))
(set! condition-type:thread-dead
- (make-condition-type 'THREAD-DEAD condition-type:thread-error
+ (make-condition-type 'THREAD-DEAD condition-type:thread-control-error
'(VERB OPERATOR OPERANDS)
(lambda (condition port)
(write-string "Unable to " port)
(write-string (thread-dead/verb condition) port)
(write-string " thread " port)
- (write-string (thread-error/thread condition) port)
+ (write-string (thread-control-error/thread condition) port)
(write-string "because it is dead." port))))
(set! signal-thread-dead
(let ((signaller
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.146 1992/02/08 15:08:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.147 1992/02/25 22:57:27 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
'()))
(add-system! microcode-system)
(add-event-receiver! event:after-restore snarf-microcode-version!)
- (add-identification! "Runtime" 14 146))
+ (add-identification! "Runtime" 14 147))
(define microcode-system)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.33 1992/02/08 15:08:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.34 1992/02/25 22:55:38 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
;; Condition System
(RUNTIME ERROR-HANDLER)
(RUNTIME MICROCODE-ERRORS)
+ ;; Threads
+ (RUNTIME THREAD)
;; I/O
(RUNTIME GENERIC-I/O-PORT)
(RUNTIME FILE-I/O-PORT)
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
(RUNTIME REP)
- (RUNTIME THREAD)
;; Debugging
(RUNTIME COMPILER-INFO)
(RUNTIME ADVICE)
)
(package/add-child! system-global-package 'USER user-initial-environment)
-(set-keyboard-interrupt-thread! (current-thread))
(start-thread-timer)
(initial-top-level-repl)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.133 1992/02/08 15:08:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.134 1992/02/25 22:56:37 cph Exp $
Copyright (c) 1988-92 Massachusetts Institute of Technology
condition-type:datum-out-of-range
condition-type:derived-file-error
condition-type:derived-port-error
+ condition-type:derived-thread-error
condition-type:divide-by-zero
condition-type:error
condition-type:file-error
condition-type:simple-condition
condition-type:simple-error
condition-type:simple-warning
+ condition-type:thread-error
condition-type:unassigned-variable
condition-type:unbound-variable
condition-type:variable-error
error:datum-out-of-range
error:derived-file
error:derived-port
+ error:derived-thread
error:divide-by-zero
error:file-operation
error:no-such-restart
port/set-output-blocking-mode
port/set-output-terminal-mode
port/state
+ port/thread-mutex
port/with-input-blocking-mode
port/with-input-terminal-mode
port/with-output-blocking-mode
(define-package (runtime interrupt-handler)
(files "intrpt")
(parent ())
- (export ()
- keyboard-interrupt-thread
- set-keyboard-interrupt-thread!)
(export (runtime emacs-interface)
hook/^G-interrupt
hook/clean-input/flush-typeahead)
(parent ())
(export ()
block-thread-events
+ condition-type:thread-dead
condition-type:thread-deadlock
condition-type:thread-detached
- condition-type:thread-error
+ condition-type:thread-control-error
create-thread
current-thread
detach-thread
suspend-current-thread
thread-continuation
thread-dead?
+ thread-mutex-owner
thread-mutex?
thread-timer-interval
thread?
try-lock-thread-mutex
unblock-thread-events
unlock-thread-mutex
+ with-thread-mutex-locked
yield-current-thread)
(export (runtime interrupt-handler)
thread-timer-interrupt-handler)
projects / mit-scheme.git / commitdiff