I'll throw this out for comment. I've been looking at why sends are 
slower than say 2.8. As part of this work I cleaned up a few methods 
to improve performance of message sends. So perhaps someone can 
review and let me know if this makes a difference? Of course letting 
me know if I've not broken anything would be cool too, mind usually 
at this level mistakes are very fatal...


'From Squeak3.2alpha of 1 November 2001 [latest update: #4599] on 1 
January 2002 at 10:38:25 pm'!
"Change Set:		SlightlyFasterActivate-JMM
Date:			1 January 2002
Author:			johnmci at smalltalkconsulting.com

A few minor changes to clean up the code for method activation. In 
some places too many if statements are executed, and in others we 
have a common sub expression that is evaulated as we stuff values 
into the context header. Most compilers mostly factor that out, but 
if we explicitly do it then we get much better assembler code for the 
for loops. This improves messages sends by about a percent or so"!


!ObjectMemory methodsFor: 'allocation' stamp: 'JMM 12/29/2001 19:18'!
allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop 
h3: extendedSize doFill: doFill with: fillWord
	"Allocate a new object of the given size and number of header 
words. (Note: byteSize already includes space for the base header 
word.) Initialize the header fields of the new object and fill the 
remainder of the object with the given value."

	| newObj remappedClassOop end i |
	self inline: true.
	"remap classOop in case GC happens during allocation"
	hdrSize > 1 ifTrue: [ self pushRemappableOop: classOop ].
   	newObj _ self allocateChunk: byteSize + ((hdrSize - 1) * 4).
	hdrSize > 1 ifTrue:
		[remappedClassOop _ self popRemappableOop.
		hdrSize = 2
			ifTrue:
				[self longAt: newObj     put: 
(remappedClassOop bitOr: HeaderTypeClass).
				self longAt: newObj + 4 put: 
(baseHeader bitOr: HeaderTypeClass).
				newObj _ newObj + 4]
			ifFalse:
				[self longAt: newObj     put: 
(extendedSize bitOr: HeaderTypeSizeAndClass).
				self longAt: newObj + 4 put: 
(remappedClassOop bitOr: HeaderTypeSizeAndClass).
				self longAt: newObj + 8 put: 
(baseHeader bitOr: HeaderTypeSizeAndClass).
				newObj _ newObj + 8]]
		ifFalse: [self longAt: newObj put: (baseHeader bitOr: 
HeaderTypeShort)].

	"clear new object"
	doFill ifTrue:
		[end _ newObj + byteSize.
		i _ newObj + 4.
		[i < end] whileTrue:
			[self longAt: i put: fillWord.
			i _ i + 4]].

	DoAssertionChecks ifTrue: [
		self okayOop: newObj.
		self oopHasOkayClass: newObj.
		(self objectAfter: newObj) = freeBlock
			ifFalse: [ self error: 'allocate bug: did not 
set header of new oop correctly' ].
		(self objectAfter: freeBlock) = endOfMemory
			ifFalse: [ self error: 'allocate bug: did not 
set header of freeBlock correctly' ].
	].

	^ newObj! !

!ObjectMemory methodsFor: 'allocation' stamp: 'JMM 12/29/2001 19:05'!
allocateOrRecycleContext: needsLarge
	"Return a recycled context or a newly allocated one if none 
is available for recycling."
	| cntxt |
	needsLarge = 0
	ifTrue: [freeContexts ~= NilContext ifTrue:
				[cntxt _ freeContexts.
				freeContexts _ self fetchPointer: 0 
ofObject: cntxt.
				^ cntxt].
			cntxt _ self instantiateContext: (self 
splObj: ClassMethodContext)
				sizeInBytes: SmallContextSize]
	ifFalse: [freeLargeContexts ~= NilContext ifTrue:
				[cntxt _ freeLargeContexts.
				freeLargeContexts _ self 
fetchPointer: 0 ofObject: cntxt.
				^ cntxt].
			cntxt _ self instantiateContext: (self 
splObj: ClassMethodContext)
				sizeInBytes: LargeContextSize].

	"Required init -- above does not fill w/nil.  All others get written."
	self storePointerUnchecked: 4 "InitialIPIndex" ofObject: cntxt
					withValue: nilObj.
	^ cntxt
! !

!ObjectMemory methodsFor: 'allocation' stamp: 'JMM 12/29/2001 17:43'!
recycleContextIfPossible: cntxOop
	| header |
	"If possible, save the given context on a list of free 
contexts to be recycled."
	"Note: The context is not marked free, so it can be reused 
with minimal fuss.  The recycled context lists are cleared at every 
garbage collect."

	self inline: true.
	"only recycle young contexts (which should be most of them)"
	cntxOop >= youngStart ifTrue:
		[header _ self baseHeader: cntxOop.
		(self isMethodContextHeader: header) ifTrue:
			["It's a young context, alright."
			(header bitAnd: SizeMask) = SmallContextSize
				ifTrue:
				["Recycle small contexts"
				self storePointerUnchecked: 0 
ofObject: cntxOop withValue: freeContexts.
				freeContexts _ cntxOop]
				ifFalse:
					[(header bitAnd: SizeMask) = 
LargeContextSize
						ifTrue:
						["Recycle large contexts"
						self 
storePointerUnchecked: 0 ofObject: cntxOop withValue: 
freeLargeContexts.
						freeLargeContexts _ cntxOop]]]]
! !


!Interpreter methodsFor: 'message sending' stamp: 'JMM 12/29/2001 15:39'!
activateNewMethod
	| newContext methodHeader initialIP tempCount nilOop where argCount2 |
	methodHeader _ self headerOf: newMethod.
	newContext _ self allocateOrRecycleContext: (methodHeader 
bitAnd: LargeContextBit).

	initialIP _ ((LiteralStart + (self literalCountOfHeader: 
methodHeader)) * 4) + 1.
	tempCount _ (methodHeader >> 19) bitAnd: 16r3F.

	"Assume: newContext will be recorded as a root if necessary by the
	 call to newActiveContext: below, so we can use unchecked stores."

	where _  (self cCoerce: newContext to: 'char *') + BaseHeaderSize.
	self longAt: where + (SenderIndex << 2) put: activeContext.
	self longAt: where + (InstructionPointerIndex << 2) put: 
(self integerObjectOf: initialIP).
	self longAt: where + (StackPointerIndex << 2) put: (self 
integerObjectOf: tempCount).
	self longAt: where + (MethodIndex << 2) put: newMethod.

	"Copy the reciever and arguments..."
	argCount2 _ argumentCount.
	0 to: argCount2 do:
		[:i | self longAt: where + ((ReceiverIndex+i) << 2) 
put: (self stackValue: argCount2-i)].

	"clear remaining temps to nil in case it has been recycled"
	nilOop _ nilObj.
	argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
		[:i | self longAt: where + (i << 2) put: nilOop].

	self pop: argCount2 + 1.
	reclaimableContextCount _ reclaimableContextCount + 1.
	self newActiveContext: newContext.! !

!Interpreter methodsFor: 'message sending' stamp: 'JMM 12/29/2001 17:26'!
internalActivateNewMethod
	| methodHeader newContext tempCount argCount2 needsLarge where |
	self inline: true.

	methodHeader _ self headerOf: newMethod.
	needsLarge _ methodHeader bitAnd: LargeContextBit.
	(needsLarge = 0 and: [freeContexts ~= NilContext])
		ifTrue: [newContext _ freeContexts.
				freeContexts _ self fetchPointer: 0 
ofObject: newContext]
		ifFalse: ["Slower call for large contexts or empty free list"
				self externalizeIPandSP.
				newContext _ self 
allocateOrRecycleContext: needsLarge.
				self internalizeIPandSP].
	tempCount _ (methodHeader >> 19) bitAnd: 16r3F.

	"Assume: newContext will be recorded as a root if necessary by the
	 call to newActiveContext: below, so we can use unchecked stores."

	where _  (self cCoerce: newContext to: 'char *') + BaseHeaderSize.
	self longAt: where + (SenderIndex << 2) put: activeContext.
	self longAt: where + (InstructionPointerIndex << 2) put:
			(self integerObjectOf:
				(((LiteralStart + (self 
literalCountOfHeader: methodHeader)) * 4) + 1)).
	self longAt: where + (StackPointerIndex << 2) put: (self 
integerObjectOf: tempCount).
	self longAt: where + (MethodIndex << 2) put: newMethod.

	"Copy the reciever and arguments..."
	argCount2 _ argumentCount.
	0 to: argCount2 do:
		[:i | self longAt: where + ((ReceiverIndex+i) << 2)
				put: (self internalStackValue: argCount2-i)].

	"clear remaining temps to nil in case it has been recycled"
	methodHeader _ nilObj.  "methodHeader here used just as 
faster (register?) temp"
	argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
		[:i | self longAt: where + (i << 2) put: methodHeader].

	self internalPop: argCount2 + 1.
	reclaimableContextCount _ reclaimableContextCount + 1.
	self internalNewActiveContext: newContext.
! !

!Interpreter methodsFor: 'control primitives' stamp: 'JMM 12/29/2001 16:22'!
primitiveBlockCopy

	| context methodContext contextSize newContext initialIP where |
	context _ self stackValue: 1.
	(self isIntegerObject: (self fetchPointer: MethodIndex 
ofObject: context))
		ifTrue: ["context is a block; get the context of its 
enclosing method"
				methodContext _ self fetchPointer: 
HomeIndex ofObject: context]
		ifFalse: [methodContext _ context].
	contextSize _ self sizeBitsOf: methodContext.  "in bytes, 
including header"
	context _ nil.  "context is no longer needed and is not 
preserved across allocation"

	"remap methodContext in case GC happens during allocation"
	self pushRemappableOop: methodContext.
	newContext _ self instantiateContext: (self splObj: ClassBlockContext)
 
sizeInBytes: contextSize.
	methodContext _ self popRemappableOop.

	initialIP _ self integerObjectOf: instructionPointer - method.
	"Was instructionPointer + 3, but now it's greater by
		methodOop + 4 (headerSize) and less by 1 due to preIncrement"

	"Assume: have just allocated a new context; it must be young.
	 Thus, can use uncheck stores. See the comment in 
fetchContextRegisters."

	where _  (self cCoerce: newContext to: 'char *') + BaseHeaderSize.
	self longAt: where + (InitialIPIndex << 2) put: initialIP.
	self longAt: where + (InstructionPointerIndex << 2) put: initialIP.
	self longAt: where + (StackPointerIndex << 2) put: (self 
integerObjectOf: 0).
	self longAt: where + (BlockArgumentCountIndex << 2) put: 
(self stackValue: 0).
	self longAt: where + (HomeIndex << 2) put: methodContext.
	self longAt: where + (SenderIndex << 2) put: nilObj.

	self pop: 2 thenPush: newContext.! !


-- 
--
===========================================================================
John M. McIntosh <johnmci at smalltalkconsulting.com> 1-800-477-2659
Corporate Smalltalk Consulting Ltd.  http://www.smalltalkconsulting.com
===========================================================================