[PATCH] DebugTools package
Locked
 
|
This provides a class to control an inferior process. It also includes
a fast implementation of the "next" and "finish" using continuations instead of single-stepping. Paolo 2007-07-16 Paolo Bonzini <[hidden email]> * examples/MiniDebugger.st: Use DebugTools. * kernel/ContextPart.st: Add stub methods for #currentLine and #debugger. * kernel/ExcHandling.st: Use #stopInferior: if the process is already being debugged. * kernel/ProcSched.st: Add #activeDebugger. * kernel/Process.st: Add #debugger. * packages/browser/Debugger.st: Use DebugTools. * packages/browser/Notifier.st: Use DebugTools. * packages/browser/Load.st: Delimit namespaces with periods. * packages/debug/DebugTools.st: New. * packages/debug/debugtests.st: New. * looking for [hidden email]--2004b/smalltalk--devo--2.2--patch-471 to compare with * comparing to [hidden email]--2004b/smalltalk--devo--2.2--patch-471 A/ packages/debug A packages/debug/ChangeLog A packages/debug/DebugTools.st A packages/debug/debugtests.st A packages/debug/package.xml M tests/testsuite.at M tests/testsuite M packages/browser/package.xml M configure.ac M examples/MiniDebugger.st M ChangeLog M packages/browser/ChangeLog M packages/browser/Debugger.st M packages/browser/Load.st M packages/browser/Notifier.st M NEWS M TODO M kernel/ContextPart.st M kernel/ExcHandling.st M kernel/ProcSched.st M kernel/Process.st * modified files --- orig/NEWS +++ mod/NEWS @@ -81,6 +81,10 @@ o Added #from: to Collection, which co returns a string and is the same as using #, repeatedly, but is more efficient. +o A new package DebugTools provides a generic Debugger class that can + be used to control an inferior Smalltalk process. It is used by the + textual MiniDebugger. + o Continuations and generators have moved to the base image. More complex examples of continuations still reside in the Continuations package. --- orig/configure.ac +++ mod/configure.ac @@ -247,6 +247,7 @@ GST_PACKAGE([BloxTK], [blox/tk], [Makefile], [blox-tk.la]) GST_PACKAGE([Browser], [browser]) GST_PACKAGE([Continuations], [continuations]) +GST_PACKAGE([DebugTools], [debug]) GST_PACKAGE([DB], [db]) GST_PACKAGE([GDBM], [gdbm], [AC_CHECK_HEADER([gdbm.h])], --- orig/examples/MiniDebugger.st +++ mod/examples/MiniDebugger.st @@ -1,6 +1,6 @@ "====================================================================== | -| Minimal inspector and debugger +| Minimal inspector and debugger using DebugTools | | ======================================================================" @@ -8,7 +8,7 @@ "====================================================================== | -| Copyright 2002, 2006 Free Software Foundation, Inc. +| Copyright 2002, 2006, 2007 Free Software Foundation, Inc. | Written by Paolo Bonzini. | | This file is part of GNU Smalltalk. @@ -28,6 +28,7 @@ | ======================================================================" +PackageLoader fileInPackage: #DebugTools! Object subclass: #MiniTool instanceVariableNames: 'commandArg command' @@ -44,8 +45,7 @@ MiniTool subclass: #MiniInspector ! MiniTool subclass: #MiniDebugger - instanceVariableNames: 'process activeContext depth stepSemaphore - methodSourceCodeCache methodLineMapCache' + instanceVariableNames: 'debugger activeContext depth methodSourceCodeCache' classVariableNames: '' poolDictionaries: '' category: 'System-Debugging-Support' @@ -244,112 +244,78 @@ debuggingPriority !MiniDebugger class methodsFor: 'instance creation'! -openOn: process message: aString - [ - Processor activeProcess name: 'MiniDebugger'. - [ process isSuspended ] whileFalse: [ Processor yield ]. - aString printNl. - self new initializeFor: process; commandLoop - ] fork. - process suspend. +open: aString + [ :debugger || continuation arg | + Processor activeProcess name: 'Debugger'. + arg := Continuation currentDo: [ :cc | + continuation := cc. + aString ]. + arg printNl. + [ self new debugger: debugger; commandLoop ] + on: SystemExceptions.DebuggerReentered + do: [ :ex | continuation value: ex messageText ] + ] forkDebugger ! ! - -!MiniDebugger methodsFor: 'stepping commands'! +!MiniDebugger methodsFor: 'commands'! -up - activeContext parentContext isNil ifTrue: [ ^self ]. - activeContext := activeContext parentContext. - depth := depth + 1. +debugger: aDebugger + debugger := aDebugger. ! -down - depth > 0 ifFalse: [ ^self ]. - depth := depth - 1. - activeContext := process suspendedContext. - depth timesRepeat: [ activeContext := activeContext parentContext ] -! +commandLoop -stepBytecode - process singleStepWaitingOn: stepSemaphore. - process suspend. -! + "Show meaningful source code to the user." + [ debugger suspendedContext isInternalExceptionHandlingContext ] + whileTrue: [ debugger slowFinish ]. -step - | context line | - context := process suspendedContext. - line := self currentLine. + depth := 0. + activeContext := debugger suspendedContext. + debugger suspendedContext backtrace. + self printCurrentLine. [ - self stepBytecode. - activeContext := process suspendedContext. - activeContext == context and: [ line = self currentLine ] + self getCommand. + debugger isActive ] whileTrue. - depth := 0. + Processor activeProcess suspend ! -next - | context | - context := process suspendedContext. - [ - self step. - activeContext notNil and: [ activeContext parentContext == context ] - ] whileTrue: [ - self finish: activeContext - ] -! -finish: aContext - | context | - [ - context := process suspendedContext. - [ - self stepBytecode. - process suspendedContext == context - ] whileTrue. - - activeContext := process suspendedContext. - activeContext notNil "no context? exit" - and: [ activeContext parentContext == context "a send? go on" - or: [ (self depthOf: aContext) notNil ]] "aContext still in the chain? go on" - ] whileTrue -! +!MiniDebugger methodsFor: 'commands'! + +step + debugger step. + self resetContext! + +next + debugger next. + self resetContext! finish - self finish: activeContext -! + debugger finish: activeContext. + self resetContext! continue - | proc | - proc := Processor activeProcess. - [ proc terminate. process resume ] forkAt: Processor unpreemptedPriority. - - "Suspend just in case we get here." - proc suspend -! ! + debugger continue! - -!MiniDebugger methodsFor: 'source code'! +resetContext + activeContext := debugger suspendedContext. + depth := 0! -currentMethodSource - activeContext isNil ifTrue: [ ^#() ]. - ^methodSourceCodeCache at: activeContext method ifAbsentPut: [ - self linesOf: activeContext method methodSourceString - ] +up + activeContext parentContext isNil ifTrue: [ ^self ]. + activeContext := activeContext parentContext. + depth := depth + 1. ! -currentLine - | lineMap | - activeContext isNil ifTrue: [ ^self ]. - lineMap := methodLineMapCache at: activeContext method ifAbsentPut: [ - activeContext method sourceCodeMap - ]. - ^lineMap at: activeContext ip + 1 ifAbsent: [ activeContext inspect. 1 ] -! +down + depth > 0 ifFalse: [ ^self ]. + depth := depth - 1. + activeContext := debugger suspendedContext. + depth timesRepeat: [ activeContext := activeContext parentContext ] +! ! -linesOf: aString - aString isNil ifTrue: [ ^nil ]. - ^aString readStream lines contents -! +!MiniDebugger methodsFor: 'printing'! printCurrentMethod | source | @@ -366,9 +332,10 @@ printCurrentMethod printCurrentLine | line source | + activeContext isNil ifTrue: [ ^self ]. source := self currentMethodSource. source isNil ifTrue: [ ^self ]. - line := self currentLine. + line := Debugger currentLineIn: activeContext. line = 0 ifTrue: [ ^self ]. self rightJustify: line. @@ -409,7 +376,11 @@ doProcessCommand | id proc | ('TSKb' includes: command) ifFalse: [ ^false ]. - proc := process. + (commandArg isEmpty and: [ command == $b ]) ifTrue: [ + activeContext backtrace. + ^true ]. + + proc := debugger process. commandArg notEmpty ifTrue: [ id := Number readFrom: commandArg onError: nil. @@ -421,12 +392,12 @@ doProcessCommand proc suspendedContext isNil ifTrue: [ 'process was terminated' displayNl. ^true ]. - (command == $b) ifTrue: [ self backtraceOf: proc ]. + (command == $b) ifTrue: [ proc context backtrace ]. (command == $S) ifTrue: [ proc suspend ]. (command == $K) ifTrue: [ proc primTerminate ]. (command == $T) ifTrue: [ proc terminate. - proc == process ifTrue: [ self continue ] + proc == debugger process ifTrue: [ self continue ] ]. ^true ! @@ -455,14 +426,6 @@ doCommand ^true ! -commandLoop - [ - self getCommand. - process isTerminated - ] whileFalse. - Processor activeProcess suspend -! - eofCommand ^'T' ! @@ -503,43 +466,14 @@ Other commands: x ..... exit Smalltalk' ! ! - !MiniDebugger methodsFor: 'private'! -initializeFor: aProcess - process := aProcess. - stepSemaphore := Semaphore new. - methodSourceCodeCache := IdentityDictionary new. - methodLineMapCache := IdentityDictionary new. - activeContext := process suspendedContext. - depth := 0. - - [ activeContext isInternalExceptionHandlingContext ] - whileTrue: [ self finish ]. - - self backtraceOf: process. - self printCurrentLine. -! - -backtraceOf: aProcess - | context | - context := aProcess == process - ifTrue: [ activeContext ] - ifFalse: [ aProcess suspendedContext ]. - - context backtrace -! - -depthOf: aContext - | context depth | - context := activeContext. - depth := 0. - [ context == aContext ] whileFalse: [ - context := context parentContext. - context isNil ifTrue: [ ^nil ]. - depth := depth + 1. - ]. - ^depth +currentMethodSource + activeContext isNil ifTrue: [ ^#() ]. + methodSourceCodeCache isNil ifTrue: [ + methodSourceCodeCache := WeakKeyIdentityDictionary new ]. + ^methodSourceCodeCache at: activeContext method ifAbsentPut: [ + activeContext method methodSourceString lines ] ! rightJustify: n @@ -551,13 +485,24 @@ rightJustify: n ! showProcesses - self rightJustify: process asOop. '>' display. process printNl. + self rightJustify: debugger process asOop. + '>' display. + debugger process printNl. + Process allSubinstancesDo: [ :each | - each == process - ifFalse: [ self rightJustify: each asOop. ' ' display. each printNl ] - ] + each == debugger process ifFalse: [ + self rightJustify: each asOop. + ' ' display. + each printNl ] ] ! ! +!UndefinedObject methodsFor: 'polymorphism'! + +lines + ^nil +! ! + + !Behavior methodsFor: 'debugging'! --- orig/kernel/ContextPart.st +++ mod/kernel/ContextPart.st @@ -139,6 +139,19 @@ backtraceOn: aStream !ContextPart methodsFor: 'debugging'! +currentLine + "Answer the 1-based number of the line that is pointed to by the receiver's + instruction pointer. It is always 1 unless the DebugTools package is + loaded." + ^1 +! + +debugger + "Answer the debugger that is attached to the given context. It + is always nil unless the DebugTools package is loaded." + ^nil +! + debuggerClass "Answer which debugger should be used to debug the current context chain. The class with the highest debugging @@ -147,15 +160,15 @@ debuggerClass ctx := self. last := self class lastUnwindPoint. [ - currentClass := ctx receiver class debuggerClass. - currentClass isNil ifTrue: [ ^nil ]. - (debuggerClass isNil - or: [ currentClass debuggingPriority > debuggerClass debuggingPriority ]) - ifTrue: [ debuggerClass := currentClass ]. + currentClass := ctx receiver class debuggerClass. + currentClass isNil ifTrue: [ ^nil ]. + (debuggerClass isNil + or: [ currentClass debuggingPriority > debuggerClass debuggingPriority ]) + ifTrue: [ debuggerClass := currentClass ]. - ctx == last | ctx isNil + ctx == last | ctx isNil ] whileFalse: [ - ctx := ctx parentContext + ctx := ctx parentContext ]. ^debuggerClass ! --- orig/kernel/ExcHandling.st +++ mod/kernel/ExcHandling.st @@ -720,15 +720,16 @@ primError: message "This might start the debugger... Note that we use #basicPrint 'cause #printOn: might invoke an error." - | debuggerClass context | + | debugger debuggerClass context | Transcript initialize. stdout flush. + + debugger := Processor activeDebugger. + debugger isNil ifFalse: [ ^debugger stopInferior: message ]. + debuggerClass := thisContext debuggerClass. debuggerClass isNil ifFalse: [ - ^debuggerClass - openOn: Processor activeProcess - message: self class printString, ' error: ', message - ]. + ^debuggerClass open: self class printString, ' error: ', message ]. "Default behavior - print backtrace" RegressionTesting ifFalse: [ self basicPrint ]. --- orig/kernel/ProcSched.st +++ mod/kernel/ProcSched.st @@ -58,6 +58,11 @@ activeProcess ^activeProcess ! +activeDebugger + "Answer the active process' debugger" + ^self activeProcess debugger +! + activePriority "Answer the active process' priority" ^self activeProcess priority --- orig/kernel/Process.st +++ mod/kernel/Process.st @@ -58,6 +58,11 @@ on: aBlockClosure at: aPriority suspend: !Process methodsFor: 'basic'! +debugger + "Return the object in charge of debugging the receiver. This always returns + nil unless the debugging package is loaded." + ^self context debugger! + context "Return the execution context of the receiver." ^self == Processor activeProcess --- orig/packages/browser/Debugger.st +++ mod/packages/browser/Debugger.st @@ -30,10 +30,9 @@ " GuiData subclass: #Debugger - instanceVariableNames: 'stacktrace contexts process stepSemaphore + instanceVariableNames: 'stacktrace contexts debugger activeContext receiverInspector stackInspector - listView theClass theMethod textView topView - methodLineMapCache' + listView theClass theMethod textView topView' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Browser'! @@ -75,12 +74,10 @@ new: notifier !Debugger methodsFor: 'initialize/release'! init: notifier - process := notifier process. - stepSemaphore := Semaphore new. - methodLineMapCache := IdentityDictionary new. + debugger := notifier debugger. - [ process suspendedContext isInternalExceptionHandlingContext ] - whileTrue: [ self finish ]. + [ debugger suspendedContext isInternalExceptionHandlingContext ] + whileTrue: [ debugger slowFinish ]. self createWindowFrom: notifier. ! @@ -191,7 +188,7 @@ contextSelectedFrom: assoc highlight: context | line | - line := self lineFor: context. + line := context currentLine. textView blox gotoLine: line end: false; selectFrom: 1 @ line to: 1 @ (line + 1)! @@ -219,39 +216,51 @@ debugSelectors #() #('Terminate' #terminateButtonCallback)) ! +updateAfter: aBlock + "If there's an exception, replace this window with another + notifier." + aBlock + on: SystemExceptions.DebuggerReentered + do: [ :ex | + topView close. + Notifier openOn: debugger process. + ^self ]. + + self updateContextList! + stepButtonCallback - self step; updateContextList + self updateAfter: [ debugger step ] ! nextButtonCallback - self next; updateContextList + self updateAfter: [ debugger next ] ! finishButtonCallback - self finish; updateContextList + self updateAfter: [ debugger finish: activeContext ] ! continueButtonCallback topView close. - self continue. + debugger continue. ! killButtonCallback topView close. - process primTerminate + debugger process primTerminate ! terminateButtonCallback topView close. - process terminate. - self continue + debugger process terminate. + debugger continue ! ! !Debugger methodsFor: 'list pane'! updateContextList | context lastContext | - context := process suspendedContext. + context := debugger suspendedContext. lastContext := context environment. stacktrace := OrderedCollection new. contexts := OrderedCollection new. @@ -265,7 +274,7 @@ updateContextList ]. self changeState: #stacktrace. - self currentContext: process suspendedContext! + self currentContext: debugger suspendedContext! currentContext: context activeContext := context. @@ -278,93 +287,6 @@ currentContext: context self highlight: context! ! -!Debugger methodsFor: 'debugging operations'! - -depthOf: aContext - | context depth | - context := activeContext. - depth := 0. - [ context == aContext ] whileFalse: [ - context := context parentContext. - context isNil ifTrue: [ ^nil ]. - depth := depth + 1. - ]. - ^depth -! - -currentLine - ^self lineFor: process suspendedContext! - -lineFor: context - | lineMap | - context isNil ifTrue: [ ^1 ]. - lineMap := methodLineMapCache at: context method - ifAbsentPut: [ context method sourceCodeMap ]. - ^lineMap at: context ip + 1 ifAbsent: [ 1 ]! - -stepBytecode - "Execute a bytecode of the debugged process" - process singleStepWaitingOn: stepSemaphore. - process suspend. -! - -step - "Execute a line of the debugged process, going inside a message - that is sent." - | context line | - context := process suspendedContext. - line := self currentLine. - [ - self stepBytecode. - activeContext := process suspendedContext. - activeContext == context and: [ line = self currentLine ] - ] whileTrue. -! - -next - "Execute a line of the debugged process, stepping over a message - that is sent." - | context | - context := process suspendedContext. - [ - self step. - activeContext notNil and: [ activeContext parentContext == context ] - ] whileTrue: [ - self finish: activeContext - ] -! - -finish: aContext - "Execute the debugged process until it returns from aContext" - | context | - [ - context := process suspendedContext. - [ - self stepBytecode. - process suspendedContext == context - ] whileTrue. - - activeContext := process suspendedContext. - activeContext notNil "no context? exit" - and: [ activeContext parentContext == context "a send? go on" - or: [ (self depthOf: aContext) notNil ]] "aContext still in the chain? go on" - ] whileTrue -! - -finish - "Execute the debugged process until it returns from the active context" - self finish: activeContext -! - -continue - | proc | - proc := Processor activeProcess. - [ proc terminate. process resume ] forkAt: Processor unpreemptedPriority. - - "Suspend just in case we get here." - proc suspend -! ! - !PrimitiveInspectorFieldList methodsFor: 'primitives'! validSize: anObject --- orig/packages/browser/Load.st +++ mod/packages/browser/Load.st @@ -36,4 +36,4 @@ Class allSubclassesDo: [ :each | ]! (BLOX.BLOXBrowser includesKey: #BrowserMain) - ifTrue: [ BLOX BLOXBrowser BrowserMain close ]! + ifTrue: [ BLOX.BLOXBrowser.BrowserMain close ]! --- orig/packages/browser/Notifier.st +++ mod/packages/browser/Notifier.st @@ -30,8 +30,8 @@ " GuiData subclass: #Notifier - instanceVariableNames: 'callstackList process stacktrace - currentSelection errMessage topView ' + instanceVariableNames: 'callstackList debugger stacktrace + currentSelection errMessage topView listView ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Browser'! @@ -51,40 +51,36 @@ debuggingPriority !Notifier class methodsFor: 'instance creation'! -openOn: process message: message - | handleErrorsWithGui | - handleErrorsWithGui := BLOX BLOXBrowser BrowserMain handleErrorsWithGui. - BLOX BLOXBrowser BrowserMain handleErrorsWithGui: false. - [ - Processor activeProcess name: 'Notifier/Debugger'. - [ process isSuspended ] whileFalse: [ Processor yield ]. +openOn: aProcess message: message + self new init: message debugger: (Smalltalk.Debugger on: aProcess)! - self new - init: message - process: process. +open + self open: ('Notifier on %1' % { Processor activeProcess })! - BLOX BLOXBrowser BrowserMain handleErrorsWithGui: handleErrorsWithGui. - ] fork. - - process suspend. +open: message + | handleErrorsWithGui | + handleErrorsWithGui := BLOX.BLOXBrowser.BrowserMain handleErrorsWithGui. + BLOX.BLOXBrowser.BrowserMain handleErrorsWithGui: false. + [ :debugger | + Processor activeProcess name: 'Notifier/Debugger'. + self new init: message debugger: debugger. + BLOX.BLOXBrowser.BrowserMain handleErrorsWithGui: handleErrorsWithGui. + ] forkDebugger ! ! !Notifier methodsFor: 'accessing'! currentContext - currentSelection isNil ifTrue: [^nil]. + currentSelection isNil ifTrue: [currentSelection := 1]. ^callstackList at: currentSelection! ! !Notifier methodsFor: 'callback'! -contexts - ^callstackList elements! - -nameList - ^callstackList labels! - process - ^process! + ^debugger process! + +debugger + ^debugger! contextSelectedFrom: assoc currentSelection := assoc key! @@ -102,11 +98,11 @@ close: aView tv := aView rootView blox. aView rootView close ifTrue: [tv destroy]! -init: aString process: aProcess +init: aString debugger: aDebugger | context lastContext contexts | errMessage := aString. - process := aProcess. - context := process suspendedContext. + debugger := aDebugger. + context := debugger suspendedContext. lastContext := context environment. stacktrace := OrderedCollection new. contexts := OrderedCollection new. @@ -129,10 +125,12 @@ init: aString process: aProcess self createWindow. callstackList contents: stacktrace elements: contexts. - topView display! + topView display. + listView update. + listView select: 1! createWindow - | topLevel listView | + | topLevel | topView := (BrowserShell new: errMessage) data: self. topLevel := topView blox. topLevel --- orig/packages/browser/package.xml +++ mod/packages/browser/package.xml @@ -1,8 +1,11 @@ <package> <name>Browser</name> <namespace>BLOX.BLOXBrowser</namespace> + <prereq>Blox</prereq> <prereq>Parser</prereq> + <prereq>DebugTools</prereq> + <filein>Load.st</filein> <filein>GuiData.st</filein> <filein>View.st</filein> --- orig/tests/testsuite +++ mod/tests/testsuite @@ -620,7 +620,7 @@ at_times_file=$at_suite_dir/at-times # List of the tested programs. at_tested='gst' # List of the all the test groups. -at_groups_all=' banner-1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 banner-2 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 banner-3 41 42 banner-4 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 banner-5 108 109 110 111 112 113' +at_groups_all=' banner-1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 banner-2 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 banner-3 41 42 banner-4 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 banner-5 108 109 110 111 112 113 114' # As many question marks as there are digits in the last test group number. # Used to normalize the test group numbers so that `ls' lists them in # numerical order. @@ -734,11 +734,12 @@ at_help_all="1;testsuite.at:27;arrays.st 106;testsuite.at:138;ZeroDivideANSITest;ANSI SUnit; 107;testsuite.at:139;ZeroDivideFactoryANSITest;ANSI SUnit; 108;testsuite.at:142;Continuations;Continuations SUnit; -109;testsuite.at:143;DhbNumericalMethods;DhbNumericalMethods SUnit; -110;testsuite.at:144;GDBM;GDBM SUnit; -111;testsuite.at:145;MD5;MD5 SUnit; -112;testsuite.at:146;ZLib;ZLib SUnit; -113;testsuite.at:147;Iconv;Iconv SUnit; +109;testsuite.at:143;DebugTools;DebugTools SUnit; +110;testsuite.at:144;DhbNumericalMethods;DhbNumericalMethods SUnit; +111;testsuite.at:145;GDBM;GDBM SUnit; +112;testsuite.at:146;Iconv;Iconv SUnit; +113;testsuite.at:147;MD5;MD5 SUnit; +114;testsuite.at:148;ZLib;ZLib SUnit; " at_prev= @@ -8527,10 +8528,10 @@ $at_traceon at_status=`cat "$at_status_file"` ;; - 109 ) # 109. testsuite.at:143: DhbNumericalMethods + 109 ) # 109. testsuite.at:143: DebugTools at_setup_line='testsuite.at:143' - at_desc="DhbNumericalMethods" - $at_quiet $ECHO_N "109: DhbNumericalMethods $ECHO_C" + at_desc="DebugTools" + $at_quiet $ECHO_N "109: DebugTools $ECHO_C" at_xfail=no echo "# -*- compilation -*-" >> "$at_group_log" ( @@ -8546,12 +8547,12 @@ $at_traceon esac $at_traceoff -echo "$at_srcdir/testsuite.at:143: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit \$? > retcode; } | tr -d '\\r'; . retcode" +echo "$at_srcdir/testsuite.at:143: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p DebugTools); echo exit \$? > retcode; } | tr -d '\\r'; . retcode" echo testsuite.at:143 >"$at_check_line_file" at_trace_this= if test -n "$at_traceon"; then - case "{ (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? > retcode; } | tr -d '\\r'; . retcode" in + case "{ (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DebugTools); echo exit $? > retcode; } | tr -d '\\r'; . retcode" in *' '*) echo 'Not enabling shell tracing (command contains an embedded newline)' ;; *) at_trace_this=yes ;; @@ -8559,12 +8560,12 @@ if test -n "$at_traceon"; then fi if test -n "$at_trace_this"; then - ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1" + ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DebugTools); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1" at_status=$? grep '^ *+' "$at_stder1" >&2 grep -v '^ *+' "$at_stder1" >"$at_stderr" else - ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr" + ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DebugTools); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr" at_status=$? fi @@ -8593,10 +8594,10 @@ $at_traceon at_status=`cat "$at_status_file"` ;; - 110 ) # 110. testsuite.at:144: GDBM + 110 ) # 110. testsuite.at:144: DhbNumericalMethods at_setup_line='testsuite.at:144' - at_desc="GDBM" - $at_quiet $ECHO_N "110: GDBM $ECHO_C" + at_desc="DhbNumericalMethods" + $at_quiet $ECHO_N "110: DhbNumericalMethods $ECHO_C" at_xfail=no echo "# -*- compilation -*-" >> "$at_group_log" ( @@ -8612,36 +8613,25 @@ $at_traceon esac $at_traceoff -echo "$at_srcdir/testsuite.at:144: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p GDBM - ret=\$? - case \$ret in - 2) exit 77 ;; - 0|1) exit \$ret ;; - esac); echo exit \$? > retcode; } | tr -d '\\r'; . retcode" +echo "$at_srcdir/testsuite.at:144: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit \$? > retcode; } | tr -d '\\r'; . retcode" echo testsuite.at:144 >"$at_check_line_file" at_trace_this= if test -n "$at_traceon"; then - echo 'Not enabling shell tracing (command contains an embedded newline)' + case "{ (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? > retcode; } | tr -d '\\r'; . retcode" in + *' +'*) echo 'Not enabling shell tracing (command contains an embedded newline)' ;; + *) at_trace_this=yes ;; + esac fi if test -n "$at_trace_this"; then - ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p GDBM - ret=$? - case $ret in - 2) exit 77 ;; - 0|1) exit $ret ;; - esac); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1" + ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1" at_status=$? grep '^ *+' "$at_stder1" >&2 grep -v '^ *+' "$at_stder1" >"$at_stderr" else - ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p GDBM - ret=$? - case $ret in - 2) exit 77 ;; - 0|1) exit $ret ;; - esac); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr" + ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p DhbNumericalMethods); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr" at_status=$? fi @@ -8670,10 +8660,10 @@ $at_traceon at_status=`cat "$at_status_file"` ;; - 111 ) # 111. testsuite.at:145: MD5 + 111 ) # 111. testsuite.at:145: GDBM at_setup_line='testsuite.at:145' - at_desc="MD5" - $at_quiet $ECHO_N "111: MD5 $ECHO_C" + at_desc="GDBM" + $at_quiet $ECHO_N "111: GDBM $ECHO_C" at_xfail=no echo "# -*- compilation -*-" >> "$at_group_log" ( @@ -8689,25 +8679,36 @@ $at_traceon esac $at_traceoff -echo "$at_srcdir/testsuite.at:145: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p MD5); echo exit \$? > retcode; } | tr -d '\\r'; . retcode" +echo "$at_srcdir/testsuite.at:145: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p GDBM + ret=\$? + case \$ret in + 2) exit 77 ;; + 0|1) exit \$ret ;; + esac); echo exit \$? > retcode; } | tr -d '\\r'; . retcode" echo testsuite.at:145 >"$at_check_line_file" at_trace_this= if test -n "$at_traceon"; then - case "{ (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d '\\r'; . retcode" in - *' -'*) echo 'Not enabling shell tracing (command contains an embedded newline)' ;; - *) at_trace_this=yes ;; - esac + echo 'Not enabling shell tracing (command contains an embedded newline)' fi if test -n "$at_trace_this"; then - ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1" + ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p GDBM + ret=$? + case $ret in + 2) exit 77 ;; + 0|1) exit $ret ;; + esac); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1" at_status=$? grep '^ *+' "$at_stder1" >&2 grep -v '^ *+' "$at_stder1" >"$at_stderr" else - ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr" + ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p GDBM + ret=$? + case $ret in + 2) exit 77 ;; + 0|1) exit $ret ;; + esac); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr" at_status=$? fi @@ -8736,10 +8737,10 @@ $at_traceon at_status=`cat "$at_status_file"` ;; - 112 ) # 112. testsuite.at:146: ZLib + 112 ) # 112. testsuite.at:146: Iconv at_setup_line='testsuite.at:146' - at_desc="ZLib" - $at_quiet $ECHO_N "112: ZLib $ECHO_C" + at_desc="Iconv" + $at_quiet $ECHO_N "112: Iconv $ECHO_C" at_xfail=no echo "# -*- compilation -*-" >> "$at_group_log" ( @@ -8755,7 +8756,7 @@ $at_traceon esac $at_traceoff -echo "$at_srcdir/testsuite.at:146: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p ZLib +echo "$at_srcdir/testsuite.at:146: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p Iconv ret=\$? case \$ret in 2) exit 77 ;; @@ -8769,7 +8770,7 @@ if test -n "$at_traceon"; then fi if test -n "$at_trace_this"; then - ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p ZLib + ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p Iconv ret=$? case $ret in 2) exit 77 ;; @@ -8779,7 +8780,7 @@ if test -n "$at_trace_this"; then grep '^ *+' "$at_stder1" >&2 grep -v '^ *+' "$at_stder1" >"$at_stderr" else - ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p ZLib + ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p Iconv ret=$? case $ret in 2) exit 77 ;; @@ -8813,10 +8814,10 @@ $at_traceon at_status=`cat "$at_status_file"` ;; - 113 ) # 113. testsuite.at:147: Iconv + 113 ) # 113. testsuite.at:147: MD5 at_setup_line='testsuite.at:147' - at_desc="Iconv" - $at_quiet $ECHO_N "113: Iconv $ECHO_C" + at_desc="MD5" + $at_quiet $ECHO_N "113: MD5 $ECHO_C" at_xfail=no echo "# -*- compilation -*-" >> "$at_group_log" ( @@ -8832,13 +8833,79 @@ $at_traceon esac $at_traceoff -echo "$at_srcdir/testsuite.at:147: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p Iconv +echo "$at_srcdir/testsuite.at:147: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p MD5); echo exit \$? > retcode; } | tr -d '\\r'; . retcode" +echo testsuite.at:147 >"$at_check_line_file" + +at_trace_this= +if test -n "$at_traceon"; then + case "{ (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d '\\r'; . retcode" in + *' +'*) echo 'Not enabling shell tracing (command contains an embedded newline)' ;; + *) at_trace_this=yes ;; + esac +fi + +if test -n "$at_trace_this"; then + ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stder1" + at_status=$? + grep '^ *+' "$at_stder1" >&2 + grep -v '^ *+' "$at_stder1" >"$at_stderr" +else + ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p MD5); echo exit $? > retcode; } | tr -d '\r'; . retcode ) >"$at_stdout" 2>"$at_stderr" + at_status=$? +fi + +at_failed=false +$at_diff "$at_devnull" "$at_stderr" || at_failed=: +echo stdout:; cat "$at_stdout" +case $at_status in + 77) echo 77 > "$at_status_file"; exit 77;; + 0) ;; + *) echo "$at_srcdir/testsuite.at:147: exit code was $at_status, expected 0" + at_failed=:;; +esac +if $at_failed; then + + + echo 1 > "$at_status_file" + exit 1 +fi + +$at_traceon + + + $at_traceoff + $at_times_p && times >"$at_times_file" + ) 5>&1 2>&1 | eval $at_tee_pipe + at_status=`cat "$at_status_file"` + ;; + + 114 ) # 114. testsuite.at:148: ZLib + at_setup_line='testsuite.at:148' + at_desc="ZLib" + $at_quiet $ECHO_N "114: ZLib $ECHO_C" + at_xfail=no + echo "# -*- compilation -*-" >> "$at_group_log" + ( + echo "114. testsuite.at:148: testing ..." + $at_traceon + + + + + case $AUTOTEST_PATH in + tests) image_path="-I $abs_top_builddir/gst.im" ;; + *) image_path="" ;; + esac + + $at_traceoff +echo "$at_srcdir/testsuite.at:148: { (cd \$abs_top_builddir && gst \$image_path -f \$abs_top_srcdir/scripts/Test.st -p ZLib ret=\$? case \$ret in 2) exit 77 ;; 0|1) exit \$ret ;; esac); echo exit \$? > retcode; } | tr -d '\\r'; . retcode" -echo testsuite.at:147 >"$at_check_line_file" +echo testsuite.at:148 >"$at_check_line_file" at_trace_this= if test -n "$at_traceon"; then @@ -8846,7 +8913,7 @@ if test -n "$at_traceon"; then fi if test -n "$at_trace_this"; then - ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p Iconv + ( $at_traceon; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p ZLib ret=$? case $ret in 2) exit 77 ;; @@ -8856,7 +8923,7 @@ if test -n "$at_trace_this"; then grep '^ *+' "$at_stder1" >&2 grep -v '^ *+' "$at_stder1" >"$at_stderr" else - ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p Iconv + ( :; { (cd $abs_top_builddir && gst $image_path -f $abs_top_srcdir/scripts/Test.st -p ZLib ret=$? case $ret in 2) exit 77 ;; @@ -8871,7 +8938,7 @@ echo stdout:; cat "$at_stdout" case $at_status in 77) echo 77 > "$at_status_file"; exit 77;; 0) ;; - *) echo "$at_srcdir/testsuite.at:147: exit code was $at_status, expected 0" + *) echo "$at_srcdir/testsuite.at:148: exit code was $at_status, expected 0" at_failed=:;; esac if $at_failed; then --- orig/tests/testsuite.at +++ mod/tests/testsuite.at @@ -140,8 +140,9 @@ AT_ANSI_TEST([ZeroDivideFactoryANSITest] AT_BANNER([Other packages.]) AT_PACKAGE_TEST([Continuations]) +AT_PACKAGE_TEST([DebugTools]) AT_PACKAGE_TEST([DhbNumericalMethods]) AT_OPTIONAL_PACKAGE_TEST([GDBM]) +AT_OPTIONAL_PACKAGE_TEST([Iconv]) AT_PACKAGE_TEST([MD5]) AT_OPTIONAL_PACKAGE_TEST([ZLib]) -AT_OPTIONAL_PACKAGE_TEST([Iconv]) * added files --- /dev/null +++ mod/packages/debug/DebugTools.st @@ -0,0 +1,353 @@ +"====================================================================== +| +| Inferior process control +| +| + ======================================================================" + + +"====================================================================== +| +| Copyright 2002, 2006, 2007 Free Software Foundation, Inc. +| Written by Paolo Bonzini. +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + + +Object subclass: #Debugger + instanceVariableNames: 'debugProcess process breakpointContext + stepSemaphore ' + classVariableNames: 'MethodLineMapCache' + poolDictionaries: '' + category: 'System-Debugging' +! + +Debugger comment: +'I provide debugging facilities for another inferior process. I have +methods that allow the controlled process to proceed with varying +granularity. In addition, I keep a cache mapping instruction +pointer bytecodes to line numbers.'! + +Namespace current: SystemExceptions! + +Notification subclass: #DebuggerReentered + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'System-Debugging' +! + +DebuggerReentered comment: +'This notification is raised when the debugger is started on a process +that was already being debugged. Trapping it allows the pre-existing +debugger to keep control of the process.'! + +!DebuggerReentered methodsFor: 'description'! + +description + "Answer a textual description of the exception." + ^'the debugger was started on an already debugged process'! ! + +Namespace current: Smalltalk! + +!Debugger class methodsFor: 'source code'! + +currentLineIn: aContext + | lineMap method | + method := aContext method. + MethodLineMapCache isNil ifTrue: [ + MethodLineMapCache := WeakKeyIdentityDictionary new ]. + lineMap := MethodLineMapCache + at: method + ifAbsentPut: [ method sourceCodeMap ]. + ^lineMap + at: aContext ip + 1 + ifAbsent: [ 1 ] +! ! + +!Debugger class methodsFor: 'instance creation'! + +on: aProcess + "Suspend aProcess and return a new Debugger that controls aProcess. + aProcess must not be the currently running process." + aProcess == Processor activeProcess + ifTrue: [self error: 'cannot attach to current process']. + aProcess suspend. + ^self new initializeFor: aProcess! ! + +!Debugger class methodsFor: 'disabling debugging'! + +debuggerClass + ^nil +! ! + +!Debugger methodsFor: 'inferior process properties'! + +isActive + "Answer true if the inferior process is still running." + ^process notNil and: [ process suspendedContext notNil ] +! + +process + "Answer the inferior process." + ^process +! + +currentLine + "Return the line number in traced process." + self isActive ifFalse: [ ^'' ]. + ^self suspendedContext currentLine +! + +suspendedContext + "Answer the suspended execution state of the inferior process." + ^process suspendedContext +! ! + +!Debugger methodsFor: 'stepping commands'! + +stopInferior + "Suspend the inferior process and raise a DebuggerReentered notification + in the controlling process." + self stopInferior: nil +! + +stopInferior: anObject + "Suspend the inferior process and raise a DebuggerReentered notification + in the controlling process with anObject as the exception's message." + | exception | + [ + [ + process suspend. + debugProcess + queueInterrupt: [ + self disableBreakpointContext. + SystemExceptions.DebuggerReentered signal: anObject ]; + resume. + ] on: Exception do: [ :ex | + exception := ex. + process resume + ]. + ] forkAt: Processor unpreemptedPriority. + + "Pass the exception on in the calling process." + exception isNil ifFalse: [ exception signal ] +! + +stepBytecode + "Run a single bytecode in the inferior process." + debugProcess := Processor activeProcess. + process singleStepWaitingOn: stepSemaphore. + process suspend. + debugProcess := nil. +! + +step + "Run to the end of the current line in the inferior process or to the + next message send." + | context line | + context := self suspendedContext. + line := self currentLine. + [ + self stepBytecode. + self suspendedContext == context and: [ line = self currentLine ] + ] whileTrue +! + +next + "Run to the end of the current line in the inferior process, skipping + over message sends." + | context line | + context := self suspendedContext. + line := self currentLine. + [ + self stepBytecode. + (self suspendedContext notNil + and: [ self suspendedContext parentContext == context ]) + ifTrue: [ self finish: self suspendedContext ]. + self suspendedContext == context and: [ line = self currentLine ] + ] whileTrue +! + +finish + "Run to the next return." + self finish: self suspendedContext +! + +finish: aContext + "Run up until aContext returns." + <debugging: true> + | proc cont context retVal | + + "First, use the slow scheme for internal exception handling contexts. + These are more delicate and in general pretty small, so it is not + expensive." + aContext isInternalExceptionHandlingContext + ifTrue: [ ^self slowFinish: aContext ]. + [ self suspendedContext isInternalExceptionHandlingContext ] + whileTrue: [ self slowFinish: self suspendedContext ]. + + "Create a context that will restart the debugger and place it in the + chain. We don't really use the continuation object directly but, + if we use the methods in Continuation, we are sure that contexts + are set up correctly." + debugProcess := Processor activeProcess. + retVal := Continuation currentDo: [ :cc | cont := cc ]. + Processor activeProcess == debugProcess + ifTrue: [ + "Put our context below aContext and restart the debugged process." + context := cont stack. + + context instVarAt: MethodContext instSize put: 2. + context parentContext: aContext parentContext. + aContext parentContext: context. + [ + breakpointContext := aContext. + debugProcess suspend. + process resume. + ] forkAt: Processor unpreemptedPriority. + + "Finish the continuation context, which is at the `retVal' line + below." + debugProcess := nil. + self slowFinish: context ] + + ifFalse: [ + "We arrive here when we finish execution of aContext. Put the + debugger process in control again." + [ + breakpointContext := nil. + process suspend. + debugProcess resume + ] forkAt: Processor unpreemptedPriority. + ^retVal ] +! + +slowFinish + "Run in single-step mode up to the next return." + self slowFinish: self suspendedContext +! + +slowFinish: aContext + "Run in single-step mode until aContext returns." + | context newContext | + context := self suspendedContext. + [ + [ + self stepBytecode. + self suspendedContext == context + ] whileTrue. + + newContext := self suspendedContext. + + newContext notNil "no context? exit" + and: [ + "a send? go on" + newContext parentContext == context or: [ + "aContext still in the chain? go on" + self includes: aContext ] ] + ] whileTrue. +! + +continue + "Terminate the controlling process and continue execution of the + traced process." + | theDebugProcess theProcess | + theDebugProcess := Processor activeProcess. + theProcess := process. + [ + debugProcess := nil. + process := nil. + theDebugProcess terminate. + theProcess resume + ] forkAt: Processor unpreemptedPriority. + + "Just in case we get here." + theDebugProcess primTerminate +! ! + + +!Debugger methodsFor: 'private'! + +disableBreakpointContext + "Remove the context inserted set by #finish:." + | theBreakpointContext | + theBreakpointContext := breakpointContext. + breakpointContext := nil. + debugProcess := nil. + + theBreakpointContext isNil ifFalse: [ + theBreakpointContext + parentContext: theBreakpointContext parentContext parentContext ]! + +includes: aContext + "Answer whether aContext is still in the stack of the traced process." + | context | + context := self suspendedContext. + [ + context isNil ifTrue: [ ^false ]. + context == aContext ifTrue: [ ^true ]. + context := context parentContext. + ] repeat +! + +initializeFor: aProcess + process := aProcess. + stepSemaphore := Semaphore new! + + +!ContextPart methodsFor: 'source code'! + +currentLine + "Answer the 1-based number of the line that is pointed to by the receiver's + instruction pointer." + ^Debugger currentLineIn: self +! + +!ContextPart methodsFor: 'debugging'! + +debugger + "Answer the debugger that is attached to the given context. It + is always nil unless the DebugTools package is loaded." + | ctx home | + ctx := self. + [ ctx isNil ] whileFalse: [ + home := ctx home. + (home notNil and: [ + (home method attributeAt: #debugging: ifAbsent: [ nil ]) notNil]) + ifTrue: [ ^ctx receiver ]. + + ctx := ctx parentContext ]. + ^nil +! ! + +!BlockClosure methodsFor: 'instance creation'! + +forkDebugger + "Suspend the currently running process and fork the receiver into a new + process, passing a Debugger object that controls the currently running + process." + | process | + process := Processor activeProcess. + [ + process suspend. + Processor activeProcess priority: process priority. + self value: (Debugger on: process) + ] forkAt: Processor unpreemptedPriority. +! ! + --- /dev/null +++ mod/packages/debug/debugtests.st @@ -0,0 +1,248 @@ +"====================================================================== +| +| DebugTools package unit tests +| +| + ======================================================================" + + +"====================================================================== +| +| Copyright 2007 Free Software Foundation, Inc. +| Written by Paolo Bonzini +| +| This file is part of GNU Smalltalk. +| +| GNU Smalltalk is free software; you can redistribute it and/or modify it +| under the terms of the GNU General Public License as published by the Free +| Software Foundation; either version 2, or (at your option) any later version. +| +| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT +| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +| details. +| +| You should have received a copy of the GNU General Public License along with +| GNU Smalltalk; see the file COPYING. If not, write to the Free Software +| Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +| + ======================================================================" + +PackageLoader fileInPackage: #SUnit! + +TestCase subclass: #DebuggerTest + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'System-Debugging-Test'! + +!DebuggerTest methodsFor: 'test'! + +debuggerOn: aBlock + "Attach aBlock to a debugger and step until aBlock's execution begins." + | debugger | + debugger := Debugger + on: [ Processor activeProcess suspend. aBlock value ] fork. + [ debugger suspendedContext method == aBlock block ] + whileFalse: [ debugger stepBytecode ]. + ^debugger! + +testOn + "Test that #debuggerOn: works as we intend." + | debugger notReached | + notReached := false. + debugger := self debuggerOn: [ notReached := true ]. + self assert: debugger suspendedContext isBlock. + self deny: notReached! + +testStep + "Test that #step goes through the traced process a single line at a time." + | debugger reached1 reached2 notReached | + reached1 := reached2 := notReached := false. + debugger := self debuggerOn: [ + reached1 := true. reached2 := true. + notReached := true ]. + debugger step. + self assert: reached1. + self assert: reached2. + self deny: notReached! + +testCurrentLine + "Test that #currentLine does not do something completely bogus." + | debugger a b c prevLine | + debugger := self debuggerOn: [ + a := 5. + b := 6. + c := 7 ]. + + [ debugger step. a = 5 ] whileFalse. + prevLine := debugger currentLine. + debugger step. + self assert: prevLine + 1 = debugger currentLine! + +testForkDebugger + "Test forking a debugger for the current process." + | value | + [ :debugger | + [ debugger step. debugger suspendedContext selector = #y ] whileFalse. + value := false. + debugger finish. + [ debugger step. debugger suspendedContext selector = #y ] whileFalse. + value := true. + debugger finish. + [ debugger step. debugger suspendedContext selector = #y ] whileFalse. + value := 42. + debugger continue + ] forkDebugger. + self y. + self deny: value. + self y. + self assert: value. + self y. + self assert: value = 42! + +testStopInferior + "Test using #stopInferior to restart the debugger." + | theDebugger value | + [ :debugger | + theDebugger := debugger. + [ [ debugger step ] repeat ] + on: SystemExceptions.DebuggerReentered + do: [ :ex | ex return ]. + + value := 42. + debugger continue + ] forkDebugger. + + self assert: value isNil. + theDebugger stopInferior. + self assert: value = 42! + +testStepIntoSend + "Test that #step stops at the next message send." + | debugger reached notReached | + reached := false. + debugger := self debuggerOn: [ + reached := true. notReached := 3 factorial ]. + debugger step. + self assert: reached. + self assert: notReached isNil! + +testFinish + "Test that #finish does not proceed further in the parent context." + | debugger reached | + debugger := self debuggerOn: [ + reached := 3 factorial ]. + debugger step. + self assert: reached isNil. + debugger finish. + "The assignment has not been executed yet." + self assert: reached isNil. + debugger finish. + self assert: reached = 6! + +testStepTooMuch + "Test that #stepBytecode eventually raises an error." + | debugger reached toFinish | + debugger := self debuggerOn: [ 3 factorial ]. + self + should: [ [debugger stepBytecode] repeat ] + raise: Error. + self deny: debugger isActive! + +testFinishColon + "Test using #finish: to leave multiple contexts at once." + | debugger reached toFinish | + debugger := self debuggerOn: [ + self x: [ :foo | reached := foo ] + ]. + + [ + debugger step. + debugger suspendedContext selector = #x: ] whileFalse. + + toFinish := debugger suspendedContext. + [ + debugger step. + debugger suspendedContext selector = #z: ] whileFalse. + + debugger finish: toFinish. + self assert: reached = 42. + self deny: debugger suspendedContext selector = #x:! + +testContinue + "Test that #continue terminates the controlling process." + | debugger reached sema1 sema2 curtailed | + debugger := self debuggerOn: [ + reached := 3 factorial. + sema1 signal ]. + + sema1 := Semaphore new. + sema2 := Semaphore new. + curtailed := true. + [ + "The controlling process is terminated, so we run the test in another + process." + [ + debugger continue. + curtailed := false + ] ensure: [ sema2 signal ]. + ] fork. + + sema1 wait. + sema2 wait. + self assert: reached = 6. + self assert: curtailed. + self deny: debugger isActive! + +testStepOverPrimitive + "Test that #step does not go inside a primitive." + | debugger reached notReached | + debugger := self debuggerOn: [ + reached := Object new ]. + debugger step. + self assert: reached notNil! + +testNext + "Test that #next runs a whole line independent of how many sends are there." + | debugger reached1 reached2 | + debugger := self debuggerOn: [ + reached1 := 3 factorial. reached2 := 4 factorial ]. + debugger next. + self assert: reached1 = 6. + self assert: reached2 = 24! + +testCurtailFinish + "Test that finish is not fooled by method returns." + | debugger notReached | + notReached := false. + debugger := self debuggerOn: [ self w. notReached := true ]. + + [ debugger step. debugger suspendedContext selector = #z: ] + whileFalse. + + debugger finish. + self assert: debugger suspendedContext selector = #y. + debugger finish. + self assert: debugger suspendedContext selector = #x:. + debugger step. + self assert: debugger suspendedContext isBlock. + self assert: debugger suspendedContext selector = #w. + debugger finish. + self assert: debugger isActive. + self deny: notReached! ! + +!DebuggerTest methodsFor: 'support'! + +w + self x: [ :foo | ^foo ]! + +x: aBlock + aBlock value: self y! + +y + ^self z: 42! + +z: anObject + ^anObject! ! + --- /dev/null +++ mod/packages/debug/package.xml @@ -0,0 +1,13 @@ +<package> + <name>DebugTools</name> + + <test> + <sunit>DebuggerTest</sunit> + <filein>debugtests.st</filein> + </test> + + <filein>DebugTools.st</filein> + + <file>DebugTools.st</file> + <file>debugtests.st</file> +</package> _______________________________________________ help-smalltalk mailing list [hidden email] http://lists.gnu.org/mailman/listinfo/help-smalltalk |
«
Return to Gnu
|
1 view|%1 views
| Free forum by Nabble | Edit this page |