'From Squeak3.6beta of ''4 July 2003'' [latest update: #5352] on 21 July 2003 at 10:21:09 am'! "Change Set: ContextCleanupDebugFix-ajh Date: 21 July 2003 (version 4) Author: Anthony Hannan Debugger fixes: 1. highlighting of decompiled source (do-its). 2. stepping over exception signals. 3. step no longer skips inlined messages (ifTrue:, ifFalse:, etc.). 4. stepping through into a nested block. 5. restarting a block context with args. 6. suspend process properly. 7. display stored temp names when decompiling. New protocol to support fixes above: 1. MessageCatcher 2. InstructionStream >> nextInstruction & peekInstruction. 3. Process >> isTerminated "! ProtoObject subclass: #MessageCatcher instanceVariableNames: 'echoToTranscript ' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !MessageCatcher commentStamp: 'ajh 7/18/2003 21:27' prior: 0! Any message sent to me is returned as a Message object.! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 9/26/2002 12:24'! doesNotUnderstand: aMessage echoToTranscript == true ifTrue: [Transcript show: aMessage printString; cr]. ^ aMessage! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/18/2003 21:28'! privEchoToTranscript: bool echoToTranscript _ bool! ! !Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:37'! mustBeBoolean "Catches attempts to test truth of non-Booleans. This message is sent from the VM. The sending context is rewound to just before the jump causing this exception." ^ self mustBeBooleanIn: thisContext sender! ! !Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:40'! mustBeBooleanIn: context "context is the where the non-boolean error occurred. Rewind context to before jump then raise error." | proceedValue | context skipBackBeforeJump. proceedValue _ NonBooleanReceiver new object: self; signal: 'proceed for truth.'. ^ proceedValue ~~ false! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 09:45'! holdsTempNames "Are tempNames stored in trailer bytes" | flagByte | flagByte _ self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]]) ifTrue: [^ false]. "No source pointer & no temp names" flagByte < 252 ifTrue: [^ true]. "temp names compressed" ^ false "Source pointer" ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 00:29'! tempNames | byteCount bytes | self holdsTempNames ifFalse: [ ^ (1 to: self numTemps) collect: [:i | 't', i printString] ]. byteCount _ self at: self size. byteCount = 0 ifTrue: [^ Array new]. bytes _ (ByteArray new: byteCount) replaceFrom: 1 to: byteCount with: self startingAt: self size - byteCount. ^ (self qDecompress: bytes) findTokens: ' '! ! !Debugger methodsFor: 'initialize' stamp: 'ajh 7/20/2003 23:41'! errorWasInUIProcess: boolean errorWasInUIProcess _ boolean! ! !Debugger methodsFor: 'initialize' stamp: 'ajh 7/6/2003 17:10'! windowIsClosing "My window is being closed; clean up. Restart the low space watcher." interruptedProcess == nil ifTrue: [^ self]. [interruptedProcess terminate] on: Error do: []. interruptedProcess _ nil. interruptedController _ nil. contextStack _ nil. contextStackTop _ nil. receiverInspector _ nil. contextVariablesInspector _ nil. Smalltalk installLowSpaceWatcher. "restart low space handler" ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 7/6/2003 21:06'! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. currentContext _ self selectedContext. newContext _ interruptedProcess completeStep: currentContext. newContext == currentContext ifTrue: [ newContext _ interruptedProcess stepToSendOrReturn]. self contextStackIndex > 1 ifTrue: [self resetContext: newContext] ifFalse: [newContext == currentContext ifTrue: [self changed: #contentsSelection. self updateInspectors] ifFalse: [self resetContext: newContext]]. ! ! !Debugger methodsFor: 'private' stamp: 'ajh 7/21/2003 10:08'! resumeProcess: aTopView Smalltalk isMorphic ifFalse: [aTopView erase]. savedCursor ifNotNil: [Sensor currentCursor: savedCursor]. isolationHead ifNotNil: [failedProject enterForEmergencyRecovery. isolationHead invoke. isolationHead _ nil]. interruptedProcess isTerminated ifFalse: [ Smalltalk isMorphic ifTrue: [errorWasInUIProcess ifTrue: [Project resumeProcess: interruptedProcess] ifFalse: [interruptedProcess resume]] ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]]. "if old process was terminated, just terminate current one" interruptedProcess _ nil. "Before delete, so release doesn't terminate it" Smalltalk isMorphic ifTrue: [aTopView delete. World displayWorld] ifFalse: [aTopView controller closeAndUnscheduleNoErase]. Smalltalk installLowSpaceWatcher. "restart low space handler" errorWasInUIProcess == false ifFalse: [Processor terminateActive]! ! !Debugger class methodsFor: 'opening' stamp: 'ajh 7/20/2003 23:53'! openOn: process context: context label: title contents: contentsStringOrNil fullView: bool "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." | errorWasInUIProcess | errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: process. [ [ | debugger | debugger _ self new process: process controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == process]) ifTrue: [ScheduledControllers activeController]) context: context. bool ifTrue: [debugger openFullNoSuspendLabel: title] ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]. debugger errorWasInUIProcess: errorWasInUIProcess. Preferences logDebuggerStackToFile ifTrue: [ Smalltalk logError: title inContext: context to: 'SqueakDebug.log']. ] on: Error do: [:ex | self primitiveError: 'Orginal error: ', title asString, '. Debugger error: ', ([ex description] on: Error do: ['a ', ex class printString]), ':' ] ] fork. process suspend. ! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'ajh 7/21/2003 00:53'! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | node | node _ self codeSelector: selector code: nil. tempVars _ vars. ^MethodNode new selector: node arguments: (tempVars copyFrom: 1 to: nArgs) precedence: selector precedence temporaries: (tempVars copyFrom: nArgs + 1 to: tempVars size) block: block encoder: (Encoder new initScopeAndLiteralTables temps: tempVars literals: literalValues class: class) primitive: primitive! ! !Encoder methodsFor: 'initialize-release' stamp: 'ajh 7/21/2003 00:53'! temps: tempVars literals: lits class: cl "Decompile." supered _ false. class _ cl. nTemps _ tempVars size. tempVars do: [:node | scopeTable at: node name put: node]. literalStream _ ReadStream on: lits. literalStream position: lits size. sourceRanges _ Dictionary new: 32. globalSourceRanges _ OrderedCollection new: 32. ! ! !InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:32'! nextInstruction "Return the next bytecode instruction as a message that an InstructionClient would understand. This advances the pc by one instruction." ^ self interpretNextInstructionFor: MessageCatcher new! ! !InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:36'! peekInstruction "Return the next bytecode instruction as a message that an InstructionClient would understand. The pc remains unchanged." | currentPc instr | currentPc _ self pc. instr _ self nextInstruction. self pc: currentPc. ^ instr! ! !InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:29'! previousPc | currentPc dummy prevPc | currentPc _ pc. pc _ self method initialPC. dummy _ MessageCatcher new. [pc = currentPc] whileFalse: [ prevPc _ pc. self interpretNextInstructionFor: dummy. ]. ^ prevPc! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 7/6/2003 20:38'! jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." | bool | bool _ self pop. (bool == true or: [bool == false]) ifFalse: [ ^self send: #mustBeBooleanIn: to: bool with: {self} super: false]. (bool eqv: condition) ifTrue: [self jump: distance]! ! !ContextPart methodsFor: 'system simulation' stamp: 'ajh 7/6/2003 17:59'! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willReallySend or: [self willReturn or: [self willStore or: [self willJumpIfTrue or: [self willJumpIfFalse]]]]] whileFalse: [ ctxt _ self step. ctxt == self ifFalse: [self halt. "Caused by mustBeBoolean handling" ^ctxt]]! ! !ContextPart methodsFor: 'private' stamp: 'ajh 7/21/2003 09:59'! insertSender: aContext "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." | ctxt | ctxt _ aContext bottomContext. ctxt privSender: self sender. self privSender: aContext. ^ ctxt! ! !ContextPart methodsFor: 'query' stamp: 'ajh 7/21/2003 09:59'! bottomContext "Return the last context (the first context invoked) in my sender chain" ^ self findContextSuchThat: [:c | c sender isNil]! ! !BlockContext methodsFor: 'initialize-release' stamp: 'ajh 7/18/2003 21:49'! privRefresh "Reinitialize the receiver so that it is in the state it was at its creation." pc _ startpc. self stackp: 0. nargs timesRepeat: [ "skip arg popping" self nextInstruction selector = #popIntoTemporaryVariable: ifFalse: [self halt: 'unexpected bytecode instruction'] ]. ! ! !Decompiler methodsFor: 'initialize-release' stamp: 'ajh 7/21/2003 01:14'! initSymbols: aClass | nTemps namedTemps | constructor method: method class: aClass literals: method literals. constTable _ constructor codeConstants. instVars _ Array new: aClass instSize. nTemps _ method numTemps. namedTemps _ tempVars ifNil: [method tempNames]. tempVars _ (1 to: nTemps) collect: [:i | i <= namedTemps size ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] ifFalse: [constructor codeTemp: i - 1]]! ! !MethodNode methodsFor: 'code generation' stamp: 'ajh 7/6/2003 15:25'! parserClass "Which parser produces this class of parse node" ^ Parser! ! !MethodNode methodsFor: 'code generation' stamp: 'ajh 7/6/2003 15:26'! sourceMap "Answer a SortedCollection of associations of the form: pc (byte offset in me) -> sourceRange (an Interval) in source text." | methNode | methNode _ self. sourceText ifNil: [ "No source, use decompile string as source to map from" methNode _ self parserClass new parse: self decompileString class: self methodClass ]. methNode generateNative: #(0 0 0 0). "set bytecodes to map to" ^ methNode encoder sourceMap! ! !Process methodsFor: 'changing process state' stamp: 'ajh 7/20/2003 22:51'! primitiveSuspend "Primitive. Stop the process that self represents in such a way that it can be restarted at a later time (by sending #resume). ASSUMES self is the active process. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Process methodsFor: 'changing process state' stamp: 'ajh 7/20/2003 22:47'! suspend "Stop the process that the receiver represents in such a way that it can be restarted at a later time (by sending the receiver the message resume). If the receiver represents the activeProcess, suspend it. Otherwise remove the receiver from the list of waiting processes." self isActiveProcess ifTrue: [ myList _ nil. self primitiveSuspend. ] ifFalse: [ myList ifNotNil: [ myList remove: self ifAbsent: []. myList _ nil]. ] ! ! !Process methodsFor: 'changing process state' stamp: 'ajh 7/20/2003 21:15'! terminate "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." self isActiveProcess ifTrue: [ | ctxt unwindBlock | [ ctxt _ thisContext findNextUnwindContextUpTo: nil. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. thisContext terminateTo: ctxt sender. unwindBlock value. ]. thisContext terminateTo: nil. ] ifFalse: [ self popTo: nil. ]. self suspend. ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 7/6/2003 20:09'! complete: aContext "Run self until aContext is popped or an UnhandledError is raised, then resume here. Return context to highlight." | error ctxt here meth sigCtxt | here _ thisContext. "Insert ensure: context under aContext that will halt self when reached, then resume self. Also insert on:do: context that will halt self if an UnhandledError is raised." error _ false. ctxt _ aContext insertSender: (ContextPart contextOn: UnhandledError do: [:ex | error ifTrue: [ex pass] ifFalse: [ error _ true. suspendedContext _ thisContext. ex resumeUnchecked: here jump] ]). ctxt _ ctxt insertSender: (ContextPart contextEnsure: [error ifFalse: [ suspendedContext _ thisContext. here jump] ]). suspendedContext jumpTop. "Execution resumes here once above ensure: context is reached or on:do: context is raised" suspendedContext push: nil. "top context needs return value" error ifFalse: [ "No error was raised, remove ensure: context and step down to sender" self stepToCallee. suspendedContext == ctxt ifTrue: [^ self stepToCallee]. "pop ensure: & return" "suspendedContext must be ContextPart>>#return:, step until it returns" ctxt _ suspendedContext. [ctxt isDead] whileFalse: [self step]. ^ suspendedContext ] ifTrue: [ "Error was raised, remove added contexts then return signaler context to be highlighted" aContext terminateTo: ctxt sender. meth _ Exception compiledMethodAt: #signal. ctxt _ suspendedContext. [ ctxt method == meth ifTrue: [sigCtxt _ ctxt]. ctxt _ ctxt sender. ctxt == aContext ] whileFalse. ^ sigCtxt ifNotNil: [sigCtxt receiver signalerContext] ifNil: [suspendedContext] ]. ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 7/18/2003 20:58'! popTo: aContext "Replace the suspendedContext with aContext, releasing all contexts between the currently suspendedContext and it." | callee | self == Processor activeProcess ifTrue: [^ self error: 'The active process cannot pop contexts']. callee _ (self calleeOf: aContext) ifNil: [^ self]. "aContext is on top" self return: callee value: callee receiver! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 7/18/2003 21:00'! return: aContext value: value "Pop thread down to aContext's sender. Execute any unwind blocks on the way." suspendedContext == aContext ifTrue: [ ^ suspendedContext _ aContext return: value from: aContext]. self activateReturn: aContext value: value. self complete: aContext. ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 7/18/2003 22:13'! stepToHome: aContext "Resume self until the home of top context is aContext. Top context may be a block context." | home ctxt | home _ aContext home. [ ctxt _ self step. home == ctxt home. ] whileFalse: [ home isDead ifTrue: [^ self suspendedContext]. ]. ^ self suspendedContext! ! !Process methodsFor: 'accessing' stamp: 'ajh 7/21/2003 10:04'! isTerminated self isActiveProcess ifTrue: [^ false]. ^ suspendedContext isNil or: [ | ctxt | ctxt _ suspendedContext bottomContext. ctxt method == (self class compiledMethodAt: #terminate) and: [ctxt receiver == self] ]! ! !Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:54'! debug: context title: title "Open debugger on self with context shown on top" self debug: context title: title full: false. ! ! !Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:53'! debug: context title: title full: bool "Open debugger on self with context shown on top" | topCtxt | topCtxt _ self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext]. (topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process']. Debugger openOn: self context: context label: title contents: nil fullView: bool. ! ! !Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:55'! debugWithTitle: title "Open debugger on self" | context | context _ self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext]. self debug: context title: title full: true. ! ! !ProcessBrowser methodsFor: 'process list' stamp: 'ajh 7/21/2003 10:11'! updateProcessList | oldSelectedProcess newIndex now | now _ Time millisecondClockValue. now - lastUpdate < 500 ifTrue: [^ self]. "Don't update too fast" lastUpdate _ now. oldSelectedProcess _ selectedProcess. processList _ selectedProcess _ selectedSelector _ nil. Smalltalk garbageCollectMost. "lose defunct processes" processList _ Process allSubInstances reject: [:each | each isTerminated]. processList _ processList sortBy: [:a :b | a priority >= b priority]. processList _ WeakArray withAll: processList. newIndex _ processList indexOf: oldSelectedProcess ifAbsent: [0]. self changed: #processNameList. self processListIndex: newIndex! ! ContextPart removeSelector: #bottom! ContextPart removeSelector: #suspend!