(parent (edwin))
(import (runtime primitive-io)
channel-descriptor-for-select)
+ (import (runtime thread)
+ enable-smp?)
(export (edwin)
accept-process-output
add-process-filter
terminal-raw-input
terminal-raw-output
terminal-set-state)
+ (import (runtime thread)
+ enable-smp?)
(initialization (initialize-package!)))))
(os-type-case
xterm-screen/set-name)
(import (edwin process)
register-process-output-events)
+ (import (runtime thread)
+ enable-smp?)
(initialization (initialize-package!)))
(define-package (edwin x-keys)
(register-subprocess-event
subprocess 'RUNNING (current-thread)
(named-lambda (edwin-process-status-event status)
+ (%trace "edwin-process status-event "status)
(set-process-pending-status! process status))))
(update-process-mark! process)
(subprocess-put! subprocess 'EDWIN-PROCESS process)
(list condition-type:port-error)
(lambda (condition) condition (k #f))
(lambda ()
+ ;;(%trace "process-output-available?: peek") ; The busy-spin makes this obnoxious.
(input-port/peek-char port)))))))
(loop (cdr processes))))))
(define (accept-process-output)
+ (%trace "accept-process-output")
(let loop ((processes edwin-processes)
(output? #f))
(if (pair? processes)
(define input-buffer (make-string 512))
(define (poll-process-for-output process)
+ (%trace "poll-process-for-output: "process)
(let ((port (subprocess-input-port (process-subprocess process))))
(and (port/open? port)
(let ((n
(bind-condition-handler (list condition-type:port-error)
(lambda (condition) condition (k #t))
(lambda ()
+ (%trace "poll-process-for-output: read")
(input-port/read-string! port input-buffer)))))))
+ (%trace "poll-process-for-output: read "n" octets")
(if (or (not (fixnum? n))
(fix:= n 0))
- (close-port port)
- (output-substring process input-buffer n))
+ (begin
+ (%trace "poll-process-for-output: closing "port)
+ (close-port port)
+ (%trace "poll-process-for-output: closed "port))
+ (begin
+ (%trace "poll-process-for-output: output "n" octets")
+ (output-substring process input-buffer n)))
+ (%trace "poll-process-for-output: returning "(and(fixnum? n)(fix:> n 0)))
(and (fixnum? n)
(fix:> n 0))))))
\f
(apply run-synchronous-process
input-region output-mark directory pty?
(ref-variable shell-file-name)
- (os/form-shell-command command)))
\ No newline at end of file
+ (os/form-shell-command command)))
+
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+(define (%outf-error . msg)
+ (apply outf-error `(";",(if enable-smp?
+ (number->string ((ucode-primitive smp-id 0)))
+ "")
+ " ",@msg"\n")))
\ No newline at end of file
(registrations))
(dynamic-wind
(lambda ()
+ (%trace "block-for-event: registering")
(let ((thread (current-thread)))
(set! registrations
(cons
(channel-descriptor-for-select channel) 'READ
thread (lambda (mode)
mode
+ (%trace "block-for-event: console input")
(set! input-available? #t)))
(register-process-output-events
thread (lambda (mode)
mode
+ (%trace "block-for-event: process output")
(set! output-available? #t)))))))
(lambda ()
(with-thread-events-blocked
(not output-available?)
(not (process-status-changes?))
(not inferior-thread-changes?))
- (suspend-current-thread))))
+ (begin
+ (%trace "block-for-event: suspending")
+ (suspend-current-thread)
+ (%trace "block-for-event: awake to "
+ (cond (input-available?
+ "console")
+ (output-available?
+ "process output")
+ ((process-status-changes?)
+ "process status")
+ (inferior-thread-changes?
+ "inferior thread")
+ (else "nothing?")))))))
unspecific)
(lambda ()
+ (%trace "block-for-event: deregistering")
(for-each deregister-io-thread-event registrations)))))))
(values
(named-lambda (halt-update?)
(set-terminal-state/delete-line-cost! state delete-line-cost)
(set-terminal-state/delete-line-next-cost! state delete-line-next-cost)
(set-terminal-state/scroll-region-cost! state scroll-region-cost)
- (set-screen-size! screen x-size y-size)))))
\ No newline at end of file
+ (set-screen-size! screen x-size y-size)))))
+
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+(define (%outf-error . msg)
+ (apply outf-error `(";",(if enable-smp?
+ (number->string ((ucode-primitive smp-id 0)))
+ "")
+ " ",@msg"\n")))
\ No newline at end of file
(guarantee-result)))))))))))
\f
(define (read-event queue display block?)
+ ;;(%trace "read-event "block?) The busy-spin makes this obnoxious.
(preview-events display queue)
+ ;;(%trace "read-event previewed events") The busy-spin makes this obnoxious.
(let ((event
(if (queue-empty? queue)
(if (eq? 'IN-UPDATE block?)
(define (read-event-1 display block?)
;; Now consider other (non-X) events.
+ ;;(%trace "read-event-1 "block?) The busy-spin makes this obnoxious.
(if (eq? '#T block?)
(let loop ()
(let ((event (block-for-event display)))
(or event
- (loop))))
+ (begin
+ (%trace "block-for-event: retry")
+ (loop)))))
(cond (inferior-thread-changes?
event:inferior-thread-output)
((process-output-available?)
(else #f))))
(define (block-for-event display)
+ (%trace "block-for-event")
(let ((x-events-available? #f)
(output-available? #f)
(registrations))
(dynamic-wind
(lambda ()
+ (%trace "block-for-event: registering")
(let ((thread (current-thread)))
(set! registrations
(cons
(x-display-descriptor display) 'READ
thread (lambda (mode)
mode
+ (%trace "block-for-event: X input")
(set! x-events-available? #t)))
(register-process-output-events
thread (lambda (mode)
mode
+ (%trace "block-for-event: process output")
(set! output-available? #t)))))))
(lambda ()
(let loop ()
(not output-available?)
(not (process-status-changes?))
(not inferior-thread-changes?))
- (suspend-current-thread))))
+ (begin
+ (%trace "block-for-event: suspending")
+ (suspend-current-thread)
+ (%trace "block-for-event: awake")))))
(cond (x-events-available?
+ (%trace "block-for-event: X events available")
(let ((queue x-display-events))
(preview-events display queue)
+ (%trace "block-for-event previewed events")
(if (queue-empty? queue)
#f
(dequeue!/unsafe queue))))
((process-status-changes?)
+ (%trace "block-for-event: process status available")
event:process-status)
(output-available?
+ (%trace "block-for-event: process output available")
event:process-output)
(inferior-thread-changes?
+ (%trace "block-for-event: inferior thread available")
event:inferior-thread-output)
(else
+ (%trace "block-for-event: loop")
(loop)))))
(lambda ()
+ (%trace "block-for-event: deregistering")
(for-each deregister-io-thread-event registrations)
(set! registrations)))))
(loop)))))))
\f
(define (preview-event event queue)
+ (%trace "preview-event "event)
(cond ((and signal-interrupts?
(vector? event)
(fix:= event-type:key-press (vector-ref event 0))
with-x-interrupts-disabled))
(reset-x-display!)
(add-event-receiver! event:after-restore reset-x-display!)
- unspecific)
\ No newline at end of file
+ unspecific)
+
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+(define (%outf-error . msg)
+ (apply outf-error `(";",(if enable-smp?
+ (number->string ((ucode-primitive smp-id 0)))
+ "")
+ " ",@msg"\n")))
\ No newline at end of file
(let* ((id (processor-id))
(old-top (vector-ref calloutback-stacks id)))
(%if-tracing
- (outf-error ";"(tindent)"=> "alien-function" "args"\n")
+ (%outf-error (tindent id)"=> "alien-function" "args)
(vector-set! calloutback-stacks id
(cons (cons alien-function args) old-top)))
(let ((value (apply (ucode-primitive c-call -1) alien-function args)))
(%assert (eq? old-top (cdr (vector-ref calloutback-stacks id)))
"call-alien: freak stack "(vector-ref calloutback-stacks id))
(vector-set! calloutback-stacks id old-top)
- (outf-error ";"(tindent id)"<= "value"\n"))
+ (%outf-error (tindent id)"<= "value))
value)))
\f
(let* ((id (processor-id))
(old-top (vector-ref calloutback-stacks id)))
(%if-tracing
- (outf-error ";"(tindent id)"=>> "procedure" "args"\n")
+ (%outf-error (tindent id)"=>> "procedure" "args)
(vector-set! calloutback-stacks id (cons (cons procedure args) old-top)))
(let ((value (apply-callback-proc procedure args)))
(%if-tracing
"callback-handler: freak stack "
(vector-ref calloutback-stacks id))
(vector-set! calloutback-stacks id old-top)
- (outf-error ";"(tindent id)"<<= "value"\n"))
+ (%outf-error (tindent id)"<<= "value))
value))))
(define (apply-callback-proc procedure args)
(define calloutback-stacks)
-(define %trace? #f)
-
(define (reset-package!)
(reset-alien-functions!)
(reset-malloced-aliens!)
(add-gc-daemon! free-malloced-aliens)
unspecific)
-(define-syntax %if-tracing
- (syntax-rules ()
- ((_ BODY ...)
- (if %trace?
- (begin BODY ...)))))
-
(define-syntax %assert
(syntax-rules ()
((_ TEST MSG ...)
(if (not TEST)
(error "Failed assert:" MSG ...)))))
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
(define-syntax %trace
(syntax-rules ()
- ((_ MSG ...)
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+(define-syntax %if-tracing
+ (syntax-rules ()
+ ((_ BODY ...)
(if %trace?
- (outf-error MSG ...)))))
+ (begin BODY ...)))))
(define (tindent id)
- (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space))
\ No newline at end of file
+ (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space))
+
+(define (%outf-error . msg)
+ (apply outf-error `(";",(if enable-smp?
+ (number->string ((ucode-primitive smp-id 0)))
+ "")
+ " ",@msg"\n")))
\ No newline at end of file
(define gc-events-mutex (make-thread-mutex))
(define (register-gc-event event)
+ (%trace "register-gc-event "(current-thread))
(guarantee-procedure-of-arity event 1 'register-gc-event)
(with-thread-mutex-lock gc-events-mutex
(lambda ()
(set! gc-events (cons (weak-cons thread event) gc-events)))))))
(define (deregister-gc-event)
+ (%trace "deregister-gc-event "(current-thread))
(with-thread-mutex-lock gc-events-mutex
(lambda ()
(clean-gc-events)
;; and all other processors in the GC-WAIT state. It may interrupt
;; the procedures holding the gc-events-mutex, but it does not
;; modify the list.
+ (%trace "signal-gc-events "(current-thread))
(with-thread-lock
(lambda ()
(for-each
(lambda (entry)
(let ((thread (weak-car entry))
(event (weak-cdr entry)))
+ (%trace "signal-gc-events: signal "thread" with "event)
(if (and thread
event
(not (eq? 'DEAD (thread/execution-state thread))))
(abort-if-heap-low (gc-statistic/heap-left statistic))
(event statistic))))))
gc-events)
- (%maybe-toggle-thread-timer))))
+ (%maybe-toggle-thread-timer)
+ (%trace "signal-gc-events: done"))))
(define (weak-assq obj alist)
(let loop ((alist alist))
(gc-statistic/this-gc-end-clock statistic)
(gc-statistic/last-gc-end-clock statistic))
" real time; free: "
- (number->string (gc-statistic/heap-left statistic)))))
\ No newline at end of file
+ (number->string (gc-statistic/heap-left statistic)))))
+
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+(define (%outf-error . msg)
+ (apply outf-error `(";",(if enable-smp?
+ (number->string ((ucode-primitive smp-id 0)))
+ "")
+ " ",@msg"\n")))
\ No newline at end of file
(set-select-registry-length! registry #f))
\f
(define (test-for-io-on-channel channel mode #!optional block?)
+ (%trace "test-for-io-on-channel "channel" "mode" "block?)
(test-for-io-on-descriptor (channel-descriptor-for-select channel)
(if (default-object? block?)
(channel-blocking? channel)
mode))
(define (channel-has-input? channel)
+ (%trace "channel-has-input?")
(let loop ()
(let ((mode (test-select-descriptor (channel-descriptor-for-select channel)
'READ)))
(if (pair? mode)
- (or (eq? (car mode) 'READ)
- (eq? (car mode) 'READ/WRITE))
- (loop)))))
+ (begin
+ (%trace "channel-has-input? "(car mode)" "(cdr mode))
+ (or (eq? (car mode) 'READ)
+ (eq? (car mode) 'READ/WRITE)))
+ (begin
+ (%trace "channel-has-input? "mode)
+ (loop))))))
(define-integrable (channel-descriptor-for-select channel)
((ucode-primitive channel-descriptor 1) (channel-descriptor channel)))
(define (test-for-io-on-descriptor descriptor block? mode)
+ (%trace "test-for-io-on-descriptor "descriptor" "block?" "mode)
(or (let ((rmode (test-select-descriptor descriptor mode)))
(if (pair? rmode)
(simplify-select-registry-mode rmode)
(block-on-io-descriptor descriptor mode))))
(define (test-select-descriptor descriptor mode)
+ (%trace "test-select-descriptor "descriptor" "mode)
(let ((result
((ucode-primitive test-select-descriptor 3)
descriptor
#f
(encode-select-registry-mode mode))))
+ (%trace "test-select-descriptor "descriptor" "mode" => "result)
(cond ((>= result 0) (decode-select-registry-mode result))
((= result -1) 'INTERRUPT)
((= result -2)
(define (all-dld-handles)
(with-thread-mutex-lock dld-handles-mutex
(lambda ()
- (list-copy dld-handles))))
\ No newline at end of file
+ (list-copy dld-handles))))
+
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+(define (%outf-error . msg)
+ ((ucode-primitive outf-error 1)
+ (apply string-append `(";",(if enable-smp?
+ (number->string ((ucode-primitive smp-id 0)))
+ "")
+ " ",@(map %->string msg)"\n"))))
+
+(define (%->string object)
+ (cond ((string? object) object)
+ ((symbol? object) (symbol-name object))
+ ((number? object) (number->string object))
+ ((eq? object #f) "#f")
+ ((eq? object #t) "#t")
+ ((eq? object #!default) "#!default")
+ ;;((thread? object)
+ ;; The hash procedure now uses the thread system (will deadlock).
+ ;; (string-append "#[thread "(number->string (hash object))"]"))
+ (else
+ (string-append "#["(symbol-name
+ (microcode-type/code->name
+ ((ucode-primitive object-type 1) object)))
+ ;;" "(number->string (hash object))"]"
+ " 0x"(number->string (object-datum object) 16)"]"))))
\ No newline at end of file
(if (and (eq? ctty 'FOREGROUND)
(eq? (subprocess-status process) 'RUNNING))
(subprocess-continue-foreground process))
+ (%trace "make-subprocess "process" ("(subprocess-status process)")")
process))
(define (subprocess-delete process)
+ (%trace "subprocess-delete "process)
(if (subprocess-index process)
(begin
(poll-subprocess-status process)
(deregister-subprocess process
(lambda ()
(remove-from-locked-gc-finalizer!
- subprocess-finalizer process))))))))
+ subprocess-finalizer process)))))))
+ (%trace "subprocess-delete "process" done"))
\f
(define (subprocess-wait process)
+ (%trace "subprocess-wait "process)
(let ((result #f)
(registration))
(dynamic-wind
(lambda ()
+ (%trace "subprocess-wait registering")
(set! registration
(register-subprocess-event
process 'RUNNING (current-thread)
(named-lambda (subprocess-wait-event status)
+ (%trace "subprocess-wait event")
(set! result status)))))
(lambda ()
(let loop ()
(with-thread-events-blocked
(lambda ()
(if (eq? result '#f)
- (suspend-current-thread))
+ (begin
+ (%trace "subprocess-wait suspending")
+ (suspend-current-thread)
+ (%trace "subprocess-wait woke with "result)))
(if (eq? result 'RUNNING)
(set! result #f))))
(if (not result)
- (loop)
+ (begin
+ (%trace "subprocess-wait looping")
+ (loop))
result)))
(lambda ()
+ (%trace "subprocess-wait deregistering")
(deregister-subprocess-event registration)))))
(define (subprocess-continue-foreground process)
(%poll-subprocess-status process))))
(define (%poll-subprocess-status process)
+ (%trace "%poll-subprocess-status "process)
(let ((index (subprocess-index process)))
(if (and index ((ucode-primitive process-status-sync 1) index))
(begin
+ (%trace "%poll-subprocess-status "process" new status")
(set-subprocess-status!
process
(convert-subprocess-status
((ucode-primitive process-status 1) index)))
(set-subprocess-exit-reason!
process
- ((ucode-primitive process-reason 1) index))))))
+ ((ucode-primitive process-reason 1) index)))
+ (%trace "%poll-subprocess-status "process" no change"))))
(define (convert-subprocess-status status)
(case status
(error:wrong-type-argument object "subprocess" procedure)))
(define (register-subprocess-event subprocess status thread event)
+ (%trace "register-subprocess-event "subprocess" "status" "thread" "event)
(guarantee-subprocess subprocess 'register-subprocess-event)
(guarantee-thread thread 'register-subprocess-event)
(guarantee-procedure-of-arity event 1 'register-subprocess-event)
(set! subprocess-registrations
(cons registration subprocess-registrations))
(let ((current (subprocess-status subprocess)))
+ (%trace "register-subprocess-event: current status: "current)
(if (not (eq? status current))
(begin
+ (%trace "register-subprocess-event: immediately signaling "thread)
(%signal-thread-event
thread (and event (lambda () (event current))))
(set-subprocess-registration/status! registration current))))))
registration))
(define (deregister-subprocess-event registration)
+ (%trace "deregister-subprocess-event "registration)
(guarantee-subprocess-registration registration
'DEREGISTER-SUBPROCESS-EVENT)
(with-thread-lock
(delq! registration subprocess-registrations)))))
(define (deregister-subprocess subprocess delete-subprocess!)
+ (%trace "deregister-subprocess "subprocess)
(let ((error?
(with-thread-lock
(lambda ()
(signal-condition error?))))
(define (deregister-subprocess-events thread)
+ (%trace "%deregister-subprocess-events "thread)
(set! subprocess-registrations
(filter!
(lambda (registration)
(subprocess-list))))
(define (%handle-subprocess-status-change)
+ (%trace "%handle-subprocess-status-change")
(if ((ucode-primitive process-status-sync-all 0))
(begin
+ (%trace "%handle-subprocess-status-change: new status")
(for-each (lambda (weak)
(let ((subprocess (weak-car weak)))
(if subprocess
(old (subprocess-registration/status registration)))
(if (not (eq? status old))
(let ((event (subprocess-registration/event registration)))
+ (%trace "%handle-subprocess-status-change to "(subprocess-registration/thread registration))
(%signal-thread-event
(subprocess-registration/thread registration)
(and event (lambda () (event status))))
(set-subprocess-registration/status! registration
- status)))))
+ status))
+ (%trace-subs "%signal-subprocess-status-change NOT to "(subprocess-registration/thread registration)))))
subprocess-registrations)
(set! subprocess-registrations
(filter! (lambda (registration)
(subprocess-registration/status registration)))
(not (or (eq? status 'EXITED)
(eq? status 'SIGNALLED)))))
- subprocess-registrations)))))
+ subprocess-registrations)))
+ (%trace "%handle-subprocess-status-change: no change")))
(define-integrable subprocess-job-control-available?
(ucode-primitive os-job-control? 0))
(and (not (null? bindings))
(if (string-prefix? prefix (car bindings))
bindings
- (loop (cdr bindings)))))))
\ No newline at end of file
+ (loop (cdr bindings)))))))
+
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+(define (%outf-error . msg)
+ ((ucode-primitive outf-error 1)
+ (apply string-append `(";",(if enable-smp?
+ (number->string ((ucode-primitive smp-id 0)))
+ "")
+ " ",@(map %->string msg)"\n"))))
+
+(define (%->string object)
+ (cond ((string? object) object)
+ ((symbol? object) (symbol-name object))
+ ((number? object) (number->string object))
+ ((eq? object #f) "#f")
+ ((eq? object #t) "#t")
+ ((eq? object #!default) "#!default")
+ ;;((thread? object)
+ ;; The hash procedure now uses the thread system (will deadlock).
+ ;; (string-append "#[thread "(number->string (hash object))"]"))
+ (else
+ (string-append "#["(symbol-name
+ (microcode-type/code->name
+ ((ucode-primitive object-type 1) object)))
+ ;;" "(number->string (hash object))"]"
+ " 0x"(number->string (object-datum object) 16)"]"))))
\ No newline at end of file
(port/set-default-directory (cmdl/port cmdl) pathname))
\f
(define (cmdl/start cmdl message)
+ (%trace "cmdl/start")
(let ((port (cmdl/port cmdl)))
(let ((thunk
(lambda ()
(fluid *bound-restarts*)
'())
(lambda ()
+ (%trace "cmdl/start: start loop")
(let loop ((message message))
(loop
(bind-abort-restart cmdl
(lambda ()
+ (%trace "cmdl/start: abort-restart-bound")
(deregister-all-events)
(with-interrupt-mask interrupt-mask/all
(lambda (interrupt-mask)
interrupt-mask
+ (%trace "cmdl/start: unmasked")
(unblock-thread-events)
+ (%trace "cmdl/start: unblocked")
(ignore-errors
(lambda ()
- ((->cmdl-message message) cmdl)))
+ (%trace "cmdl/start: emit message")
+ ((->cmdl-message message) cmdl)
+ (%trace "cmdl/start: message emitted")))
(call-with-current-continuation
(lambda (continuation)
(with-create-thread-continuation continuation
(lambda ()
- ((cmdl/driver cmdl) cmdl)))))))))))))))
+ (%trace "cmdl/start: run driver")
+ ((cmdl/driver cmdl) cmdl)
+ (%trace "cmdl/start: driver done")))))))))))))))
(mutex (port/thread-mutex port)))
(let ((thread (current-thread))
(owner (thread-mutex-owner mutex)))
(cond ((and owner (not (eq? thread owner)))
+ (%trace "cmdl/start: start-non-owned")
(signal-thread-event owner
(let ((signaller
(or (cmdl/local-operation cmdl 'START-NON-OWNED)
(lambda (cmdl thread)
cmdl
+ (%outf-error "Non-owner thread can't start CMDL")
(error "Non-owner thread can't start CMDL:"
thread)))))
(lambda ()
+ (%trace "cmdl/start: start-non-owned event")
(unblock-thread-events)
- (signaller cmdl thread))))
+ (signaller cmdl thread)
+ (%trace "cmdl/start: start-non-owned event done"))))
+ (%trace "cmdl/start: stop-current-thread")
(stop-current-thread))
((let ((parent (cmdl/parent cmdl)))
(and parent
(cmdl/local-operation parent 'START-CHILD)))
- => (lambda (operation) (operation cmdl thunk)))
+ => (lambda (operation) (%trace "cmdl/start: start-child")
+ (operation cmdl thunk)
+ (%trace "cmdl/start: start-child done")))
(else
- (with-thread-mutex-locked mutex thunk)))))))
+ (%trace "cmdl/start: grab port mutex")
+ (with-thread-mutex-locked mutex thunk)
+ (%trace "cmdl/start: release port mutex")))))))
\f
(define (bind-abort-restart cmdl thunk)
(call-with-current-continuation
repl)))
\f
(define (repl/start repl #!optional message)
+ (%trace "repl/start")
(cmdl/start repl
(make-repl-message repl
(if (default-object? message)
(breakpoint/message condition)))
(define standard-breakpoint-hook)
+
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+(define (%outf-error . msg)
+ (apply outf-error `(";",(if enable-smp?
+ (number->string ((ucode-primitive smp-id 0)))
+ "")
+ " ",@msg"\n")))
\ No newline at end of file
(import (runtime thread)
%maybe-toggle-thread-timer
%signal-thread-event
+ enable-smp?
thread/execution-state
with-thread-lock)
(initialization (initialize-package!)))
remove-from-select-registry!
test-select-registry)
(import (runtime thread)
- deregister-io-descriptor)
+ deregister-io-descriptor
+ enable-smp?)
(import (runtime gc-finalizer)
with-gc-finalizer-lock
remove-from-locked-gc-finalizer!)
write-restarts)
(export (runtime working-directory)
cmdl/set-default-directory)
+ (import (runtime thread)
+ enable-smp?)
(initialization (initialize-package!)))
(define-package (runtime save/restore)
%handle-subprocess-status-change)
(import (runtime thread)
%signal-thread-event
+ enable-smp?
subprocess-registrations
subprocess-support-loaded?
with-thread-lock)
(set! subprocess-registrations '()))
(define (threads-list)
+ (%trace "threads-list")
(with-thread-lock
(lambda ()
(map-over-population thread-population (lambda (thread) thread)))))
(thread/execution-state thread))
(define (create-thread root-continuation thunk)
+ (%trace "create-thread")
(if (not (or (not root-continuation) (continuation? root-continuation)))
(error:wrong-type-argument root-continuation
"continuation or #f"
(set-thread/root-dynamic-state! thread
(continuation/dynamic-state
continuation))
+ (%trace "create-thread: locking")
(with-thread-lock
(lambda ()
+ (%trace "create-thread: adding "thread)
(add-to-population!/unsafe thread-population thread)
+ (%trace "create-thread: making "thread" runnable")
(thread-running thread)))
(%within-continuation (let ((k return)) (set! return #f) k)
#t
- (lambda () thread)))))
+ (lambda () (%trace "create-thread: returning "thread)
+ thread))))
+ (%trace "create-thread: running "thread))
(exit-current-thread
(with-create-thread-continuation root-continuation thunk))))))))
(%maybe-toggle-thread-timer))
(define (%thread-running thread)
+ (%trace "%thread-running "thread)
(%assert-locked '%thread-running)
(set-thread/execution-state! thread 'RUNNING)
(let ((prev last-runnable-thread))
"%thread-running: last-runnable-thread has a next"))
(define (thread-not-running id thread state)
+ (%trace "thread-not-running: stopping "thread" in state "state)
(%assert-locked 'thread-not-running)
(%assert (eq? thread (%thread id)) "thread-not-running: not current")
(set-thread/execution-state! thread state)
(run-first-thread id))
(define (run-first-thread id)
+ (%trace "run-first-thread")
(%assert-locked 'run-first-thread)
(%assert (not (%thread id)) "run-first-thread: still running a thread")
(if first-runnable-thread
(wait-for-io id)))
\f
(define (run-thread thread)
+ (%trace "run-thread "thread)
(%assert-locked 'run-thread)
(let ((continuation (thread/continuation thread))
(fp-env (thread/floating-point-environment thread)))
(%resume-thread thread)))))
(define (%resume-thread thread)
+ (%trace "%resume-thread "thread)
(%assert-locked '%resume-thread)
(%assert (eq? thread (%thread (%%id))) "%resume-thread: not current")
(if (not (thread/block-events? thread))
(unlock))
(define (suspend-current-thread)
+ (%trace "suspend-current-thread")
(lock)
(let* ((id (%id))
(thread (%thread id))
(block-events? (thread/block-events? thread)))
- ;;(%assert block-events? "suspend-current-thread: not blocking events!")
+ (%assert block-events? "suspend-current-thread: not blocking events!")
(%suspend-thread id thread)
(%assert (eq? block-events? (thread/block-events? thread))
"suspend-current-thread cleared block-events?!")))
(define (%suspend-thread id thread)
+ (%trace "%suspend-thread "thread)
(%assert-locked '%suspend-thread)
(let ((block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #f)
(maybe-signal-io-thread-events)
(let ((any-events? (handle-thread-events thread)))
+ (%trace "%suspend-thread "thread" "(if any-events? "punting" "proceeding"))
(set-thread/block-events?! thread block-events?)
(if any-events?
(begin
(thread-not-running id thread 'WAITING)))))))
(define (stop-current-thread)
+ (%trace "stop-current-thread: "(%thread (%%id)))
(call-with-current-continuation
(lambda (continuation)
(lock)
(thread-not-running id thread 'STOPPED)))))
(define (restart-thread thread discard-events? event)
+ (%trace "restart-thread "thread" "discard-events?" "event)
(guarantee-thread thread 'RESTART-THREAD)
(let ((discard-events?
(if (eq? discard-events? 'ASK)
;; Preserve the floating-point environment here to guarantee that the
;; thread timer won't raise or clear exceptions (particularly the
;; inexact result exception) that the interrupted thread cares about.
+ (%trace "thread-timer-interrupt in "(%thread (%%id)))
(let* ((id (%id))
(old (%thread id))
(fp-env (and old (enter-default-float-environment old))))
(%lock)
(set! next-scheduled-timeout #f)
(deliver-timer-events)
+ (%trace "thread-timer-interrupt checking for IO")
(maybe-signal-io-thread-events)
+ (%trace "thread-timer-interrupt checked for IO")
(cond ((not old)
+ (%trace "thread-timer: looking for work")
(run-first-thread id))
;; Else we interrupt a running thread (OLD).
((not first-runnable-thread)
+ (%trace "thread-timer: no other work")
(restore-float-environment-from-default fp-env)
(%resume-thread old))
((eq? 'RUNNING-WITHOUT-PREEMPTION (thread/execution-state old))
+ (%trace "thread-timer: ignoring other work")
(restore-float-environment-from-default fp-env)
(%resume-thread old))
(else
+ (%trace "thread-timer: yielding "old)
(yield-thread id old fp-env)))))
(define (yield-current-thread)
(yield-thread id thread)))
(define (yield-thread id thread #!optional fp-env)
+ (%trace "%yield-thread "id" "thread" "fp-env)
(%assert-locked 'yield-thread)
(%assert (eq? thread (%thread id)) "yield-thread: not current")
(if (not first-runnable-thread)
(begin
+ (%trace "%yield-thread: no runnable threads")
(if (not (default-object? fp-env))
(restore-float-environment-from-default fp-env))
(%resume-thread thread))
(call-with-current-continuation
(lambda (continuation)
+ (%trace "%yield-thread: yielding to "first-runnable-thread)
(set-thread/continuation! thread continuation)
(maybe-save-thread-float-environment! thread fp-env)
(%thread-running thread)
\f
(define (exit-current-thread value)
(let ((thread (current-thread)))
+ (%trace "exit-current-thread "thread" with "value)
(set-thread/block-events?! thread #t)
(dynamic-unwind thread (thread/root-dynamic-state thread))
+ (%trace "exit-current-thread unwound "thread)
(lock)
(ring/discard-all (thread/pending-events thread))
(%deregister-io-thread-events thread)
(%disassociate-thread-mutexes thread)
(if (eq? no-exit-value-marker (thread/exit-value thread))
(release-joined-threads thread value))
- (thread-not-running (%id) thread 'DEAD)))
+ (thread-not-running (%id) thread 'DEAD))
+ (%trace "exit-current-thread continued!"))
(define (join-thread thread event-constructor)
+ (%trace "join-thread "thread)
(guarantee-thread thread 'JOIN-THREAD)
(let ((self (current-thread)))
(if (eq? thread self)
(set-thread/joined-to!
self
(cons thread (thread/joined-to self)))
+ (%trace "join-thread "self" to "thread": queued")
(unlock))
((eq? value detached-thread-marker)
+ (%trace "join-thread "self" to "thread": detached")
(unlock)
(signal-thread-detached thread))
(else
+ (%trace "join-thread "self" to "thread": signal self")
(unlock)
(signal-thread-event
self
;; Executed in the dynamic state of SELF, not THREAD(!).
- (event-constructor thread value)))))))))
+ (event-constructor thread value))
+ (%trace "join-thread "self" to "thread": signaled self"))))))))
(define (detach-thread thread)
(guarantee-thread thread 'DETACH-THREAD)
next)
(define (wait-for-io id)
+ (%trace "wait-for-io: next timeout = "next-scheduled-timeout)
(%assert-locked 'wait-for-io)
(%assert (interrupt-mask-ok?) "wait-for-io: wrong interrupt mask")
(%assert (not (%thread id)) "wait-for-io: not idle")
(%maybe-toggle-thread-timer #f)
(let ((result (begin
(%unlock)
+ (%trace "wait-for-io: blocking for i/o")
(test-select-registry io-registry #t))))
+ (%trace "wait-for-io: woken")
(%lock)
+ (%trace "wait-for-io: signal-select-result")
(signal-select-result result)
(run-first-thread id)))
\f
(define (signal-select-result result)
(%assert-locked 'signal-select-result)
(cond ((vector? result)
+ (%trace "signal-select-result: signal IO events")
(signal-io-thread-events (vector-ref result 0)
(vector-ref result 1)
(vector-ref result 2)))
((eq? 'PROCESS-STATUS-CHANGE result)
+ (%trace "signal-select-result: process-status-change")
(%handle-subprocess-status-change))
((eq? 'INTERRUPT result)
+ (%trace "signal-select-result: interrupt")
(unlock)
(handle-interrupts)
- (lock))))
+ (lock)
+ (%trace "signal-select-result: interrupts handled"))
+ ((eq? #f result)
+ (%trace "signal-select-result: #f"))
+ (else
+ (%trace "signal-select-result: unknown result "result))))
(define (handle-interrupts)
+ (%trace " mischief managed")
#t)
(define (maybe-signal-io-thread-events)
+ (%trace "maybe-signal-io-thread-events")
(%assert-locked 'maybe-signal-io-thread-events)
(if (or io-registrations
subprocess-registrations)
result))
\f
(define (permanently-register-io-thread-event descriptor mode thread event)
+ (%trace "%permanently-register-io-thread-event "descriptor" "mode" "thread" "event)
(let ((stop? #f)
(registration #f))
(letrec ((handler
(named-lambda (permanent-io-event mode*)
+ (%trace "permanent-io-event "descriptor" "mode*" "stop?)
(if (not stop?)
(event mode*))
(if (not (or stop? (memq mode* '(ERROR HANGUP #F))))
(lambda ()
(deregister)
(if (not stop?)
- (set! registration
- (register-io-thread-event descriptor mode
- thread handler)))))
+ (begin
+ (set! registration
+ (register-io-thread-event descriptor mode
+ thread handler))
+ (%trace "permanent-io-event registration "registration)))))
(deregister
(lambda ()
+ (%trace "permanent-io-event deregister "registration)
(if registration
(begin
(deregister-io-thread-event registration)
registration))))
(define (deregister-io-thread-event registration)
+ (%trace "deregister-io-thread-event "registration)
(if (and (pair? registration)
(eq? (car registration) 'DEREGISTER-PERMANENT-IO-EVENT))
(with-thread-lock (cdr registration))
(%maybe-toggle-thread-timer))))
(define (deregister-io-descriptor-events descriptor mode)
+ (%trace "deregister-io-descriptor-events "descriptor" "mode)
(guarantee-select-mode mode 'DEREGISTER-IO-DESCRIPTOR-EVENTS)
(with-thread-lock
(lambda ()
unspecific)
((and (eqv? descriptor (dentry/descriptor dentry))
(eq? mode (dentry/mode dentry)))
+ (%trace "remove "descriptor" "mode" from io-registry")
(remove-from-select-registry! io-registry descriptor mode)
(let ((prev (dentry/prev dentry))
(next (dentry/next dentry)))
(and event
(lambda () (event #f))))
(tloop (tentry/next tentry)))))
+ (%trace "remove "(dentry/descriptor dentry)" "(dentry/mode dentry)"from io-registry")
(remove-from-select-registry! io-registry
(dentry/descriptor dentry)
(dentry/mode dentry))
(if io-registrations
(set-dentry/prev! io-registrations dentry))
(set! io-registrations dentry)
+ (%trace "add "descriptor" "mode" to io-registry")
(add-to-select-registry! io-registry descriptor mode)))
((and (eqv? descriptor (dentry/descriptor dentry))
(eq? mode (dentry/mode dentry)))
(if (fix:< i n)
(let ((descriptor (vector-ref vfd i))
(mode (vector-ref vmode i)))
+ (%trace "signal IO ready on "descriptor" "mode)
(let ((dentry
(search
descriptor
events)))
(delete-tentry! tentry)
(loop (fix:+ i 1) events))))))
- (do ((events events (cdr events)))
- ((not (pair? events)))
- (%signal-thread-event (caar events) (cdar events)))))))
+ (begin
+ (%trace "signal "(length events)" events")
+ (do ((events events (cdr events)))
+ ((not (pair? events)))
+ (%trace "signal " (caar events))
+ (%signal-thread-event (caar events) (cdar events))))))))
(define (delete-tentry! tentry)
(%assert-locked 'delete-tentry!)
(set-dentry/last-tentry! dentry prev))
(if (not (or prev next))
(begin
+ (%trace "remove "(dentry/descriptor dentry)" "(dentry/mode dentry))
(remove-from-select-registry! io-registry
(dentry/descriptor dentry)
(dentry/mode dentry))
(define (signal-thread-event thread event)
(guarantee-thread thread 'SIGNAL-THREAD-EVENT)
(let ((self (current-thread)))
+ (%trace "signal-thread-event to "thread" from "self": "event)
(if (eq? thread self)
(let ((block-events? (block-thread-events)))
+ (%trace "signal-thread-event to self: await queue")
(with-thread-lock
(lambda ()
(%add-pending-event thread event)))
+ (%trace "signal-thread-event to self: queued")
(if (not block-events?)
- (unblock-thread-events)))
+ (begin
+ (%trace "signal-thread-event to self: unblock")
+ (unblock-thread-events))))
(begin
(lock)
(if (eq? 'DEAD (thread/execution-state thread))
(signal-thread-dead thread "signal event to"
signal-thread-event thread event))
(begin
+ (%trace "signal-thread-event: %signal")
(%signal-thread-event thread event)
(%maybe-toggle-thread-timer)
+ (%trace "signal-thread-event: done")
(unlock)))))))
(define (%signal-thread-event thread event)
(%assert-locked '%signal-thread-event)
+ (%trace "%signal-thread-event "event" to "thread)
(%add-pending-event thread event)
(if (and (not (thread/block-events? thread))
(eq? 'WAITING (thread/execution-state thread)))
- (%thread-running thread)))
+ (begin
+ (%trace "%signal-thread-event make "thread" runnable")
+ (%thread-running thread))))
(define (%add-pending-event thread event)
;; PENDING-EVENTS has three states: (1) empty; (2) one #F event; or
(ring/enqueue ring event))))))
(define (handle-thread-events thread)
+ ;;(%trace "handle-thread-events for "thread) This will signal number->string unassigned during the cold load.
(%assert-locked 'handle-thread-events)
(let loop ((any-events? #f))
(let ((event (ring/dequeue (thread/pending-events thread) #t)))
(block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #f)
(deliver-timer-events)
+ (%trace "allow-thread-event-delivery checking for IO")
(maybe-signal-io-thread-events)
+ (%trace "allow-thread-event-delivery checked for IO")
(handle-thread-events thread)
(set-thread/block-events?! thread block-events?))
(%maybe-toggle-thread-timer))))
(define subprocess-support-loaded? #f)
(define (%deregister-subprocess-events thread)
+ (%trace-subs "%deregister-subprocess-events "thread)
(%assert-locked '%deregister-subprocess-events)
(if subprocess-support-loaded?
(deregister-subprocess-events thread)))
(define (deliver-timer-events)
(%assert-locked 'deliver-timer-events)
(let ((time (real-time-clock)))
+ (%trace "deliver-timer-events: time = "time)
(do ((record timer-records (timer-record/next record)))
((or (not record) (< time (timer-record/time record)))
(set! timer-records record)
(define (%maybe-toggle-thread-timer #!optional consider-non-timers?)
(%assert-locked '%maybe-toggle-thread-timer)
(let ((now (real-time-clock)))
+ (%trace-subs "%maybe-toggle-thread-timer "consider-non-timers?" time = "now)
(let ((start
(lambda (time)
(set! next-scheduled-timeout time)
+ (%trace-subs "%maybe-toggle-thread-timer: set to "(- time now))
((ucode-primitive real-timer-set) (- time now) 0))))
(cond (timer-records
(let ((next-event-time (timer-record/time timer-records)))
;; Instead signal the interrupt now. This is ugly
;; but much simpler than refactoring the scheduler
;; so that we can do the right thing here.
- ((ucode-primitive request-interrupts! 1)
- interrupt-bit/timer)
+ (begin
+ (%trace-subs "%maybe-toggle-thread-timer: requested")
+ ((ucode-primitive request-interrupts! 1)
+ interrupt-bit/timer))
(start
(if (and consider-non-timers? timer-interval)
(min next-event-time (+ now timer-interval))
(or io-registrations
subprocess-registrations
first-runnable-thread))
+ (let ((current (%thread (%%id))))
+ (cond (io-registrations (%trace-subs "%maybe-toggle-thread-timer: continue for IO"))
+ ((pair? subprocess-registrations) (%trace-subs "%maybe-toggle-thread-timer: continue for SIGCHLD"))
+ ((and current (thread/next current)) (%trace-subs "%maybe-toggle-thread-timer: continue for other running thread(s)"))
+ (else (%trace-subs "%maybe-toggle-thread-timer: continue for no reason"))))
(start (+ now timer-interval)))
(else
+ (%trace-subs "%maybe-toggle-thread-timer: stopped")
(%stop-thread-timer))))))
(define (%stop-thread-timer)
(if (not (interrupt-mask-ok?))
(%outf-error caller": wrong interrupt mask")))
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error . MSG)))))
+
+#;(define-syntax %trace-subs
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace-subs? #f)
+
+(define-syntax %trace-subs
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace-subs? (%outf-error . MSG)))))
+
(define (%outf-error . msg)
((ucode-primitive outf-error 1)
(apply string-append `(";",(if enable-smp? (number->string (%%id)) "")
projects / mit-scheme.git / commitdiff