diff --git a/sources/environment/dfmc/application/app-server.dylan b/sources/environment/dfmc/application/app-server.dylan index 0ead262287..18060530f5 100644 --- a/sources/environment/dfmc/application/app-server.dylan +++ b/sources/environment/dfmc/application/app-server.dylan @@ -58,6 +58,8 @@ define sealed class () slot application-stop-reason :: false-or() = #f; + sealed slot application-stop-reason-message :: false-or() = #f; + // phoward added the following slots slot application-tether-status :: = #"start"; diff --git a/sources/environment/dfmc/application/control-protocols.dylan b/sources/environment/dfmc/application/control-protocols.dylan index a374bece10..223561e9db 100644 --- a/sources/environment/dfmc/application/control-protocols.dylan +++ b/sources/environment/dfmc/application/control-protocols.dylan @@ -152,10 +152,11 @@ define method run-application else dll-project? & dll-wrap? & phase == #"end" end; - debug-target-message(target, $debug-level, - "Preparing %=: top? %=, dll? %=, dll-wrap? %=, phase %=", - prepare-for-interaction?, top-level?, - dll-project?, dll-wrap?, phase); + debug-target-message + (target, $debug-level, + "Preparing %=: for-interaction? %= top? %=, dll? %=, dll-wrap? %=, phase %=", + lib, prepare-for-interaction?, top-level?, + dll-project?, dll-wrap?, phase); if (prepare-for-interaction?) initialize-interactive-threads(application, thread); maybe-initialize-allocation-profiling(application) diff --git a/sources/environment/dfmc/application/stop-reason-handlers.dylan b/sources/environment/dfmc/application/stop-reason-handlers.dylan index c8d51a22c8..2b1fe951ed 100644 --- a/sources/environment/dfmc/application/stop-reason-handlers.dylan +++ b/sources/environment/dfmc/application/stop-reason-handlers.dylan @@ -410,6 +410,7 @@ define method note-application-thread-message let thread :: false-or() = stop-reason-thread-object(application, stop-reason); let message :: = compose-application-message(application, stop-reason); + application.application-stop-reason-message := message; invoke-application-callback (application, application-thread-message-callback, thread, message) @@ -437,13 +438,6 @@ end method note-application-process-finished; define constant $depth-indentation = 2; -define sealed method application-stop-reason-message - (application :: ) - => (message :: false-or()) - let stop-reason = application.application-stop-reason; - stop-reason & compose-application-message(application, stop-reason) -end method application-stop-reason-message; - define method compose-application-message (application :: , stop-reason :: ) => (message :: ) @@ -1044,6 +1038,7 @@ define function finish-debugging-transaction (application :: , stop-reason :: ) => () application.application-stop-reason := #f; + application.application-stop-reason-message := #f; application.application-just-initialized? := #f; application.application-reached-interaction-point? := #f; application.application-just-finished-execution? := #f; diff --git a/sources/environment/dfmc/application/thread-objects.dylan b/sources/environment/dfmc/application/thread-objects.dylan index ead69b408e..a87ad21fae 100644 --- a/sources/environment/dfmc/application/thread-objects.dylan +++ b/sources/environment/dfmc/application/thread-objects.dylan @@ -672,7 +672,10 @@ end method; define method initialize-interactive-threads (application :: , thread :: ) - => () + => () + assert(application.application-initialized-interactive-threads? == #f, + "the interactive threads should only be spawned once"); + // Spawn these three interactive threads after // library initialization is complete let target = application.application-target-app; diff --git a/sources/environment/protocols/project-objects.dylan b/sources/environment/protocols/project-objects.dylan index a789bafdeb..47fadc9b24 100644 --- a/sources/environment/protocols/project-objects.dylan +++ b/sources/environment/protocols/project-objects.dylan @@ -1224,7 +1224,7 @@ define method %find-environment-object end method %find-environment-object; define method find-environment-object - (project :: , id :: , + (project :: , id :: , #rest keys, #key, #all-keys) => (object :: false-or()) diff --git a/sources/environment/tests/dfmc/debugging.dylan b/sources/environment/tests/dfmc/debugging.dylan index 7cff185b58..4f93294aa2 100644 --- a/sources/environment/tests/dfmc/debugging.dylan +++ b/sources/environment/tests/dfmc/debugging.dylan @@ -13,6 +13,7 @@ define constant $debugging-module-id = make(, name: "dylan-test", library: $debugging-library-id); define variable *test-application-application* :: false-or() = #f; +define variable *finished?* :: = #f; define variable *transaction-id* = #f; @@ -58,6 +59,13 @@ define method note-application-interactive-results *transaction-id* := transaction-id; end method note-application-interactive-results; +define method note-application-finished-execution + (context :: ) + => () + test-debugger-message("Application finished execution"); + *finished?* := #t; +end method; + define function clear-project-messages () with-lock (associated-lock($project-message-notification)) $project-message-queue.size := 0; @@ -78,7 +86,8 @@ define function initialize-application-client register-application-callbacks (application, initialized-callback: note-application-initialized, - interactive-results-callback: note-application-interactive-results); + interactive-results-callback: note-application-interactive-results, + finished-execution-callback: note-application-finished-execution); end function; define function open-debugging-test-project () => () @@ -110,13 +119,15 @@ define function ensure-application-at-start () end if; clear-project-messages(); + *finished?* := #f; let machine = dbg-machine(); *test-application-application* := run-application(*test-application*, initialize-client: initialize-application-client, startup-option: #"debug", - share-console?: #t, + share-console?: #f, + pause-before-termination?: #t, machine: machine); iterate loop (initialized? = #f, stopped? = #t, transient-bp-count = 0) @@ -372,6 +383,395 @@ define test interactivity-test () end for; end test; +define test source-location-breakpoint-test () + ensure-application-at-start(); + + let threads = *test-application-application*.application-threads; + let main-thread + = find-element + (threads, + method (thread :: ) + environment-object-primitive-name(*test-application*, thread) + = "Main thread" + end); + + let module + = find-module(*test-application*, id-name($debugging-module-id)); + let test-method + = find-environment-object(*test-application*, + "conses", module: module); + check-instance?("test method", , test-method); + + let loc = environment-object-source-location(*test-application*, test-method); + + // N.B. needs to be modified if cmu-test-suite is + let further = make-line-location(source-location-source-record(loc), + source-location-start-line(loc) + 9); + let breakpoint + = make(, + project: *test-application*, + object: further); + check-instance?("Created source-location breakpoint", + , breakpoint); + + iterate loop (stopped-at-breakpoint? = #f) + let message = await-project-message(); + select (message by instance?) + => + let state = *test-application-application*.application-state; + test-debugger-message(" Application state is now %s", state); + select (state) + #"closed" => + #f; + #"stopped" => + let stack-trace + = thread-complete-stack-trace(*test-application*, main-thread); + let top-frame = first(stack-trace); + let top-function + = stack-frame-function(*test-application*, top-frame); + let (top-location, top-exact?) + = stack-frame-source-location(*test-application*, top-frame); + test-debugger-message + ("Stopped in %s (%s): %s", + environment-object-primitive-name(*test-application*, top-function), + with-output-to-string (s) + top-location & print-source-location(s, top-location) + end, + application-stop-reason-message(*test-application-application*)); + if (*finished?*) + test-debugger-message("Finished"); + check-true("Stopped in test breakpoint", stopped-at-breakpoint?); + else + check-true("Breakpoint hit test true", + application-just-hit-breakpoint? + (*test-application-application*, main-thread)); + let stop-bps + = current-stop-breakpoints + (*test-application-application*, main-thread); + check-equal("Stop was at test breakpoint", + vector(breakpoint), stop-bps); + let equiv? = (vector(breakpoint) = stop-bps); + + continue-application(*test-application*); + + loop(stopped-at-breakpoint? | equiv?) + end if; + otherwise => + test-debugger-message(" Application state is %s", state); + loop(stopped-at-breakpoint?); + end select; + + => + let changed-breakpoint = message.message-breakpoint; + let state = message.message-breakpoint-state; + test-debugger-message(" Breakpoint %= state is now %s", + changed-breakpoint, state); + if (state == #"created") + if (changed-breakpoint == breakpoint) + test-debugger-message("breakpoints created, test loop continue"); + continue-application(*test-application*); + end if + end if; + loop(stopped-at-breakpoint?); + + otherwise => + loop(stopped-at-breakpoint?); + end select; + end iterate; + destroy-breakpoint(breakpoint); +end test; + +define constant $class-breakpoint-pattern + = compile-regex(#r"^Class breakpoint reached: Allocating [0-9]+ bytes of \{: \}"); + +define test class-breakpoint-test () + ensure-application-at-start(); + + let threads = *test-application-application*.application-threads; + let main-thread + = find-element + (threads, + method (thread :: ) + environment-object-primitive-name(*test-application*, thread) + = "Main thread" + end); + + let module + = find-module(*test-application*, id-name($debugging-module-id)); + let test-class + = find-environment-object(*test-application*, + "", module: module); + check-instance?("test class", , test-class); + + let breakpoint + = make(, + project: *test-application*, + object: test-class); + check-instance?("Created class breakpoint", + , breakpoint); + + iterate loop (stopped-at-breakpoint? = #f) + let message = await-project-message(); + select (message by instance?) + => + let state = *test-application-application*.application-state; + test-debugger-message(" Application state is now %s", state); + select (state) + #"closed" => + #f; + #"stopped" => + let stack-trace + = thread-complete-stack-trace(*test-application*, main-thread); + let top-frame = first(stack-trace); + let top-function + = stack-frame-function(*test-application*, top-frame); + + let message + = application-stop-reason-message(*test-application-application*); + test-debugger-message + ("Stopped in %s: %s", + environment-object-primitive-name(*test-application*, top-function), + message); + if (*finished?*) + test-debugger-message("Finished"); + check-true("Stopped in test breakpoint", stopped-at-breakpoint?); + else + // TODO make class breakpoints fully "signalling" + // + // check-true("Breakpoint hit test true", + // application-just-hit-breakpoint? + // (*test-application-application*, main-thread)); + // let stop-bps + // = current-stop-breakpoints + // (*test-application-application*, main-thread); + // check-equal("Stop was at test breakpoint", + // vector(breakpoint), stop-bps); + let matched? = regex-position($class-breakpoint-pattern, message); + + continue-application(*test-application*); + + loop(stopped-at-breakpoint? | matched?); + end if; + otherwise => + test-debugger-message(" Application state is %s", state); + loop(stopped-at-breakpoint?); + end select; + + => + let changed-breakpoint = message.message-breakpoint; + let state = message.message-breakpoint-state; + test-debugger-message(" Breakpoint %= state is now %s", + changed-breakpoint, state); + if (state == #"created") + if (changed-breakpoint == breakpoint) + test-debugger-message("breakpoints created, test loop continue"); + continue-application(*test-application*); + end if + end if; + loop(stopped-at-breakpoint?); + + otherwise => + loop(stopped-at-breakpoint?); + end select; + end iterate; + destroy-breakpoint(breakpoint); +end test; + +define test method-inout-breakpoint-test () + ensure-application-at-start(); + + let threads = *test-application-application*.application-threads; + let main-thread + = find-element + (threads, + method (thread :: ) + environment-object-primitive-name(*test-application*, thread) + = "Main thread" + end); + + let module + = find-module(*test-application*, id-name($debugging-module-id)); + let test-method + = find-environment-object(*test-application*, + "method test-static-gf-2-alpha (, )", + module: module); + check-instance?("test method", , test-method); + + let breakpoint + = make(, + project: *test-application*, + object: test-method); + check-instance?("Created method breakpoint", + , breakpoint); + + iterate loop (stopped-at-breakpoint? = #f) + let message = await-project-message(); + select (message by instance?) + => + let state = *test-application-application*.application-state; + test-debugger-message(" Application state is now %s", state); + select (state) + #"closed" => + #f; + #"stopped" => + let stack-trace + = thread-complete-stack-trace(*test-application*, main-thread); + let top-frame = first(stack-trace); + let top-function + = stack-frame-function(*test-application*, top-frame); + test-debugger-message + ("Stopped in %s: %s", + environment-object-primitive-name(*test-application*, top-function), + application-stop-reason-message(*test-application-application*)); + if (*finished?*) + test-debugger-message("Finished"); + check-true("Stopped in test breakpoint", stopped-at-breakpoint?); + else + check-true("Breakpoint hit test true", + application-just-hit-breakpoint? + (*test-application-application*, main-thread)); + let stop-bps + = current-stop-breakpoints + (*test-application-application*, main-thread); + check-equal("Stop was at test breakpoint", + vector(breakpoint), stop-bps); + + let equiv? = (vector(breakpoint) = stop-bps); + + continue-application(*test-application*); + + loop(stopped-at-breakpoint? | equiv?); + end if; + otherwise => + test-debugger-message(" Application state is %s", state); + loop(stopped-at-breakpoint?); + end select; + + => + let changed-breakpoint = message.message-breakpoint; + let state = message.message-breakpoint-state; + test-debugger-message(" Breakpoint %= state is now %s", + changed-breakpoint, state); + if (state == #"created") + if (changed-breakpoint == breakpoint) + test-debugger-message("breakpoints created, test loop continue"); + continue-application(*test-application*); + end if + end if; + loop(stopped-at-breakpoint?); + + otherwise => + loop(stopped-at-breakpoint?); + end select; + end iterate; + destroy-breakpoint(breakpoint); +end test; + +define test generic-function-inout-breakpoint-test () + ensure-application-at-start(); + + let threads = *test-application-application*.application-threads; + let main-thread + = find-element + (threads, + method (thread :: ) + environment-object-primitive-name(*test-application*, thread) + = "Main thread" + end); + + let module + = find-module(*test-application*, id-name($debugging-module-id)); + let tautology-gf + = find-environment-object(*test-application*, "tautology", module: module); + check-instance?("tautology GF", , tautology-gf); + let breakpoint + = make(, + project: *test-application*, + object: tautology-gf); + check-instance?("Created GF breakpoint", , breakpoint); + + let tautology-methods + = generic-function-object-methods(*test-application*, tautology-gf); + let tautology-methods-set + = as(, tautology-methods); + let unstopped-methods-set + = as(, tautology-methods); + + iterate loop() + let message = await-project-message(); + select (message by instance?) + => + let state = *test-application-application*.application-state; + test-debugger-message(" Application state is now %s", state); + select (state) + #"closed" => + #f; + #"stopped" => + let stack-trace + = thread-complete-stack-trace(*test-application*, main-thread); + let top-frame = first(stack-trace); + let top-function + = stack-frame-function(*test-application*, top-frame); + test-debugger-message + ("Stopped in %s: %s", + environment-object-primitive-name(*test-application*, top-function), + application-stop-reason-message(*test-application-application*)); + if (*finished?*) + test-debugger-message("Finished"); + else + check-true("Breakpoint hit test true", + application-just-hit-breakpoint? + (*test-application-application*, main-thread)); + let stop-bps + = current-stop-breakpoints + (*test-application-application*, main-thread); + for (breakpoint in stop-bps) + test-debugger-message + ("Stopped at %= (%=) transient?=%= entry-function?=%= entry-point?=%=", + breakpoint, breakpoint.breakpoint-object, + breakpoint.breakpoint-transient?, + breakpoint.breakpoint-entry-function?, + breakpoint.breakpoint-entry-point?); + remove!(unstopped-methods-set, breakpoint.breakpoint-object); + test-debugger-message("%d unstopped methods remain", unstopped-methods-set.size); + end for; + + test-debugger-message("test loop continue"); + continue-application(*test-application*); + loop() + end if; + otherwise => + test-debugger-message(" Application state is %s", state); + loop(); + end select; + + => + let changed-breakpoint = message.message-breakpoint; + let state = message.message-breakpoint-state; + test-debugger-message(" Breakpoint %= state is now %s", + changed-breakpoint, state); + if (state == #"created") + if (changed-breakpoint == breakpoint) + test-debugger-message("breakpoints created, test loop continue"); + continue-application(*test-application*); + else + check-true("Breakpoint object in GF methods set", + member?(changed-breakpoint.breakpoint-object, + tautology-methods-set)); + end if + end if; + loop(); + + otherwise => + loop(); + end select; + end iterate; + destroy-breakpoint(breakpoint); + + check-equal("Set of unencountered breakpoints is empty", + 0, unstopped-methods-set.size); +end test; + define suite dfmc-environment-debugging-suite (setup-function: open-debugging-test-project, cleanup-function: close-debugging-test-project, @@ -386,4 +786,8 @@ define suite dfmc-environment-debugging-suite test stack-trace-test; test registers-test; test interactivity-test; + test source-location-breakpoint-test; + test class-breakpoint-test; + test method-inout-breakpoint-test; + test generic-function-inout-breakpoint-test; end suite; diff --git a/sources/environment/tests/dfmc/library.dylan b/sources/environment/tests/dfmc/library.dylan index 4c677dd096..d9f42bd623 100644 --- a/sources/environment/tests/dfmc/library.dylan +++ b/sources/environment/tests/dfmc/library.dylan @@ -10,6 +10,7 @@ define library dfmc-environment-test-suite use common-dylan; use io; use system; + use collections; use progress-stream; use source-records; diff --git a/sources/environment/tests/dfmc/module.dylan b/sources/environment/tests/dfmc/module.dylan index de8ab1f3a3..da92b9187c 100644 --- a/sources/environment/tests/dfmc/module.dylan +++ b/sources/environment/tests/dfmc/module.dylan @@ -17,6 +17,7 @@ define module dfmc-environment-test-suite use file-system; use threads; use logging; + use set; use source-records; use operating-system, diff --git a/sources/io/library.dylan b/sources/io/library.dylan index 53ecb804f7..f4fe8355a0 100644 --- a/sources/io/library.dylan +++ b/sources/io/library.dylan @@ -306,6 +306,7 @@ define module print-internals use threads; use dylan-extensions; use dylan-primitives; + use dylan-c-ffi; use byte-vector; use format-internals; use streams-internals; diff --git a/sources/io/print.dylan b/sources/io/print.dylan index eabcccccd6..caeae5a115 100644 --- a/sources/io/print.dylan +++ b/sources/io/print.dylan @@ -1080,6 +1080,20 @@ define sealed method print-object end method; +/// C pointers +/// +define method print-object + (pointer :: , stream :: ) => () + let class = pointer.object-class; + printing-logical-block (stream, prefix: "{", suffix: "}") + write(stream, as-lowercase(as(, class.debug-name))); + write(stream, " "); + let address + = primitive-cast-pointer-as-raw(primitive-unwrap-c-pointer(pointer)); + write(stream, machine-word-to-string(primitive-wrap-machine-word(address))); + end +end method; + /// Float printing. /// diff --git a/sources/runtime-manager/access-path/module.dylan b/sources/runtime-manager/access-path/module.dylan index 66a3ed54f1..b985dd6fea 100644 --- a/sources/runtime-manager/access-path/module.dylan +++ b/sources/runtime-manager/access-path/module.dylan @@ -470,7 +470,6 @@ define module access-path-nub exception-is-first-chance?, get-exception-violation-address, get-exception-violation-op, - first-debugger-invocation?, connection-can-receive-first-chance, connection-set-first-chance, connection-unset-first-chance, @@ -527,7 +526,8 @@ define module access-path-implementation use dylan-extensions, import: {, , - $minimum-unsigned-machine-word, integer-as-raw}, + $minimum-unsigned-machine-word, integer-as-raw, + debug-name}, export: all; use dylan-primitives; use machine-word-lowlevel; @@ -535,7 +535,8 @@ define module access-path-implementation use format; use format-out; use print; - use streams, import: {, , force-output, close}; + use pprint; + use streams, import: {, , write, force-output, close}; use locators, import: {}; use file-system; use operating-system, import: {environment-variable}; diff --git a/sources/runtime-manager/access-path/remote-objects.dylan b/sources/runtime-manager/access-path/remote-objects.dylan index ced8a91add..7e8d0f81d3 100644 --- a/sources/runtime-manager/access-path/remote-objects.dylan +++ b/sources/runtime-manager/access-path/remote-objects.dylan @@ -86,12 +86,14 @@ define method make (class == , #rest keys, #key, #all-keys) end method; define method print-object - (t :: , stream :: ) => () - format(stream, "{Remote Thread [%=, %=, %=, %=, %=, %=]}", - t.thread-name, t.nub-descriptor, t.thread-state, - t.os-thread-priority, t.thread-stack, t.thread-suspended?); -end; - + (t :: , stream :: ) => () + printing-logical-block (stream, prefix: "{", suffix: "}") + let obj-class = t.object-class; + write(stream, obj-class.debug-name); + format(stream, " instance name: %=, suspended?: %=, stack: %=", + t.thread-name, t.thread-suspended?, t.thread-stack); + end; +end method; ///// @@ -137,6 +139,12 @@ define abstract class () */ end class; +define method print-object + (lib :: , stream :: ) => () + format(stream, "{Remote Library %s %=}", + lib.library-image-name, lib.library-base-address); +end; + define generic library-version (lib :: ) => (major-version-number :: , minor-version-number :: ); @@ -253,23 +261,23 @@ define open generic construct-thread-object define method find-or-make-thread (ap :: , thread :: , #key priority) - => (thread :: ) - let i = 0; - let remote-thread = #f; - while ((~remote-thread) & (i < size(ap.threads))) - if (ap.threads[i].nub-descriptor = thread) - remote-thread := ap.threads[i]; - else - i := i + 1; - end if - end while; - if (~remote-thread) - remote-thread := - construct-thread-object - (ap.connection, thread, path: ap, priority: priority); - ap.threads := add! (ap.threads, remote-thread); - end if; - remote-thread; + => (thread :: ) + local + method compare-desc + (thread :: , remote-thread :: ) + => (match? :: ) + remote-thread.nub-descriptor = thread + end; + let pos = position(ap.threads, thread, test: compare-desc); + if (pos) + ap.threads[pos] + else + let remote-thread + = construct-thread-object + (ap.connection, thread, path: ap, priority: priority); + ap.threads := add!(ap.threads, remote-thread); + remote-thread + end if end method; @@ -285,22 +293,23 @@ define open generic construct-library-object // Similar to FIND-OR-MAKE-THREAD define method find-or-make-library - (ap :: , lib :: ) - => (lib :: ) - let i = 0; - let remote-library = #f; - while ((~remote-library) & (i < size(ap.libraries))) - if (ap.libraries[i].nub-descriptor = lib) - remote-library := ap.libraries[i]; - else - i := i + 1; - end if - end while; - if (~remote-library) - remote-library := construct-library-object (ap.connection, lib); - ap.libraries := add! (ap.libraries, remote-library); - end if; - remote-library; + (ap :: , lib :: ) + => (remote-library :: ) + local + method compare-desc + (lib :: , remote-library :: ) + => (match? :: ) + remote-library.nub-descriptor = lib + end; + let pos + = position(ap.libraries, lib, test: compare-desc); + if (pos) + ap.libraries[pos] + else + let remote-library = construct-library-object(ap.connection, lib); + ap.libraries := add!(ap.libraries, remote-library); + remote-library + end if end method; /* diff --git a/sources/runtime-manager/access-path/stop-reasons.dylan b/sources/runtime-manager/access-path/stop-reasons.dylan index d0662dfa95..966cc1287a 100644 --- a/sources/runtime-manager/access-path/stop-reasons.dylan +++ b/sources/runtime-manager/access-path/stop-reasons.dylan @@ -26,6 +26,7 @@ define constant $integer-divide-by-zero-exception = 12; define constant $noncontinuable-exception = 13; define constant $breakpoint-exception = 14; define constant $hard-coded-breakpoint-exception = 15; +define constant $system-initialized-exception = 35; define constant $single-step-exception = 16; define constant $create-process = 17; define constant $exit-process = 18; @@ -77,6 +78,17 @@ define abstract sealed class () end class; +define method print-object + (stop :: , stream :: ) => () + printing-logical-block (stream, prefix: "{", suffix: "}") + let obj-class = stop.object-class; + write(stream, obj-class.debug-name); + write(stream, " instance thread: "); + print-object(stop.stop-reason-thread, stream); + end; +end method; + + ///// // Stop reasons NOT defined by the access path. These represent // stop-reasons generated by the application, but not at system level. @@ -180,6 +192,18 @@ define abstract class () required-init-keyword: address:; end class; +define method print-object + (stop :: , stream :: ) => () + printing-logical-block (stream, prefix: "{", suffix: "}") + let obj-class = stop.object-class; + write(stream, obj-class.debug-name); + write(stream, " instance thread: "); + print-object(stop.stop-reason-thread, stream); + write(stream, ", address: "); + print-object(stop.stop-reason-debug-point-address, stream); + end; +end; + define class () end class; @@ -326,7 +350,9 @@ end class; define method wait-for-stop-reason (ap :: , #key timeout = #f, profile-interval = #f) - => (maybe-sr :: false-or()) + => (maybe-sr :: false-or()) + assert(ap.state == #"running" | ap.state == #"dead", + "Can not wait for a non-running application"); let sr = #f; if (timeout) sr := wait-for-stop-reason-with-timeout (ap.connection, timeout, @@ -448,24 +474,20 @@ define open generic get-exception-violation-op (conn :: ) => (op :: ); -///// FIRST-DEBUGGER-INVOCATION? -// Is this the first time that the application has signalled a hard-coded -// breakpoint? -// If so, we will assume this breakpoint to be "special", and that it -// is a signal that the application, and all of its shared libraries, -// have loaded and performed their system-level initializations. On -// Windows, this is true for free. Debugger nubs on other platforms, -// however, might need to force the generation of this stop reason. - -define open generic first-debugger-invocation? - (conn :: ) => (well? :: ); - - ///// CONSTRUCT-STOP-REASON // Given a low-level stop-reason code, this constructs a high-level // stop reason event object. (Returns #f if the code indicates a // timeout). +define constant $timeout-handled-stop-reason + = make(); +define constant $timeout-unhandled-stop-reason + = make(); +define constant $profiler-stop-reason + = make(); +define constant $profiler-unhandled-stop-reason + = make(); + define method construct-stop-reason (ap :: , event-type :: , #key process, thread) @@ -481,7 +503,6 @@ define method construct-stop-reason end unless; end if; - let source-library = #f; let stop-reason = #f; if (source-thread) @@ -496,12 +517,14 @@ define method construct-stop-reason $timed-out => stop-reason := #f; $timed-out-handled => - stop-reason := make(); + stop-reason := $timeout-handled-stop-reason; $timed-out-unhandled => - stop-reason := make(); + stop-reason := $timeout-unhandled-stop-reason; $create-process => - source-library := find-or-make-library - (ap, get-debug-event-library (ap.connection)); + let source-library + = find-or-make-library(ap, get-debug-event-library(ap.connection)); + assert(ap.libraries.size = 1); + assert(ap.threads.size = 1); stop-reason := make (, process: source-process, thread: source-thread, @@ -518,6 +541,8 @@ define method construct-stop-reason exit-code: get-debug-event-process-exit-code (ap.connection)); + ap.libraries.size := 0; + ap.threads.size := 0; deregister-access-path(ap); $exit-thread => stop-reason := make (, @@ -528,22 +553,20 @@ define method construct-stop-reason (ap.connection)); ap.threads := remove! (ap.threads, source-thread); $load-dll => - source-library := - find-or-make-library - (ap, get-debug-event-library (ap.connection)); + let source-library + = find-or-make-library(ap, get-debug-event-library(ap.connection)); stop-reason := make (, process: source-process, thread: source-thread, library: source-library); $unload-dll => - source-library := - find-or-make-library - (ap, get-debug-event-library (ap.connection)); + let source-library + = find-or-make-library(ap, get-debug-event-library(ap.connection)); stop-reason := make (, process: source-process, thread: source-thread, library: source-library); - ap.libraries := remove! (ap.libraries, source-library); + ap.libraries := remove!(ap.libraries, source-library); $output-debug-string => let (string-address, string-length, string-unicode?) = get-debug-event-string-information(ap.connection); @@ -704,32 +727,30 @@ define method construct-stop-reason thread: source-thread, address: get-exception-address (ap.connection)); $hard-coded-breakpoint-exception => - if (first-debugger-invocation?(ap.connection)) - stop-reason := make (, - exception-address: - get-exception-address(ap.connection), - first-chance?: - exception-is-first-chance?(ap.connection), - process: source-process, - thread: source-thread); - else - stop-reason := make (, - exception-address: - get-exception-address(ap.connection), - first-chance?: - exception-is-first-chance?(ap.connection), - process: source-process, - thread: source-thread); - end if; + stop-reason := make (, + exception-address: + get-exception-address(ap.connection), + first-chance?: + exception-is-first-chance?(ap.connection), + process: source-process, + thread: source-thread); $single-step-exception => stop-reason := make (, process: source-process, thread: source-thread, - address: get-exception-address (ap.connection)); + address: get-exception-address (ap.connection)); + $system-initialized-exception => + stop-reason := make (, + exception-address: + get-exception-address(ap.connection), + first-chance?: + exception-is-first-chance?(ap.connection), + process: source-process, + thread: source-thread); $profiler => - stop-reason := make (); + stop-reason := $profiler-stop-reason; $profiler-unhandled => - stop-reason := make (); + stop-reason := $profiler-unhandled-stop-reason; otherwise => stop-reason := make (, process: source-process, diff --git a/sources/runtime-manager/debugger-manager/debug-target.dylan b/sources/runtime-manager/debugger-manager/debug-target.dylan index 41b6d76c75..aba6cc5691 100644 --- a/sources/runtime-manager/debugger-manager/debug-target.dylan +++ b/sources/runtime-manager/debugger-manager/debug-target.dylan @@ -57,6 +57,8 @@ define open abstract class () slot debugger-generated-stop-reason :: = make(); + slot application-loading? :: , + init-value: #f; slot up-and-running? :: , init-value: #f; @@ -190,14 +192,6 @@ define open abstract class () // the current debugger transaction. It is guaranteed that these // pages can be read safely using the access-path. slot pages-safe-to-read-cache :: = make(); -/* - // This slot holds info about the MM entry functions so that we - // can detect when threads are in the MM at the start of debugger - // transactions. The info is created in the first transaction. - - slot mm-function-info :: - = make(); -*/ end class; diff --git a/sources/runtime-manager/debugger-manager/initialization-tracking.dylan b/sources/runtime-manager/debugger-manager/initialization-tracking.dylan index 719917ca27..1e801a0461 100644 --- a/sources/runtime-manager/debugger-manager/initialization-tracking.dylan +++ b/sources/runtime-manager/debugger-manager/initialization-tracking.dylan @@ -8,17 +8,6 @@ License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND -///// -// Describes the states in which a dylan library can be. - -define constant = - one-of(#"uninitialized", - #"statically-initialized", - #"dynamically-initialized", - #"unloaded", - #"foreign"); - - ///// // Either START or END. @@ -57,22 +46,16 @@ define abstract class () constant slot tracker-remote-library :: , required-init-keyword: remote-library:; - slot tracker-initialization-state :: ; - constant slot tracker-top-level? :: , required-init-keyword: top-level?:; end class; define class () - inherited slot tracker-initialization-state, - init-value: #"foreign"; end class; define class () - inherited slot tracker-initialization-state, - init-value: #"uninitialized"; constant slot tracker-initialization-symbol :: , required-init-keyword: initializer-function:; @@ -85,9 +68,14 @@ define sealed method initialize (entry-init :: , #key) => () let lib = entry-init.tracker-remote-library; let target = entry-init.tracker-debug-target; + assert(target.application-loading? == #f, + "initialization trackers should not be installed during the initial load phase"); let path = target.debug-target-access-path; let core = lib.library-core-name; let init-fun = entry-init.tracker-initialization-symbol; + debug-target-message + (target, $debug-level, "Installing initialization tracker for %= at %=", + lib, init-fun.remote-symbol-address); let tracer = make(, address: init-fun.remote-symbol-address, callback: dynamic-initializer-start-callback, @@ -143,10 +131,9 @@ define method dynamic-initializer-start-callback (application :: , start :: , thread :: ) => (interested? :: ) - ignore - (start.entry-initialization-tracker.tracker-initialization-state); - start.entry-initialization-tracker.tracker-initialization-state := - #"statically-initialized"; + debug-target-message + (application, $debug-level, "Dynamic initializer start for %=", + start.entry-initialization-tracker.tracker-remote-library); if (start.entry-initialization-tracker.tracker-remote-library == application.application-dylan-library) allocate-temporary-download-block-in(application, thread); @@ -177,8 +164,6 @@ define method dynamic-initializer-done-callback => (interested? :: ) deregister-debug-point(application, done); deregister-debug-point(application, done.corresponding-entry-tracepoint); - done.exit-initialization-tracker.tracker-initialization-state := - #"dynamically-initialized"; debug-target-message (application, $debug-level, "Tracker for %s state set to dynamically-initialized (done)", @@ -336,6 +321,8 @@ define method register-dylan-library => () debug-target-message (application, $debug-level, "Registering Dylan library %=", dylan-library); + assert(application.application-dylan-library == #f, + "the dylan library should only be initialized once"); application.application-dylan-library := dylan-library; application.dylan-application? := #t; application.dylan-spy := make(); @@ -365,6 +352,8 @@ define method register-dylan-runtime-library debug-target-message (application, $debug-level, "Registering Dylan runtime library %=", runtime-library); + assert(application.application-dylan-runtime-library == #f, + "the dylan runtime library should only be initialized once"); let path = application.debug-target-access-path; let one = as-remote-value(1); application.application-dylan-runtime-library := runtime-library; @@ -434,3 +423,76 @@ define method top-level-library-definition-name "unknown"; as-lowercase(name); end method; + +define method register-library + (application :: , lib :: ) + => () + let needs-tracking? = #f; + let (dylan-lib-name, runtime-lib-name) + = dylan-and-runtime-library-names(application); + let lib-name = as-uppercase(lib.library-core-name); + if (lib-name = dylan-lib-name) + register-dylan-library(application, lib); + needs-tracking? := #t; + end if; + if (lib-name = runtime-lib-name) + register-dylan-runtime-library(application, lib); + needs-tracking? := #t; + end if; + let top-level? = (lib-name = application.top-level-library-name); + debug-target-message + (application, $debug-level, "Load library %=, top-level?=%= needs-tracking?=%=", + lib, top-level?, needs-tracking?); + if (top-level? | needs-tracking?) + let sym + = if (top-level?) + // For top-level libraries, determine whether the library + // is self-contained by searching for an unusual entry-point; + // use this entry-point for the component's initialization + // tracking + let component-sym + = find-symbol(application.debug-target-access-path, + $standard-dylan-component-initializer, + library: lib); + if (component-sym) + lib.self-contained-component? := #t; + component-sym + else + find-symbol(application.debug-target-access-path, + $standard-dylan-initializer, + library: lib); + end + else + find-symbol(application.debug-target-access-path, + $standard-dylan-initializer, + library: lib); + end; + if (sym) + application.library-initialization-trackers[lib] + := make(, + debug-target: application, + remote-library: lib, + top-level?: top-level?, + initializer-function: sym); + else + application.library-initialization-trackers[lib] + := make(, + debug-target: application, + top-level?: top-level?, + remote-library: lib); + end if; + end if; +end method; + +define method deregister-library + (application :: , lib :: ) + => () + debug-target-message + (application, $debug-level, "Deregistering library %=", lib); + if (lib == application.application-dylan-library) + deregister-dylan-library(application); + end if; + if (lib == application.application-dylan-runtime-library) + deregister-dylan-runtime-library(application); + end if; +end method; diff --git a/sources/runtime-manager/debugger-manager/stop-reason-interpret.dylan b/sources/runtime-manager/debugger-manager/stop-reason-interpret.dylan index e88d7cdb21..994df5c7d4 100644 --- a/sources/runtime-manager/debugger-manager/stop-reason-interpret.dylan +++ b/sources/runtime-manager/debugger-manager/stop-reason-interpret.dylan @@ -45,6 +45,11 @@ define method interpret-stop-reason debug-target-message(application, $debug-level, "Interpret stop reason %=", stop-reason); select (stop-reason by instance?) + => + maybe-modified-stop-reason := stop-reason; + application.application-loading? := #f; + do-libraries(curry(register-library, application), path); + => // If this is a dylan-level invocation of the debugger, // generate the required high-level stop reason. Otherwise, @@ -199,40 +204,13 @@ define method interpret-stop-reason => maybe-modified-stop-reason := stop-reason; + application.application-loading? := #t; application.up-and-running? := #t; create-thread-descriptor(application, stop-reason.stop-reason-thread); - application.application-primary-thread := - stop-reason.stop-reason-thread; - let lib = stop-reason.stop-reason-executable-component; - application.application-executable := lib; - let (dylan-lib-name, runtime-lib-name) - = dylan-and-runtime-library-names(application); - let lib-name = as-uppercase(lib.library-core-name); - if (lib-name = dylan-lib-name) - register-dylan-library(application, lib) - end if; - if (lib-name = runtime-lib-name) - register-dylan-runtime-library(application, lib) - end if; - let top-level? = (lib-name = application.top-level-library-name); - let sym = find-symbol(application.debug-target-access-path, - $standard-dylan-initializer, - library: lib); - if (sym) - application.dylan-application? := #t; - application.library-initialization-trackers[lib] := - make(, - debug-target: application, - remote-library: lib, - top-level?: top-level?, - initializer-function: sym); - else - application.library-initialization-trackers[lib] := - make(, - debug-target: application, - remote-library: lib, - top-level?: top-level?); - end if; + application.application-primary-thread + := stop-reason.stop-reason-thread; + application.application-executable + := stop-reason.stop-reason-executable-component; => stop-profiling(application); @@ -242,75 +220,16 @@ define method interpret-stop-reason => maybe-modified-stop-reason := stop-reason; let lib :: = stop-reason.stop-reason-library; - let needs-tracking? = #f; - let (dylan-lib-name, runtime-lib-name) - = dylan-and-runtime-library-names(application); - let lib-name = as-uppercase(lib.library-core-name); - if (lib-name = dylan-lib-name) - register-dylan-library(application, lib); - needs-tracking? := #t; - end if; - if (lib-name = runtime-lib-name) - register-dylan-runtime-library(application, lib); - needs-tracking? := #t; - end if; - let top-level? = (lib-name = application.top-level-library-name); - if (top-level? | needs-tracking?) - let sym = - if (top-level?) - // For top-level libraries, determine whether the library - // is self-contained by searching for an unusual entry-point; - // use this entry-point for the component's initialization - // tracking - let component-sym = - find-symbol(application.debug-target-access-path, - $standard-dylan-component-initializer, - library: lib); - if (component-sym) - lib.self-contained-component? := #t; - component-sym - else - find-symbol(application.debug-target-access-path, - $standard-dylan-initializer, - library: lib); - end - else - find-symbol(application.debug-target-access-path, - $standard-dylan-initializer, - library: lib); - end; - if (sym) - application.library-initialization-trackers[lib] := - make(, - debug-target: application, - remote-library: lib, - top-level?: top-level?, - initializer-function: sym); - else - application.library-initialization-trackers[lib] := - make(, - debug-target: application, - top-level?: top-level?, - remote-library: lib); - end if; - end if; + unless (application.application-loading?) + register-library(application, lib); + end unless; => maybe-modified-stop-reason := stop-reason; let lib = stop-reason.stop-reason-library; - if (lib == application.application-dylan-library) - deregister-dylan-library(application); - end if; - if (lib == application.application-dylan-runtime-library) - deregister-dylan-runtime-library(application); - end if; - let tracker = - element(application.library-initialization-trackers, - lib, - default: #f); - if (tracker) - tracker.tracker-initialization-state := #"unloaded" - end if; + unless (application.application-loading?) + deregister-library(application, lib); + end unless; => // We have performed a source-stepping operation. If this was diff --git a/sources/runtime-manager/debugger-manager/transaction.dylan b/sources/runtime-manager/debugger-manager/transaction.dylan index c317484bcd..d6ca3bd84e 100644 --- a/sources/runtime-manager/debugger-manager/transaction.dylan +++ b/sources/runtime-manager/debugger-manager/transaction.dylan @@ -6,234 +6,6 @@ Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc. License: See License.txt in this distribution for details. Warranty: Distributed WITHOUT WARRANTY OF ANY KIND -/* -// A list of function names which can be used to determine whether a thread -// is in the memory manager. If one of these functions appears anywhere on -// the thread's stack then the thread is in the MM. -// -define constant $mm-function-names - = list("mps_amc_apply", - "ArenaAccess", - "mps_message_finalization_ref", - "mps_message_queue_type", - "mps_message_get", - "mps_message_type_enable", - "mps_message_discard", - "mps_message_type", - "mps_message_poll", - "mps_finalize", - "mps_ld_reset", - "mps_thread_dereg", - "mps_thread_reg", - "mps_root_destroy", - "mps_root_create_reg", - "mps_root_create_fmt", - "mps_root_create_table_masked", - "mps_root_create_table", - "mps_root_create", - "mps_ap_trip", - "mps_ap_fill", - "mps_ap_destroy", - "mps_ap_create_v", - "mps_ap_create", - "mps_free", - "mps_alloc_v", - "mps_pool_destroy", - "mps_pool_create_v", - "mps_fmt_destroy", - "mps_fmt_create_A", - "mps_arena_collect", - "mps_arena_park", - "mps_arena_release", - "mps_arena_clamp", - "mps_arena_committed", - "mps_arena_reserved", - "mps_arena_extend"); - - - -// A type which describes the range of addresses a function in the -// debug target occupies. -// -define class () - slot address-range-from :: , required-init-keyword: from:; - slot address-range-to :: , required-init-keyword: to:; -end class; - -define method inside-address-range? - (address :: , range :: ) - => (well? :: ) - remote-value-<=(address, range.address-range-to) - & remote-value-<(range.address-range-from, address); -end method; - - - -// A type which describes address information for a group of functions -// in the debug target. This is implemented as a vector of s. -// -define constant = ; - - -// Returns #t if and only if the address supplied falls inside the -// address range of one of the functions in the remote function info. -// -define function address-inside-function? - (address :: , info :: ) - => (well? :: ) - any?(curry(inside-address-range?, address), info); -end function; - - -// This is called when a new debugger transaction starts. It ensures -// that address information for the MM functions has been initialized. -// -define function ensure-mm-function-info-initialized - (application :: ) => () - if (size(application.mm-function-info) = 0) - let access-path = application.debug-target-access-path; -// let n = size($mm-function-names); - let new-info = make(); - for (name in $mm-function-names) - let symbol = find-symbol(access-path, name); - if (symbol) - let address = remote-symbol-address(symbol); - let (start, finish) - = function-bounding-addresses(access-path, address); - add!(new-info, make(, from: start, to: finish)); - end if; - end for; - application.mm-function-info := new-info; - end if; -end function; - - -// Steps through each thread in the debug target. If the thread is in the -// MM, then all other threads are suspended and the thread is allowed to -// run until it leaves the MM. -// -define function step-all-threads-out-of-mm (application :: ) - => () - let access-path = application.debug-target-access-path; - - // Returns true if the stack frame belongs to a know MM function - // - local method mm-stack-frame? (frame :: ) => (well? :: ) - let address = frame-instruction-address(access-path, frame); - address-inside-function?(address, application.mm-function-info); - end method; - - // Returns the oldest MM frame on the thread's stack, or #f if there - // are none. - // - local method mm-entry-stack-frame (thread :: ) - => (frame :: false-or()) - block(return) - let stack-frame = initialize-stack-trace(access-path, thread); - if (mm-stack-frame?(stack-frame)) - let oldest-mm-frame = stack-frame; - stack-frame := previous-frame(access-path, stack-frame); - while ((stack-frame) & (mm-stack-frame?(stack-frame))) - oldest-mm-frame := stack-frame; - stack-frame := previous-frame(access-path, stack-frame); - end while; - oldest-mm-frame; - else - return(#f) - end if - end block; - end method; - - // Returns #t if this stop reason is due to hitting a breakpoint - // set at the supplied address. - // - local method our-debug-point? - (stop-reason :: false-or(), address :: ) - => (well? :: ) - (instance?(stop-reason, ) - & (stop-reason-debug-point-address(stop-reason) = address)); - end method; - - // Steps a single thread we know is in the MM out of the MM. - // - local method step-thread-out-of-mm - (mm-thread :: , mm-frame :: ) => () - - // suspend all threads except the one we are stepping - do-threads(method (thread) - if (thread ~== mm-thread) - suspend-thread(access-path, thread); - end if; - end method, access-path); - - // set a breakpoint on the return address of the oldest MM frame. - let address = frame-return-address(access-path, mm-frame); - let breakpoint-already? = query-breakpoint?(access-path, address); - unless (breakpoint-already?) - enable-breakpoint(access-path, address); - end unless; - - // Step the thread - while (mm-entry-stack-frame(mm-thread)) - continue(access-path); - let stop-reason = wait-for-stop-reason(access-path, timeout: 1000); - while(~(our-debug-point?(stop-reason, address))) - if (stop-reason) - continue(access-path); - end if; - stop-reason := wait-for-stop-reason(access-path, timeout: 1000); - end while; - end while; - - // remove the breakpoint - unless (breakpoint-already?) - disable-breakpoint(access-path, address) - end unless; - - // resume all suspended threads - do-threads(curry(resume-thread, access-path), access-path); - - // Work on the principle that a thread that has been successfully - // recovered from the MM should now be happy to run spy code without - // freezing up. - use-thread-for-spy-functions(application, mm-thread); - end method; - - // Step through each thread in turn, stepping it out of the MM if - // necessary. - do-threads(method (thread :: ) - let frame = mm-entry-stack-frame(thread); - if (frame) - step-thread-out-of-mm(thread, frame); - end if; - end method, access-path); -end function; - - -// This is called at the start of a debugger transaction once all the -// debug target's threads are known not to be in the MM. It informs -// the MM that a transaction has started. -// -define function mm-start-debugger-transaction (dt :: ) => () - let spy-thread = select-thread-for-spy(dt); - if (spy-thread) - run-spy-on-thread(dt, spy-thread, dt.C-spy.start-debugger-transaction); - end if; -end function; - - -// This is called at the end of a debugger transaction. It informs -// the MM that the current transaction has finished. -// -define function mm-end-debugger-transaction (dt :: ) => () - let spy-thread = select-thread-for-spy(dt); - if (spy-thread) - run-spy-on-thread(dt, spy-thread, dt.C-spy.end-debugger-transaction); - end if; -end function; -*/ - ///// // A class used to store remote dylan objects in fast-lookup form. // The values in the table can be arbitrary information that needs to diff --git a/sources/runtime-manager/debugger-nub/remote-nub.idl b/sources/runtime-manager/debugger-nub/remote-nub.idl index f8ca383b2e..6390c05805 100644 --- a/sources/runtime-manager/debugger-nub/remote-nub.idl +++ b/sources/runtime-manager/debugger-nub/remote-nub.idl @@ -376,9 +376,6 @@ RNUB stop_reason_process RNUBTHREAD stop_reason_thread (); -NUBINT first_hard_coded_breakpoint - (); - NUBINT stop_reason_process_exit_code (); diff --git a/sources/runtime-manager/debugger-nub/server/remote-nub-defs.dylan b/sources/runtime-manager/debugger-nub/server/remote-nub-defs.dylan index bba39b91a5..0c0e632bcd 100644 --- a/sources/runtime-manager/debugger-nub/server/remote-nub-defs.dylan +++ b/sources/runtime-manager/debugger-nub/server/remote-nub-defs.dylan @@ -825,14 +825,6 @@ define corba-method Rtmgr/RemoteNub/stop-reason-thread (process); end corba-method; -define corba-method Rtmgr/RemoteNub/first-hard-coded-breakpoint - (rnub :: ) - => (result :: Rtmgr/RemoteNub/) - let process = remote-process(rnub); - nub-first-hard-coded-breakpoint - (process); -end corba-method; - define corba-method Rtmgr/RemoteNub/stop-reason-process-exit-code (rnub :: ) => (result :: Rtmgr/RemoteNub/) diff --git a/sources/runtime-manager/debugger-nub/server/remote-nub-ffi-defs.dylan b/sources/runtime-manager/debugger-nub/server/remote-nub-ffi-defs.dylan index 049258bcae..8a55bc9882 100644 --- a/sources/runtime-manager/debugger-nub/server/remote-nub-ffi-defs.dylan +++ b/sources/runtime-manager/debugger-nub/server/remote-nub-ffi-defs.dylan @@ -805,12 +805,6 @@ define debugger-nub-interface nub-stop-reason-process c-name: "nub_stop_reason_process"; end debugger-nub-interface; -define debugger-nub-interface nub-first-hard-coded-breakpoint - parameter nub :: ; - result is-first :: ; - c-name: "nub_first_hard_coded_breakpoint"; -end debugger-nub-interface; - define debugger-nub-interface nub-stop-reason-thread parameter nub :: ; result thread :: ; diff --git a/sources/runtime-manager/debugger-nub/x86-win32/app_control.c b/sources/runtime-manager/debugger-nub/x86-win32/app_control.c index 6c3827862a..b09aae2906 100644 --- a/sources/runtime-manager/debugger-nub/x86-win32/app_control.c +++ b/sources/runtime-manager/debugger-nub/x86-win32/app_control.c @@ -205,6 +205,8 @@ void continue_application (NUB nub, int handling) LPDBGTHREAD main_thread = process->ThreadList; LPDBGTHREAD this_thread = main_thread; LPDBGTHREAD last_thread = main_thread; + LPDBGLIBRARY this_library = process->LibraryList; + LPDBGLIBRARY last_library = process->LibraryList; // Apply specialized "continue" behaviour to each thread in turn. @@ -262,6 +264,25 @@ void continue_application (NUB nub, int handling) } } + // Clean out invalidated (unloaded) libraries + while (this_library != NULL) { + if (!this_library->Valid) { + // Drop a node out of the list + last_library->Next = this_library->Next; + + release_library_debug_map(process, this_library); + release_library_coff_map(process, this_library); + CloseHandle(this_library->ImageInformation.ImageFileHandle); + free(this_library); + + this_library = last_library->Next; + } + else { + // This one lives on. + last_library = this_library; + this_library = this_library->Next; + } + } } diff --git a/sources/runtime-manager/debugger-nub/x86-win32/coff_map.h b/sources/runtime-manager/debugger-nub/x86-win32/coff_map.h index 9f31808e3d..2089c56c82 100644 --- a/sources/runtime-manager/debugger-nub/x86-win32/coff_map.h +++ b/sources/runtime-manager/debugger-nub/x86-win32/coff_map.h @@ -83,4 +83,6 @@ void print_coff_symbol_name void debug_print_coff_symbols (LPDBGLIBRARY module); - +// Disposes of all memory that was allocated to hold COFF symbol and string +// tables in the image. +void release_library_coff_map(LPDBGPROCESS process, LPDBGLIBRARY module); diff --git a/sources/runtime-manager/debugger-nub/x86-win32/debug_map.c b/sources/runtime-manager/debugger-nub/x86-win32/debug_map.c index e5942d2fe1..e78b8e8254 100644 --- a/sources/runtime-manager/debugger-nub/x86-win32/debug_map.c +++ b/sources/runtime-manager/debugger-nub/x86-win32/debug_map.c @@ -54,11 +54,6 @@ int equal_cv_names (CV_HEADER *rec, BYTE l, char *name); // Returns non-zero if the name of the symbolic record is equal to the // given length-prefixed name. -void release_library_coff_map(LPDBGPROCESS process, LPDBGLIBRARY module); -// Imported from coff_map.c. -// Disposes of all memory that was allocated to hold COFF symbol and string -// tables in the image. - DWORD number_of_codeview_subsections (PIMAGE_DEBUG_INFORMATION info) { SS_DIR_HEADER *ss_dir_header; diff --git a/sources/runtime-manager/debugger-nub/x86-win32/misc_utils.c b/sources/runtime-manager/debugger-nub/x86-win32/misc_utils.c index 140ecf6554..b2dbe0fff1 100644 --- a/sources/runtime-manager/debugger-nub/x86-win32/misc_utils.c +++ b/sources/runtime-manager/debugger-nub/x86-win32/misc_utils.c @@ -391,16 +391,15 @@ void add_library_descriptor } -DWORD lowest_base_address (LPDBGPROCESS process) +void invalidate_library_descriptor + (LPDBGPROCESS process, + UNLOAD_DLL_DEBUG_INFO info) { - LPDBGLIBRARY lib = process->LibraryList; - DWORD lowest = lib->ImageInformation.ImageBase; - while (lib != NULL) { - if (lib->ImageInformation.ImageBase < lowest) - lowest = lib->ImageInformation.ImageBase; - lib = lib->Next; + LPDBGLIBRARY lib + = library_descriptor_from_base_address(process, (DWORD) info.lpBaseOfDll); + if (lib != process->LibraryList) { + lib->Valid = FALSE; // Mark it for deletion } - return(lowest); } @@ -570,6 +569,7 @@ void housekeep_for_stop_reason break; case UNLOAD_DLL_DEBUG_EVENT: + invalidate_library_descriptor(process, event->u.UnloadDll); break; case EXCEPTION_DEBUG_EVENT: diff --git a/sources/runtime-manager/debugger-nub/x86-win32/nub-core.h b/sources/runtime-manager/debugger-nub/x86-win32/nub-core.h index df8e37d7ae..45910c1a2e 100644 --- a/sources/runtime-manager/debugger-nub/x86-win32/nub-core.h +++ b/sources/runtime-manager/debugger-nub/x86-win32/nub-core.h @@ -109,7 +109,7 @@ void checked_free(void*); // These MUST agree with the codes specified in the Access Path. -#define MAX_EVENT_TYPES 35 +#define MAX_EVENT_TYPES 36 #define TIMED_OUT 0 #define TIMED_OUT_HANDLED 32 #define TIMED_OUT_UNHANDLED 33 @@ -128,6 +128,7 @@ void checked_free(void*); #define NONCONTINUABLE_EXCEPTION_DBG_EVENT 13 #define BREAKPOINT_EXCEPTION_DBG_EVENT 14 #define HARD_CODED_BREAKPOINT_DBG_EVENT 15 +#define SYSTEM_INITIALIZED_DBG_EVENT 35 #define SINGLE_STEP_DBG_EVENT 16 #define CREATE_PROCESS_DBG_EVENT 17 #define EXIT_PROCESS_DBG_EVENT 18 @@ -152,9 +153,9 @@ void checked_free(void*); // that the debugger nub should simply filter out this event because it's // uninteresting. -#define FILTER_HANDLED_DBG_EVENT 35 -#define FILTER_UNHANDLED_DBG_EVENT 36 -#define SPY_RETURN_DBG_EVENT 37 +#define FILTER_HANDLED_DBG_EVENT 36 +#define FILTER_UNHANDLED_DBG_EVENT 37 +#define SPY_RETURN_DBG_EVENT 38 #define EXCEPTIONS_HANDLED 1 #define EXCEPTIONS_UNHANDLED 2 diff --git a/sources/runtime-manager/debugger-nub/x86-win32/stop_reasons.c b/sources/runtime-manager/debugger-nub/x86-win32/stop_reasons.c index e845dca22f..221de7f9f2 100644 --- a/sources/runtime-manager/debugger-nub/x86-win32/stop_reasons.c +++ b/sources/runtime-manager/debugger-nub/x86-win32/stop_reasons.c @@ -243,16 +243,9 @@ void initialize_process_exception_information (LPDBGPROCESS process) i = INTEGER_OVERFLOW_EXCEPTION_DBG_EVENT; process->ExceptionInformation[i].ReceivingFirstChance = FALSE; process->ExceptionInformation[i].ReceivableFirstChance = TRUE; - -} - -NUBINT nub_first_hard_coded_breakpoint (NUB nub) -{ - LPDBGPROCESS process = (LPDBGPROCESS) nub; - if (process->HardCodedBreakpointCounter == 1) - return((NUBINT) 1); - else - return((NUBINT) 0); + i = SYSTEM_INITIALIZED_DBG_EVENT; + process->ExceptionInformation[i].ReceivingFirstChance = TRUE; + process->ExceptionInformation[i].ReceivableFirstChance = TRUE; } NUBINT stop_reason_to_nub_code (LPDEBUG_EVENT event) @@ -437,7 +430,10 @@ NUBINT process_this_first_chance_breakpoint // programmatic entry to the debugger. thread->StoppedState = THREAD_INVOKED_DEBUGGER; (process->HardCodedBreakpointCounter)++; - return (HARD_CODED_BREAKPOINT_DBG_EVENT); + if (process->HardCodedBreakpointCounter == 1) + return SYSTEM_INITIALIZED_DBG_EVENT; + else + return HARD_CODED_BREAKPOINT_DBG_EVENT; break; case INTERNAL_BREAKPOINT: diff --git a/sources/runtime-manager/devel-dbg-ui/command-reader.dylan b/sources/runtime-manager/devel-dbg-ui/command-reader.dylan index 82c543909f..70331969b6 100644 --- a/sources/runtime-manager/devel-dbg-ui/command-reader.dylan +++ b/sources/runtime-manager/devel-dbg-ui/command-reader.dylan @@ -98,6 +98,7 @@ define method read-console-commands () => () command := #f; while(~command) format-out("Command> "); + force-out(); let command-string = read-command(); let seq = tokenize(command-string); if ((seq.size > 1) & (check-lexical-correctness(seq))) diff --git a/sources/runtime-manager/devel-dbg-ui/debugger-message.dylan b/sources/runtime-manager/devel-dbg-ui/debugger-message.dylan index 802d274381..7979dee9b0 100644 --- a/sources/runtime-manager/devel-dbg-ui/debugger-message.dylan +++ b/sources/runtime-manager/devel-dbg-ui/debugger-message.dylan @@ -12,9 +12,10 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND // and extra formatting. Use as a direct substitute for format-out define method debugger-message (s :: , #rest stuff) - format-out (";;; "); - apply (format-out, s, stuff); - format-out ("\n") + format-out(";;; "); + apply(format-out, s, stuff); + format-out("\n"); + force-out(); end method; diff --git a/sources/runtime-manager/devel-dbg-ui/new-execute.dylan b/sources/runtime-manager/devel-dbg-ui/new-execute.dylan index cd2afeffa7..c719dbe177 100644 --- a/sources/runtime-manager/devel-dbg-ui/new-execute.dylan +++ b/sources/runtime-manager/devel-dbg-ui/new-execute.dylan @@ -2875,9 +2875,11 @@ define method execute-debugger-command let prompt = " [Y or N] > "; while (~valid-answer) format-out("%s", prompt); + force-out(); attempts := attempts + 1; answer := read-line(*standard-input*); format-out("\n"); + force-out(); if ((instance?(answer, )) & (size(answer) > 0) & (as-uppercase(answer[0]) == 'Y')) diff --git a/sources/runtime-manager/local-access-path/nub-ffi-defs.dylan b/sources/runtime-manager/local-access-path/nub-ffi-defs.dylan index d33e85ba40..4f50876f09 100644 --- a/sources/runtime-manager/local-access-path/nub-ffi-defs.dylan +++ b/sources/runtime-manager/local-access-path/nub-ffi-defs.dylan @@ -831,12 +831,6 @@ define debugger-nub-interface nub-stop-reason-process c-name: "nub_stop_reason_process"; end debugger-nub-interface; -define debugger-nub-interface nub-first-hard-coded-breakpoint - parameter nub :: ; - result is-first :: ; - c-name: "nub_first_hard_coded_breakpoint"; -end debugger-nub-interface; - define debugger-nub-interface nub-stop-reason-thread parameter nub :: ; result thread :: ; diff --git a/sources/runtime-manager/local-access-path/stop-reasons.dylan b/sources/runtime-manager/local-access-path/stop-reasons.dylan index 5eafa7068a..9c90a6c519 100644 --- a/sources/runtime-manager/local-access-path/stop-reasons.dylan +++ b/sources/runtime-manager/local-access-path/stop-reasons.dylan @@ -177,22 +177,6 @@ define method get-exception-violation-op (conn :: ) end method; -///// FIRST-DEBUGGER-INVOCATION? -// Is this the first time that the application has signalled a hard-coded -// breakpoint? -// If so, we will assume this breakpoint to be "special", and that it -// is a signal that the application, and all of its shared libraries, -// have loaded and performed their system-level initializations. On -// Windows, this is true for free. Debugger nubs on other platforms, -// however, might need to force the generation of this stop reason. - -define method first-debugger-invocation? - (conn :: ) => (well? :: ) - let int-answer = nub-first-hard-coded-breakpoint(conn.connection-process); - int-answer == 1 -end method; - - ///// CONNECTION-CAN-RECEIVE-FIRST-CHANCE // Calls the nub to determine whether an exception is first-chance // receivable. diff --git a/sources/runtime-manager/remote-access-path/stop-reasons.dylan b/sources/runtime-manager/remote-access-path/stop-reasons.dylan index bc46a28faf..c771633b4e 100644 --- a/sources/runtime-manager/remote-access-path/stop-reasons.dylan +++ b/sources/runtime-manager/remote-access-path/stop-reasons.dylan @@ -153,15 +153,6 @@ define method get-exception-violation-op (conn :: ) end method; -///// FIRST-DEBUGGER-INVOCATION? - -define method first-debugger-invocation? - (conn :: ) => (well? :: ) - let int-answer = Rtmgr/RemoteNub/first-hard-coded-breakpoint(conn.nub); - int-answer == 1 -end method; - - ///// CONNECTION-CAN-RECEIVE-FIRST-CHANCE define method connection-can-receive-first-chance