Fellow Squeakers,

Please find attached two change sets which, taken
together, fix all known bugs in the exception handling
system (including ensured execution).  As a side
effect, everyone's favorite method
(BlockContext>>valueUninterruptably) goes away - so if
you're particularly sentimental about that method, go
have one last read-through before filing this in.

Anyway.  The first change set is one that Stephen Pair
sent around a few months ago, modifying the
Interpreter to support ensured execution.  Using a vm
that (I think) Andreas Raab built, I have verified
that it does indeed work as expected.

The second change set contains the actual
modifications to the EHS.  In aggregate, it results in
a slight reduction in the code base.

In the past, there has been some concern that the
Interpreter modifications will slow down the vm.  I
have not run any benchmarks, but I expect that the hit
will be trivial:  if you look at Stephen's changes,
you will observe that the additional overhead consists
of a single equality test in
Interpreter>>returnValue:to:, in the normal case. 
_Only_ in the case of a nonlocal return-in-progress is
there any significant additional processing (and prior
to the modifications it didn't work anyway).  So imho,
SqC should consider moving these modifications
straight into the core vm stream.

Although I get to have the pleasure of announcing the
results, I should observe that the Squeak EHS has been
quite a collaborative effort.  Exceptions are a nasty
complicated hairy beast of a subset of Smalltalk, and
without the work done by the Richard Harmon and the
Camp Smalltalk ANSI group we wouldn't have had all the
unit tests that give me the confidence that this thing
actually works - thanks guys!  Allen Wirfs-Brock and
the other authors of the ANSI document get credit for
giving us a target.  Nice semantics!

Stephen Pair and Craig Latta contributed code to the
effort, and in addition both of them helped me to
think through some of the more twisted questions. 
Dan, Andreas, and David Caster also threw valuable
insights into the mix, and Steve Rees confirmed the
existence of the very-very-evil 'nested ensure: bug'.

Finally, thanks to exobox for putting on the finishing
touches, the results of which are in the
aforementioned second change set.  I hope I'm not
leaving anyone out, but if so, apologies!

Well, I forget myself, this was not meant to be an
Oscar acceptance speech, but merely an announcement to
accompany some code.  Here 'tis.

Paul

__________________________________________________
Do You Yahoo!?
Send instant messages & get email alerts with Yahoo! Messenger.
http://im.yahoo.com/
-------------- next part --------------
'From Squeak2.7 of 5 January 2000 [latest update: #1762] on 16 August 2000 at 3:26:09 pm'!

!BlockContext methodsFor: 'exceptions' stamp: 'pnm 8/16/2000 15:07'!
ensure: aBlock
	"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."

	| returnValue |
	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: [aBlock value].
	^returnValue! !


!Exception methodsFor: 'private' stamp: 'pnm 8/16/2000 14:55'!
findHandlerFrom: startCtx
	| ctx handler |
	ctx := startCtx.
	[ctx == nil]
		whileFalse:
			[ctx isHandlerContext
				ifTrue:
					[handler := ctx tempAt: 1. "the first argument"
					((handler handles: self) and: [(ctx tempAt: 2) sender == nil])
						ifTrue:
							[handlerContext := ctx.
							^ctx]].
			ctx := ctx sen!
der].
	^nil! !

!Exception methodsFor: 'private' stamp: 'pnm 8/16/2000 15:21'!
handlerAction
	| na handler returnValue |
	handler := handlerContext tempAt: 2.    "the second argument"
	na := handler numArgs.
	returnValue := na == 0
		ifTrue: [handler value]
		ifFalse: [handler value: self].
	resignalException == nil ifFalse: [^returnValue].
	"Execution will only continue beyond this point if the handler did not specify a handler action."
	self return: returnValue! !

!Exception methodsFor: 'private' stamp: 'pnm 8/16/2000 15:21'!
initialContext: aContext
	initialContext := aContext! !

!Exception methodsFor: 'private' stamp: 'pnm 8/16/2000 15:04'!
receiver
	^initialContext receiver! !

!Exception methodsFor: 'signaledException' stamp: 'pnm 8/16/2000 13:05'!
outer
	"Evaluate the enclosing exception action for the receiver and return."

	| outer |
	^self isResumable
		ifTrue:
			[outer := self findHandlerFrom: handlerContext sender.
			outer == nil
				ifTrue: [self defaultActio!
n]
				ifFalse: [self handlerAction]]
		ifFalse: [self pass]! !

!Exception methodsFor: 'signaledException' stamp: 'pnm 8/16/2000 14:45'!
resignalAs: replacementException
	"Signal an alternative exception in place of the receiver."

	thisContext unwindTo: initialContext.
	replacementException initialContext: initialContext.
	resignalException := replacementException.
	thisContext swapSender: thisContext sender sender! !

!Exception methodsFor: 'signaledException' stamp: 'pnm 8/16/2000 14:59'!
resume
	"Return from the message that signaled the receiver."

	^self resume: nil! !

!Exception methodsFor: 'signaledException' stamp: 'pnm 8/16/2000 14:59'!
resume: resumptionValue
	"Return the argument as the value of the message that signaled the receiver."

	self isResumable ifFalse: [IllegalResumeAttempt signal].
	thisContext unwindTo: initialContext.
	thisContext terminateTo: initialContext.
	^resumptionValue! !

!Exception methodsFor: 'signaledException' stamp: 'pnm 8/16/2000 15:0!
0'!
retry
	"Abort an exception handler and re-evaluate its protected block."

	thisContext unwindTo: handlerContext.
	thisContext terminateTo: handlerContext.
	handlerContext restart! !

!Exception methodsFor: 'signaledException' stamp: 'pnm 8/16/2000 15:00'!
retryUsing: alternativeBlock
	"Abort an exception handler and evaluate a new block in place of the handler's protected block."

	handlerContext receiver: alternativeBlock.
	self retry! !

!Exception methodsFor: 'signaledException' stamp: 'pnm 8/16/2000 12:57'!
return: returnValue
	"Return the argument as the value of the block protected by the active exception handler."

	initialContext unwindTo: handlerContext.
	thisContext terminateTo: handlerContext.
	^returnValue! !

!Exception methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:00'!
messageText: signalerText
	"Set an exception's message text."

	messageText := signalerText! !

!Exception methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:23'!
tag: t
	"This !
message is not specified in the ANSI protocol, but that looks like an oversight because #tag is specified, and the spec states that the signaler may store the tag value."

	tag := t! !

!Exception methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 14:53'!
defaultAction
	"The default action taken if the exception is signaled."

	self subclassResponsibility! !

!Exception methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 14:53'!
description
	"Return a textual description of the exception."

	| desc mt |
	desc := self class name asString.
	^(mt := self messageText) == nil
		ifTrue: [desc]
		ifFalse: [desc, ': ', mt]! !

!Exception methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 14:53'!
isResumable
	"Determine whether an exception is resumable."

	^false! !

!Exception methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 14:53'!
messageText
	"Return an exception's message text."

	^messageText! !

!Exception methodsFor: 'exceptionDescription' stamp: 'pnm !
8/16/2000 14:54'!
tag
	"Return an exception's tag value."

	^tag == nil
		ifTrue: [self messageText]
		ifFalse: [tag]! !


!Exception class methodsFor: 'exceptionInstantiator' stamp: 'pnm 8/16/2000 15:01'!
signal: signalerText
	"Signal the occurrence of an exceptional condition with a specified textual description."

	| ex |
	ex := self new.
	ex initialContext: thisContext sender.
	^ex signal: signalerText! !


!ExceptionSet methodsFor: 'exceptionSelector' stamp: 'pnm 8/16/2000 15:15'!
handles: anException
	"Determine whether an exception handler will accept a signaled exception."

	exceptions do:
		[:ex |
		(ex handles: anException)
			ifTrue: [^true]].
	^false! !


!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:03'!
message: aMessage

	message := aMessage! !

!MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 15:03'!
messageText
	"Return an exception's message text."

	^messageText == nil
		ifTrue:
			[message == nil!

				ifTrue: [super messageText]
				ifFalse: [message selector asString]]
		ifFalse: [messageText]! !


!Notification methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 15:04'!
defaultAction
	"No action is taken. The value nil is returned as the value of the message that signaled the exception."

	^nil! !


!Warning methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 15:05'!
defaultAction
	"The user should be notified of the occurrence of an exceptional occurrence and given an option of continuing or aborting the computation. The description of the occurrence should include any text specified as the argument of the #signal: message."

	(self confirm: 'Warning: ', self messageText, ' Continue?') ifTrue: [self resume]! !


!ZeroDivide methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 15:05'!
isResumable
	"Determine whether an exception is resumable."

	^true! !

!ZeroDivide methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:05'!
dividend: argument
	"Speci!
fy the number that was being divided by zero."

	dividend := argument! !


BlockContext removeSelector: #valueUninterruptably!
MessageNotUnderstood removeSelector: #receiver!
MethodContext removeSelector: #answer:!
Smalltalk removeClassNamed: #ExceptionAboutToReturn!
-------------- next part --------------
'From Squeak2.7 of 5 January 2000 [latest update: #1762] on 15 January 2000 at 10:38:13 pm'!
"Change Set:		SafeReturn
Date:			15 January 2000
Author:			Stephen Pair (spair at acm.org)

This change set modifies the interpreter to support returns that
can happen in block, but allow for curtail and ensure block to 
be executed.  This was developed in Squeak2.7.

This modification requires you to generate a new interp.c and
compile a new VM.  I've compiled the VM for Windows (based on BLD2 from Andreas), which can be downloaded here: http://safereturn-squeak.swiki.net/.uploads/squeak_sr.exe

Note, I have yet to benchmark the performance of this VM as compared with the shipped VM.  If anyone has any ideas of how to acquire such measurements, please let me know:  spair at acm.org

Also, if someone can enhance the code to make it perform better, let me now."!

Object subclass: #ObjectMemory
	instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialOb!
jectsOop rootTable rootTableCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold statFullGCs statFullGCMSecs statIncrGCs statIncrGCMSecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter displayBits '
	classVariableNames: 'AllButHashBits AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit AllButTypeMask BaseHeaderSize BlockContextProto CharacterTable ClassArray ClassBitmap ClassBlockContext ClassByteArray ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassPoint ClassProcess ClassPseudoContext ClassSemaphore ClassString ClassTranslatedMethod CompactClassMask CompactClasses ConstMinusOne!
 ConstOne ConstTwo ConstZero CtxtTempFrameStart DoAssertionChecks Done ExternalObjectsArray FalseObject FloatProto GCTopMarker HashBits HashBitsOffset HeaderTypeClass HeaderTypeFree HeaderTypeGC HeaderTypeShort HeaderTypeSizeAndClass LargeContextBit LargeContextSize MarkBit MethodContextProto MinimumForwardTableBytes NilContext NilObject RemapBufferSize RootBit RootTableSize SchedulerAssociation SelectorAboutToReturn SelectorCannotInterpret SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SizeMask SmallContextSize SpecialSelectors StackStart StartField StartObj TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject TypeMask Upward '
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!

!BlockContext methodsFor: 'private' stamp: 'svp 1/15/2000 22:02'!
aboutToReturn: result to: returnContext

	self unwindTo: returnContext.
	thisContext swapSender: returnContext.
	^result! !

!Blo!
ckContext methodsFor: 'exceptions' stamp: 'svp 1/15/2000 22:20'!
ensure: aBlock
	"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."

	| returnValue |
	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: [ aBlock value ].
	^returnValue! !

!BlockContext methodsFor: 'exceptions' stamp: 'svp 1/15/2000 22:03'!
ifCurtailed: aBlock
	"Evaluate the receiver with an abnormal termination action."

	^self value! !


!MethodContext methodsFor: 'private-exceptions' stamp: 'svp 1/15/2000 21:38'!
aboutToReturn: result to: returnContext

	thisContext swapSender: returnContext.
	^result! !


!Interpreter methodsFor: 'compiled methods' stamp: 'svp 1/15/2000 21:38'!
returnValue: presultObj to: preturnContext
	"Note: Assumed to b!
e inlined into the dispatch loop."

	| nilOop thisCntx contextOfCaller returnContext resultObj |
	self inline: true.
	self sharedCodeNamed: 'commonReturn' inCase: 120.

	resultObj _ presultObj.
	returnContext _ preturnContext.
	nilOop _ nilObj. "keep in a register"
	thisCntx _ activeContext.

	"make sure we can return to the given context"
	((returnContext = nilOop) or:
	 [(self fetchPointer: InstructionPointerIndex ofObject: returnContext) = nilOop]) ifTrue: [
		"error: sender's instruction pointer or context is nil; cannot return"
		self internalPush: activeContext.
		self internalPush: resultObj.
		messageSelector _ self splObj: SelectorCannotReturn.
		argumentCount _ 1.
		^ self normalSend
	].

	"If this return is not to our sender, inform the context and let it deal with it.
	This provides a chance for ensure unwinding to occur"
	contextOfCaller _ self fetchPointer: SenderIndex ofObject: thisCntx.
	contextOfCaller = returnContext ifFalse: [
		self internalPush: activeCont!
ext.
		self internalPush: resultObj.
		self internalPush: returnContext.
		messageSelector _ self splObj: SelectorAboutToReturn.
		argumentCount _ 2.
		^self normalSend.
	].

	[thisCntx = returnContext] whileFalse: [
		"climb up stack to returnContext"
		contextOfCaller _ self fetchPointer: SenderIndex ofObject: thisCntx.

		"zap exited contexts so any future attempted use will be caught"
		self storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.
		self storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.

		reclaimableContextCount > 0 ifTrue: [
			"try to recycle this context"
			reclaimableContextCount _ reclaimableContextCount - 1.
			self recycleContextIfPossible: thisCntx.
		].
		thisCntx _ contextOfCaller.
	].
	activeContext _ thisCntx.
	(thisCntx < youngStart) ifTrue: [ self beRootIfOld: thisCntx ].

	self internalFetchContextRegisters: thisCntx.  "updates local IP and SP"
	self fetchNextBytecode.
	self internalPush: !
resultObj.
! !


!ObjectMemory class methodsFor: 'initialization' stamp: 'svp 1/15/2000 20:40'!
initializeSpecialObjectIndices
	"Initialize indices into specialObjects array."

	NilObject _ 0.
	FalseObject _ 1.
	TrueObject _ 2.
	SchedulerAssociation _ 3.
	ClassBitmap _ 4.
	ClassInteger _ 5.
	ClassString _ 6.
	ClassArray _ 7.
	"SmalltalkDictionary _ 8."  "Do not delete!!"
	ClassFloat _ 9.
	ClassMethodContext _ 10.
	ClassBlockContext _ 11.
	ClassPoint _ 12.
	ClassLargePositiveInteger _ 13.
	TheDisplay _ 14.
	ClassMessage _ 15.
	ClassCompiledMethod _ 16.
	TheLowSpaceSemaphore _ 17.
	ClassSemaphore _ 18.
	ClassCharacter _ 19.
	SelectorDoesNotUnderstand _ 20.
	SelectorCannotReturn _ 21.
	TheInputSemaphore _ 22.
	SpecialSelectors _ 23.
	CharacterTable _ 24.
	SelectorMustBeBoolean _ 25.
	ClassByteArray _ 26.
	ClassProcess _ 27.
	CompactClasses _ 28.
	TheTimerSemaphore _ 29.
	TheInterruptSemaphore _ 30.
	FloatProto _ 31.
	SelectorCannotInterpret _ 34.
	MethodContextProto _ 35.
	BlockC!
ontextProto _ 37.
	ExternalObjectsArray _ 38.
	ClassPseudoContext _ 39.
	ClassTranslatedMethod _ 40.
	TheFinalizationSemaphore _ 41.
	ClassLargeNegativeInteger _ 42.

	ClassExternalAddress _ 43.
	ClassExternalStructure _ 44.
	ClassExternalData _ 45.
	ClassExternalFunction _ 46.
	ClassExternalLibrary _ 47.

	SelectorAboutToReturn _ 48.
! !


!SystemDictionary methodsFor: 'special objects' stamp: 'svp 1/15/2000 21:47'!
recreateSpecialObjectsArray    "Smalltalk recreateSpecialObjectsArray"
	"The Special Objects Array is an array of object pointers used by the
	Smalltalk virtual machine.  Its contents are critical and unchecked,
	so don't even think of playing here unless you know what you are doing."
	| newArray |
	newArray _ Array new: 49.
	"Nil false and true get used throughout the interpreter"
	newArray at: 1 put: nil.
	newArray at: 2 put: false.
	newArray at: 3 put: true.
	"This association holds the active process (a ProcessScheduler)"
	newArray at: 4 put: (Smalltalk associ!
ationAt: #Processor).
	"Numerous classes below used for type checking and instantiation"
	newArray at: 5 put: Bitmap.
	newArray at: 6 put: SmallInteger.
	newArray at: 7 put: String.
	newArray at: 8 put: Array.
	newArray at: 9 put: Smalltalk. 
	newArray at: 10 put: Float.
	newArray at: 11 put: MethodContext.
	newArray at: 12 put: BlockContext.
	newArray at: 13 put: Point.
	newArray at: 14 put: LargePositiveInteger.
	newArray at: 15 put: Display.
	newArray at: 16 put: Message.
	newArray at: 17 put: CompiledMethod.
	newArray at: 18 put: (self specialObjectsArray at: 18)  "(low space Semaphore)".
	newArray at: 19 put: Semaphore.
	newArray at: 20 put: Character.
	newArray at: 21 put: #doesNotUnderstand:.
	newArray at: 22 put: #cannotReturn:.
	newArray at: 23 put: nil.  "*unused*"
	"An array of the 32 selectors that are compiled as special bytecodes,
	paired alternately with the number of arguments each takes."
	newArray at: 24 put: #(+ 1 - 1 < 1 > 1 <= 1 >= 1 = 1 ~= 1 * 1 / 1 \\ 1 !
@ 1 bitShift: 1 // 1 bitAnd: 1 bitOr: 1 at: 1 at:put: 2 size 0 next 0 nextPut: 1 atEnd 0 == 1 class 0 blockCopy: 1 value 0 value: 1 do: 1 new 0 new: 1 x 0 y 0 ).
	"An array of the 255 Characters in ascii order."
	newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]).
	newArray at: 26 put: #mustBeBoolean.
	newArray at: 27 put: ByteArray.
	newArray at: 28 put: Process.
	"An array of up to 31 classes whose instances will have compact headers"
	newArray at: 29 put: self compactClassesArray.
	newArray at: 30 put: (self specialObjectsArray at: 30)   "(delay Semaphore)".
	newArray at: 31 put: (self specialObjectsArray at: 31)   "(user input Semaphore)".

	"Prototype instances that can be copied for fast initialization"
	newArray at: 32 put: (Float new: 2).
	newArray at: 33 put: (LargePositiveInteger new: 4).
	newArray at: 34 put: Point new.
	newArray at: 35 put: #cannotInterpret:.
	"Note: This must be fixed once we start using context prototypes"
	newArray at:!
 36 put: (self specialObjectsArray at: 36). 
						"(MethodContext new: CompiledMethod fullFrameSize)."
	newArray at: 37 put: nil.
	newArray at: 38 put: (self specialObjectsArray at: 38). 
						"(BlockContext new: CompiledMethod fullFrameSize)."

	newArray at: 39 put: Array new.  "array of objects referred to by external code"

	newArray at: 40 put: PseudoContext.
	newArray at: 41 put: TranslatedMethod.

	"finalization Semaphore"
	newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil:[Semaphore new]).

	newArray at: 43 put: LargeNegativeInteger.

	"External objects for callout.
	Note: Written so that one can actually completely remove the FFI."
	newArray at: 44 put: (Smalltalk at: #ExternalAddress ifAbsent:[nil]).
	newArray at: 45 put: (Smalltalk at: #ExternalStructure ifAbsent:[nil]).
	newArray at: 46 put: (Smalltalk at: #ExternalData ifAbsent:[nil]).
	newArray at: 47 put: (Smalltalk at: #ExternalFunction ifAbsent:[nil]).
	newArray at: 48 put: (Smalltalk at: #Externa!
lLibrary ifAbsent:[nil]).

	newArray at: 49 put: #aboutToReturn:to:.

	"Now replace the interpreter's reference in one atomic operation"
	self specialObjectsArray become: newArray! !


"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."

Smalltalk recreateSpecialObjectsArray
!