From: Matt Birkholz Date: Sun, 12 Jul 2015 01:38:22 +0000 (-0700) Subject: debugging X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=refs%2Fheads%2FSMP-old;p=mit-scheme.git debugging --- diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 811069443..63db9d92a 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -918,6 +918,8 @@ USA. (parent (edwin)) (import (runtime primitive-io) channel-descriptor-for-select) + (import (runtime thread) + enable-smp?) (export (edwin) accept-process-output add-process-filter @@ -996,6 +998,8 @@ USA. terminal-raw-input terminal-raw-output terminal-set-state) + (import (runtime thread) + enable-smp?) (initialization (initialize-package!))))) (os-type-case @@ -1043,6 +1047,8 @@ USA. xterm-screen/set-name) (import (edwin process) register-process-output-events) + (import (runtime thread) + enable-smp?) (initialization (initialize-package!))) (define-package (edwin x-keys) diff --git a/src/edwin/process.scm b/src/edwin/process.scm index 228f109e4..6100dfd3b 100644 --- a/src/edwin/process.scm +++ b/src/edwin/process.scm @@ -164,6 +164,7 @@ Initialized from the SHELL environment variable." (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) @@ -228,10 +229,12 @@ Initialized from the SHELL environment variable." (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) @@ -243,6 +246,7 @@ Initialized from the SHELL environment variable." (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 @@ -251,11 +255,19 @@ Initialized from the SHELL environment variable." (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)))))) @@ -693,4 +705,22 @@ Prefix arg means replace the region with it." (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 diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm index f57b3dd3b..f526cf3c1 100644 --- a/src/edwin/tterm.scm +++ b/src/edwin/tterm.scm @@ -307,6 +307,7 @@ USA. (registrations)) (dynamic-wind (lambda () + (%trace "block-for-event: registering") (let ((thread (current-thread))) (set! registrations (cons @@ -314,10 +315,12 @@ USA. (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 @@ -326,9 +329,22 @@ USA. (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?) @@ -1247,4 +1263,22 @@ Note that the multiply factors are in tenths of characters. |# (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 diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm index c6454bc21..42b1e283e 100644 --- a/src/edwin/xterm.scm +++ b/src/edwin/xterm.scm @@ -496,7 +496,9 @@ USA. (guarantee-result))))))))))) (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?) @@ -542,11 +544,14 @@ USA. (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?) @@ -556,11 +561,13 @@ USA. (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 @@ -568,10 +575,12 @@ USA. (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 () @@ -581,22 +590,32 @@ USA. (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))))) @@ -613,6 +632,7 @@ USA. (loop))))))) (define (preview-event event queue) + (%trace "preview-event "event) (cond ((and signal-interrupts? (vector? event) (fix:= event-type:key-press (vector-ref event 0)) @@ -1403,4 +1423,22 @@ Otherwise, it is copied from the primary selection." 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 diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index e4068edd8..14b5d76a8 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -326,7 +326,7 @@ USA. (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))) @@ -336,7 +336,7 @@ USA. (%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))) @@ -493,7 +493,7 @@ USA. (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 @@ -504,7 +504,7 @@ USA. "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) @@ -592,8 +592,6 @@ USA. (define calloutback-stacks) -(define %trace? #f) - (define (reset-package!) (reset-alien-functions!) (reset-malloced-aliens!) @@ -609,23 +607,35 @@ USA. (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 diff --git a/src/runtime/gcnote.scm b/src/runtime/gcnote.scm index eb4f3b2bf..5b2972835 100644 --- a/src/runtime/gcnote.scm +++ b/src/runtime/gcnote.scm @@ -66,6 +66,7 @@ USA. (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 () @@ -77,6 +78,7 @@ USA. (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) @@ -112,12 +114,14 @@ USA. ;; 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)))) @@ -126,7 +130,8 @@ USA. (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)) @@ -227,4 +232,22 @@ USA. (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 diff --git a/src/runtime/io.scm b/src/runtime/io.scm index d8038206e..f56ae52dd 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -524,6 +524,7 @@ USA. (set-select-registry-length! registry #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) @@ -531,18 +532,24 @@ USA. 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) @@ -551,11 +558,13 @@ USA. (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) @@ -751,4 +760,40 @@ USA. (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 diff --git a/src/runtime/process.scm b/src/runtime/process.scm index 54b4408ba..5730dc66f 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -177,9 +177,11 @@ USA. (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) @@ -190,30 +192,40 @@ USA. (deregister-subprocess process (lambda () (remove-from-locked-gc-finalizer! - subprocess-finalizer process)))))))) + subprocess-finalizer process))))))) + (%trace "subprocess-delete "process" done")) (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) @@ -231,16 +243,19 @@ USA. (%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 @@ -279,6 +294,7 @@ USA. (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) @@ -289,14 +305,17 @@ USA. (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 @@ -305,6 +324,7 @@ USA. (delq! registration subprocess-registrations))))) (define (deregister-subprocess subprocess delete-subprocess!) + (%trace "deregister-subprocess "subprocess) (let ((error? (with-thread-lock (lambda () @@ -322,6 +342,7 @@ USA. (signal-condition error?)))) (define (deregister-subprocess-events thread) + (%trace "%deregister-subprocess-events "thread) (set! subprocess-registrations (filter! (lambda (registration) @@ -337,8 +358,10 @@ USA. (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 @@ -351,11 +374,13 @@ USA. (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) @@ -363,7 +388,8 @@ USA. (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)) @@ -460,4 +486,40 @@ USA. (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 diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 65c86f072..7d291a2c6 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -113,6 +113,7 @@ USA. (port/set-default-directory (cmdl/port cmdl) pathname)) (define (cmdl/start cmdl message) + (%trace "cmdl/start") (let ((port (cmdl/port cmdl))) (let ((thunk (lambda () @@ -133,44 +134,61 @@ USA. (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"))))))) (define (bind-abort-restart cmdl thunk) (call-with-current-continuation @@ -531,6 +549,7 @@ USA. repl))) (define (repl/start repl #!optional message) + (%trace "repl/start") (cmdl/start repl (make-repl-message repl (if (default-object? message) @@ -958,3 +977,21 @@ USA. (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 diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 94b234507..326073414 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2023,6 +2023,7 @@ USA. (import (runtime thread) %maybe-toggle-thread-timer %signal-thread-event + enable-smp? thread/execution-state with-thread-lock) (initialization (initialize-package!))) @@ -3323,7 +3324,8 @@ USA. 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!) @@ -3617,6 +3619,8 @@ USA. write-restarts) (export (runtime working-directory) cmdl/set-default-directory) + (import (runtime thread) + enable-smp?) (initialization (initialize-package!))) (define-package (runtime save/restore) @@ -3891,6 +3895,7 @@ USA. %handle-subprocess-status-change) (import (runtime thread) %signal-thread-event + enable-smp? subprocess-registrations subprocess-support-loaded? with-thread-lock) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 5854220fe..25306e195 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -284,6 +284,7 @@ USA. (set! subprocess-registrations '())) (define (threads-list) + (%trace "threads-list") (with-thread-lock (lambda () (map-over-population thread-population (lambda (thread) thread))))) @@ -293,6 +294,7 @@ USA. (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" @@ -310,13 +312,18 @@ USA. (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)))))))) @@ -381,6 +388,7 @@ USA. (%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)) @@ -392,6 +400,7 @@ USA. "%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) @@ -399,6 +408,7 @@ USA. (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 @@ -418,6 +428,7 @@ USA. (wait-for-io id))) (define (run-thread thread) + (%trace "run-thread "thread) (%assert-locked 'run-thread) (let ((continuation (thread/continuation thread)) (fp-env (thread/floating-point-environment thread))) @@ -429,6 +440,7 @@ USA. (%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)) @@ -439,21 +451,24 @@ USA. (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 @@ -467,6 +482,7 @@ USA. (thread-not-running id thread 'WAITING))))))) (define (stop-current-thread) + (%trace "stop-current-thread: "(%thread (%%id))) (call-with-current-continuation (lambda (continuation) (lock) @@ -477,6 +493,7 @@ USA. (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) @@ -506,23 +523,30 @@ USA. ;; 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) @@ -536,15 +560,18 @@ USA. (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) @@ -559,8 +586,10 @@ USA. (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) @@ -571,9 +600,11 @@ USA. (%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) @@ -589,16 +620,20 @@ USA. (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) @@ -657,34 +692,48 @@ USA. 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))) (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) @@ -715,10 +764,12 @@ USA. result)) (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)))) @@ -727,11 +778,14 @@ USA. (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) @@ -753,6 +807,7 @@ USA. 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)) @@ -768,6 +823,7 @@ USA. (%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 () @@ -776,6 +832,7 @@ USA. 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))) @@ -813,6 +870,7 @@ USA. (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)) @@ -846,6 +904,7 @@ USA. (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))) @@ -899,6 +958,7 @@ USA. (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 @@ -919,9 +979,12 @@ USA. 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!) @@ -941,6 +1004,7 @@ USA. (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)) @@ -990,13 +1054,18 @@ USA. (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)) @@ -1005,16 +1074,21 @@ USA. (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 @@ -1032,6 +1106,7 @@ USA. (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))) @@ -1054,7 +1129,9 @@ USA. (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)))) @@ -1065,6 +1142,7 @@ USA. (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))) @@ -1110,6 +1188,7 @@ USA. (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) @@ -1186,9 +1265,11 @@ USA. (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))) @@ -1197,8 +1278,10 @@ USA. ;; 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)) @@ -1208,8 +1291,14 @@ USA. (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) @@ -1516,6 +1605,30 @@ USA. (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)) "")