'From Squeak3.7alpha of 11 September 2003 [latest update: #5764] on 5 March 2004 at 4:12:21 am'! "Change Set: UnwindFixes-ajh Date: 5 March 2004 Author: Anthony Hannan If an error is raised while unwinding from a terminate, a debugger will now appear. Fixed unwind simulation. Fixed ensure: so a remote return from its ensure block won't trigger itself again. Refactored Process>>popTo: and complete:. "! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 3/5/2004 03:44'! return: value from: aSender "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" | newTop ctxt | aSender isDead ifTrue: [ ^ self send: #cannotReturn: to: self with: {value} super: false]. newTop _ aSender sender. ctxt _ self findNextUnwindContextUpTo: newTop. ctxt ifNotNil: [ ^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false]. self releaseTo: newTop. newTop ifNotNil: [newTop push: value]. ^ newTop ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 3/5/2004 02:37'! return: value "Roll back thisContext to self and return value to self's sender. Execute any unwind blocks on the way. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | (sender isNil or: [sender isDead]) ifTrue: [self cannotReturn: value to: sender]. [ ctxt _ thisContext findNextUnwindContextUpTo: self sender. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. thisContext terminateTo: ctxt sender. unwindBlock value. ]. thisContext terminateTo: self sender. ^ value! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 3/5/2004 02:00'! runUntilErrorOrReturnFrom: aSender "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." | error ctxt here topContext | here _ thisContext. "Insert ensure and exception handler contexts under aSender" error _ nil. ctxt _ aSender insertSender: (ContextPart contextOn: UnhandledError do: [:ex | error ifNil: [ error _ ex exception. topContext _ thisContext. ex resumeUnchecked: here jump] ifNotNil: [ex pass] ]). ctxt _ ctxt insertSender: (ContextPart contextEnsure: [error ifNil: [ topContext _ thisContext. here jump] ]). self jumpTop. "Control jumps to self" "Control resumes here once above ensure block or exception handler is executed" topContext push: nil. "top context needs return value" error ifNil: [ "No error was raised, remove ensure context and step down to sender" topContext _ topContext stepToCallee. "pop ensure block context" topContext == ctxt ifTrue: [^ {topContext stepToCallee. nil}]. "pop ensure context & return" "ensure block must have been executed as a result of remote returning past it, so topContext must be ContextPart>>#return:" topContext method == ContextPart theReturnMethod ifFalse: [ topContext halt: 'Error in control assumptions'. ^ {topContext.nil}]. "Allow remote return to complete by running until the home context returns" ^ topContext runUntilErrorOrReturnFrom: topContext receiver ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" ^ {topContext. error} ]. ! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 3/4/2004 22:36'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue b | returnValue := self value. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [ "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" b _ aBlock. thisContext tempAt: 1 put: nil. "aBlock _ nil" b value. ]. ^ returnValue! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 3/5/2004 20:50'! theReturnMethod | meth | meth _ self lookupSelector: #return:. meth primitive = 0 ifFalse: [^ self error: '#return: must not be a primitive']. ^ meth! ! !Debugger methodsFor: 'initialize' stamp: 'ajh 3/5/2004 21:31'! windowIsClosing "My window is being closed; clean up. Restart the low space watcher." interruptedProcess == nil ifTrue: [^ self]. interruptedProcess terminate. interruptedProcess _ nil. interruptedController _ nil. contextStack _ nil. contextStackTop _ nil. receiverInspector _ nil. contextVariablesInspector _ nil. Smalltalk installLowSpaceWatcher. "restart low space handler" ! ! !Debugger methodsFor: 'accessing' stamp: 'ajh 3/5/2004 01:20'! contents: aText notifying: aController "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the selected context." | selector classOfMethod category h ctxt | contextStackIndex = 0 ifTrue: [^ false]. self selectedContext isExecutingBlock ifTrue: [h := self selectedContext finalBlockHome. h ifNil: [self inform: 'Method not found for block, can''t edit'. ^ false]. (self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: h] ifFalse: [^ false]]. classOfMethod := self selectedClass. category := self selectedMessageCategoryName. selector := self selectedClass parserClass new parseSelector: aText. selector == self selectedMessageName ifFalse: [self inform: 'can''t change selector'. ^ false]. selector := classOfMethod compile: aText classified: category notifying: aController. selector ifNil: [^ false]. "compile cancelled" contents := aText. ctxt := interruptedProcess popTo: self selectedContext. ctxt == self selectedContext ifFalse: [ self inform: 'Method saved, but current context unchanged because of unwind error. Click OK to see error'. ] ifTrue: [ interruptedProcess restartTopWith: (classOfMethod compiledMethodAt: selector); stepToSendOrReturn. contextVariablesInspector object: nil. theMethodNode := Preferences browseWithPrettyPrint ifTrue: [ctxt methodNodeFormattedAndDecorated: Preferences colorWhenPrettyPrinting] ifFalse: [ctxt methodNode]. sourceMap := theMethodNode sourceMap. tempNames := theMethodNode tempNames. ]. self resetContext: ctxt. ^ true! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 3/4/2004 23:10'! peelToFirst "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" | upperGuy meth second ctxt | contextStackIndex = 0 ifTrue: [^ Beeper beep]. "self okToChange ifFalse: [^ self]." upperGuy _ contextStack at: contextStackIndex. meth _ upperGuy method. contextStackIndex+1 to: contextStack size do: [:ind | (contextStack at: ind) method == meth ifTrue: [ second _ upperGuy. upperGuy _ contextStack at: ind]]. second ifNil: [second _ upperGuy]. ctxt _ interruptedProcess popTo: self selectedContext. ctxt == self selectedContext ifTrue: [self resetContext: second] ifFalse: [self resetContext: ctxt]. "unwind error" ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 3/4/2004 23:14'! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." "Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46" | ctxt noUnwindError | self okToChange ifFalse: [^ self]. self checkContextSelection. ctxt _ interruptedProcess popTo: self selectedContext. noUnwindError _ false. ctxt == self selectedContext ifTrue: [ noUnwindError _ true. interruptedProcess restartTop; stepToSendOrReturn]. self resetContext: ctxt. (Preferences restartAlsoProceeds and: [noUnwindError]) ifTrue: [self proceed]. ! ! !Process methodsFor: 'changing process state' stamp: 'ajh 3/4/2004 22:22'! terminate "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." | ctxt unwindBlock | self isActiveProcess ifTrue: [ [ ctxt _ thisContext findNextUnwindContextUpTo: nil. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. thisContext terminateTo: ctxt sender. unwindBlock value. ]. thisContext terminateTo: nil. myList _ nil. self primitiveSuspend. ] ifFalse: [ myList ifNotNil: [ myList remove: self ifAbsent: []. myList _ nil]. ctxt _ self popTo: suspendedContext bottomContext. ctxt == suspendedContext bottomContext ifFalse: [ self debug: ctxt title: 'Unwind error during termination']. ]. ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:13'! complete: aContext "Run self until aContext is popped or an unhandled error is raised. Return self's new top context, unless an unhandled error was raised then return the signaler context (rather than open a debugger)." | ctxt pair error | ctxt _ suspendedContext. suspendedContext _ nil. "disable this process while running its stack in active process below" pair _ ctxt runUntilErrorOrReturnFrom: aContext. suspendedContext _ pair first. error _ pair second. error ifNotNil: [^ error signalerContext]. ^ suspendedContext! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'! popTo: aContext "Pop self down to aContext by remote returning from aContext's callee. Unwind blocks will be executed on the way. This is done by pushing a new context on top which executes 'aContext callee return' then resuming self until aContext is reached. This way any errors raised in an unwind block will get handled by senders in self and not by senders in the activeProcess. If an unwind block raises an error that is not handled then the popping stops at the error and the signalling context is returned, othewise aContext is returned." | callee | self == Processor activeProcess ifTrue: [^ self error: 'The active process cannot pop contexts']. callee _ (self calleeOf: aContext) ifNil: [^ aContext]. "aContext is on top" ^ self return: callee value: callee receiver! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'! return: aContext value: value "Pop thread down to aContext's sender. Execute any unwind blocks on the way. See #popTo: comment and #runUntilErrorOrReturnFrom: for more details." suspendedContext == aContext ifTrue: [ ^ suspendedContext _ aContext return: value from: aContext]. self activateReturn: aContext value: value. ^ self complete: aContext. ! ! !Process methodsFor: 'accessing' stamp: 'ajh 3/4/2004 22:18'! isTerminated self isActiveProcess ifTrue: [^ false]. ^ suspendedContext isNil or: [ suspendedContext == suspendedContext bottomContext and: [ suspendedContext pc > suspendedContext startpc]]! !