File: VMM38b4-64bit-vm1-ikp.1.cs

package info (click to toggle)
squeak-vm 1%3A4.10.2.2614-4.1
links: PTS, VCS
area: main
in suites: stretch
size: 13,284 kB
ctags: 15,344
sloc: ansic: 75,096; cs: 11,191; objc: 5,494; sh: 3,170; asm: 1,533; cpp: 449; pascal: 372; makefile: 366; awk: 103
file content (8661 lines) | stat: -rw-r--r-- 363,166 bytes
parent folder | download | duplicates (6)
'From Squeak3.8gamma of ''24 November 2004'' [latest update: #6548] on 31 March 2005 at 2:51:49 pm'!
"Change Set:		VMM38b4-64bit-vm
Date:			2005-03-31
Author:			ian.piumarta@squeakland.org

Changes relative to VMMaker-tpr.14 that add 64-bit support to the VM."!

CArray subclass: #BalloonArray
	instanceVariableNames: 'simArray'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!

!BalloonArray commentStamp: '<historical>' prior: 0!
BalloonArray keeps a shadow copy of its raw memory data in a Smalltalk array.  This allows support for C's inhomogeneous access, returning floats where Floats were stored, and negative ints where they were stored.  This ruse only works, of course where we have control over all the access.!

BalloonEnginePlugin subclass: #BalloonEngineSimulation
	instanceVariableNames: 'bbObj workBufferArray '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
Object subclass: #InterpreterSimulationObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-Plugins'!
Object subclass: #ObjectMemory
	instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop 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 totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal '
	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 DoBalanceChecks Done ExternalObjectsArray FalseObject FloatProto GCTopMarker HashBits HashBitsOffset HeaderTypeClass HeaderTypeFree HeaderTypeGC HeaderTypeShort HeaderTypeSizeAndClass LargeContextBit LargeContextSize MarkBit MethodContextProto NilContext NilObject RemapBufferSize RootBit RootTableRedZone RootTableSize SchedulerAssociation SelectorAboutToReturn SelectorCannotInterpret SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SelectorRunWithIn SizeMask SmallContextSize SpecialSelectors StackStart StartField StartObj TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject TypeMask Upward Bytes3to0Mask Size4Bit Byte1Shift Byte4Shift Byte7Shift Bytes7to4Mask ContextFixedSizePlusHeader Byte7ShiftNegated Byte2Mask Byte4ShiftNegated Byte1ShiftNegated Byte0Shift Byte5Mask Byte1Mask Byte3Shift Byte6Shift BytesPerWord Byte4Mask Byte0Mask Byte7Mask Byte3Mask LongSizeMask Byte2Shift Byte5ShiftNegated Byte6Mask Byte5Shift WordMask Byte3ShiftNegated ShiftForWord '
	poolDictionaries: ''
	category: 'VMMaker-Interpreter'!

!ObjectMemory commentStamp: '<historical>' prior: 0!
This class describes a 32-bit direct-pointer object memory for Smalltalk.  The model is very simple in principle:  a pointer is either a SmallInteger or a 32-bit direct object pointer.

SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.

All object pointers point to a header, which may be followed by a number of data fields.  This object memory achieves considerable compactness by using a variable header size (the one complexity of the design).  The format of the 0th header word is as follows:

	3 bits	reserved for gc (mark, root, unused)
	12 bits	object hash (for HashSets)
	5 bits	compact class index
	4 bits	object format
	6 bits	object size in 32-bit words
	2 bits	header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)

If a class is in the compact class table, then this is the only header information needed.  If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits.  It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.

The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).

This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers.  It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.

There is now a simple 64-bit version of the object memory.  It is the simplest possible change that could work.  It merely sign-extends all integer oops, and extends all object headers and oops by adding 32 zeroes in the high bits.  The format of the base header word is changed in one minor, not especially elegant, way.  Consider the old 32-bit header:
	ggghhhhhhhhhhhhcccccffffsssssstt
The 64-bit header is almost identical, except that the size field (now being in units of 8 bytes, has a zero in its low-order bit.  At the same time, the byte-size residue bits for byte objects, which are in the low order bits of formats 8-11 and 12-15, are now in need of another bit of residue.  So, the change is as follows:
	ggghhhhhhhhhhhhcccccffffsssssrtt
where bit r supplies the 4's bit of the byte size residue for byte objects.  Oh, yes, this is also needed now for 'variableWord' objects, since their size in 32-bit words requires a low-order bit.

See the comment in formatOf: for the change allowing for 64-bit wide bitmaps, now dubbed 'variableLong'.!

Interpreter subclass: #InterpreterSimulator
	instanceVariableNames: 'byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript logging displayView '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
InterpreterSimulatorLSB subclass: #InterpreterSimulatorLSB64
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
InterpreterSimulatorMSB subclass: #InterpreterSimulatorMSB64
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!

!Object methodsFor: '*VMMaker-translation support' stamp: 'di 7/14/2004 12:15'!
isCObjectAccessor

	^ false! !


!Array methodsFor: 'converting' stamp: 'di 5/9/2004 09:55'!
coerceTo: cTypeString sim: interpreterSimulator

	^ self! !


!CArray methodsFor: 'converting' stamp: 'di 7/15/2004 16:55'!
asCArrayAccessor

	^ (CArrayAccessor on: self)
			+= -1   "Defeat the +1 offset in the accessor"! !

!CArray methodsFor: 'converting' stamp: 'tpr 3/23/2005 12:36'!
coerceTo: cTypeString sim: interpreterSimulator

	cTypeString = 'int' ifTrue: [^ self ptrAddress].
	cTypeString = 'float *' ifTrue: [^ self asCArrayAccessor asFloatAccessor].
	cTypeString = 'int *' ifTrue: [^ self asCArrayAccessor asIntAccessor].
	cTypeString = 'unsigned' ifTrue: [^ self ptrAddress].
	^ self! !

!CArray methodsFor: 'accessing' stamp: 'di 7/6/2004 09:32'!
at: offset

	ptrOffset = 0 ifFalse: [self error: 'only expect base address to receive at: message'].
	unitSize = 1 ifTrue: [^ interpreter byteAt: arrayBaseAddress + offset].
	unitSize = 4 ifTrue: [^ interpreter long32At: arrayBaseAddress + (offset * 4)].
	self halt: 'Can''t handle unitSize ', unitSize printString
! !

!CArray methodsFor: 'accessing' stamp: 'di 7/19/2004 12:01'!
at: offset put: val

	ptrOffset = 0 ifFalse: [self error: 'only expect base address to receive at:put: message'].
	unitSize = 1 ifTrue: [^ interpreter byteAt: arrayBaseAddress + offset put: val].
	unitSize = 4 ifTrue: [^ interpreter long32At: arrayBaseAddress + (offset * 4) put: val].
	self halt: 'Can''t handle unitSize ', unitSize printString
! !

!CArray methodsFor: 'accessing' stamp: 'di 7/16/2004 12:45'!
floatAt: index
	^ Float fromIEEE32Bit: (self at: index)! !

!CArray methodsFor: 'accessing' stamp: 'di 7/16/2004 12:45'!
floatAt: index put: value
	^ self at: index put: value asIEEE32BitWord! !

!CArray methodsFor: 'accessing' stamp: 'di 7/16/2004 12:45'!
intAt: index
	^ (self at: index) signedIntFromLong! !

!CArray methodsFor: 'accessing' stamp: 'di 7/16/2004 12:45'!
intAt: index put: signedInt
	^ self at: index put: signedInt signedIntToLong! !


!BalloonArray methodsFor: 'memory access' stamp: 'di 7/16/2004 12:14'!
at: index
	| value |
	value _ simArray at: index+1.
	"Debug only..."
	value ifNil:
		[self error: 'attempt to read an uninitialized field'.
		^ super at: index  "Maybe it was set in Squeak.  Return the raw value"].
	(self bitsOf: value) ~= (super at: index) ifTrue:
		[self error: 'inconsistent values'].
	^ value! !

!BalloonArray methodsFor: 'memory access' stamp: 'di 7/16/2004 11:28'!
at: index put: value

	super at: index put: (self bitsOf: value).
	^ simArray at: index + 1 put: value.
	! !

!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:34'!
bitsOf: value
	"Convert pos and neg ints and floats to 32-bit representations expected by C"

	value isInteger ifTrue:
		[value >= 0 ifTrue: [^ value].
		^ value + 16r80000000 + 16r80000000].
	value isFloat ifTrue:
		[^ value asIEEE32BitWord].
	self error: 'unexpected value for 32 bits'.
	^ 0! !

!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 16:04'!
floatAt: index
	| value |
	value _ self at: index.
	value isFloat ifFalse:
		[value = 0 ifTrue: [^ 0.0].
		self error: 'non-float was stored'.
		^ Float fromIEEE32Bit: value].
	^ value! !

!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:00'!
floatAt: index put: value

	value isFloat
		ifFalse: [self error: 'inconsistent values'].
	^ self at: index put: value! !

!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:02'!
intAt: index
	| value |
	value _ self at: index.
	value isInteger
		ifFalse: [self error: 'inconsistent values'].
	^ value! !

!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:01'!
intAt: index put: value

	value isInteger
		ifFalse: [self error: 'inconsistent values'].
	^ self at: index put: value! !

!BalloonArray methodsFor: 'memory access' stamp: 'di 7/15/2004 13:17'!
setSimArray: anArray

	simArray _ anArray! !


!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/2/2004 14:19'!
storeHeaderOnFile: fileName bytesPerWord: bytesPerWord
	"Store C header code for this interpreter on the given file."

	| aStream |
	aStream _ CrLfFileStream forceNewFileNamed: fileName.
	aStream ifNil: [Error signal: 'Could not open C header file: ', fileName].
	aStream
		nextPutAll: '/* Automatically generated from Squeak on ';
		print: Time dateAndTimeNow;
		nextPutAll: ' */'; cr; cr;
		nextPutAll: '#define SQ_VI_BYTES_PER_WORD ';
		print: bytesPerWord;
		cr;
		close! !

!CCodeGenerator methodsFor: 'utilities' stamp: 'ikp 6/13/2004 22:22'!
builtin: sel
	"Answer true if the given selector is one of the builtin selectors."

	((sel = #byteAt:) or: [sel = #byteAt:put:]) ifTrue: [ ^true ].
	((sel = #shortAt:) or: [sel = #shortAt:put:]) ifTrue: [ ^true ].
	((sel = #intAt:) or: [sel = #intAt:put:]) ifTrue: [ ^true ].
	((sel = #longAt:) or: [(sel = #longAt:put:) or: [sel = #error:]]) ifTrue: [ ^true ].
	((sel = #byteAtPointer:) or: [sel = #byteAtPointer:put:]) ifTrue: [ ^true ].
	((sel = #shortAtPointer:) or: [sel = #shortAtPointer:put:]) ifTrue: [ ^true ].
	((sel = #longAtPointer:) or: [(sel = #longAtPointer:put:) or: [sel = #error:]]) ifTrue: [ ^true ].
	^translationDict includesKey: sel! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 8/3/2004 20:16'!
cLiteralFor: anObject
	"Return a string representing the C literal value for the given object."
	(anObject isKindOf: Integer) ifTrue: [
		(anObject < 16r7FFFFFFF)
			ifTrue: [^ anObject printString]
			ifFalse: [^ anObject printString , ObjectMemory unsignedIntegerSuffix "ikp"]].
	(anObject isKindOf: String) ifTrue: [^ '"', anObject, '"' ].
	(anObject isKindOf: Float) ifTrue: [^ anObject printString ].
	anObject == nil ifTrue: [^ 'null' ].
	anObject == true ifTrue: [^ '1' ].			"ikp"
	anObject == false ifTrue: [^ '0' ].			"ikp"
	(anObject isKindOf: Character) ifTrue:[^anObject asString printString]. "ar"
	self error:								"ikp"
		'Warning: A Smalltalk literal could not be translated into a C constant: ', anObject printString.
	^'"XXX UNTRANSLATABLE CONSTANT XXX"'! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 6/9/2004 16:04'!
emitCHeaderForPrimitivesOn: aStream
	"Write a C file header for compiled primitives onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */'; cr; cr.

	aStream nextPutAll: '#include "sq.h"'; cr; cr.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].

	aStream nextPutAll: '
#include "sqMemoryAccess.h"

/*** Imported Functions/Variables ***/
extern sqInt stackValue(sqInt);
extern sqInt stackIntegerValue(sqInt);
extern sqInt successFlag;

/* allows accessing Strings in both C and Smalltalk */
#define asciiValue(c) c
'.
	aStream cr.! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 6/9/2004 16:06'!
emitCHeaderOn: aStream
	"Write a C file header onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */'; cr; cr.
	self emitGlobalStructFlagOn: aStream.
	aStream nextPutAll: '#include "sq.h"'; cr.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].

	aStream nextPutAll: '
#include "sqMemoryAccess.h"

sqInt printCallStack(void);
void error(char *s);
void error(char *s) {
	/* Print an error message and exit. */
	static sqInt printingStack = false;

	printf("\n%s\n\n", s);
	if (!!printingStack) {
		/* flag prevents recursive error when trying to print a broken stack */
		printingStack = true;
		printCallStack();
	}
	exit(-1);
}
'.
	aStream cr.! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 6/9/2004 16:04'!
emitCVariablesOn: aStream 
	"Store the global variable declarations on the given stream."
	| varString |
	aStream nextPutAll: '/*** Variables ***/';
		 cr.
	variables asSortedCollection
		do: [:var | 
			varString _ var asString.
			self isGeneratingPluginCode
				ifTrue: [varString = 'interpreterProxy'
						ifTrue: ["quite special..."
							aStream cr; nextPutAll: '#ifdef SQUEAK_BUILTIN_PLUGIN'.
							aStream cr; nextPutAll: 'extern'.
							aStream cr; nextPutAll: '#endif'; cr]
						ifFalse: [aStream nextPutAll: 'static ']].
			(variableDeclarations includesKey: varString)
				ifTrue: [aStream nextPutAll: (variableDeclarations at: varString) , ';'; cr]
				ifFalse: ["default variable declaration"
					aStream nextPutAll: 'sqInt ' , varString , ';'; cr]].
	aStream cr! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ikp 6/9/2004 16:13'!
generateAsInteger: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll:'((sqInt) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' )'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ikp 8/4/2004 16:29'!
generateBitShift: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| arg rcvr |
	arg _ msgNode args first.
	rcvr _ msgNode receiver.
	arg isConstant ifTrue: [
		"bit shift amount is a constant"
		aStream nextPutAll: '((usqInt) '.
		self emitCExpression: rcvr on: aStream.
		arg value < 0 ifTrue: [
			aStream nextPutAll: ' >> ', arg value negated printString.
		] ifFalse: [
			aStream nextPutAll: ' << ', arg value printString.
		].
		aStream nextPutAll: ')'.
	] ifFalse: [
		"bit shift amount is an expression"
		aStream nextPutAll: '(('.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: ' < 0) ? ((usqInt) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' >> -'.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: ') : ((usqInt) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' << '.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: '))'.
	].! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ikp 6/9/2004 16:14'!
generateDivide: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| rcvr arg divisor |
	rcvr _ msgNode receiver.
	arg _ msgNode args first.
	(arg isConstant and:
	 [UseRightShiftForDivide and:
	 [(divisor _ arg value) isInteger and:
	 [divisor isPowerOfTwo and:
	 [divisor > 0 and:
	 [divisor <= (1 bitShift: 31)]]]]])
	ifTrue: [
		"use signed (arithmetic) right shift instead of divide"
		aStream nextPutAll: '((sqInt) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' >> ', (divisor log: 2) asInteger printString.
		aStream nextPutAll: ')'.
	] ifFalse: [
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' / '.
		self emitCExpression: arg on: aStream].
! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ikp 8/4/2004 18:25'!
generateShiftRight: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '((usqInt) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ')'.
	aStream nextPutAll: ' >> '.
	self emitCExpression: msgNode args first on: aStream.! !


!CCodeGeneratorGlobalStructure methodsFor: 'C code generator' stamp: 'ikp 6/9/2004 16:05'!
emitCVariablesOn: aStream
	"Store the global variable declarations on the given stream.
	break logic into vars for structure and vars for non-structure"
	| varString structure nonstruct target |

	structure _ WriteStream on: (String new: 32768).
	nonstruct _ WriteStream on: (String new: 32768).
	aStream nextPutAll: '/*** Variables ***/'; cr.
	structure nextPutAll: 'struct foo {'; cr.
	self buildSortedVariablesCollection do: [ :var |
		varString _ var asString.
		target _ (self placeInStructure: var) 
			ifTrue: [structure]
			ifFalse: [nonstruct].
		(self isGeneratingPluginCode) ifTrue:[
			varString = 'interpreterProxy' ifTrue:[
				"quite special..."
				aStream cr; nextPutAll: '#ifdef SQUEAK_BUILTIN_PLUGIN'.
				aStream cr; nextPutAll: 'extern'.
				aStream cr; nextPutAll: '#endif'; cr.
			] ifFalse:[aStream nextPutAll:'static '].
		].
		(variableDeclarations includesKey: varString) ifTrue: [
			target nextPutAll: (variableDeclarations at: varString), ';'; cr.
		] ifFalse: [
			"default variable declaration"
			target nextPutAll: 'sqInt ', varString, ';'; cr.
		].
	].
	structure nextPutAll: ' } fum;';cr.

	"if the machine needs the fum structure defining locally, do it now"
	localStructDef ifTrue:[structure nextPutAll: 'struct foo * foo = &fum;';cr;cr].

	aStream nextPutAll: structure contents.
	aStream nextPutAll: nonstruct contents.
	aStream cr.! !


!CObjectAccessor methodsFor: 'converting' stamp: 'di 7/14/2004 17:36'!
asFloatAccessor

	^ self asPluggableAccessor
		atBlock: [:obj :index | obj floatAt: index]
		atPutBlock: [:obj :index :value | obj floatAt: index put: value]! !

!CObjectAccessor methodsFor: 'converting' stamp: 'di 7/14/2004 17:36'!
asIntAccessor

	^ self asPluggableAccessor
		atBlock: [:obj :index | obj intAt: index]
		atPutBlock: [:obj :index :value | obj intAt: index put: value]! !

!CObjectAccessor methodsFor: 'converting' stamp: 'di 7/14/2004 11:55'!
asPluggableAccessor
	^ (CPluggableAccessor on: object) += offset! !

!CObjectAccessor methodsFor: 'converting' stamp: 'di 7/14/2004 17:38'!
coerceTo: cTypeString sim: interpreterSimulator

	cTypeString = 'float *' ifTrue: [^ self asFloatAccessor].
	cTypeString = 'int *' ifTrue: [^ self asIntAccessor].
	^ self! !

!CObjectAccessor methodsFor: 'accessing' stamp: 'di 7/14/2004 12:13'!
isCObjectAccessor

	^ true! !


!CPluggableAccessor methodsFor: 'initialize' stamp: 'di 7/14/2004 11:55'!
atBlock: rBlock atPutBlock: wBlock
	readBlock _ rBlock.
	writeBlock _ wBlock! !


!CompiledMethod methodsFor: 'accessing' stamp: 'di 6/29/2004 12:28'!
initialPC
	"Answer the program counter for the receiver's first bytecode."

	^ (self numLiterals + 1) * Smalltalk wordSize + 1
! !


!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'di 7/16/2004 15:06'!
signedIntFromLong
	"Self is an unsigned 32-bit integer"

	| sign |
	self < 0 ifTrue: [self error: 'only valid for unsigned ints'].
	sign _ self bitAnd: 16r80000000.
	sign = 0 ifTrue: [^ self].
	^ self - sign - sign! !

!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'di 7/16/2004 15:06'!
signedIntFromShort
	"Self is an unsigned 16-bit integer in twos-comp form"

	| sign |
	self < 0 ifTrue: [self error: 'only valid for unsigned ints'].
	sign _ self bitAnd: 16r8000.
	sign = 0 ifTrue: [^ self].
	^ self - sign - sign! !

!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'di 7/14/2004 12:27'!
signedIntToLong
	"Produces a 32-bit value in twos-comp form.  Sorry no error checking"

	self >= 0
		ifTrue: [^ self]
		ifFalse: [^ self + 16r80000000 + 16r80000000]
! !

!Integer methodsFor: '*VMMaker-interpreter simulator' stamp: 'di 7/14/2004 12:26'!
signedIntToShort
	"Produces a 16-bit value (0-65k) in twos-comp form.  Sorry no error checking"

	self >= 0
		ifTrue: [^ self]
		ifFalse: [^ self + 16r8000 + 16r8000]
! !


!InterpreterPlugin methodsFor: 'initialize' stamp: 'ikp 8/3/2004 19:18'!
getInterpreter
	"Note: This is coded so that plugins can be run from Squeak."

	self returnTypeC: 'VirtualMachine *'.
	^interpreterProxy! !


!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 7/11/2004 13:43'!
workBufferPut: wbOop
	workBuffer := interpreterProxy firstIndexableField: wbOop.! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ikp 8/9/2004 18:22'!
fillSpan: fill from: leftX to: rightX
	"Fill the span buffer from leftX to rightX with the given fill.
	Clip before performing any operations. Return true if the fill must
	be handled by some Smalltalk code."
	| x0 x1 type |
	self var: #fill type: 'unsigned int'.
	self inline: false.
	fill = 0 ifTrue:[^false]. "Nothing to do"
	"Start from spEnd - we must not paint pixels twice at a scan line"
	leftX < self spanEndAAGet 
		ifTrue:[x0 _ self spanEndAAGet]
		ifFalse:[x0 _ leftX].
	rightX > (self spanSizeGet << self aaShiftGet) 
		ifTrue:[x1 _ (self spanSizeGet << self aaShiftGet)]
		ifFalse:[x1 _ rightX].

	"Clip left and right values"
	x0 < self fillMinXGet ifTrue:[x0 _ self fillMinXGet].
	x1 > self fillMaxXGet ifTrue:[x1 _ self fillMaxXGet].

	"Adjust start and end values of span"
	x0 < self spanStartGet ifTrue:[self spanStartPut: x0].
	x1 > self spanEndGet ifTrue:[self spanEndPut: x1].
	x1 > self spanEndAAGet ifTrue:[self spanEndAAPut: x1].

	x0 >= x1 ifTrue:[^false]. "Nothing to do"

	(self isFillColor: fill) ifTrue:[
		self fillColorSpan: fill from: x0 to: x1.
	] ifFalse:[
		"Store the values for the dispatch"
		self lastExportedFillPut: fill.
		self lastExportedLeftXPut: x0.
		self lastExportedRightXPut: x1.
		type _ self fillTypeOf: fill.
		type <= 1 ifTrue:[^true].
		self dispatchOn: type in: FillTable.
	].
	^false! !

!BalloonEngineBase methodsFor: 'GET processing' stamp: 'di 7/14/2004 13:09'!
initializeGETProcessing
	"Initialization stuff that needs to be done before any processing can take place."
	self inline: false.

	"Make sure aaLevel is initialized"
	self setAALevel: self aaLevelGet.

	self clipMinXGet < 0 ifTrue:[self clipMinXPut: 0].
	self clipMaxXGet > self spanSizeGet ifTrue:[self clipMaxXPut: self spanSizeGet].
	"Convert clipRect to aaLevel"
	self fillMinXPut: self clipMinXGet << self aaShiftGet.
	self fillMinYPut: self clipMinYGet << self aaShiftGet.
	self fillMaxXPut: self clipMaxXGet << self aaShiftGet.
	self fillMaxYPut: self clipMaxYGet << self aaShiftGet.

	"Reset GET and AET"
	self getUsedPut: 0.
	self aetUsedPut: 0.
	getBuffer _ objBuffer + objUsed.
	aetBuffer _ objBuffer + objUsed.

	"Create the global edge table"
	self createGlobalEdgeTable.
	engineStopped ifTrue:[^nil].

	self getUsedGet = 0 ifTrue:[
		"Nothing to do"
		self currentYPut: self fillMaxYGet.
		^0].

	"Sort entries in the GET"
	self sortGlobalEdgeTable.

	"Find the first y value to be processed"
	self currentYPut: (self edgeYValueOf: (getBuffer at: 0)).
	self currentYGet < self fillMinYGet ifTrue:[self currentYPut: self fillMinYGet].

	"Load and clear the span buffer"
	self spanStartPut: 0.
	self spanEndPut: (self spanSizeGet << self aaShiftGet) - 1.
	self clearSpanBuffer. "@@: Is this really necessary?!!"! !

!BalloonEngineBase methodsFor: 'private' stamp: 'ikp 6/14/2004 15:14'!
copyBitsFrom: x0 to: x1 at: yValue

	copyBitsFn = 0 ifTrue: [
		"We need copyBits here so try to load it implicitly"
		self initialiseModule ifFalse: [^false].
	].
	^self cCode: '((sqInt (*)(sqInt, sqInt, sqInt))copyBitsFn)(x0, x1, yValue)'! !

!BalloonEngineBase methodsFor: 'private' stamp: 'ikp 6/14/2004 15:14'!
loadBitBltFrom: bbObj

	loadBBFn = 0 ifTrue: [
		"We need copyBits here so try to load it implicitly"
		self initialiseModule ifFalse:[^false].
	].
	^self cCode: '((sqInt (*)(sqInt))loadBBFn)(bbObj)'! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 7/11/2004 13:42'!
loadWorkBufferFrom: wbOop
	"Load the working buffer from the given oop"
	self inline: false.
	(interpreterProxy isIntegerObject: wbOop) ifTrue:[^false].
	(interpreterProxy isWords: wbOop) ifFalse:[^false].
	(interpreterProxy slotSizeOf: wbOop) < GWMinimalSize ifTrue:[^false].
	self workBufferPut: wbOop.
	self magicNumberGet = GWMagicNumber ifFalse:[^false].
	"Sanity checks"
	(self wbSizeGet = (interpreterProxy slotSizeOf: wbOop)) ifFalse:[^false].
	self objStartGet = GWHeaderSize ifFalse:[^false].

	"Load buffers"
	objBuffer _ workBuffer + self objStartGet.
	getBuffer _ objBuffer + self objUsedGet.
	aetBuffer _ getBuffer + self getUsedGet.

	"Make sure we don't exceed the work buffer"
	GWHeaderSize + self objUsedGet + self getUsedGet + self aetUsedGet > self wbSizeGet ifTrue:[^false].

	^true! !

!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar 7/11/2004 13:42'!
primitiveInitializeBuffer
	| wbOop size |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	wbOop _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: wbOop) 
		ifFalse:[^interpreterProxy primitiveFail].
	(size _ interpreterProxy slotSizeOf: wbOop) < GWMinimalSize
		ifTrue:[^interpreterProxy primitiveFail].
	self workBufferPut: wbOop.
	objBuffer _ workBuffer + GWHeaderSize.
	self magicNumberPut: GWMagicNumber.
	self wbSizePut: size.
	self wbTopPut: size.
	self statePut: GEStateUnlocked.
	self objStartPut: GWHeaderSize.
	self objUsedPut: 4.	"Dummy fill object"
	self objectTypeOf: 0 put: GEPrimitiveFill.
	self objectLengthOf: 0 put: 4.
	self objectIndexOf: 0 put: 0.
	self getStartPut: 0.
	self getUsedPut: 0.
	self aetStartPut: 0.
	self aetUsedPut: 0.
	self stopReasonPut: 0.
	self needsFlushPut: 0.
	self clipMinXPut: 0.
	self clipMaxXPut: 0.
	self clipMinYPut: 0.
	self clipMaxYPut: 0.
	self currentZPut: 0.
	self resetGraphicsEngineStats.
	self initEdgeTransform.
	self initColorTransform.
	interpreterProxy pop: 2.
	interpreterProxy push: wbOop.! !


!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ikp 6/14/2004 15:22'!
bitmapValue: bmFill bits: bits atX: xp y: yp

	| bmDepth bmRaster value rShift cMask r g b a |
	self inline: true.

	bmDepth _ self bitmapDepthOf: bmFill.
	bmRaster _ self bitmapRasterOf: bmFill.
	bmDepth = 32 ifTrue: [
		value _ (self cCoerce: bits to:'int*') at: (bmRaster * yp) + xp.
		(value ~= 0 and: [(value bitAnd: 16rFF000000) = 0])
				ifTrue: [value _ value bitOr: 16rFF000000].
		^self uncheckedTransformColor: value].
	"rShift - shift value to convert from pixel to word index"
	rShift _ self rShiftTable at: bmDepth.
	value _ self makeUnsignedFrom: 
		((self cCoerce: bits to:'int*') at: (bmRaster * yp) + (xp >> rShift)).
	"cMask - mask out the pixel from the word"
	cMask _ (1 << bmDepth) - 1.
	"rShift - shift value to move the pixel in the word to the lowest bit position"
	rShift _ 32 - bmDepth - ((xp bitAnd: (1 << rShift - 1)) * bmDepth).
	value _ (value >> rShift) bitAnd: cMask.
	bmDepth = 16 ifTrue: [
		"Must convert by expanding bits"
		value = 0 ifFalse: [
			b _ (value bitAnd: 31) << 3.		b _ b + (b >> 5).
			g _ (value >> 5 bitAnd: 31) << 3.	g _ g + (g >> 5).
			r _ (value >> 10 bitAnd: 31) << 3.	r _ r + (r >> 5).
			a _ 255.
			value _ b + (g << 8) + (r << 16) + (a << 24)].
	] ifFalse: [
		"Must convert by using color map"
		(self bitmapCmSizeOf: bmFill) = 0
			ifTrue: [value _ 0]
			ifFalse: [value _ self makeUnsignedFrom: ((self colormapOf: bmFill) at: value)].
	].
	^self uncheckedTransformColor: value.! !

!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'di 7/16/2004 15:19'!
checkCompressedFillIndexList: fillList max: maxIndex segments: nSegs
	"Check the fill indexes in the run-length encoded fillList"
	| length runLength runValue nFills fillPtr |
	self inline: false.
	self var: #fillPtr declareC:'int *fillPtr'.
	length _ interpreterProxy slotSizeOf: fillList.
	fillPtr _ interpreterProxy firstIndexableField: fillList.
	nFills _ 0.
	0 to: length-1 do:[:i |
		runLength _ self shortRunLengthAt: i from: fillPtr.
		runValue _ self shortRunValueAt: i from: fillPtr.
		(runValue >= 0 and:[runValue <= maxIndex]) ifFalse:[^false].
		nFills _ nFills + runLength.
	].
	^nFills = nSegs! !

!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'di 7/16/2004 15:13'!
checkCompressedFills: indexList
	"Check if the indexList (containing fill handles) is okay."
	| fillPtr length fillIndex |
	self inline: false.
	self var: #fillPtr declareC:'int *fillPtr'.
	"First check if the oops have the right format"
	(interpreterProxy isWords: indexList) ifFalse:[^false].

	"Then check the fill entries"
	length _ interpreterProxy slotSizeOf: indexList.
	fillPtr _ interpreterProxy firstIndexableField: indexList.
	0 to: length-1 do:[:i |
		fillIndex _ fillPtr at: i.
		"Make sure the fill is okay"
		(self isFillOkay: fillIndex) ifFalse:[^false]].

	^ true! !


!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/13/2004 16:42'!
copyBitsFrom: x0 to: x1 at: y
	"Simulate the copyBits primitive"

	| bb |
	bbObj isInteger ifTrue:
		["Create a proxy object to handle BitBlt calls"
		bb _ BitBltSimulator new.
		bb initialiseModule.
		bb setInterpreter: interpreterProxy.
		(bb loadBitBltFrom: bbObj)
			ifTrue: [bbObj _ bb]
			ifFalse: [^ self]].
	bbObj copyBitsFrom: x0 to: x1 at: y.
"
	interpreterProxy showDisplayBits: bbObj destForm
		Left: bb affectedLeft Top: bb affectedTop
		Right: bb affectedRight Bottom: bb affectedBottom.
"! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/16/2004 15:07'!
loadPointShortAt: index from: intArray
	"Load the short value from the given index in intArray"

	| long |
	long _ intArray at: index // 2.
	^ ((index bitAnd: 1) = 0
		ifTrue:[interpreterProxy halfWordHighInLong32: long]
		ifFalse:[interpreterProxy halfWordLowInLong32: long])
		signedIntFromShort
! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/16/2004 15:11'!
shortRunLengthAt: index from: runArray
	"Load the short value from the given index in intArray"

	^ interpreterProxy halfWordHighInLong32: (runArray at: index)! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/16/2004 15:10'!
shortRunValueAt: index from: runArray
	"Load the short value from the given index in intArray"

	^ (interpreterProxy halfWordLowInLong32: (runArray at: index)) signedIntFromShort ! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'di 7/16/2004 12:37'!
workBufferPut: wbOop
	interpreterProxy isInterpreterProxy 
		ifTrue:[^super workBufferPut: wbOop].
	workBuffer := ((interpreterProxy firstIndexableField: wbOop) as: BalloonArray) asCArrayAccessor.
	workBufferArray ifNil:
		[workBufferArray _ Array new: (interpreterProxy slotSizeOf: wbOop)].
	workBuffer getObject setSimArray: workBufferArray! !

!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'di 7/12/2004 15:54'!
initialiseModule
	super initialiseModule.
	^ true! !

!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'di 7/15/2004 16:19'!
loadWordTransformFrom: transformOop into: destPtr length: n
	"Load a float array transformation from the given oop"

	| srcPtr wordDestPtr |

true ifTrue:
[^ super loadWordTransformFrom: transformOop into: destPtr length: n].

	srcPtr _ interpreterProxy firstIndexableField: transformOop.
	wordDestPtr _ destPtr as: CArrayAccessor.  "Remove float conversion shell"
	0 to: n-1 do: [:i | wordDestPtr at: i put: (srcPtr at: i)].! !

!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'di 7/16/2004 12:06'!
primitiveInitializeBuffer

	"Fix an uninitialized variable (should probably go into the real engine too)"
	super primitiveInitializeBuffer.
	self spanEndAAPut: 0.! !

!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'di 7/12/2004 16:15'!
primitiveSetBitBltPlugin
	"Primitive. Set the BitBlt plugin to use."
	| pluginName |
	pluginName _ interpreterProxy stackValue: 0.
	"Must be string to work"
	(interpreterProxy isBytes: pluginName) 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy stringOf: pluginName) = bbPluginName
		ifTrue: [interpreterProxy pop: 1. "Return receiver"]
		ifFalse: [^interpreterProxy primitiveFail]! !


!BitBltSimulation methodsFor: 'combination rules' stamp: 'ikp 6/11/2004 16:38'!
merge: sourceWord with: destinationWord
	| mergeFnwith |
	"Sender warpLoop is too big to include this in-line"
	self var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	^ self mergeFn: sourceWord with: destinationWord! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp 8/4/2004 18:03'!
alphaSourceBlendBits32
	"This version assumes 
		combinationRule = 34
		sourcePixSize = destPixSize = 32
		sourceForm ~= destForm.
	Note: The inner loop has been optimized for dealing
		with the special cases of srcAlpha = 0.0 and srcAlpha = 1.0 
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY srcY dstY |
	self inline: false. "This particular method should be optimized in itself"

	"Give the compile a couple of hints"

	"The following should be declared as pointers so the compiler will
	notice that they're used for accessing memory locations 
	(good to know on an Intel architecture) but then the increments
	would be different between ST code and C code so must hope the
	compiler notices what happens (MS Visual C does)"

	deltaY _ bbH + 1. "So we can pre-decrement"
	srcY _ sy.
	dstY _ dy.

	"This is the outer loop"
	[(deltaY _ deltaY - 1) ~= 0] whileTrue:[
		srcIndex _ sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex _ destBits + (dstY * destPitch) + (dx * 4).
		deltaX _ bbW + 1. "So we can pre-decrement"

		"This is the inner loop"
		[(deltaX _ deltaX - 1) ~= 0] whileTrue:[
			sourceWord _ self srcLongAt: srcIndex.
			srcAlpha _ sourceWord >> 24.
			srcAlpha = 255 ifTrue:[
				self dstLongAt: dstIndex put: sourceWord.
				srcIndex _ srcIndex + 4.
				dstIndex _ dstIndex + 4.
				"Now copy as many words as possible with alpha = 255"
				[(deltaX _ deltaX - 1) ~= 0 and:[
					(sourceWord _ self srcLongAt: srcIndex) >> 24 = 255]]
						whileTrue:[
							self dstLongAt: dstIndex put: sourceWord.
							srcIndex _ srcIndex + 4.
							dstIndex _ dstIndex + 4.
						].
				"Adjust deltaX"
				deltaX _ deltaX + 1.
			] ifFalse:[ "srcAlpha ~= 255"
				srcAlpha = 0 ifTrue:[
					srcIndex _ srcIndex + 4.
					dstIndex _ dstIndex + 4.
					"Now skip as many words as possible,"
					[(deltaX _ deltaX - 1) ~= 0 and:[
						(sourceWord _ self srcLongAt: srcIndex) >> 24 = 0]]
						whileTrue:[
							srcIndex _ srcIndex + 4.
							dstIndex _ dstIndex + 4.
						].
					"Adjust deltaX"
					deltaX _ deltaX + 1.
				] ifFalse:[ "0 < srcAlpha < 255"
					"If we have to mix colors then just copy a single word"
					destWord _ self dstLongAt: dstIndex.
					destWord _ self alphaBlendScaled: sourceWord with: destWord.
					self dstLongAt: dstIndex put: destWord.
					srcIndex _ srcIndex + 4.
					dstIndex _ dstIndex + 4.
				].
			].
		].
		srcY _ srcY + 1.
		dstY _ dstY + 1.
	].! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp 6/11/2004 16:27'!
copyLoop
	| prevWord thisWord skewWord halftoneWord mergeWord hInc y unskew skewMask notSkewMask mergeFnwith destWord |
	"This version of the inner loop assumes noSource = false."
	self inline: false.
	self var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	hInc _ hDir*4.  "Byte delta"
	"degenerate skew fixed for Sparc. 10/20/96 ikp"
	skew == -32
		ifTrue: [skew _ unskew _ skewMask _ 0]
		ifFalse: [skew < 0
			ifTrue:
				[unskew _ skew+32.
				skewMask _ AllOnes << (0-skew)]
			ifFalse:
				[skew = 0
					ifTrue:
						[unskew _ 0.
						skewMask _ AllOnes]
					ifFalse:
						[unskew _ skew-32.
						skewMask _ AllOnes >> skew]]].
	notSkewMask _ skewMask bitInvert32.
	noHalftone
		ifTrue: [halftoneWord _ AllOnes.  halftoneHeight _ 0]
		ifFalse: [halftoneWord _ self halftoneAt: 0].

	y _ dy.
	1 to: bbH do: "here is the vertical loop"
		[ :i |
		halftoneHeight > 1 ifTrue:  "Otherwise, its always the same"
			[halftoneWord _ self halftoneAt: y.
			y _ y + vDir].
		preload ifTrue:
			["load the 64-bit shifter"
			prevWord _ self srcLongAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc]
			ifFalse:
			[prevWord _ 0].

	"Note: the horizontal loop has been expanded into three parts for speed:"

			"This first section requires masking of the destination store..."
			destMask _ mask1.
			thisWord _ self srcLongAt: sourceIndex.  "pick up next word"
			sourceIndex _ sourceIndex + hInc.
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			destWord _ self dstLongAt: destIndex.
			mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord) with: destWord.
			destWord _ (destMask bitAnd: mergeWord) bitOr:
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex _ destIndex + hInc.

		"This central horizontal loop requires no store masking"
		destMask _ AllOnes.
combinationRule = 3
ifTrue: [(skew = 0) & (halftoneWord = AllOnes)
		ifTrue: 
		["Very special inner loop for STORE mode with no skew -- just move words"
		hDir = -1
		ifTrue: ["Woeful patch: revert to older code for hDir = -1"
				2 to: nWords-1 do: 
					[ :word |
					thisWord _ self srcLongAt: sourceIndex.
					sourceIndex _ sourceIndex + hInc.
					self dstLongAt: destIndex put: thisWord.
					destIndex _ destIndex + hInc]]
		ifFalse: [2 to: nWords-1 do: 
					[ :word |  "Note loop starts with prevWord loaded (due to preload)"
					self dstLongAt: destIndex put: prevWord.
					destIndex _ destIndex + hInc.
					prevWord _ self srcLongAt: sourceIndex.
					sourceIndex _ sourceIndex + hInc]]]
		ifFalse:
		["Special inner loop for STORE mode -- no need to call merge"
		2 to: nWords-1 do: 
			[ :word |
			thisWord _ self srcLongAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc.
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			self dstLongAt: destIndex put: (skewWord bitAnd: halftoneWord).
			destIndex _ destIndex + hInc]]
] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge:"
			[ :word |
			thisWord _ self srcLongAt: sourceIndex.  "pick up next word"
			sourceIndex _ sourceIndex + hInc.
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
							with: (self dstLongAt: destIndex).
			self dstLongAt: destIndex put: mergeWord.
			destIndex _ destIndex + hInc]
].

		"This last section, if used, requires masking of the destination store..."
		nWords > 1 ifTrue:
			[destMask _ mask2.
			thisWord _ self srcLongAt: sourceIndex.  "pick up next word"
			sourceIndex _ sourceIndex + hInc.
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			destWord _ self dstLongAt: destIndex.
			mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord) with: destWord.
			destWord _ (destMask bitAnd: mergeWord) bitOr:
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex _ destIndex + hInc].

	sourceIndex _ sourceIndex + sourceDelta.
	destIndex _ destIndex + destDelta]! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp 6/11/2004 16:27'!
copyLoopNoSource
	"Faster copyLoop when source not used.  hDir and vDir are both
	positive, and perload and skew are unused"
	| halftoneWord mergeWord mergeFnwith destWord |
	self inline: false.
	self var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].

	"Note: the horizontal loop has been expanded into three parts for speed:"

			"This first section requires masking of the destination store..."
			destMask _ mask1.
			destWord _ self dstLongAt: destIndex.
			mergeWord _ self mergeFn: halftoneWord
							with: destWord.
			destWord _ (destMask bitAnd: mergeWord) bitOr: 
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex _ destIndex + 4.

		"This central horizontal loop requires no store masking"
			destMask _ AllOnes.
			combinationRule = 3 ifTrue: ["Special inner loop for STORE"
				destWord _ halftoneWord.
				2 to: nWords-1 do:[ :word |
					self dstLongAt: destIndex put: destWord.
					destIndex _ destIndex + 4].
			] ifFalse:[ "Normal inner loop does merge"
				2 to: nWords-1 do:[ :word | "Normal inner loop does merge"
					destWord _ self dstLongAt: destIndex.
					mergeWord _ self mergeFn: halftoneWord with: destWord.
					self dstLongAt: destIndex put: mergeWord.
					destIndex _ destIndex + 4].
			].

		"This last section, if used, requires masking of the destination store..."
		nWords > 1 ifTrue:
			[destMask _ mask2.
			destWord _ self dstLongAt: destIndex.
			mergeWord _ self mergeFn: halftoneWord with: destWord.
			destWord _ (destMask bitAnd: mergeWord) bitOr:
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex _ destIndex + 4].

	destIndex _ destIndex + destDelta]! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp 6/11/2004 16:28'!
copyLoopPixMap
	"This version of the inner loop maps source pixels
	to a destination form with different depth.  Because it is already
	unweildy, the loop is not unrolled as in the other versions.
	Preload, skew and skewMask are all overlooked, since pickSourcePixels
	delivers its destination word already properly aligned.
	Note that pickSourcePixels could be copied in-line at the top of
	the horizontal loop, and some of its inits moved out of the loop."
	"ar 12/7/1999:
	The loop has been rewritten to use only one pickSourcePixels call.
	The idea is that the call itself could be inlined. If we decide not
	to inline pickSourcePixels we could optimize the loop instead."
	| skewWord halftoneWord mergeWord scrStartBits nSourceIncs startBits endBits sourcePixMask destPixMask mergeFnwith nPix srcShift dstShift destWord words srcShiftInc dstShiftInc dstShiftLeft mapperFlags |
	self inline: false.
	self var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	"Additional inits peculiar to unequal source and dest pix size..."
	sourcePPW _ 32//sourceDepth.
	sourcePixMask _ maskTable at: sourceDepth.
	destPixMask _ maskTable at: destDepth.
	mapperFlags _ cmFlags bitAnd: ColorMapNewStyle bitInvert32.
	sourceIndex _ sourceBits +
					(sy * sourcePitch) + ((sx // sourcePPW) *4).
	scrStartBits _ sourcePPW - (sx bitAnd: sourcePPW-1).
	bbW < scrStartBits
		ifTrue: [nSourceIncs _ 0]
		ifFalse: [nSourceIncs _ (bbW - scrStartBits)//sourcePPW + 1].
	sourceDelta _ sourcePitch - (nSourceIncs * 4).

	"Note following two items were already calculated in destmask setup!!"
	startBits _ destPPW - (dx bitAnd: destPPW-1).
	endBits _ ((dx + bbW - 1) bitAnd: destPPW-1) + 1.

	bbW < startBits ifTrue:[startBits _ bbW].

	"Precomputed shifts for pickSourcePixels"
	srcShift _ ((sx bitAnd: sourcePPW - 1) * sourceDepth).
	dstShift _ ((dx bitAnd: destPPW - 1) * destDepth).
	srcShiftInc _ sourceDepth.
	dstShiftInc _ destDepth.
	dstShiftLeft _ 0.
	sourceMSB ifTrue:[
		srcShift _ 32 - sourceDepth - srcShift.
		srcShiftInc _ 0 - srcShiftInc].
	destMSB ifTrue:[
		dstShift _ 32 - destDepth - dstShift.
		dstShiftInc _ 0 - dstShiftInc.
		dstShiftLeft _ 32 - destDepth].

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		"*** is it possible at all that noHalftone == false? ***"
		noHalftone
			ifTrue:[halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].
		"setup first load"
		srcBitShift _ srcShift.
		dstBitShift _ dstShift.
		destMask _ mask1.
		nPix _ startBits.
		"Here is the horizontal loop..."
		words _ nWords.
			["pick up the word"
			skewWord _ self pickSourcePixels: nPix flags: mapperFlags 
								srcMask: sourcePixMask destMask: destPixMask
								srcShiftInc: srcShiftInc dstShiftInc: dstShiftInc.
			"align next word to leftmost pixel"
			dstBitShift _ dstShiftLeft.

			destMask = AllOnes ifTrue:["avoid read-modify-write"
				mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (self dstLongAt: destIndex).
				self dstLongAt: destIndex put: (destMask bitAnd: mergeWord).
			] ifFalse:[ "General version using dest masking"
				destWord _ self dstLongAt: destIndex.
				mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (destWord bitAnd: destMask).
				destWord _ (destMask bitAnd: mergeWord) bitOr:
								(destWord bitAnd: destMask bitInvert32).
				self dstLongAt: destIndex put: destWord.
			].
			destIndex _ destIndex + 4.
			words = 2 "e.g., is the next word the last word?"
				ifTrue:["set mask for last word in this row"
						destMask _ mask2.
						nPix _ endBits]
				ifFalse:["use fullword mask for inner loop"
						destMask _ AllOnes.
						nPix _ destPPW].
			(words _ words - 1) = 0] whileFalse.
		"--- end of inner loop ---"
		sourceIndex _ sourceIndex + sourceDelta.
		destIndex _ destIndex + destDelta]
! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ikp 8/2/2004 19:49'!
warpLoop
	"This version of the inner loop traverses an arbirary quadrilateral
	source, thus producing a general affine transformation."
	| skewWord halftoneWord mergeWord startBits
	  deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy pBx pBy
	  xDelta yDelta smoothingCount sourceMapOop
	  nSteps nPix words destWord endBits mergeFnwith dstShiftInc dstShiftLeft mapperFlags |
	self inline: false.
	self var: #mergeFnwith declareC: 'sqInt (*mergeFnwith)(sqInt, sqInt)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'sqInt (*)(sqInt, sqInt)'.
	mergeFnwith.  "null ref for compiler"

	(interpreterProxy slotSizeOf: bitBltOop) >= (BBWarpBase+12)
		ifFalse: [^ interpreterProxy primitiveFail].
	nSteps _ height-1.  nSteps <= 0 ifTrue: [nSteps _ 1].

	pAx _ self fetchIntOrFloat: BBWarpBase ofObject: bitBltOop.
	words _ self fetchIntOrFloat: BBWarpBase+3 ofObject: bitBltOop.
	deltaP12x _ self deltaFrom: pAx to: words nSteps: nSteps.
	deltaP12x < 0 ifTrue: [pAx _ words - (nSteps*deltaP12x)].

	pAy _ self fetchIntOrFloat: BBWarpBase+1 ofObject: bitBltOop.
	words _ self fetchIntOrFloat: BBWarpBase+4 ofObject: bitBltOop.
	deltaP12y _ self deltaFrom: pAy to: words nSteps: nSteps.
	deltaP12y < 0 ifTrue: [pAy _ words - (nSteps*deltaP12y)].

	pBx _ self fetchIntOrFloat: BBWarpBase+9 ofObject: bitBltOop.
	words _ self fetchIntOrFloat: BBWarpBase+6 ofObject: bitBltOop.
	deltaP43x _ self deltaFrom: pBx to: words nSteps: nSteps.
	deltaP43x < 0 ifTrue: [pBx _ words - (nSteps*deltaP43x)].

	pBy _ self fetchIntOrFloat: BBWarpBase+10 ofObject: bitBltOop.
	words _ self fetchIntOrFloat: BBWarpBase+7 ofObject: bitBltOop.
	deltaP43y _ self deltaFrom: pBy to: words nSteps: nSteps.
	deltaP43y < 0 ifTrue: [pBy _ words - (nSteps*deltaP43y)].

	interpreterProxy failed ifTrue: [^ false].  "ie if non-integers above"
	interpreterProxy methodArgumentCount = 2
		ifTrue: [smoothingCount _ interpreterProxy stackIntegerValue: 1.
				sourceMapOop _ interpreterProxy stackValue: 0.
				sourceMapOop = interpreterProxy nilObject
				ifTrue: [sourceDepth < 16 ifTrue:
					["color map is required to smooth non-RGB dest"
					^ interpreterProxy primitiveFail]]
				ifFalse: [(interpreterProxy slotSizeOf: sourceMapOop)
							< (1 << sourceDepth) ifTrue:
					["sourceMap must be long enough for sourceDepth"
					^ interpreterProxy primitiveFail].
					sourceMapOop _ self oopForPointer: (interpreterProxy firstIndexableField: sourceMapOop)]]
		ifFalse: [smoothingCount _ 1.
				sourceMapOop _ interpreterProxy nilObject].
	nSteps _ width-1.  nSteps <= 0 ifTrue: [nSteps _ 1].
	startBits _ destPPW - (dx bitAnd: destPPW-1).
	endBits _ ((dx + bbW - 1) bitAnd: destPPW-1) + 1.
 	bbW < startBits ifTrue:[startBits _ bbW].

	destY < clipY ifTrue:[
		"Advance increments if there was clipping in y"
		pAx _ pAx + (clipY - destY * deltaP12x).
		pAy _ pAy + (clipY - destY * deltaP12y).
		pBx _ pBx + (clipY - destY * deltaP43x).
		pBy _ pBy + (clipY - destY * deltaP43y)].

	"Setup values for faster pixel fetching."
	self warpLoopSetup.
	"Setup color mapping if not provided"
	(smoothingCount > 1 and:[(cmFlags bitAnd: ColorMapNewStyle) = 0]) ifTrue:[
		cmLookupTable == nil ifTrue:[
			destDepth = 16 ifTrue:[self setupColorMasksFrom: 8 to: 5].
		] ifFalse:[
			self setupColorMasksFrom: 8 to: cmBitsPerColor.
		].
	].
	mapperFlags _ cmFlags bitAnd: ColorMapNewStyle bitInvert32.

	destMSB
		ifTrue:[	dstShiftInc _ 0 - destDepth.
				dstShiftLeft _ 32 - destDepth]
		ifFalse:[	dstShiftInc _ destDepth.
				dstShiftLeft _ 0].
	1 to: bbH do:
		[ :i | "here is the vertical loop..."
		xDelta _ self deltaFrom: pAx to: pBx nSteps: nSteps.
 		xDelta >= 0 ifTrue: [sx _ pAx] ifFalse: [sx _ pBx - (nSteps*xDelta)].
		yDelta _ self deltaFrom: pAy to: pBy nSteps: nSteps.
 		yDelta >= 0 ifTrue: [sy _ pAy] ifFalse: [sy _ pBy - (nSteps*yDelta)].

		destMSB
			ifTrue:[dstBitShift _ 32 - ((dx bitAnd: destPPW - 1) + 1 * destDepth)]
			ifFalse:[dstBitShift _ (dx bitAnd: destPPW - 1) * destDepth].

		(destX < clipX) ifTrue:[
			"Advance increments if there was clipping in x"
			sx _ sx + (clipX - destX * xDelta).
			sy _ sy + (clipX - destX * yDelta).
		].

		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].
		destMask _ mask1.
		nPix _ startBits.
		"Here is the inner loop..."
		words _ nWords.
			["pick up word"
			smoothingCount = 1 ifTrue:["Faster if not smoothing"
				skewWord _ self warpPickSourcePixels: nPix
								xDeltah: xDelta yDeltah: yDelta
								xDeltav: deltaP12x yDeltav: deltaP12y
								dstShiftInc: dstShiftInc flags: mapperFlags.
			] ifFalse:["more difficult with smoothing"
				skewWord _ self warpPickSmoothPixels: nPix
						xDeltah: xDelta yDeltah: yDelta
						xDeltav: deltaP12x yDeltav: deltaP12y
						sourceMap: sourceMapOop
						smoothing: smoothingCount
						dstShiftInc: dstShiftInc.
			].
			"align next word access to left most pixel"
			dstBitShift _ dstShiftLeft.
			destMask = AllOnes ifTrue:["avoid read-modify-write"
				mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (self dstLongAt: destIndex).
				self dstLongAt: destIndex put: (destMask bitAnd: mergeWord).
			] ifFalse:[ "General version using dest masking"
				destWord _ self dstLongAt: destIndex.
				mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (destWord bitAnd: destMask).
				destWord _ (destMask bitAnd: mergeWord) bitOr:
								(destWord bitAnd: destMask bitInvert32).
				self dstLongAt: destIndex put: destWord.
			].
			destIndex _ destIndex + 4.
			words = 2 "e.g., is the next word the last word?"
				ifTrue:["set mask for last word in this row"
						destMask _ mask2.
						nPix _ endBits]
				ifFalse:["use fullword mask for inner loop"
						destMask _ AllOnes.
						nPix _ destPPW].
			(words _ words - 1) = 0] whileFalse.
		"--- end of inner loop ---"
		pAx _ pAx + deltaP12x.
		pAy _ pAy + deltaP12y.
		pBx _ pBx + deltaP43x.
		pBy _ pBy + deltaP43y.
		destIndex _ destIndex + destDelta]! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ikp 8/2/2004 20:25'!
warpPickSmoothPixels: nPixels
	xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	sourceMap: sourceMap
	smoothing: n
	dstShiftInc: dstShiftInc
	"Pick n (sub-) pixels from the source form, mapped by sourceMap,
	average the RGB values, map by colorMap and return the new word.
	This version is only called from WarpBlt with smoothingCount > 1"
	| rgb x y a r g b xx yy xdh ydh xdv ydv dstMask destWord i j k nPix |
	self inline: false. "nope - too much stuff in here"
	dstMask _ maskTable at: destDepth.
	destWord _ 0.
	n = 2 "Try avoiding divides for most common n (divide by 2 is generated as shift)"
		ifTrue:[xdh _ xDeltah // 2. ydh _ yDeltah // 2. 
				xdv _ xDeltav // 2. ydv _ yDeltav // 2]
		ifFalse:[xdh _ xDeltah // n. ydh _ yDeltah // n. 
				xdv _ xDeltav // n. ydv _ yDeltav // n].
	i _ nPixels.
	[
		x _ sx. y _ sy.
		a _ r _ g _ b _ 0.
		"Pick and average n*n subpixels"
		nPix _ 0.  "actual number of pixels (not clipped and not transparent)"
		j _ n.
		[
			xx _ x. yy _ y.
			k _ n.
			[
				"get a single subpixel"
				rgb _ self pickWarpPixelAtX: xx y: yy.
				(combinationRule=25 "PAINT" and: [rgb = 0]) ifFalse:[
					"If not clipped and not transparent, then tally rgb values"
					nPix _ nPix + 1.
					sourceDepth < 16 ifTrue:[
						"Get RGBA values from sourcemap table"
						rgb _ self long32At: sourceMap + (rgb << 2).
					] ifFalse:["Already in RGB format"
						sourceDepth = 16 
								ifTrue:[rgb _ self rgbMap16To32: rgb]
								ifFalse:[rgb _ self rgbMap32To32: rgb]].
					b _ b + (rgb bitAnd: 255).
					g _ g + (rgb >> 8 bitAnd: 255).
					r _ r + (rgb >> 16 bitAnd: 255).
					a _ a + (rgb >> 24)].
				xx _ xx + xdh.
				yy _ yy + ydh.
			(k _ k - 1) = 0] whileFalse.
			x _ x + xdv.
			y _ y + ydv.
		(j _ j - 1) = 0] whileFalse.

		(nPix = 0 or: [combinationRule=25 "PAINT" and: [nPix < (n * n // 2)]]) ifTrue:[
			rgb _ 0  "All pixels were 0, or most were transparent"
		] ifFalse:[
			"normalize rgba sums"
			nPix = 4 "Try to avoid divides for most common n"
				ifTrue:[r _ r >> 2.	g _ g >> 2.	b _ b >> 2.	a _ a >> 2]
				ifFalse:[	r _ r // nPix.	g _ g // nPix.	b _ b // nPix.	a _ a // nPix].
			rgb _ (a << 24) + (r << 16) + (g << 8) + b.

			"map the pixel"
			rgb = 0 ifTrue: [
				"only generate zero if pixel is really transparent"
				(r + g + b + a) > 0 ifTrue: [rgb _ 1]].
			rgb _ self mapPixel: rgb flags: cmFlags.
		].
		"Mix it in"
		destWord _ destWord bitOr: (rgb bitAnd: dstMask) << dstBitShift.
		dstBitShift _ dstBitShift + dstShiftInc.
		sx _ sx + xDeltah.
		sy _ sy + yDeltah.
	(i _ i - 1) = 0] whileFalse.

	^destWord
! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ikp 8/2/2004 19:48'!
loadBitBltDestForm
	"Load the dest form for BitBlt. Return false if anything is wrong, true otherwise."

	| destBitsSize |
	self inline: true.
	destBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
	destWidth _ interpreterProxy fetchInteger: FormWidthIndex ofObject: destForm.
	destHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: destForm.
	(destWidth >= 0 and: [destHeight >= 0])
		ifFalse: [^ false].
	destDepth _ interpreterProxy fetchInteger: FormDepthIndex ofObject: destForm.
	destMSB _ destDepth > 0.
	destDepth < 0 ifTrue:[destDepth _ 0 - destDepth].
	"Ignore an integer bits handle for Display in which case 
	the appropriate values will be obtained by calling ioLockSurfaceBits()."
	(interpreterProxy isIntegerObject: destBits) ifTrue:[
		"Query for actual surface dimensions"
		(self queryDestSurface: (interpreterProxy integerValueOf: destBits))
			ifFalse:[^false].
		destPPW _ 32 // destDepth.
		destBits _ destPitch _ 0.
	] ifFalse:[
		destPPW _ 32 // destDepth.
		destPitch _ destWidth + (destPPW-1) // destPPW * 4.
		destBitsSize _ interpreterProxy byteSizeOf: destBits.
		((interpreterProxy isWordsOrBytes: destBits)
			and: [destBitsSize = (destPitch * destHeight)])
			ifFalse: [^ false].
		"Skip header since external bits don't have one"
		destBits _ self oopForPointer: (interpreterProxy firstIndexableField: destBits).
	].
	^true! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ikp 8/2/2004 19:48'!
loadBitBltSourceForm
	"Load the source form for BitBlt. Return false if anything is wrong, true otherwise."
	| sourceBitsSize |
	self inline: true.
	sourceBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
	sourceWidth _ self fetchIntOrFloat: FormWidthIndex ofObject: sourceForm.
	sourceHeight _ self fetchIntOrFloat: FormHeightIndex ofObject: sourceForm.
	(sourceWidth >= 0 and: [sourceHeight >= 0])
		ifFalse: [^ false].
	sourceDepth _ interpreterProxy fetchInteger: FormDepthIndex ofObject: sourceForm.
	sourceMSB _ sourceDepth > 0.
	sourceDepth < 0 ifTrue:[sourceDepth _ 0 - sourceDepth].
	"Ignore an integer bits handle for Display in which case 
	the appropriate values will be obtained by calling ioLockSurfaceBits()."
	(interpreterProxy isIntegerObject: sourceBits) ifTrue:[
		"Query for actual surface dimensions"
		(self querySourceSurface: (interpreterProxy integerValueOf: sourceBits))
			ifFalse:[^false].
		sourcePPW _ 32 // sourceDepth.
		sourceBits _ sourcePitch _ 0.
	] ifFalse:[
		sourcePPW _ 32 // sourceDepth.
		sourcePitch _ sourceWidth + (sourcePPW-1) // sourcePPW * 4.
		sourceBitsSize _ interpreterProxy byteSizeOf: sourceBits.
		((interpreterProxy isWordsOrBytes: sourceBits)
			and: [sourceBitsSize = (sourcePitch * sourceHeight)])
			ifFalse: [^ false].
		"Skip header since external bits don't have one"
		sourceBits _ self oopForPointer: (interpreterProxy firstIndexableField: sourceBits).
	].
	^true! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ikp 8/2/2004 19:49'!
loadHalftoneForm
	"Load the halftone form"
	| halftoneBits |
	self inline: true.
	noHalftone ifTrue:[
		halftoneBase _ nil.
		^true].
	((interpreterProxy isPointers: halftoneForm) and: [(interpreterProxy slotSizeOf: halftoneForm) >= 4])
		ifTrue:
		["Old-style 32xN monochrome halftone Forms"
		halftoneBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: halftoneForm.
		halftoneHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: halftoneForm.
		(interpreterProxy isWords: halftoneBits)
			ifFalse: [noHalftone _ true]]
		ifFalse:
		["New spec accepts, basically, a word array"
		((interpreterProxy isPointers: halftoneForm) not
			and: [interpreterProxy isWords: halftoneForm])
			ifFalse: [^ false].
		halftoneBits _ halftoneForm.
		halftoneHeight _ interpreterProxy slotSizeOf: halftoneBits].
	halftoneBase _ self oopForPointer: (interpreterProxy firstIndexableField: halftoneBits).
	^true! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ikp 8/2/2004 20:25'!
dstLongAt: idx

	^self long32At: idx! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ikp 8/2/2004 20:29'!
dstLongAt: idx put: value

	^self long32At: idx put: value! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ikp 8/2/2004 20:25'!
halftoneAt: idx
	"Return a value from the halftone pattern."

	^self long32At: halftoneBase + (idx \\ halftoneHeight * 4)! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ikp 8/2/2004 20:25'!
srcLongAt: idx

	^self long32At: idx! !

!BitBltSimulation methodsFor: 'initialize-release' stamp: 'ikp 6/10/2004 15:02'!
initBBOpTable
	self cCode: 'opTable[0+1] = (void *)clearWordwith'.
	self cCode: 'opTable[1+1] = (void *)bitAndwith'.
	self cCode: 'opTable[2+1] = (void *)bitAndInvertwith'.
	self cCode: 'opTable[3+1] = (void *)sourceWordwith'.
	self cCode: 'opTable[4+1] = (void *)bitInvertAndwith'.
	self cCode: 'opTable[5+1] = (void *)destinationWordwith'.
	self cCode: 'opTable[6+1] = (void *)bitXorwith'.
	self cCode: 'opTable[7+1] = (void *)bitOrwith'.
	self cCode: 'opTable[8+1] = (void *)bitInvertAndInvertwith'.
	self cCode: 'opTable[9+1] = (void *)bitInvertXorwith'.
	self cCode: 'opTable[10+1] = (void *)bitInvertDestinationwith'.
	self cCode: 'opTable[11+1] = (void *)bitOrInvertwith'.
	self cCode: 'opTable[12+1] = (void *)bitInvertSourcewith'.
	self cCode: 'opTable[13+1] = (void *)bitInvertOrwith'.
	self cCode: 'opTable[14+1] = (void *)bitInvertOrInvertwith'.
	self cCode: 'opTable[15+1] = (void *)destinationWordwith'.
	self cCode: 'opTable[16+1] = (void *)destinationWordwith'.
	self cCode: 'opTable[17+1] = (void *)destinationWordwith'.
	self cCode: 'opTable[18+1] = (void *)addWordwith'.
	self cCode: 'opTable[19+1] = (void *)subWordwith'.
	self cCode: 'opTable[20+1] = (void *)rgbAddwith'.
	self cCode: 'opTable[21+1] = (void *)rgbSubwith'.
	self cCode: 'opTable[22+1] = (void *)OLDrgbDiffwith'.
	self cCode: 'opTable[23+1] = (void *)OLDtallyIntoMapwith'.
	self cCode: 'opTable[24+1] = (void *)alphaBlendwith'.
	self cCode: 'opTable[25+1] = (void *)pixPaintwith'.
	self cCode: 'opTable[26+1] = (void *)pixMaskwith'.
	self cCode: 'opTable[27+1] = (void *)rgbMaxwith'.
	self cCode: 'opTable[28+1] = (void *)rgbMinwith'.
	self cCode: 'opTable[29+1] = (void *)rgbMinInvertwith'.
	self cCode: 'opTable[30+1] = (void *)alphaBlendConstwith'.
	self cCode: 'opTable[31+1] = (void *)alphaPaintConstwith'.
	self cCode: 'opTable[32+1] = (void *)rgbDiffwith'.
	self cCode: 'opTable[33+1] = (void *)tallyIntoMapwith'.
	self cCode: 'opTable[34+1] = (void *)alphaBlendScaledwith'.
	self cCode: 'opTable[35+1] = (void *)alphaBlendScaledwith'.
	self cCode: 'opTable[36+1] = (void *)alphaBlendScaledwith'.	
	self cCode: 'opTable[37+1] = (void *)rgbMulwith'.
	self cCode: 'opTable[38+1] = (void *)pixSwapwith'.
	self cCode: 'opTable[39+1] = (void *)pixClearwith'.
	self cCode: 'opTable[40+1] = (void *)fixAlphawith'.! !

!BitBltSimulation methodsFor: 'surface support' stamp: 'ikp 6/9/2004 22:51'!
lockSurfaces
	"Get a pointer to the bits of any OS surfaces."
	"Notes: 
	* For equal source/dest handles only one locking operation is performed.
	This is to prevent locking of overlapping areas which does not work with
	certain APIs (as an example, DirectDraw prevents locking of overlapping areas). 
	A special case for non-overlapping but equal source/dest handle would 
	be possible but we would have to transfer this information over to 
	unlockSurfaces somehow (currently, only one unlock operation is 
	performed for equal source and dest handles). Also, this would require
	a change in the notion of ioLockSurface() which is right now interpreted
	as a hint and not as a requirement to lock only the specific portion of
	the surface.

	* The arguments in ioLockSurface() provide the implementation with
	an explicit hint what area is affected. It can be very useful to
	know the max. affected area beforehand if getting the bits requires expensive
	copy operations (e.g., like a roundtrip to the X server or a glReadPixel op).
	However, the returned pointer *MUST* point to the virtual origin of the surface
	and not to the beginning of the rectangle. The promise made by BitBlt
	is to never access data outside the given rectangle (aligned to 4byte boundaries!!)
	so it is okay to return a pointer to the virtual origin that is actually outside
	the valid memory area.

	* The area provided in ioLockSurface() is already clipped (e.g., it will always
	be inside the source and dest boundingBox) but it is not aligned to word boundaries
	yet. It is up to the support code to compute accurate alignment if necessary.

	* Warping always requires the entire source surface to be locked because
	there is no beforehand knowledge about what area will actually be traversed.

	"
	| sourceHandle destHandle l r t b fn |
	self inline: true. "If the CCodeGen learns how to inline #cCode: methods"
	self var: #fn declareC:'sqInt (*fn)(sqInt, sqInt*, sqInt, sqInt, sqInt, sqInt)'.
	hasSurfaceLock _ false.
	destBits = 0 ifTrue:["Blitting *to* OS surface"
		lockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn _ self cCoerce: lockSurfaceFn to: 'sqInt (*)(sqInt, sqInt*, sqInt, sqInt, sqInt, sqInt)'.
		destHandle _ interpreterProxy fetchInteger: FormBitsIndex ofObject: destForm.
		(sourceBits = 0 and:[noSource not]) ifTrue:[
			sourceHandle _ interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
			"Handle the special case of equal source and dest handles"
			(sourceHandle = destHandle) ifTrue:[
				"If we have overlapping source/dest we lock the entire area
				so that there is only one area transmitted"
				isWarping ifFalse:[
					"When warping we always need the entire surface for the source"
					sourceBits _ self cCode:'fn(sourceHandle, &sourcePitch, 0,0, sourceWidth, sourceHeight)'.
				] ifTrue:[
					"Otherwise use overlapping area"
					l _ sx min: dx. r _ (sx max: dx) + bbW.
					t _ sy min: dy. b _ (sy max: sy) + bbH.
					sourceBits _ self cCode:'fn(sourceHandle, &sourcePitch, l, t, r-l, b-t)'.
				].
				destBits _ sourceBits.
				destPitch _ sourcePitch.
				hasSurfaceLock _ true.
				^destBits ~~ 0
			].
			"Fall through - if not equal it'll be handled below"
		].
		destBits _ self cCode:'fn(destHandle, &destPitch, dx, dy, bbW, bbH)'.
		hasSurfaceLock _ true.
	].
	(sourceBits == 0 and:[noSource not]) ifTrue:["Blitting *from* OS surface"
		sourceHandle _ interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
		lockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn _ self cCoerce: lockSurfaceFn to: 'sqInt (*)(sqInt, sqInt*, sqInt, sqInt, sqInt, sqInt)'.
		"Warping requiring the entire surface"
		isWarping ifTrue:[
			sourceBits _ self cCode:'fn(sourceHandle, &sourcePitch, 0, 0, sourceWidth, sourceHeight)'.
		] ifFalse:[
			sourceBits _ self cCode:'fn(sourceHandle, &sourcePitch, sx, sy, bbW, bbH)'.
		].
		hasSurfaceLock _ true.
	].
	^destBits ~~ 0 and:[sourceBits ~~ 0 or:[noSource]].! !

!BitBltSimulation methodsFor: 'surface support' stamp: 'ikp 6/9/2004 22:52'!
queryDestSurface: handle
	"Query the dimension of an OS surface.
	This method is provided so that in case the inst vars of the
	source form are broken, *actual* values of the OS surface
	can be obtained. This might, for instance, happen if the user
	resizes the main window.
	Note: Moved to a separate function for better inlining of the caller."
	querySurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^false]].
	^(self cCode:' ((sqInt (*) (sqInt, sqInt*, sqInt*, sqInt*, sqInt*))querySurfaceFn)
		(handle, &destWidth, &destHeight, &destDepth, &destMSB)'
			 inSmalltalk:[false])! !

!BitBltSimulation methodsFor: 'surface support' stamp: 'ikp 6/9/2004 22:57'!
querySourceSurface: handle
	"Query the dimension of an OS surface.
	This method is provided so that in case the inst vars of the
	source form are broken, *actual* values of the OS surface
	can be obtained. This might, for instance, happen if the user
	resizes the main window.
	Note: Moved to a separate function for better inlining of the caller."
	querySurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^false]].
	^(self cCode:' ((sqInt (*) (sqInt, sqInt*, sqInt*, sqInt*, sqInt*))querySurfaceFn)
		(handle, &sourceWidth, &sourceHeight, &sourceDepth, &sourceMSB)'
			inSmalltalk:[false])! !

!BitBltSimulation methodsFor: 'surface support' stamp: 'ikp 6/11/2004 16:54'!
unlockSurfaces
	"Unlock the bits of any OS surfaces."
	"See the comment in lockSurfaces. Similar rules apply. That is, the area provided in ioUnlockSurface can be used to determine the dirty region after drawing. If a source is unlocked, then the area will be (0,0,0,0) to indicate that no portion is dirty."
	| sourceHandle destHandle destLocked fn |
	self var: #fn declareC:'sqInt (*fn)(sqInt, sqInt, sqInt, sqInt, sqInt)'.
	hasSurfaceLock ifTrue:[
		unlockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn _ self cCoerce: unlockSurfaceFn to: 'sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt)'.
		destLocked _ false.
		destHandle _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
		(interpreterProxy isIntegerObject: destHandle) ifTrue:[
			destHandle _ interpreterProxy integerValueOf: destHandle.
			"The destBits are always assumed to be dirty"
			self cCode:'fn(destHandle, affectedL, affectedT, affectedR-affectedL, affectedB-affectedT)'.
			destBits _ destPitch _ 0.
			destLocked _ true.
		].
		noSource ifFalse:[
			sourceHandle _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
			(interpreterProxy isIntegerObject: sourceHandle) ifTrue:[
				sourceHandle _ interpreterProxy integerValueOf: sourceHandle.
				"Only unlock sourceHandle if different from destHandle"
				(destLocked and:[sourceHandle = destHandle]) 
					ifFalse:[self cCode: 'fn(sourceHandle, 0, 0, 0, 0)'].
				sourceBits _ sourcePitch _ 0.
			].
		].
		hasSurfaceLock _ false.
	].! !

!BitBltSimulation methodsFor: 'primitives' stamp: 'ikp 6/10/2004 12:46'!
primitiveDisplayString

	| kernDelta xTable glyphMap stopIndex startIndex sourceString bbObj maxGlyph ascii glyphIndex sourcePtr left quickBlt |
	self export: true.
	self var: #sourcePtr type: 'unsigned char *'.
	interpreterProxy methodArgumentCount = 6 
		ifFalse:[^interpreterProxy primitiveFail].
	kernDelta _ interpreterProxy stackIntegerValue: 0.
	xTable _ interpreterProxy stackObjectValue: 1.
	glyphMap _ interpreterProxy stackObjectValue: 2.
	((interpreterProxy fetchClassOf: xTable) = interpreterProxy classArray and:[
		(interpreterProxy fetchClassOf: glyphMap) = interpreterProxy classArray])
			ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: glyphMap) = 256 ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy failed ifTrue:[^nil].
	maxGlyph _ (interpreterProxy slotSizeOf: xTable) - 2.

	stopIndex _ interpreterProxy stackIntegerValue: 3.
	startIndex _ interpreterProxy stackIntegerValue: 4.
	sourceString _ interpreterProxy stackObjectValue: 5.
	(interpreterProxy isBytes: sourceString) ifFalse:[^interpreterProxy primitiveFail].
	(startIndex > 0 and:[stopIndex > 0 and:[
		stopIndex <= (interpreterProxy byteSizeOf: sourceString)]])
			ifFalse:[^interpreterProxy primitiveFail].

	bbObj _ interpreterProxy stackObjectValue: 6.
	(self loadBitBltFrom: bbObj) ifFalse:[^interpreterProxy primitiveFail].
	(combinationRule = 30 or:[combinationRule = 31]) "needs extra source alpha"
		ifTrue:[^interpreterProxy primitiveFail].
	"See if we can go directly into copyLoopPixMap (usually we can)"
	quickBlt _ destBits ~= 0 "no OS surfaces please"
				and:[sourceBits ~= 0 "and again"
				and:[noSource = false "needs a source"
				and:[sourceForm ~= destForm "no blits onto self"
				and:[(cmFlags ~= 0 
						or:[sourceMSB ~= destMSB 
						or:[sourceDepth ~= destDepth]]) "no point using slower version"
				]]]].
	left _ destX.
	sourcePtr _ interpreterProxy firstIndexableField: sourceString.
	startIndex to: stopIndex do:[:charIndex|
		ascii _ interpreterProxy byteAtPointer: sourcePtr + charIndex - 1.
		glyphIndex _ interpreterProxy fetchInteger: ascii ofObject: glyphMap.
		(glyphIndex < 0 or:[glyphIndex > maxGlyph]) 
			ifTrue:[^interpreterProxy primitiveFail].
		sourceX _ interpreterProxy fetchInteger: glyphIndex ofObject: xTable.
		width _ (interpreterProxy fetchInteger: glyphIndex+1 ofObject: xTable) - sourceX.
		interpreterProxy failed ifTrue:[^nil].
		self clipRange.	"Must clip here"
		(bbW > 0 and:[bbH > 0]) ifTrue: [
			quickBlt ifTrue:[
				self destMaskAndPointerInit.
				self copyLoopPixMap.
				"both, hDir and vDir are known to be > 0"
				affectedL _ dx.
				affectedR _ dx + bbW.
				affectedT _ dy.
				affectedB _ dy + bbH.
			] ifFalse:[self copyBits]].
		interpreterProxy failed ifTrue:[^nil].
		destX _ destX + width + kernDelta.
	 ].
	affectedL _ left.
	self showDisplayBits.
	interpreterProxy pop: 6. "pop args, return rcvr"! !


!BitBltSimulator methodsFor: 'debug support' stamp: 'ikp 8/2/2004 20:25'!
dstLongAt: dstIndex

	interpreterProxy isInterpreterProxy
		ifTrue:[^dstIndex long32At: 0].
	((dstIndex anyMask: 3) or:[dstIndex + 4 < destBits or:[
		dstIndex > (destBits + (destPitch * destHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^self long32At: dstIndex! !

!BitBltSimulator methodsFor: 'debug support' stamp: 'ikp 8/2/2004 20:29'!
dstLongAt: dstIndex put: value

	interpreterProxy isInterpreterProxy
		ifTrue:[^dstIndex long32At: 0 put: value].
	((dstIndex anyMask: 3) or:[dstIndex < destBits or:[
		dstIndex >= (destBits + (destPitch * destHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^self long32At: dstIndex put: value! !

!BitBltSimulator methodsFor: 'debug support' stamp: 'ikp 8/2/2004 20:25'!
srcLongAt: srcIndex

	interpreterProxy isInterpreterProxy
		ifTrue:[^srcIndex long32At: 0].
	((srcIndex anyMask: 3) or:[srcIndex + 4 < sourceBits or:[
		srcIndex > (sourceBits + (sourcePitch * sourceHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^self long32At: srcIndex! !

!BitBltSimulator methodsFor: 'simulation' stamp: 'ikp 8/2/2004 20:25'!
tableLookup: table at: index

	^ self long32At: (table + (index * 4))! !


!FFIPlugin methodsFor: 'primitive support' stamp: 'di 7/4/2004 08:38'!
addressOf: rcvr startingAt: byteOffset size: byteSize
	| rcvrClass rcvrSize addr |
	(interpreterProxy isBytes: rcvr) ifFalse:[^interpreterProxy primitiveFail].
	(byteOffset > 0) ifFalse:[^interpreterProxy primitiveFail].
	rcvrClass _ interpreterProxy fetchClassOf: rcvr.
	rcvrSize _ interpreterProxy byteSizeOf: rcvr.
	rcvrClass == interpreterProxy classExternalAddress ifTrue:[
		(rcvrSize = 4) ifFalse:[^interpreterProxy primitiveFail].
		addr _ interpreterProxy fetchPointer: 0 ofObject: rcvr.
		"don't you dare to read from object memory!!"
		(addr == 0 or:[interpreterProxy isInMemory: addr])
			ifTrue:[^interpreterProxy primitiveFail].
	] ifFalse:[
		(byteOffset+byteSize-1 <= rcvrSize)
			ifFalse:[^interpreterProxy primitiveFail].
		addr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'int'.
	].
	addr _ addr + byteOffset - 1.
	^addr! !

!FFIPlugin methodsFor: 'callout support' stamp: 'di 7/4/2004 08:39'!
ffiContentsOfHandle: oop errCode: errCode
	"Make sure that the given oop is a valid external handle"
	self inline: true.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^self ffiFail: errCode].
	(interpreterProxy isBytes: oop)
		ifFalse:[^self ffiFail: errCode].
	((interpreterProxy byteSizeOf: oop) == 4)
		ifFalse:[^self ffiFail: errCode].
	^interpreterProxy fetchPointer: 0 ofObject: oop! !

!FFIPlugin methodsFor: 'callout support' stamp: 'di 7/4/2004 08:40'!
ffiPushPointerContentsOf: oop
	"Push the contents of the given external structure"
	| ptrValue ptrClass ptrAddress |
	self inline: false.
	ptrValue _ oop.
	ptrClass _ interpreterProxy fetchClassOf: ptrValue.
	ptrClass == interpreterProxy classExternalAddress ifTrue:[
		ptrAddress _ interpreterProxy fetchPointer: 0 ofObject: ptrValue.
		"Don't you dare to pass pointers into object memory"
		(interpreterProxy isInMemory: ptrAddress)
			ifTrue:[^self ffiFail: FFIErrorInvalidPointer].
		^self ffiPushPointer: ptrAddress].
	ptrClass == interpreterProxy classByteArray ifTrue:[
		ptrAddress _ self cCoerce: (interpreterProxy firstIndexableField: ptrValue) to: 'int'.
		^self ffiPushPointer: ptrAddress].
	^self ffiFail: FFIErrorBadArg! !

!FFIPlugin methodsFor: 'callout support' stamp: 'di 7/4/2004 08:43'!
ffiPushStructureContentsOf: oop
	"Push the contents of the given external structure"
	| ptrValue ptrClass ptrAddress |
	self inline: true.
	ptrValue _ oop.
	ptrClass _ interpreterProxy fetchClassOf: ptrValue.
	ptrClass == interpreterProxy classExternalAddress ifTrue:[
		ptrAddress _ interpreterProxy fetchPointer: 0 ofObject: ptrValue.
		"There is no way we can make sure the structure is valid.
		But we can at least check for attempts to pass pointers to ST memory."
		(interpreterProxy isInMemory: ptrAddress)
			ifTrue:[^self ffiFail: FFIErrorInvalidPointer].
		^self ffiPush: ptrAddress 
				Structure: (self cCoerce: ffiArgSpec to:'int*')
				OfLength: ffiArgSpecSize].
	ptrClass == interpreterProxy classByteArray ifTrue:[
		"The following is a somewhat pessimistic test but I like being sure..."
		(interpreterProxy byteSizeOf: ptrValue) = (ffiArgHeader bitAnd: FFIStructSizeMask)
			ifFalse:[^self ffiFail: FFIErrorStructSize].
		ptrAddress _ self cCoerce: (interpreterProxy firstIndexableField: ptrValue) to: 'int'.
		(ffiArgHeader anyMask: FFIFlagPointer) ifFalse:[
			^self ffiPush: ptrAddress 
					Structure: (self cCoerce: ffiArgSpec to: 'int*')
					OfLength: ffiArgSpecSize].
		"If FFIFlagPointer + FFIFlagStructure is set use ffiPushPointer on the contents"
		(ffiArgHeader bitAnd: FFIStructSizeMask) = 4
			ifFalse:[^self ffiFail: FFIErrorStructSize].
		ptrAddress _ interpreterProxy fetchPointer: 0 ofObject: ptrValue.
		(interpreterProxy isInMemory: ptrAddress)
			ifTrue:[^self ffiFail: FFIErrorInvalidPointer].
		^self ffiPushPointer: ptrAddress].
	^self ffiFail: FFIErrorBadArg! !

!FFIPlugin methodsFor: 'callout support' stamp: 'di 7/4/2004 08:40'!
ffiValidateExternalData: oop AtomicType: atomicType
	"Validate if the given oop (an instance of ExternalData) can be passed as a pointer to the given atomic type."
	| ptrType specOop spec specType |
	self inline: true.
	ptrType _ interpreterProxy fetchPointer: 1 ofObject: oop.
	(interpreterProxy isIntegerObject: ptrType)
		ifTrue:[^self ffiFail: FFIErrorWrongType].
	(interpreterProxy isPointers: ptrType)
		ifFalse:[^self ffiFail: FFIErrorWrongType].
	(interpreterProxy slotSizeOf: ptrType) < 2
		ifTrue:[^self ffiFail: FFIErrorWrongType].
	specOop _ interpreterProxy fetchPointer: 0 ofObject: ptrType.
	(interpreterProxy isIntegerObject: specOop)
		ifTrue:[^self ffiFail: FFIErrorWrongType].
	(interpreterProxy isWords: specOop)
		ifFalse:[^self ffiFail: FFIErrorWrongType].
	(interpreterProxy slotSizeOf: specOop) = 0
		ifTrue:[^self ffiFail: FFIErrorWrongType].
	spec _ interpreterProxy fetchPointer: 0 ofObject: specOop.
	(self isAtomicType: spec)
		ifFalse:[^self ffiFail: FFIErrorWrongType].
	specType _ self atomicTypeOf: spec.
	specType ~= atomicType ifTrue:[
		"allow for signed/unsigned conversion but nothing else"
		(atomicType > FFITypeBool and:[atomicType < FFITypeSingleFloat])
			ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		((atomicType >> 1) = (specType >> 1))
			ifFalse:[^self ffiFail: FFIErrorCoercionFailed]].
	^0! !

!FFIPlugin methodsFor: 'primitives' stamp: 'di 6/23/2004 14:28'!
primitiveFFIIntegerAt
	"Return a (signed or unsigned) n byte integer from the given byte offset."
	| isSigned byteSize byteOffset rcvr addr value mask |
	self export: true.
	self inline: false.
	isSigned _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	byteSize _ interpreterProxy stackIntegerValue: 1.
	byteOffset _ interpreterProxy stackIntegerValue: 2.
	rcvr _ interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^0].
	(byteOffset > 0 and:[byteSize = 1 or:[byteSize = 2 or:[byteSize = 4]]])
		ifFalse:[^interpreterProxy primitiveFail].
	addr _ self addressOf: rcvr startingAt: byteOffset size: byteSize.
	interpreterProxy failed ifTrue:[^0].
	byteSize < 4 ifTrue:[
		"short/byte"
		byteSize = 1 
			ifTrue:[value _ interpreterProxy byteAt: addr]
			ifFalse:[	value _ self cCode: '*((short int *) addr)' 
								inSmalltalk: [interpreterProxy shortAt: addr]].
		isSigned ifTrue:["sign extend value"
			mask _ 1 << (byteSize * 8 - 1).
			value _ (value bitAnd: mask-1) - (value bitAnd: mask)].
		"note: byte/short never exceed SmallInteger range"
		value _ interpreterProxy integerObjectOf: value.
	] ifFalse:[
		"general 32 bit integer"
		value _ interpreterProxy longAt: addr.
		isSigned
			ifTrue:[value _ interpreterProxy signed32BitIntegerFor: value]
			ifFalse:[value _ interpreterProxy positive32BitIntegerFor: value].
	].
	interpreterProxy pop: 4.
	^interpreterProxy push: value
! !

!FFIPlugin methodsFor: 'primitives' stamp: 'di 6/23/2004 14:33'!
primitiveFFIIntegerAtPut
	"Store a (signed or unsigned) n byte integer at the given byte offset."
	| isSigned byteSize byteOffset rcvr addr value max valueOop |
	self export: true.
	self inline: false.
	isSigned _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	byteSize _ interpreterProxy stackIntegerValue: 1.
	valueOop _ interpreterProxy stackValue: 2.
	byteOffset _ interpreterProxy stackIntegerValue: 3.
	rcvr _ interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^0].
	(byteOffset > 0 and:[byteSize = 1 or:[byteSize = 2 or:[byteSize = 4]]])
		ifFalse:[^interpreterProxy primitiveFail].
	addr _ self addressOf: rcvr startingAt: byteOffset size: byteSize.
	interpreterProxy failed ifTrue:[^0].
	isSigned 
		ifTrue:[value _ interpreterProxy signed32BitValueOf: valueOop]
		ifFalse:[value _ interpreterProxy positive32BitValueOf: valueOop].
	interpreterProxy failed ifTrue:[^0].
	byteSize < 4 ifTrue:[
		isSigned ifTrue:[
			max _ 1 << (8 * byteSize - 1).
			value >= max ifTrue:[^interpreterProxy primitiveFail].
			value < (0 - max) ifTrue:[^interpreterProxy primitiveFail].
		] ifFalse:[
			value >= (1 << (8*byteSize)) ifTrue:[^interpreterProxy primitiveFail].
		].
		"short/byte"
		byteSize = 1 
			ifTrue:[interpreterProxy byteAt: addr put: value]
			ifFalse:[	self cCode: '*((short int *) addr) = value' 
						inSmalltalk: [interpreterProxy shortAt: addr put: value]].
	] ifFalse:[interpreterProxy longAt: addr put: value].
	interpreterProxy pop: 5.
	^interpreterProxy push: valueOop.! !


!FilePlugin methodsFor: 'directory primitives' stamp: 'ikp 6/14/2004 14:53'!
primitiveDirectoryCreate

	| dirName dirNameIndex dirNameSize okToCreate |
	self var: #dirNameIndex type: 'char *'.
	self export: true.

	dirName _ interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: dirName)
		ifFalse: [^interpreterProxy primitiveFail].
	dirNameIndex _ interpreterProxy firstIndexableField: dirName.
	dirNameSize _ interpreterProxy byteSizeOf: dirName.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCCPfn ~= 0
		ifTrue: [okToCreate _ self cCode: ' ((sqInt (*)(char *, sqInt))sCCPfn)(dirNameIndex, dirNameSize)'.
			okToCreate
				ifFalse: [^interpreterProxy primitiveFail]].
	(self
			cCode: 'dir_Create(dirNameIndex, dirNameSize)'
			inSmalltalk: [false])
		ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy pop: 1! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ikp 6/14/2004 14:54'!
primitiveDirectoryDelete

	| dirName dirNameIndex dirNameSize okToDelete |
	self var: #dirNameIndex type: 'char *'.
	self export: true.

	dirName _ interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: dirName)
		ifFalse: [^interpreterProxy primitiveFail].
	dirNameIndex _ interpreterProxy firstIndexableField: dirName.
	dirNameSize _ interpreterProxy byteSizeOf: dirName.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCDPfn ~= 0
		ifTrue: [okToDelete _ self cCode: ' ((sqInt (*)(char *, sqInt))sCDPfn)(dirNameIndex, dirNameSize)'.
			okToDelete
				ifFalse: [^interpreterProxy primitiveFail]].
	(self
			cCode: 'dir_Delete(dirNameIndex, dirNameSize)'
			inSmalltalk: [false])
		ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy pop: 1! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ikp 6/14/2004 14:56'!
primitiveDirectoryGetMacTypeAndCreator

	| creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize okToGet |
	self var: 'creatorStringIndex' type: 'char *'.
	self var: 'typeStringIndex' type: 'char *'.
	self var: 'fileNameIndex' type: 'char *'.
	self export: true.

	creatorString _ interpreterProxy stackValue: 0.
	typeString _ interpreterProxy stackValue: 1.
	fileName _ interpreterProxy stackValue: 2.
	((interpreterProxy isBytes: creatorString)
			and: [(interpreterProxy byteSizeOf: creatorString) = 4])
		ifFalse: [^interpreterProxy primitiveFail].
	((interpreterProxy isBytes: typeString)
			and: [(interpreterProxy byteSizeOf: typeString) = 4])
		ifFalse: [^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: fileName)
		ifFalse: [^interpreterProxy primitiveFail].
	creatorStringIndex _ interpreterProxy firstIndexableField: creatorString.
	typeStringIndex _ interpreterProxy firstIndexableField: typeString.
	fileNameIndex _ interpreterProxy firstIndexableField: fileName.
	fileNameSize _ interpreterProxy byteSizeOf: fileName.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCGFTfn ~= 0
		ifTrue: [okToGet _ self cCode: ' ((sqInt (*)(char *, sqInt))sCGFTfn)(fileNameIndex, fileNameSize)'.
			okToGet
				ifFalse: [^interpreterProxy primitiveFail]].
	(self
			cCode: 'dir_GetMacFileTypeAndCreator(fileNameIndex, fileNameSize, typeStringIndex, creatorStringIndex)'
			inSmalltalk: [true])
		ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy pop: 3! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ikp 6/14/2004 14:57'!
primitiveDirectoryLookup

	| index pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag fileSize okToList |
	self var: 'entryName' declareC: 'char entryName[256]'.
	self var: 'pathNameIndex' type: 'char *'.
	self var: 'fileSize' type: 'squeakFileOffsetType'.
	self export: true.

	index _ interpreterProxy stackIntegerValue: 0.
	pathName _ interpreterProxy stackValue: 1.
	(interpreterProxy isBytes: pathName)
		ifFalse: [^interpreterProxy primitiveFail].
	pathNameIndex _ interpreterProxy firstIndexableField: pathName.
	pathNameSize _ interpreterProxy byteSizeOf: pathName.
	"If the security plugin can be loaded, use it to check for permission. 
	If not, assume it's ok"
	sCLPfn ~= 0
		ifTrue: [okToList _ self cCode: '((sqInt (*)(char *, sqInt))sCLPfn)(pathNameIndex, pathNameSize)']
		ifFalse: [okToList _ true].
	okToList
		ifTrue: [status _ self cCode: 'dir_Lookup(pathNameIndex, pathNameSize, index,
												entryName, &entryNameSize, &createDate, &modifiedDate,
												&dirFlag, &fileSize)']
		ifFalse: [status _ DirNoMoreEntries].
	interpreterProxy failed
		ifTrue: [^nil].
	status = DirNoMoreEntries
		ifTrue: ["no more entries; return nil"
			interpreterProxy pop: 3.
			"pop pathName, index, rcvr"
			interpreterProxy push: interpreterProxy nilObject.
			^nil].
	status = DirBadPath
		ifTrue: [^interpreterProxy primitiveFail].
	"bad path"
	interpreterProxy pop: 3.
	"pop pathName, index, rcvr"
	interpreterProxy
		push: (self
				makeDirEntryName: entryName
				size: entryNameSize
				createDate: createDate
				modDate: modifiedDate
				isDir: dirFlag
				fileSize: fileSize)! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ikp 6/14/2004 14:58'!
primitiveDirectorySetMacTypeAndCreator

	| creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize  okToSet |
	self var: 'creatorStringIndex' type: 'char *'.
	self var: 'typeStringIndex' type: 'char *'.
	self var: 'fileNameIndex' type: 'char *'.
	self export: true.

	creatorString _ interpreterProxy stackValue: 0.
	typeString _ interpreterProxy stackValue: 1.
	fileName _ interpreterProxy stackValue: 2.
	((interpreterProxy isBytes: creatorString)
			and: [(interpreterProxy byteSizeOf: creatorString)
					= 4])
		ifFalse: [^interpreterProxy primitiveFail].
	((interpreterProxy isBytes: typeString)
			and: [(interpreterProxy byteSizeOf: typeString)
					= 4])
		ifFalse: [^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: fileName)
		ifFalse: [^interpreterProxy primitiveFail].
	creatorStringIndex _ interpreterProxy firstIndexableField: creatorString.
	typeStringIndex _ interpreterProxy firstIndexableField: typeString.
	fileNameIndex _ interpreterProxy firstIndexableField: fileName.
	fileNameSize _ interpreterProxy byteSizeOf: fileName.
	"If the security plugin can be loaded, use it to check for permission.
	If not, assume it's ok"
	sCSFTfn ~= 0
		ifTrue: [okToSet _ self cCode: ' ((sqInt (*)(char *, sqInt))sCSFTfn)(fileNameIndex, fileNameSize)'.
			okToSet
				ifFalse: [^interpreterProxy primitiveFail]].
	(self
			cCode: 'dir_SetMacFileTypeAndCreator(fileNameIndex, fileNameSize,typeStringIndex, creatorStringIndex)'
			inSmalltalk: [true])
		ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy pop: 3! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ikp 6/14/2004 14:01'!
fileOpenName: nameIndex size: nameSize write: writeFlag secure: secureFlag
	"Open the named file, possibly checking security. Answer the file oop."
	| file fileOop okToOpen |
	self var: #file type: 'SQFile *'.
	self var: 'nameIndex' type: 'char *'.
	self export: true.
	fileOop _ interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self fileRecordSize.
	file _ self fileValueOf: fileOop.
	interpreterProxy failed
		ifFalse: [ secureFlag ifTrue: [
				"If the security plugin can be loaded, use it to check for permission.
				If not, assume it's ok"
				sCOFfn ~= 0 
					ifTrue: [okToOpen _ self cCode: '((sqInt (*) (char *, sqInt, sqInt)) sCOFfn)(nameIndex, nameSize, writeFlag)' inSmalltalk:[true].
						okToOpen
							ifFalse: [interpreterProxy primitiveFail]]]].
	interpreterProxy failed
		ifFalse: [self cCode: 'sqFileOpen(file, oopForPointer(nameIndex), nameSize, writeFlag)' inSmalltalk: [file]].
	^ fileOop! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ikp 8/2/2004 19:49'!
primitiveFileDelete

	| namePointer nameIndex nameSize  okToDelete |
	self var: 'nameIndex' type: 'char *'.
	self export: true.

	namePointer _ interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: namePointer)
		ifFalse: [^ interpreterProxy primitiveFail].
	nameIndex _ interpreterProxy firstIndexableField: namePointer.
	nameSize _ interpreterProxy byteSizeOf: namePointer.
	"If the security plugin can be loaded, use it to check for permission.
	If 
	not, assume it's ok"
	sCDFfn ~= 0
		ifTrue: [okToDelete _ self cCode: ' ((sqInt (*)(char *, sqInt))sCDFfn)(nameIndex, nameSize)'.
			okToDelete
				ifFalse: [^ interpreterProxy primitiveFail]].
	self
		sqFileDeleteName: (self oopForPointer: nameIndex)
		Size: nameSize.
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 1]! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ikp 8/2/2004 19:49'!
primitiveFileRead

	| count startIndex array file byteSize arrayIndex bytesRead |
	self var: 'file' declareC: 'SQFile *file'.
	self var: 'arrayIndex' type: 'char *'.
	self var: 'count' type: 'size_t'.
	self var: 'startIndex' type: 'size_t'.
	self var: 'byteSize' type: 'size_t'.
	self export: true.

	count		_ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	startIndex	_ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	array		_ interpreterProxy stackValue: 2.
	file			_ self fileValueOf: (interpreterProxy stackValue: 3).

	"buffer can be any indexable words or bytes object except CompiledMethod"
	(interpreterProxy isWordsOrBytes: array) 
		ifFalse: [^interpreterProxy primitiveFail].

	(interpreterProxy isWords: array)
		ifTrue: [byteSize _ 4]
		ifFalse: [byteSize _ 1].
	((startIndex >= 1) and:
		[(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)])
			ifFalse: [^interpreterProxy primitiveFail].

	arrayIndex _ interpreterProxy firstIndexableField: array.
	"Note: adjust startIndex for zero-origin indexing"
	bytesRead _ self
		sqFile: file Read: (count * byteSize)
		Into: (self oopForPointer: arrayIndex)
		At: ((startIndex - 1) * byteSize).
	interpreterProxy failed ifFalse: [
		interpreterProxy pop: 5.  "pop rcvr, file, array, startIndex, count"
		interpreterProxy pushInteger: bytesRead // byteSize.  "push # of elements read"
	].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ikp 8/2/2004 19:50'!
primitiveFileRename

	| oldNamePointer newNamePointer oldNameIndex oldNameSize newNameIndex newNameSize  okToRename |
	self var: 'oldNameIndex' type: 'char *'.
	self var: 'newNameIndex' type: 'char *'.
	self export: true.

	newNamePointer _ interpreterProxy stackValue: 0.
	oldNamePointer _ interpreterProxy stackValue: 1.
	((interpreterProxy isBytes: newNamePointer)
			and: [interpreterProxy isBytes: oldNamePointer])
		ifFalse: [^interpreterProxy primitiveFail].
	newNameIndex _ interpreterProxy firstIndexableField: newNamePointer.
	newNameSize _ interpreterProxy byteSizeOf: newNamePointer.
	oldNameIndex _ interpreterProxy firstIndexableField: oldNamePointer.
	oldNameSize _ interpreterProxy byteSizeOf: oldNamePointer.
	"If the security plugin can be loaded, use it to check for rename permission.
	If not, assume it's ok"
	sCRFfn ~= 0
		ifTrue: [okToRename _ self cCode: ' ((sqInt (*)(char *, sqInt))sCRFfn)(oldNameIndex, oldNameSize)'.
			okToRename
				ifFalse: [^interpreterProxy primitiveFail]].
	self
		sqFileRenameOld: (self oopForPointer: oldNameIndex) Size: oldNameSize
		New: (self oopForPointer: newNameIndex) Size: newNameSize.
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 2]! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ikp 8/2/2004 19:50'!
primitiveFileWrite

	| count startIndex array file byteSize arrayIndex bytesWritten |
	self var: 'file' declareC: 'SQFile *file'.
	self var: 'arrayIndex' type: 'char *'.
	self var: 'count' type: 'size_t'.
	self var: 'startIndex' type: 'size_t'.
	self var: 'byteSize' type: 'size_t'.
	self export: true.

	count		_ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	startIndex	_ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	array		_ interpreterProxy stackValue: 2.
	file			_ self fileValueOf: (interpreterProxy stackValue: 3).

	"buffer can be any indexable words or bytes object except CompiledMethod"
	(interpreterProxy isWordsOrBytes: array) 
		ifFalse: [^interpreterProxy primitiveFail].

	(interpreterProxy isWords: array)
		ifTrue: [ byteSize _ 4 ]
		ifFalse: [ byteSize _ 1 ].
	((startIndex >= 1) and:
		[(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)])
			ifFalse: [^interpreterProxy primitiveFail].
	interpreterProxy failed ifFalse: [
		arrayIndex _ interpreterProxy firstIndexableField: array.
		"Note: adjust startIndex for zero-origin indexing"
		bytesWritten _
			self sqFile: file
				Write: (count * byteSize)
				From: (self oopForPointer: arrayIndex)
				At: ((startIndex - 1) * byteSize).
	].
	interpreterProxy failed ifFalse: [
		interpreterProxy pop: 5.  "pop rcvr, file, array, startIndex, count"
		interpreterProxy pushInteger: bytesWritten // byteSize.  "push # of elements written"
	].! !

!FilePlugin methodsFor: 'security primitives' stamp: 'ikp 8/4/2004 11:31'!
primitiveDisableFileAccess

	self export: true.
	"If the security plugin can be loaded, use it to turn off file access
	If 
	not, assume it's ok"
	sDFAfn ~= 0
		ifTrue: [self cCode: ' ((sqInt (*)(void))sDFAfn)()'].
	interpreterProxy failed
		ifFalse: [interpreterProxy pop: 1]! !

!FilePlugin methodsFor: 'security primitives' stamp: 'ikp 8/4/2004 11:31'!
primitiveHasFileAccess
	|  hasAccess |
	self export: true.
	"If the security plugin can be loaded, use it to check . 
	If not, assume 
	it's ok"
	sHFAfn ~= 0
		ifTrue: [hasAccess _ self cCode: ' ((sqInt (*)(void))sHFAfn)()' inSmalltalk: [true]]
		ifFalse: [hasAccess _ true].
	interpreterProxy pop: 1.
	interpreterProxy pushBool: hasAccess! !


!FilePluginSimulator methodsFor: 'simulation' stamp: 'di 6/23/2004 14:18'!
oopForPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	oop is the width of a machine word, and pointer is a raw address."

	^ pointer! !


!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'di 6/29/2004 14:05'!
primitiveAtPut

	| value floatValue index rcvr floatPtr |
	self export: true.
	self var: #floatValue declareC: 'double floatValue'.
	self var: #floatPtr declareC:'float *floatPtr'.
	value _ interpreterProxy stackValue: 0.
	(interpreterProxy isIntegerObject: value)
		ifTrue:[floatValue _ (interpreterProxy integerValueOf: value) asFloat]
		ifFalse:[floatValue _ interpreterProxy floatValueOf: value].
	index _ interpreterProxy stackIntegerValue: 1.
	rcvr _ interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy success: (index > 0 and:[index <= (interpreterProxy slotSizeOf: rcvr)]).
	interpreterProxy failed ifTrue:[^nil].
	floatPtr _ interpreterProxy firstIndexableField: rcvr.
	floatPtr at: index-1 put: (self cCoerce: floatValue to:'float').
	interpreterProxy failed ifFalse: [interpreterProxy pop: 3 thenPush: value].! !


!InterpreterPlugin class methodsFor: 'translation' stamp: 'ikp 8/3/2004 18:55'!
buildCodeGeneratorUpTo: aPluginClass
	"Build a CCodeGenerator for the plugin"
	 | cg theClass |
	cg _ self codeGeneratorClass new initialize.
	cg pluginName: self moduleName.
	"Add an extra declaration for module name"
	cg declareModuleName: self moduleNameAndVersion.

	theClass _ aPluginClass.
	[theClass == Object | (theClass == InterpreterSimulationObject)] whileFalse:[
		cg addClass: theClass.
		theClass _ theClass superclass].
	^cg! !


!BalloonEngineBase class methodsFor: 'translation' stamp: 'ikp 6/14/2004 15:19'!
declareCVarsIn: cg

	"Buffers"
	cg var: #workBuffer type: #'int*'.
	cg var: #objBuffer type: #'int*'.
	cg var: #getBuffer type: #'int*'.
	cg var: #aetBuffer type: #'int*'.
	cg var: #spanBuffer type: #'unsigned int*'.
	cg var: #edgeTransform declareC: 'float edgeTransform[6]'.
	cg var: #doProfileStats declareC: 'int doProfileStats = 0'.
	cg var: 'bbPluginName' declareC:'char bbPluginName[256] = "BitBltPlugin"'.
	"Functions"
	cg var: 'copyBitsFn'	type: 'void *'.
	cg var: 'loadBBFn'	type: 'void *'.! !


!BitBltSimulation class methodsFor: 'translation' stamp: 'ikp 8/4/2004 18:08'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator var: 'opTable'
		declareC: 'void *opTable[' , OpTableSize printString , ']'.
	aCCodeGenerator var: 'maskTable'
		declareC:'int maskTable[33] = {
0, 1, 3, 0, 15, 31, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 65535,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1
}'.
	aCCodeGenerator var: 'ditherMatrix4x4'
		declareC:'const int ditherMatrix4x4[16] = {
0,	8,	2,	10,
12,	4,	14,	6,
3,	11,	1,	9,
15,	7,	13,	5
}'.
	aCCodeGenerator var: 'ditherThresholds16'
		declareC:'const int ditherThresholds16[8] = { 0, 2, 4, 6, 8, 12, 14, 16 }'.
	aCCodeGenerator var: 'ditherValues16'
		declareC:'const int ditherValues16[32] = {
0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30
}'.

	aCCodeGenerator var: 'warpBitShiftTable'
		declareC:'int warpBitShiftTable[32]'.

	aCCodeGenerator var:'cmShiftTable' 
		declareC:'int *cmShiftTable'.
	aCCodeGenerator var:'cmMaskTable' 
		declareC:'unsigned int *cmMaskTable'.
	aCCodeGenerator var:'cmLookupTable' 
		declareC:'unsigned int *cmLookupTable'.

	aCCodeGenerator var: 'dither8Lookup'
		declareC:' unsigned char dither8Lookup[4096]'.

	aCCodeGenerator var: 'querySurfaceFn' declareC: 'void *querySurfaceFn'.
	aCCodeGenerator var: 'lockSurfaceFn' declareC: 'void *lockSurfaceFn'.
	aCCodeGenerator var: 'unlockSurfaceFn' declareC: 'void *unlockSurfaceFn'! !


!FilePlugin class methodsFor: 'translation' stamp: 'ikp 6/14/2004 13:52'!
declareCVarsIn: aCCodeGenerator

	aCCodeGenerator var: 'sCCPfn'	type: 'void *'.
	aCCodeGenerator var: 'sCDPfn'	type: 'void *'.
	aCCodeGenerator var: 'sCGFTfn'	type: 'void *'.
	aCCodeGenerator var: 'sCLPfn'	type: 'void *'.
	aCCodeGenerator var: 'sCSFTfn'	type: 'void *'.
	aCCodeGenerator var: 'sDFAfn'	type: 'void *'.
	aCCodeGenerator var: 'sCDFfn'	type: 'void *'.
	aCCodeGenerator var: 'sCOFfn'	type: 'void *'.
	aCCodeGenerator var: 'sCRFfn'	type: 'void *'.
	aCCodeGenerator var: 'sHFAfn'	type: 'void *'.
	aCCodeGenerator addHeaderFile: '"FilePlugin.h"'! !


!InterpreterSimulationObject methodsFor: 'memory access' stamp: 'di 8/5/2004 20:56'!
long32At: byteAddress
	"Simulation support.  Answer the 32-bit word at byteAddress which must be 0 mod 4."

	^self getInterpreter long32At: byteAddress! !

!InterpreterSimulationObject methodsFor: 'memory access' stamp: 'di 8/5/2004 20:56'!
long32At: byteAddress put: a32BitValue
	"Simulation support.  Store the 32-bit value at byteAddress which must be 0 mod 4."

	^self getInterpreter long32At: byteAddress put: a32BitValue! !

!InterpreterSimulationObject methodsFor: 'memory access' stamp: 'ikp 8/3/2004 15:56'!
oopForPointer: aPointer
	"Simulation support.  Pointers and oops are the same when simulating; answer aPointer."

	^aPointer! !

!InterpreterSimulationObject methodsFor: 'memory access' stamp: 'ikp 8/3/2004 15:56'!
pointerForOop: anOop
	"Simulation support.  Pointers and oops are the same when simulating; answer anOop."

	^anOop! !

!InterpreterSimulationObject methodsFor: 'simulation' stamp: 'di 8/5/2004 18:55'!
cCoerce: value to: cTypeString
	"Here the Simulator has a chance to create properly typed flavors of CArray access."

	value isCObjectAccessor ifTrue:
		[^ self getInterpreter cCoerce: value to: cTypeString].
	(value isMemberOf: CArray) ifTrue:
		[^ self getInterpreter cCoerce: value to: cTypeString].
	^ value! !


!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'di 6/29/2004 13:42'!
primitiveComposeMatrix
	| m1 m2 m3 result |
	self cCode: ''  "Make this fail in simulation"
		inSmalltalk: [interpreterProxy success: false. ^ nil].
	self export: true.
	self inline: false.
	self var: #m1 declareC:'float *m1'.
	self var: #m2 declareC:'float *m2'.
	self var: #m3 declareC:'float *m3'.
	m3 _ self loadArgumentMatrix: (result _ interpreterProxy stackObjectValue: 0).
	m2 _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 1).
	m1 _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 2).
	interpreterProxy failed ifTrue:[^nil].
	self matrix2x3ComposeMatrix: m1 with: m2 into: m3.
	interpreterProxy pop: 3.
	interpreterProxy push: result.! !


!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 7/1/2004 15:47'!
startField
	"Examine and possibly trace the next field of the object being 
	traced. See comment in markAndTrace for explanation of 
	tracer state variables."
	| typeBits childType |
	self inline: true.
	child _ self longAt: field.
	typeBits _ child bitAnd: TypeMask.
	(typeBits bitAnd: 1) = 1
		ifTrue: ["field contains a SmallInteger; skip it"
			field _ field - BytesPerWord.
			^ StartField].
	typeBits = 0 ifTrue: ["normal oop, go down"
			self longAt: field put: parentField.
			parentField _ field.
			^ StartObj].
	typeBits = 2 ifTrue: ["reached the header; do we need to process the class word? "
			(child bitAnd: CompactClassMask) ~= 0
				ifTrue: ["object's class is compact; we're done"
					"restore the header type bits"
					child _ child bitAnd: AllButTypeMask.
					childType _ self rightType: child.
					self longAt: field put: (child bitOr: childType).
					^ Upward]
				ifFalse: ["object has a full class word; process that class"
					child _ self longAt: field - BytesPerWord. "class word"
					child _ child bitAnd: AllButTypeMask. "clear type bits"
					self longAt: field - BytesPerWord put: parentField.
					parentField _ field - BytesPerWord bitOr: 1.
					"point at class word; mark as working on the class. "
					^ StartObj]]! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 7/1/2004 15:48'!
startObj
	"Start tracing the object 'child' and answer the next action. 
	The object may be anywhere in the middle of being swept 
	itself. See comment in markAndTrace for explanation of 
	tracer state variables."
	| oop header lastFieldOffset |
	self inline: true.
	oop _ child.
	oop < youngStartLocal
		ifTrue: ["old object; skip it"
			field _ oop.
			^ Upward].
	header _ self longAt: oop.
	(header bitAnd: MarkBit) = 0
		ifTrue: ["unmarked; mark and trace"
			"Do not trace the object's indexed fields if it's a weak class "
			(self isWeakNonInt: oop)
				ifTrue: ["Set lastFieldOffset before the weak fields in the receiver "
					lastFieldOffset _ (self nonWeakFieldsOf: oop) << ShiftForWord]
				ifFalse: ["Do it the usual way"
					lastFieldOffset _ self lastPointerOf: oop].
			header _ header bitAnd: AllButTypeMask.
			header _ (header bitOr: MarkBit) bitOr: HeaderTypeGC.
			self longAt: oop put: header.
			field _ oop + lastFieldOffset.
			^ StartField "trace its fields and class"]
		ifFalse: ["already marked; skip it"
			field _ oop.
			^ Upward]! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 7/1/2004 15:57'!
sweepPhase
	"Sweep memory from youngStart through the end of memory. Free all 
	inaccessible objects and coalesce adjacent free chunks. Clear the mark 
	bits of accessible objects. Compute the starting point for the first pass of 
	incremental compaction (compStart). Return the number of surviving 
	objects. "
	"Details: Each time a non-free object is encountered, decrement the 
	number of available forward table entries. If all entries are spoken for 
	(i.e., entriesAvailable reaches zero), set compStart to the last free 
	chunk before that object or, if there is no free chunk before the given 
	object, the first free chunk after it. Thus, at the end of the sweep 
	phase, compStart through compEnd spans the highest collection of 
	non-free objects that can be accomodated by the forwarding table. This 
	information is used by the first pass of incremental compaction to 
	ensure that space is initially freed at the end of memory. Note that 
	there should always be at least one free chunk--the one at the end of 
	the heap."
	| entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize endOfMemoryLocal |
	self inline: false.
	entriesAvailable _ self fwdTableInit: BytesPerWord*2.
	survivors _ 0.
	freeChunk _ nil.
	firstFree _ nil.
	"will be updated later"
	endOfMemoryLocal _ endOfMemory.
	oop _ self oopFromChunk: youngStart.
	[oop < endOfMemoryLocal]
		whileTrue: ["get oop's header, header type, size, and header size"
			oopHeader _ self baseHeader: oop.
			oopHeaderType _ oopHeader bitAnd: TypeMask.
			hdrBytes _ headerTypeBytes at: oopHeaderType.
			(oopHeaderType bitAnd: 1) = 1
				ifTrue: [oopSize _ oopHeader bitAnd: SizeMask]
				ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
						ifTrue: [oopSize _ (self sizeHeader: oop) bitAnd: LongSizeMask]
						ifFalse: ["free chunk" oopSize _ oopHeader bitAnd: LongSizeMask]].
			(oopHeader bitAnd: MarkBit) = 0
				ifTrue: ["object is not marked; free it"
					"<-- Finalization support: We need to mark each oop chunk as free -->"
					self longAt: oop - hdrBytes put: HeaderTypeFree.
					freeChunk ~= nil
						ifTrue: ["enlarge current free chunk to include this oop"
							freeChunkSize _ freeChunkSize + oopSize + hdrBytes]
						ifFalse: ["start a new free chunk"
							freeChunk _ oop - hdrBytes.
							"chunk may start 4 or 8 bytes before oop"
							freeChunkSize _ oopSize + (oop - freeChunk).
							"adjust size for possible extra header bytes"
							firstFree = nil ifTrue: [firstFree _ freeChunk]]]
				ifFalse: ["object is marked; clear its mark bit and possibly adjust 
					the compaction start"
					self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).
					"<-- Finalization support: Check if we're running about a weak class -->"
					(self isWeakNonInt: oop) ifTrue: [self finalizeReference: oop].
					entriesAvailable > 0
						ifTrue: [entriesAvailable _ entriesAvailable - 1]
						ifFalse: ["start compaction at the last free chunk before this object"
							firstFree _ freeChunk].
					freeChunk ~= nil
						ifTrue: ["record the size of the last free chunk"
							self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree).
							freeChunk _ nil].
					survivors _ survivors + 1].
			oop _ self oopFromChunk: oop + oopSize].
	freeChunk ~= nil
		ifTrue: ["record size of final free chunk"
			self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree)].
	oop = endOfMemory
		ifFalse: [self error: 'sweep failed to find exact end of memory'].
	firstFree = nil
		ifTrue: [self error: 'expected to find at least one free object']
		ifFalse: [compStart _ firstFree].

	^ survivors! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 7/1/2004 15:58'!
upward
	"Return from marking an object below. Incoming: 
	field = oop we just worked on, needs to be put away 
	parentField = where to put it in our object 
	NOTE: Type field of object below has already been restored!!!!!! "
	| type header |
	self inline: true.
	(parentField bitAnd: 1) = 1
		ifTrue: [parentField = GCTopMarker
				ifTrue: ["top of the chain"
					header _ (self longAt: field) bitAnd: AllButTypeMask.
					type _ self rightType: header.
					self longAt: field put: (header bitOr: type). "install type on class oop"
					^ Done]
				ifFalse: ["was working on the extended class word"
					child _ field. "oop of class"
					field _ parentField - 1. "class word, ** clear the low bit **"
					parentField _ self longAt: field.
					header _ self longAt: field + BytesPerWord. "base header word"
					type _ self rightType: header.
					self longAt: field put: (child bitOr: type). "install type on class oop"
					field _ field + BytesPerWord. "point at header"
					"restore type bits"
					header _ header bitAnd: AllButTypeMask.
					self longAt: field put: (header bitOr: type).
					^ Upward]]
		ifFalse: ["normal"
			child _ field. "who we worked on below"
			field _ parentField. "where to put it"
			parentField _ self longAt: field.
			self longAt: field put: child.
			field _ field - BytesPerWord. "point at header"
			^ StartField]! !

!ObjectMemory methodsFor: 'finalization' stamp: 'di 7/1/2004 15:45'!
finalizeReference: oop 
	"During sweep phase we have encountered a weak reference. 
	Check if  its object has gone away (or is about to) and if so, signal a 
	semaphore. "
	"Do *not* inline this in sweepPhase - it is quite an unlikely 
	case to run into a weak reference"
	| weakOop oopGone chunk firstField lastField |
	self inline: false.
	firstField _ BaseHeaderSize + ((self nonWeakFieldsOf: oop) << ShiftForWord).
	lastField _ self lastPointerOf: oop.
	firstField to: lastField by: BytesPerWord do: [:i | 
			weakOop _ self longAt: oop + i.
			(weakOop == nilObj or: [self isIntegerObject: weakOop])
				ifFalse: ["Check if the object is being collected. 
					If the weak reference points  
					* backward: check if the weakOops chunk is free
					* forward: check if the weakOoop has been marked by GC"
					weakOop < oop
						ifTrue: [chunk _ self chunkFromOop: weakOop.
							oopGone _ ((self longAt: chunk) bitAnd: TypeMask) = HeaderTypeFree]
						ifFalse: [oopGone _ ((self baseHeader: weakOop) bitAnd: MarkBit) = 0].
					oopGone ifTrue: ["Store nil in the pointer and signal the  interpreter "
							self longAt: oop + i put: nilObj.
							self signalFinalization: oop]]]! !

!ObjectMemory methodsFor: 'object enumeration' stamp: 'di 6/11/2004 13:20'!
lastPointerOf: oop 
	"Return the byte offset of the last pointer field of the given object.  
	Works with CompiledMethods, as well as ordinary objects. 
	Can be used even when the type bits are not correct."
	| fmt sz methodHeader header contextSize |
	self inline: true.
	header _ self baseHeader: oop.
	fmt _ header >> 8 bitAnd: 15.
	fmt <= 4 ifTrue: [(fmt = 3 and: [self isContextHeader: header])
					ifTrue: ["contexts end at the stack pointer"
						contextSize _ self fetchStackPointerOf: oop.
						^ CtxtTempFrameStart + contextSize * BytesPerWord].
				sz _ self sizeBitsOfSafe: oop.
				^ sz - BaseHeaderSize  "all pointers"].
	fmt < 12 ifTrue: [^ 0]. "no pointers"

	"CompiledMethod: contains both pointers and bytes:"
	methodHeader _ self longAt: oop + BaseHeaderSize.
	^ (methodHeader >> 10 bitAnd: 255) * BytesPerWord + BaseHeaderSize! !

!ObjectMemory methodsFor: 'object enumeration' stamp: 'ikp 3/26/2005 14:04'!
startOfMemory
	"Return the start of object memory."

	^memory! !

!ObjectMemory methodsFor: 'initialization' stamp: 'ikp 3/27/2005 18:06'!
adjustAllOopsBy: bytesToShift 
	"Adjust all oop references by the given number of bytes. This 
	is done just after reading in an image when the new base 
	address of the object heap is different from the base address 
	in the image."
	"di 11/18/2000 - return number of objects found"

	| oop totalObjects |
	self inline: false.
	bytesToShift = 0 ifTrue: [^300000].
	"this is probably an improvement over the previous answer of 
	nil, but maybe we should do the obejct counting loop and 
	simply guard the adjustFieldsAndClass... with a bytesToShift 
	= 0 ifFalse: ?"
	totalObjects _ 0.
	oop _ self firstObject.
	[oop < endOfMemory]
		whileTrue:
			[(self isFreeObject: oop)
				ifFalse:
					[totalObjects _ totalObjects + 1.
					 self adjustFieldsAndClassOf: oop by: bytesToShift].
			 oop _ self objectAfter: oop].
	^totalObjects! !

!ObjectMemory methodsFor: 'initialization' stamp: 'ikp 3/26/2005 14:21'!
adjustFieldsAndClassOf: oop by: offsetBytes 
	"Adjust all pointers in this object by the given offset."
	| fieldAddr fieldOop classHeader newClassOop |
	self inline: true.
	offsetBytes = 0 ifTrue: [^nil].
	fieldAddr _ oop + (self lastPointerOf: oop).
	[fieldAddr > oop]
		whileTrue: [fieldOop _ self longAt: fieldAddr.
			(self isIntegerObject: fieldOop)
				ifFalse: [self longAt: fieldAddr put: fieldOop + offsetBytes].
			fieldAddr _ fieldAddr - BytesPerWord].
	(self headerType: oop) ~= HeaderTypeShort
		ifTrue: ["adjust class header if not a compact class"
			classHeader _ self longAt: oop - BytesPerWord.
			newClassOop _ (classHeader bitAnd: AllButTypeMask) + offsetBytes.
			self longAt: oop - BytesPerWord put: (newClassOop bitOr: (classHeader bitAnd: TypeMask))]! !

!ObjectMemory methodsFor: 'initialization' stamp: 'ikp 9/2/2004 13:54'!
bytesPerWord
	"Answer the size of an object pointer in bytes."

	^BytesPerWord! !

!ObjectMemory methodsFor: 'initialization' stamp: 'ikp 9/2/2004 13:00'!
initializeMemoryFirstFree: firstFree 
	"Initialize endOfMemory to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at endOfMemory to act as a sentinal for memory scans. "
	"Note: The amount of space reserved for forwarding blocks should be chosen to ensure that incremental compactions can usually be done in a single pass. However, there should be enough forwarding blocks so a full compaction can be done in a reasonable number of passes, say ten. (A full compaction requires N object-moving passes, where N = number of non-garbage objects / number of forwarding blocks). 
	di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means an absolute worst case of 8 passes to compact memory. In most cases it will be adequate to do compaction in a single pass. "
	| fwdBlockBytes |
	"reserve space for forwarding blocks"
	fwdBlockBytes _ totalObjectCount bitAnd: WordMask - BytesPerWord + 1.
	memoryLimit - fwdBlockBytes >= (firstFree + BaseHeaderSize)
		ifFalse: ["reserve enough space for a minimal free block of BaseHeaderSize bytes"
			fwdBlockBytes _ memoryLimit - (firstFree + BaseHeaderSize)].

	"set endOfMemory and initialize freeBlock"
	endOfMemory _ memoryLimit - fwdBlockBytes.
	freeBlock _ firstFree.
	self setSizeOfFree: freeBlock to: endOfMemory - firstFree. "bytes available for oops"

	"make a fake free chunk at endOfMemory for use as a sentinel in memory scans"
	self setSizeOfFree: endOfMemory to: BaseHeaderSize.
	DoAssertionChecks
		ifTrue: [(freeBlock < endOfMemory and: [endOfMemory < memoryLimit])
				ifFalse: [self error: 'error in free space computation'].
			(self oopFromChunk: endOfMemory) = endOfMemory
				ifFalse: [self error: 'header format must have changed'].
			(self objectAfter: freeBlock) = endOfMemory
				ifFalse: [self error: 'free block not properly initialized']]! !

!ObjectMemory methodsFor: 'become' stamp: 'di 8/3/2004 12:23'!
allYoung: array1 and: array2 
	"Return true if all the oops in both arrays, and the arrays 
	themselves, are in the young object space."
	| fieldOffset |
	array1 < youngStart ifTrue: [^ false].
	array2 < youngStart ifTrue: [^ false].
	fieldOffset _ self lastPointerOf: array1.
	"same size as array2"
	[fieldOffset >= BaseHeaderSize]
		whileTrue: [(self longAt: array1 + fieldOffset) < youngStart ifTrue: [^ false].
			(self longAt: array2 + fieldOffset) < youngStart ifTrue: [^ false].
			fieldOffset _ fieldOffset - BytesPerWord].
	^ true! !

!ObjectMemory methodsFor: 'become' stamp: 'di 8/3/2004 13:12'!
containOnlyOops: array1 and: array2 
	"Return true if neither array contains a small integer. You 
	can't become: integers!!"
	| fieldOffset |
	fieldOffset _ self lastPointerOf: array1.
	"same size as array2"
	[fieldOffset >= BaseHeaderSize]
		whileTrue: [(self isIntegerObject: (self longAt: array1 + fieldOffset)) ifTrue: [^ false].
			(self isIntegerObject: (self longAt: array2 + fieldOffset)) ifTrue: [^ false].
			fieldOffset _ fieldOffset - BytesPerWord].
	^ true! !

!ObjectMemory methodsFor: 'become' stamp: 'tpr 3/23/2005 12:05'!
prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag 
	"Ensure that there are enough forwarding blocks to 
	accomodate this become, then prepare forwarding blocks for 
	the pointer swap. Return true if successful."
	"Details: Doing a GC might generate enough space for 
	forwarding blocks if we're short. However, this is an 
	uncommon enough case that it is better handled by primitive 
	fail code at the Smalltalk level."

	"Important note on multiple references to same object  - since the preparation of
	fwdBlocks is NOT idempotent we get VM crashes if the same object is referenced more
	than once in such a way as to require multiple fwdBlocks.
	oop1 forwardBecome: oop1 is ok since only a single fwdBlock is needed.
	oop1 become: oop1 would fail because the second fwdBlock woudl not have the actual object
	header but rather the mutated ref to the first fwdBlock.
	Further problems can arise with an array1 or array2 that refer multiply to the same 
	object. This would notbe expected input for programmer writen code but might arise from
	automatic usage such as in ImageSegment loading.
	To avoid the simple and rather common case of oop1 become*: oop1, we skip such pairs
	and simply avoid making fwdBlocks - it is redundant anyway"
	| entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock fwdBlkSize |
	entriesNeeded := (self lastPointerOf: array1) // BytesPerWord. "need enough entries for all oops"
	"Note: Forward blocks must be quadword aligned - see fwdTableInit:."
	twoWayFlag
		ifTrue: ["Double the number of blocks for two-way become"
			entriesNeeded _ entriesNeeded * 2.
			fwdBlkSize _ BytesPerWord * 2]
		ifFalse: ["One-way become needs backPointers in fwd blocks."
			fwdBlkSize _ BytesPerWord * 4].
	entriesAvailable _ self fwdTableInit: fwdBlkSize.
	entriesAvailable < entriesNeeded
		ifTrue: [self initializeMemoryFirstFree: freeBlock.
			"re-initialize the free block"
			^ false].
	fieldOffset _ self lastPointerOf: array1.
	[fieldOffset >= BaseHeaderSize]
		whileTrue: [oop1 _ self longAt: array1 + fieldOffset.
			oop2 _ self longAt: array2 + fieldOffset.
			"if oop1 == oop2, no need to do any work for this pair.
			May still be other entries in the arrays though so keep looking"
			oop1 = oop2
				ifFalse: [fwdBlock _ self fwdBlockGet: fwdBlkSize.
					self
						initForwardBlock: fwdBlock
						mapping: oop1
						to: oop2
						withBackPtr: twoWayFlag not.
					twoWayFlag
						ifTrue: ["Second block maps oop2 back to oop1 for two-way become"
							fwdBlock _ self fwdBlockGet: fwdBlkSize.
							self
								initForwardBlock: fwdBlock
								mapping: oop2
								to: oop1
								withBackPtr: twoWayFlag not]].
			fieldOffset _ fieldOffset - BytesPerWord].
	^ true! !

!ObjectMemory methodsFor: 'become' stamp: 'di 7/22/2004 17:50'!
restoreHeaderOf: oop 
	"Restore the original header of the given oop from its 
	forwarding block."
	| fwdHeader fwdBlock |
	fwdHeader _ self longAt: oop.
	fwdBlock _ (fwdHeader bitAnd: AllButMarkBitAndTypeMask) << 1.
	DoAssertionChecks
		ifTrue: [(fwdHeader bitAnd: MarkBit) = 0
				ifTrue: [self error: 'attempting to restore the header of an object that has no forwarding block'].
			self fwdBlockValidate: fwdBlock].
	self longAt: oop put: (self longAt: fwdBlock + BytesPerWord)! !

!ObjectMemory methodsFor: 'become' stamp: 'tpr 3/23/2005 12:07'!
restoreHeadersAfterBecoming: list1 with: list2 
	"Restore the headers of all oops in both lists. Exchange their hash bits so
	becoming objects in identity sets and dictionaries doesn't change their
	hash value."
	"See also prepareForwardingTableForBecoming:with:woWay: for notes
	regarding the case
	of oop1 = oop2"
	| fieldOffset oop1 oop2 hdr1 hdr2 |
	fieldOffset _ self lastPointerOf: list1.
	[fieldOffset >= BaseHeaderSize]
		whileTrue: [oop1 _ self longAt: list1 + fieldOffset.
			oop2 _ self longAt: list2 + fieldOffset.
			oop1 = oop2
				ifFalse: [self restoreHeaderOf: oop1.
					self restoreHeaderOf: oop2.
					"Exchange hash bits of the two objects."
					hdr1 _ self longAt: oop1.
					hdr2 _ self longAt: oop2.
					self
						longAt: oop1
						put: ((hdr1 bitAnd: AllButHashBits) bitOr: (hdr2 bitAnd: HashBits)).
					self
						longAt: oop2
						put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
			fieldOffset _ fieldOffset - BytesPerWord]! !

!ObjectMemory methodsFor: 'become' stamp: 'di 7/22/2004 17:59'!
restoreHeadersAfterForwardBecome: copyHashFlag 
	"Forward become leaves us with no original oops in the 
	mutated object list, 
	so we must enumerate the (four-word) forwarding blocks 
	where we have stored backpointers."
	"This loop start is copied from fwdTableInit:"
	| oop1 fwdBlock oop2 hdr1 hdr2 |
	fwdBlock _ endOfMemory + BaseHeaderSize + 7 bitAnd: WordMask - 7.
	fwdBlock _ fwdBlock + 16.
	"fwdBlockGet: did a pre-increment"
	[fwdBlock <= fwdTableNext
	"fwdTableNext points to the last active block"]
		whileTrue: [oop1 _ self longAt: fwdBlock + (BytesPerWord*2).
			"Backpointer to mutated object."
			oop2 _ self longAt: fwdBlock.
			self restoreHeaderOf: oop1.
			copyHashFlag
				ifTrue: ["Change the hash of the new oop (oop2) to be that of the old (oop1) 
					so mutated objects in hash structures will be 
					happy after the change."
					hdr1 _ self longAt: oop1.
					hdr2 _ self longAt: oop2.
					self longAt: oop2 put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
			fwdBlock _ fwdBlock + (BytesPerWord*4)]! !

!ObjectMemory methodsFor: 'allocation' stamp: 'ikp 3/27/2005 18:07'!
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.
	May cause a GC"

	| newObj remappedClassOop end i |
	self inline: true.
	self var: #i type: 'usqInt'.
	self var: #end type: 'usqInt'.
	"remap classOop in case GC happens during allocation"
	hdrSize > 1 ifTrue: [self pushRemappableOop: classOop].
	newObj _ self allocateChunk: byteSize + (hdrSize - 1 * BytesPerWord).
	hdrSize > 1 ifTrue: [remappedClassOop _ self popRemappableOop].

	hdrSize = 3
		ifTrue: [self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass).
			self longAt: newObj + BytesPerWord put: (remappedClassOop bitOr: HeaderTypeSizeAndClass).
			self longAt: newObj + (BytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
			newObj _ newObj + (BytesPerWord*2)].

	hdrSize = 2
		ifTrue: [self longAt: newObj put: (remappedClassOop bitOr: HeaderTypeClass).
			self longAt: newObj + BytesPerWord put: (baseHeader bitOr: HeaderTypeClass).
			newObj _ newObj + BytesPerWord].

	hdrSize = 1
		ifTrue: [self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort)].
	"clear new object"
	doFill ifTrue: [end _ newObj + byteSize.
			i _ newObj + BytesPerWord.
			[i < end] whileTrue: [self longAt: i put: fillWord.
					i _ i + BytesPerWord]].
	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: 'ikp 8/4/2004 18:29'!
allocateChunk: byteSize 
	"Allocate a chunk of the given size. Sender must be sure that  the requested size includes enough space for the header  word(s). " 
	"Details: To limit the time per incremental GC, do one every so many allocations. The number is settable via primitiveVMParameter to tune your memory system"
	| enoughSpace newFreeSize newChunk |
	self inline: true.

	allocationCount >= allocationsBetweenGCs
		ifTrue: ["do an incremental GC every so many allocations to  keep pauses short"
			self incrementalGC].

	enoughSpace _ self sufficientSpaceToAllocate: byteSize.
	enoughSpace
		ifFalse: ["signal that space is running low, but proceed with allocation if possible"
			signalLowSpace _ true.
			lowSpaceThreshold _ 0. "disable additional interrupts until lowSpaceThreshold is reset by image"
			self forceInterruptCheck].
	(self cCoerce: (self sizeOfFree: freeBlock) to: 'usqInt ') < (self cCoerce: byteSize + BaseHeaderSize to: 'usqInt ')
		ifTrue: [self error: 'out of memory'].

	"if we get here, there is enough space for allocation to  succeed "
	newFreeSize _ (self sizeOfFree: freeBlock) - byteSize.
	newChunk _ freeBlock.
	freeBlock _ freeBlock + byteSize.

	"Assume: client will initialize object header of free chunk, so following is not needed:"
	"self setSizeOfFree: newChunk to: byteSize."
	self setSizeOfFree: freeBlock to: newFreeSize.
	allocationCount _ allocationCount + 1.
	^newChunk! !

!ObjectMemory methodsFor: 'allocation' stamp: 'di 8/3/2004 12:25'!
clone: oop
	"Return a shallow copy of the given object. May cause GC"
	"Assume: Oop is a real object, not a small integer."

	| extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash |
	self inline: false.
	extraHdrBytes _ self extraHeaderBytes: oop.
	bytes _ self sizeBitsOf: oop.
	bytes _ bytes + extraHdrBytes.

	"allocate space for the copy, remapping oop in case of a GC"
	self pushRemappableOop: oop.
	newChunk _ self allocateChunk: bytes.
	remappedOop _ self popRemappableOop.

	"copy old to new including all header words"
	toIndex _ newChunk - BytesPerWord.  "loop below uses pre-increment"
	fromIndex _ (remappedOop - extraHdrBytes) - BytesPerWord.
	lastFrom _ fromIndex + bytes.
	[fromIndex < lastFrom] whileTrue: [
		self longAt: (toIndex _ toIndex + BytesPerWord) put: (self longAt: (fromIndex _ fromIndex + BytesPerWord))].
	newOop _ newChunk + extraHdrBytes.  "convert from chunk to oop"

	"fix base header: compute new hash and clear Mark and Root bits"
	hash _ self newObjectHash.
	header _ (self longAt: newOop) bitAnd: 16r1FFFF.
	"use old ccIndex, format, size, and header-type fields"
	header _ header bitOr: ((hash << 17) bitAnd: 16r1FFE0000).
	self longAt: newOop put: header.
	^newOop
! !

!ObjectMemory methodsFor: 'allocation' stamp: 'ikp 8/4/2004 18:30'!
sufficientSpaceAfterGC: minFree 
	"Return true if there is enough free space after doing a garbage collection. If not, signal that space is low."
	| growSize |
	self inline: false.

	self incrementalGC. "try to recover some space"

	(self cCoerce: (self sizeOfFree: freeBlock) to: 'usqInt ') < (self cCoerce: minFree to: 'usqInt ')
		ifTrue: [signalLowSpace ifTrue: [^false]. "give up; problem is already noted"
			self fullGC. "try harder"
			"for stability, require more free space after doing an expensive full GC"
			(self cCoerce: (self sizeOfFree: freeBlock) to: 'usqInt ') >= ((self cCoerce: minFree to: 'usqInt ') + 15000) ifTrue: [^ true].

			"still not enough; attempt to grow object memory"
			growSize _ minFree - (self sizeOfFree: freeBlock) + growHeadroom.
			self growObjectMemory: growSize.

			(self cCoerce: (self sizeOfFree: freeBlock) to: 'usqInt ') >= ((self cCoerce: minFree to: 'usqInt ') + 15000) ifTrue: [^true].

			"still not enough"
			^false].
	^true! !

!ObjectMemory methodsFor: 'allocation' stamp: 'ikp 8/4/2004 18:30'!
sufficientSpaceToAllocate: bytes
	"Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection."

	| minFree |
	self inline: true.
	minFree _ lowSpaceThreshold + bytes + BaseHeaderSize.

	"check for low-space"
	(self cCoerce: (self sizeOfFree: freeBlock) to: 'usqInt ') >= (self cCoerce: minFree to: 'usqInt ')
		ifTrue: [^true]
		ifFalse: [^self sufficientSpaceAfterGC: minFree].! !

!ObjectMemory methodsFor: 'header access' stamp: 'di 6/13/2004 06:55'!
classHeader: oop

	^ self longAt: oop - BaseHeaderSize! !

!ObjectMemory methodsFor: 'header access' stamp: 'di 10/6/2004 10:26'!
formatOf: oop
"       0      no fields
        1      fixed fields only (all containing pointers)
        2      indexable fields only (all containing pointers)
        3      both fixed and indexable fields (all containing pointers)
        4      both fixed and indexable weak fields (all containing pointers).

        5      unused
        6      indexable word fields only (no pointers)
        7      indexable long (64-bit) fields (only in 64-bit images)
 
    8-11      indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size)
   12-15     compiled methods:
                   # of literal oops specified in method header,
                   followed by indexable bytes (same interpretation of low 2 bits as above)
"

	^ ((self baseHeader: oop) >> 8) bitAnd: 16rF! !

!ObjectMemory methodsFor: 'header access' stamp: 'di 6/11/2004 16:34'!
sizeBitsOf: oop
	"Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words."
	"Note: byte indexable objects need to have low bits subtracted from this size."

	| header |
	header _ self baseHeader: oop.
	(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ ^ (self sizeHeader: oop) bitAnd: LongSizeMask ]
		ifFalse: [ ^ header bitAnd: SizeMask ].! !

!ObjectMemory methodsFor: 'header access' stamp: 'di 6/11/2004 13:15'!
sizeHeader: oop

	^ self longAt: oop - (BytesPerWord*2)! !

!ObjectMemory methodsFor: 'garbage collection' stamp: 'di 7/2/2004 12:29'!
incrementalGC
	"Do a mark/sweep garbage collection of just the young object 
	area of object memory (i.e., objects above youngStart), using 
	the root table to identify objects containing pointers to 
	young objects from the old object area."
	| survivorCount startTime |
	self inline: false.
	rootTableCount >= RootTableSize
		ifTrue: ["root table overflow; cannot do an incremental GC (this should be very rare)"
			statRootTableOverflows _ statRootTableOverflows + 1.
			^ self fullGC].
	DoAssertionChecks
		ifTrue: [self reverseDisplayFrom: 8 to: 15.
			self validateRoots; validate].

	self preGCAction: false.
	"incremental GC and compaction"

	startTime _ self ioMicroMSecs.
	self markPhase.
	survivorCount _ self sweepPhase.
	self incrementalCompaction.
	allocationCount _ 0.
	statIncrGCs _ statIncrGCs + 1.
	statIncrGCMSecs _ statIncrGCMSecs + (self ioMicroMSecs - startTime).

	self forceInterruptCheck. "Force an an interrupt check ASAP.We could choose to be clever here and only do this under certain time conditions. Keep it simple for now"
	
	(survivorCount > tenuringThreshold
			or: [rootTableCount >= RootTableRedZone])
		ifTrue: ["move up the young space boundary if 
			* there are too many survivors: 
			this limits the number of objects that must be 
			processed on future incremental GC's 
			* we're about to overflow the roots table 
			this limits the number of full GCs that may be caused 
			by root table overflows in the near future"
			statTenures _ statTenures + 1.
			self clearRootsTable.
			youngStart _ freeBlock].
	self postGCAction.
	DoAssertionChecks
		ifTrue: [self validateRoots; validate.
			self reverseDisplayFrom: 8 to: 15]! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 14:28'!
beRootWhileForwarding: oop
	"Record that the given oop in the old object area points to an object in the young area when oop may be forwarded."
	"Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated."

	| header fwdBlock |
	header _ self longAt: oop.
	(header bitAnd: MarkBit) ~= 0
		ifTrue: ["This oop is forwarded"
				fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1.
				DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
				self noteAsRoot: oop headerLoc: fwdBlock + BytesPerWord]
		ifFalse: ["Normal -- no forwarding"
				self noteAsRoot: oop headerLoc: oop]! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 15:29'!
fwdTableInit: blkSize
	"Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available."

	| |
	self inline: false.
	"set endOfMemory to just after a minimum-sized free block"
	self setSizeOfFree: freeBlock to: BaseHeaderSize.
	endOfMemory _ freeBlock + BaseHeaderSize.

	"make a fake free chunk at endOfMemory for use as a sentinal in memory scans"
	self setSizeOfFree: endOfMemory to: BaseHeaderSize.

	"use all memory free between freeBlock and memoryLimit for forwarding table"
	"Note: Forward blocks must be quadword aligned."
	fwdTableNext _ (endOfMemory + BaseHeaderSize + 7) bitAnd: WordMask-7.
	self flag: #Dan.  "Above line does not do what it says (quadword is 16 or 32 bytes)"

	fwdTableLast _ memoryLimit - blkSize.  "last forwarding table entry"

	"return the number of forwarding blocks available"
	^ (fwdTableLast - fwdTableNext) // blkSize  "round down"! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 15:30'!
fwdTableSize: blkSize
	"Estimate the number of forwarding blocks available for compaction"
	| eom fwdFirst fwdLast |
	self inline: false.

	eom _ freeBlock + BaseHeaderSize.
	"use all memory free between freeBlock and memoryLimit for forwarding table"

	"Note: Forward blocks must be quadword aligned."
	fwdFirst _ (eom + BaseHeaderSize + 7) bitAnd: WordMask-7.
	self flag: #Dan.  "Above line does not do what it says (quadword is 16 or 32 bytes)"

	fwdLast _ memoryLimit - blkSize.  "last forwarding table entry"

	"return the number of forwarding blocks available"
	^ (fwdLast - fwdFirst) // blkSize  "round down"! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 14:55'!
incCompBody
	"Move objects to consolidate free space into one big chunk. Return the newly created free chunk."

	| bytesFreed |
	self inline: false.
	"reserve memory for forwarding table"
	self fwdTableInit: BytesPerWord*2.  "Two-word blocks"

	"assign new oop locations, reverse their headers, and initialize forwarding blocks"
	bytesFreed _ self incCompMakeFwd.

	"update pointers to point at new oops"
	self mapPointersInObjectsFrom: youngStart to: endOfMemory.

	"move the objects and restore their original headers; return the new free chunk"
	^ self incCompMove: bytesFreed! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 14:56'!
incCompMakeFwd
	"Create and initialize forwarding blocks for all non-free objects  
	following compStart. If the supply of forwarding blocks is exhausted,  
	set compEnd to the first chunk above the area to be 
	compacted; otherwise, set it to endOfMemory. Return the number of 
	bytes to be freed."
	| bytesFreed oop fwdBlock newOop |
	self inline: false.
	bytesFreed _ 0.
	oop _ self oopFromChunk: compStart.
	[oop < endOfMemory]
		whileTrue: [(self isFreeObject: oop)
				ifTrue: [bytesFreed _ bytesFreed + (self sizeOfFree: oop)]
				ifFalse: ["create a forwarding block for oop"
					fwdBlock _ self fwdBlockGet: BytesPerWord*2.
					"Two-word block"
					fwdBlock = nil
						ifTrue: ["stop; we have used all available forwarding blocks"
							compEnd _ self chunkFromOop: oop.
							^ bytesFreed].
					newOop _ oop - bytesFreed.
					self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false].
			oop _ self objectAfterWhileForwarding: oop].
	compEnd _ endOfMemory.
	^ bytesFreed! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 14:58'!
incCompMove: bytesFreed 
	"Move all non-free objects between compStart and compEnd to their new  
	locations, restoring their headers in the process. Create a new free  
	block at the end of memory. Return the newly created free chunk. "
	"Note: The free block used by the allocator always must be the last free  
	block in memory. It may take several compaction passes to make all  
	free space bubble up to the end of memory."
	| oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz target |
	self inline: false.
	newOop _ nil.
	oop _ self oopFromChunk: compStart.
	[oop < compEnd]
		whileTrue: [next _ self objectAfterWhileForwarding: oop.
			(self isFreeObject: oop)
				ifFalse: ["a moving object; unwind its forwarding block"
					fwdBlock _ ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1.
					DoAssertionChecks
						ifTrue: [self fwdBlockValidate: fwdBlock].
					newOop _ self longAt: fwdBlock.
					header _ self longAt: fwdBlock + BytesPerWord.
					self longAt: oop put: header. "restore the original header"
					bytesToMove _ oop - newOop. "move the oop (including any extra header words) "
					sz _ self sizeBitsOf: oop.
					firstWord _ oop - (self extraHeaderBytes: oop).
					lastWord _ oop + sz - BaseHeaderSize.
					target _ firstWord - bytesToMove.
					firstWord to: lastWord by: BytesPerWord
						do: [:w | 
							self longAt: target put: (self longAt: w).
							target _ target + BytesPerWord]].
			oop _ next].
	newOop = nil
		ifTrue: ["no objects moved"
			oop _ self oopFromChunk: compStart.
			((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)])
				ifTrue: [newFreeChunk _ oop]
				ifFalse: [newFreeChunk _ freeBlock]]
		ifFalse: ["initialize the newly freed memory chunk"
			"newOop is the last object moved; free chunk starts 
			right after it"
			newFreeChunk _ newOop + (self sizeBitsOf: newOop).
			self setSizeOfFree: newFreeChunk to: bytesFreed].
	DoAssertionChecks
		ifTrue: [(self objectAfter: newFreeChunk) = (self oopFromChunk: compEnd)
				ifFalse: [self error: 'problem creating free chunk after compaction']].
	(self objectAfter: newFreeChunk) = endOfMemory
		ifTrue: [self initializeMemoryFirstFree: newFreeChunk]
		ifFalse: ["newFreeChunk is not at end of memory; re-install freeBlock "
			self initializeMemoryFirstFree: freeBlock].
	^ newFreeChunk! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 15:00'!
initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: backFlag 
	"Initialize the given forwarding block to map oop to newOop, 
	and replace oop's header with a pointer to the fowarding 
	block. "
	"Details: The mark bit is used to indicate that an oop is 
	forwarded. When an oop is forwarded, its header (minus the 
	mark bit) contains the address of its forwarding block. (The 
	forwarding block address is actually shifted right by one bit 
	so that its top-most bit does not conflict with the header's 
	mark bit; since fowarding blocks are stored on word 
	boundaries, the low two bits of the address are always zero.) 
	The first word of the forwarding block is the new oop; the 
	second word is the oop's orginal header. In the case of a 
	forward become, a four-word block is used, with the third 
	field being a backpointer to the old oop (for header fixup), 
	and the fourth word is unused. The type bits of the 
	forwarding header are the same as those of the original 
	header. "
	| originalHeader originalHeaderType |
	self inline: true.
	originalHeader _ self longAt: oop.
	DoAssertionChecks
		ifTrue: [fwdBlock = nil ifTrue: [self error: 'ran out of forwarding blocks in become'].
			(originalHeader bitAnd: MarkBit) ~= 0
				ifTrue: [self error: 'object already has a forwarding table entry']].
	originalHeaderType _ originalHeader bitAnd: TypeMask.
	self longAt: fwdBlock put: newOop.
	self longAt: fwdBlock + BytesPerWord put: originalHeader.
	backFlag ifTrue: [self longAt: fwdBlock + (BytesPerWord*2) put: oop].
	self longAt: oop put: (fwdBlock >> 1 bitOr: (MarkBit bitOr: originalHeaderType))! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 15:04'!
lastPointerWhileForwarding: oop 
	"The given object may have its header word in a forwarding block. Find  
	the offset of the last pointer in the object in spite of this obstacle. "
	| header fwdBlock fmt size methodHeader contextSize |
	self inline: true.
	header _ self longAt: oop.
	(header bitAnd: MarkBit) ~= 0
		ifTrue: ["oop is forwarded; get its real header from its forwarding table entry"
			fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1.
			DoAssertionChecks
				ifTrue: [self fwdBlockValidate: fwdBlock].
			header _ self longAt: fwdBlock + BytesPerWord].
	fmt _ header >> 8 bitAnd: 15.
	fmt <= 4
		ifTrue: [(fmt = 3 and: [self isContextHeader: header])
				ifTrue: ["contexts end at the stack pointer"
					contextSize _ self fetchStackPointerOf: oop.
					^ CtxtTempFrameStart + contextSize * BytesPerWord].
			"do sizeBitsOf: using the header we obtained"
			(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
				ifTrue: [size _ (self sizeHeader: oop) bitAnd: AllButTypeMask]
				ifFalse: [size _ header bitAnd: SizeMask].
			^ size - BaseHeaderSize].
	fmt < 12 ifTrue: [^ 0]. "no pointers"
	methodHeader _ self longAt: oop + BaseHeaderSize.
	^ (methodHeader >> 10 bitAnd: 255) * BytesPerWord + BaseHeaderSize! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 15:35'!
objectAfterWhileForwarding: oop
	"Return the oop of the object after the given oop when the actual header of the oop may be in the forwarding table."

	| header fwdBlock realHeader sz |
	self inline: true.
	header _ self longAt: oop.
	(header bitAnd: MarkBit) = 0 ifTrue: [ ^ self objectAfter: oop ].  "oop not forwarded"

	"Assume: mark bit cannot be set on a free chunk, so if we get here,
	 oop is not free and it has a forwarding table entry"

	fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1.
	DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
	realHeader _ self longAt: fwdBlock + BytesPerWord.
	"following code is like sizeBitsOf:"
	(realHeader bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: LongSizeMask ]
		ifFalse: [ sz _ realHeader bitAnd: SizeMask ].

	^ self oopFromChunk: (oop + sz)! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 15:37'!
remapClassOf: oop 
	"Update the class of the given object, if necessary, using its forwarding table entry."
	"Note: Compact classes need not be remapped since the compact class field is just an index into the compact class 
	table. The header type bits show if this object has a compact class; we needn't look up the oop's real header."
	| classHeader classOop fwdBlock newClassOop newClassHeader |
	(self headerType: oop) = HeaderTypeShort ifTrue: [^ nil]. "compact classes needn't be mapped"

	classHeader _ self longAt: oop - BytesPerWord.
	classOop _ classHeader bitAnd: AllButTypeMask.
	(self isObjectForwarded: classOop)
		ifTrue: [fwdBlock _ ((self longAt: classOop) bitAnd: AllButMarkBitAndTypeMask) << 1.
			DoAssertionChecks
				ifTrue: [self fwdBlockValidate: fwdBlock].
			newClassOop _ self longAt: fwdBlock.
			newClassHeader _ newClassOop bitOr: (classHeader bitAnd: TypeMask).
			self longAt: oop - BytesPerWord put: newClassHeader.
			"The following ensures that become: into an old object's class makes it a root. 
			It does nothing during either incremental or full compaction because 
			oop will never be < youngStart."
			(oop < youngStart and: [newClassOop >= youngStart])
				ifTrue: [self beRootWhileForwarding: oop]]! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 7/1/2004 15:37'!
remapFieldsAndClassOf: oop 
	"Replace all forwarded pointers in this object with their new oops, using the forwarding table. Remap its class as well, if 
	necessary. "
	"Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry."
	| fieldOffset fieldOop fwdBlock newOop |
	self inline: true.
	fieldOffset _ self lastPointerWhileForwarding: oop.
	[fieldOffset >= BaseHeaderSize]
		whileTrue: [fieldOop _ self longAt: oop + fieldOffset.
			(self isObjectForwarded: fieldOop)
				ifTrue: ["update this oop from its forwarding block"
					fwdBlock _ ((self longAt: fieldOop) bitAnd: AllButMarkBitAndTypeMask) << 1.
					DoAssertionChecks
						ifTrue: [self fwdBlockValidate: fwdBlock].
					newOop _ self longAt: fwdBlock.
					self longAt: oop + fieldOffset put: newOop.
					"The following ensures that become: into old object makes it a root. 
					It does nothing during either incremental or full compaction because 
					oop will never be < youngStart."
					(oop < youngStart and: [newOop >= youngStart])
						ifTrue: [self beRootWhileForwarding: oop]].
			fieldOffset _ fieldOffset - BytesPerWord].
	self remapClassOf: oop! !

!ObjectMemory methodsFor: 'memory access' stamp: 'tpr 3/17/2005 18:40'!
validate
"null method just to stop compilation of interp.c from barfing"! !

!ObjectMemory methodsFor: 'memory access' stamp: 'di 7/1/2004 17:22'!
validateRoots 
	"Verify that every old object that points to a new object 
		has its root bit set, and
		appears in the rootTable.
	This method should not be called if the rootTable is full, because roots
	are no longer recorded, and incremental collections are not attempted.
	If DoAssertionChecks is true, this routine will halt on an unmarked root.
	Otherwise, this routine will merely return true in that case."
	| oop fieldAddr fieldOop header badRoot |
	badRoot _ false.
	oop _ self firstObject.

	[oop < youngStart] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[fieldAddr _ oop + (self lastPointerOf: oop).
			[fieldAddr > oop] whileTrue:
				[fieldOop _ self longAt: fieldAddr.
				(fieldOop >= youngStart and: [(self isIntegerObject: fieldOop) not]) ifTrue:
					["fieldOop is a pointer to a young object"
					header _ self longAt: oop.
					(header bitAnd: RootBit) = 0
					ifTrue:
						["Forbidden: points to young obj but root bit not set."
						DoAssertionChecks ifTrue: [self error: 'root bit not set'].
						badRoot _ true]
					ifFalse:
						["Root bit is set"
						"Extreme test -- validate that oop was entered in rootTable too..."
						"Disabled for now...
						found _ false.
						1 to: rootTableCount do:
							[:i | oop = (rootTable at: i) ifTrue: [found _ true]].
						found ifFalse:
							[DoAssertionChecks ifTrue: [self error: 'root table not set'].
							badRoot _ true].
						..."
						]].
				fieldAddr _ fieldAddr - BytesPerWord]].
		oop _ self objectAfter: oop].
	^ badRoot! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 6/9/2004 23:16'!
fetchByte: byteIndex ofObject: oop

	^ self byteAt: oop + BaseHeaderSize + byteIndex! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 7/4/2004 08:34'!
fetchLong32: fieldIndex ofObject: oop
	"index by 32-bit units, and return a 32-bit value"

	^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 7/4/2004 11:11'!
fetchLong32LengthOf: objectPointer
	"Gives size appropriate for, eg, fetchLong32"

	| sz |
	sz _ self sizeBitsOf: objectPointer.
	^ (sz - BaseHeaderSize) >> 2! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 7/4/2004 08:33'!
fetchPointer: fieldIndex ofObject: oop
	"index by word size, and return a pointer as long as the word size"

	^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 8/2/2004 17:33'!
fetchWord: fieldIndex ofObject: oop
	"This message is deprecated.  Use fetchLong32, fetchLong64 or fetchPointer"

	self error: 'deprecated -- do not use -- and then delete me'! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 7/4/2004 09:34'!
fetchWordLengthOf: objectPointer
	"NOTE: this gives size appropriate for fetchPointer: n, but not in general for, eg, fetchLong32, etc."

	| sz |
	sz _ self sizeBitsOf: objectPointer.
	^ (sz - BaseHeaderSize) >> ShiftForWord! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 3/27/2005 18:07'!
instantiateClass: classPointer indexableSize: size 
	"NOTE: This method supports the backward-compatible split instSize field of the 
	class format word. The sizeHiBits will go away and other shifts change by 2 
	when the split fields get merged in an (incompatible) image change."

	| hash header1 header2 cClass byteSize format binc header3 hdrSize fillWord newObj sizeHiBits bm1 classFormat |
	self inline: false.
	DoAssertionChecks ifTrue: [size < 0
				ifTrue: [self error: 'cannot have a negative indexable field count']].
	hash _ self newObjectHash.
	classFormat _ self formatOfClass: classPointer.
	"Low 2 bits are 0"
	header1 _ (classFormat bitAnd: 16r1FF00) bitOr: (hash << HashBitsOffset bitAnd: HashBits).
	header2 _ classPointer.
	header3 _ 0.
	sizeHiBits _ (classFormat bitAnd: 16r60000) >> 9.
	cClass _ header1 bitAnd: CompactClassMask. "compact class field from format word"
	byteSize _ (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits.
		"size in bytes -- low 2 bits are 0"
	"Note this byteSize comes from the format word of the class which is pre-shifted
		to 4 bytes per field.  Need another shift for 8 bytes per word..."
	byteSize _ byteSize << (ShiftForWord-2).
	format _ classFormat >> 8 bitAnd: 15.
	self flag: #sizeLowBits.
	format < 8
		ifTrue:
			[format = 6
				ifTrue: ["long32 bitmaps"
					bm1 _ BytesPerWord-1.
					byteSize _ byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up"
					binc _ bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes"
					"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
					header1 _ header1 bitOr: (binc bitAnd: 4)]
				ifFalse: [byteSize _ byteSize + (size * BytesPerWord) "Arrays and 64-bit bitmaps"]
			]
		ifFalse:
			["Strings and Methods"
			bm1 _ BytesPerWord-1.
			byteSize _ byteSize + size + bm1 bitAnd: LongSizeMask. "round up"
			binc _ bm1 - (size + bm1 bitAnd: bm1). "odd bytes"
			"low bits of byte size go in format field"
			header1 _ header1 bitOr: (binc bitAnd: 3) << 8.
			"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
			header1 _ header1 bitOr: (binc bitAnd: 4)].
	byteSize > 255
		ifTrue: ["requires size header word"
			header3 _ byteSize.
			header1 _ header1]
		ifFalse: [header1 _ header1 bitOr: byteSize].
	header3 > 0
		ifTrue: ["requires full header"
			hdrSize _ 3]
		ifFalse: [cClass = 0
				ifTrue: [hdrSize _ 2]
				ifFalse: [hdrSize _ 1]].
	format <= 4
		ifTrue: ["if pointers, fill with nil oop"
			fillWord _ nilObj]
		ifFalse: [fillWord _ 0].
	newObj _ self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true with: fillWord.
	^ newObj! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 7/7/2004 16:46'!
instantiateContext: classPointer sizeInBytes: sizeInBytes 
	"This version of instantiateClass assumes that the total object 
	size is under 256 bytes, the limit for objects with only one or 
	two header words. Note that the size is specified in bytes 
	and should include four bytes for the base header word."
	| hash header1 header2 hdrSize |
	hash _ self newObjectHash.
	header1 _ (hash << HashBitsOffset bitAnd: HashBits) bitOr: (self formatOfClass: classPointer).
	header2 _ classPointer.
	(header1 bitAnd: CompactClassMask) > 0 "are contexts compact?"
		ifTrue: [hdrSize _ 1]
		ifFalse: [hdrSize _ 2].
	sizeInBytes <= SizeMask
		ifTrue: ["OR size into header1.  Must not do this if size > SizeMask"
				header1 _ header1 + (sizeInBytes - (header1 bitAnd: SizeMask))]
		ifFalse: [hdrSize _ 3.
				"Zero the size field of header1 if large"
				header1 _ header1 - (header1 bitAnd: SizeMask)].
self flag: #Dan.  "Check details of context sizes"
	^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: LargeContextSize doFill: false with: 0! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 8/2/2004 17:04'!
instantiateSmallClass: classPointer sizeInBytes: sizeInBytes fill: fillValue 
	"This version of instantiateClass assumes that the total object 
	size is under 256 bytes, the limit for objects with only one or 
	two header words. Note that the size is specified in bytes 
	and should include 4 or 8 bytes for the base header word. 
	NOTE this code will only work for sizes that are an integral number of words
		(like not a 32-bit LargeInteger in a 64-bit system). 
	May cause a GC"

	| hash header1 header2 hdrSize |
	(sizeInBytes bitAnd: (BytesPerWord-1)) = 0 ifFalse:
		[self error: 'size must be integral number of words'].
	hash _ self newObjectHash.
	header1 _ (hash << HashBitsOffset bitAnd: HashBits) bitOr: (self formatOfClass: classPointer).
	header2 _ classPointer.
	(header1 bitAnd: CompactClassMask) > 0 "is this a compact class"
		ifTrue: [hdrSize _ 1]
		ifFalse: [hdrSize _ 2].
	header1 _ header1 + (sizeInBytes - (header1 bitAnd: SizeMask+Size4Bit)).
	^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: true with: fillValue! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 8/4/2004 15:32'!
integerObjectOf: value

	^(value << 1) + 1! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 8/4/2004 15:29'!
isIntegerValue: valueWord 
	^ valueWord >= 16r-40000000 and: [valueWord <= 16r3FFFFFFF]! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 6/9/2004 23:16'!
storeByte: byteIndex ofObject: oop withValue: valueByte

	^ self byteAt: oop + BaseHeaderSize + byteIndex
		put: valueByte! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 7/4/2004 08:48'!
storeLong32: fieldIndex ofObject: oop withValue: valueWord

	^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)
		put: valueWord! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 6/23/2004 13:49'!
storePointer: fieldIndex ofObject: oop withValue: valuePointer
	"Note must check here for stores of young objects into old ones."

	(oop < youngStart) ifTrue: [
		self possibleRootStoreInto: oop value: valuePointer.
	].

	^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)
		put: valuePointer! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 6/23/2004 13:49'!
storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
	"Like storePointer:ofObject:withValue:, but the caller guarantees that the object being stored into is a young object or is already marked as a root."

	^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)
			put: valuePointer
! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'ikp 3/26/2005 14:29'!
storeWord: fieldIndex ofObject: oop withValue: valueWord
	"This message is deprecated.  Use storeLong32, storeLong64 or storePointer"

	self abort! !


!Interpreter methodsFor: 'message sending' stamp: 'di 6/15/2004 23:34'!
activateNewMethod
	| newContext methodHeader initialIP tempCount nilOop where |

	methodHeader _ self headerOf: newMethod.
	newContext _ self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).

	initialIP _ ((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerWord) + 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 _  newContext  + BaseHeaderSize.
	self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
	self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP).
	self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
	self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.

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

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

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

!Interpreter methodsFor: 'message sending' stamp: 'di 6/14/2004 16:50'!
createActualMessageTo: aClass 
	"Bundle up the selector, arguments and lookupClass into a Message object. 
	In the process it pops the arguments off the stack, and pushes the message object. 
	This can then be presented as the argument of e.g. #doesNotUnderstand:. 
	ikp 11/20/1999 03:59 -- added hook for external runtime compilers."
	"remap lookupClass in case GC happens during allocation"
	| argumentArray message lookupClass |
	self pushRemappableOop: aClass.
	argumentArray _ self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
	"remap argumentArray in case GC happens during allocation"
	self pushRemappableOop: argumentArray.
	message _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
	argumentArray _ self popRemappableOop.
	lookupClass _ self popRemappableOop.
	self beRootIfOld: argumentArray.

	compilerInitialized
		ifTrue: [self compilerCreateActualMessage: message storingArgs: argumentArray]
		ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * BytesPerWord) to: argumentArray + BaseHeaderSize.
			self pop: argumentCount thenPush: message].

	argumentCount _ 1.
	self storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector.
	self storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray.
	(self lastPointerOf: message) >= (MessageLookupClassIndex * BytesPerWord + BaseHeaderSize)
		ifTrue: ["Only store lookupClass if message has 3 fields (old images don't)"
			self storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]! !

!Interpreter methodsFor: 'message sending' stamp: 'di 6/14/2004 16:53'!
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 _   newContext + BaseHeaderSize.
	self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
	self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf:
			(((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerWord) + 1)).
	self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
	self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.

	"Copy the reciever and arguments..."
	argCount2 _ argumentCount.
	0 to: argCount2 do:
		[:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) 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 << ShiftForWord) put: methodHeader].

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

!Interpreter methodsFor: 'message sending' stamp: 'ikp 6/10/2004 14:10'!
primitiveCalloutToFFI
	"Perform a function call to a foreign function.
	Only invoked from method containing explicit external call spec.
	Due to this we use the pluggable prim mechanism explicitly here
	(the first literal of any FFI spec'ed method is an ExternalFunction
	and not an array as used in the pluggable primitive mechanism)."

	| function moduleName functionName |
	self var: #function declareC: 'static void *function = 0'.
	self var: #moduleName declareC: 'static char *moduleName = "SqueakFFIPrims"'.
	self var: #functionName declareC: 'static char *functionName = "primitiveCallout"'.
	function = 0 ifTrue: [
		function _ self
			ioLoadExternalFunction: (self oopForPointer: functionName)
			OfLength: 16
			FromModule: (self oopForPointer: moduleName)
			OfLength: 14.
		function == 0 ifTrue: [^self primitiveFail]].
	^self cCode: '((sqInt (*)(void))function)()'.
! !

!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp 3/26/2005 13:35'!
addNewMethodToCache
	"Add the given entry to the method cache.
	The policy is as follows:
		Look for an empty entry anywhere in the reprobe chain.
		If found, install the new entry there.
		If not found, then install the new entry at the first probe position
			and delete the entries in the rest of the reprobe chain.
		This has two useful purposes:
			If there is active contention over the first slot, the second
				or third will likely be free for reentry after ejection.
			Also, flushing is good when reprobe chains are getting full."
	| probe hash |
	self inline: false.
	self compilerTranslateMethodHook.	"newMethod x lkupClass -> newNativeMethod (may cause GC !!)"
	hash _ messageSelector bitXor: lkupClass.  "drop low-order zeros from addresses"

	primitiveFunctionPointer _ self functionPointerFor: primitiveIndex inClass: lkupClass.
	
	0 to: CacheProbeMax-1 do:
		[:p | probe _ (hash >> p) bitAnd: MethodCacheMask.
		(methodCache at: probe + MethodCacheSelector) = 0 ifTrue:
			["Found an empty entry -- use it"
			methodCache at: probe + MethodCacheSelector put: messageSelector.
			methodCache at: probe + MethodCacheClass put: lkupClass.
			methodCache at: probe + MethodCacheMethod put: newMethod.
			methodCache at: probe + MethodCachePrim put: primitiveIndex.
			methodCache at: probe + MethodCacheNative put: newNativeMethod.
			methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').
			^ nil]].

	"OK, we failed to find an entry -- install at the first slot..."
	probe _ hash bitAnd: MethodCacheMask.  "first probe"
	methodCache at: probe + MethodCacheSelector put: messageSelector.
	methodCache at: probe + MethodCacheClass put: lkupClass.
	methodCache at: probe + MethodCacheMethod put: newMethod.
	methodCache at: probe + MethodCachePrim put: primitiveIndex.
	methodCache at: probe + MethodCacheNative put: newNativeMethod.
	methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').

	"...and zap the following entries"
	1 to: CacheProbeMax-1 do:
		[:p | probe _ (hash >> p) bitAnd: MethodCacheMask.
		methodCache at: probe + MethodCacheSelector put: 0].
! !

!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp 8/2/2004 17:54'!
functionPointerFor: primIdx inClass: theClass
	"Find an actual function pointer for this primitiveIndex.  This is an
	opportunity to specialise the prim for the relevant class (format for
	example).  Default for now is simply the entry in the base primitiveTable."

	self returnTypeC: 'void *'.
	^primitiveTable at: primIdx! !

!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp 3/26/2005 13:36'!
lookupInMethodCacheSel: selector class: class
	"This method implements a simple method lookup cache. If an entry for the given selector and class is found in the cache, set the values of 'newMethod' and 'primitiveIndex' and return true. Otherwise, return false."
	"About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe, introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up."
	"WARNING: Since the hash computation is based on the object addresses of the class and selector, we must rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating the addresses of the objects in the cache."

	| hash probe |
	self inline: true.
	hash _ selector bitXor: class.  "shift drops two low-order zeros from addresses"

	probe _ hash bitAnd: MethodCacheMask.  "first probe"
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod _ methodCache at: probe + MethodCacheMethod.
			primitiveIndex _ methodCache at: probe + MethodCachePrim.
			newNativeMethod _ methodCache at: probe + MethodCacheNative.
			primitiveFunctionPointer _ self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void *'.
			^ true	"found entry in cache; done"].

	probe _ (hash >> 1) bitAnd: MethodCacheMask.  "second probe"
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod _ methodCache at: probe + MethodCacheMethod.
			primitiveIndex _ methodCache at: probe + MethodCachePrim.
			newNativeMethod _ methodCache at: probe + MethodCacheNative.
			primitiveFunctionPointer _ self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void *'.
			^ true	"found entry in cache; done"].

	probe _ (hash >> 2) bitAnd: MethodCacheMask.
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod _ methodCache at: probe + MethodCacheMethod.
			primitiveIndex _ methodCache at: probe + MethodCachePrim.
			newNativeMethod _ methodCache at: probe + MethodCacheNative.
			primitiveFunctionPointer _ self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void *'.
			^ true	"found entry in cache; done"].

	^ false
! !

!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp 3/26/2005 14:24'!
rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex

	"Rewrite the cache entry with the given primitive index and matching function pointer"
	| primPtr |
	self var: #primPtr type: 'void *'.
	self inline: false.
	localPrimIndex = 0
		ifTrue: [primPtr _ 0]
		ifFalse: [primPtr _ primitiveTable at: localPrimIndex].
	self
		rewriteMethodCacheSel: selector class: class
		primIndex: localPrimIndex primFunction: primPtr! !

!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp 3/26/2005 14:24'!
rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex primFunction: localPrimAddress
	"Rewrite an existing entry in the method cache with a new primitive 
	index & function address. Used by primExternalCall to make direct jumps to found external prims"
	| probe hash |
	self inline: false.
	self var: #localPrimAddress type: 'void *'.
	hash := selector bitXor: class.
	0 to: CacheProbeMax - 1 do: [:p | 
			probe := hash >> p bitAnd: MethodCacheMask.
			((methodCache at: probe + MethodCacheSelector) = selector
					and: [(methodCache at: probe + MethodCacheClass) = class])
				ifTrue: [methodCache at: probe + MethodCachePrim put: localPrimIndex.
					methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: localPrimAddress to: 'long').
					^ nil]]! !

!Interpreter methodsFor: 'plugin primitive support' stamp: 'ikp 8/2/2004 17:47'!
callExternalPrimitive: functionID
	"Call the external plugin function identified. In the VM this is an address, see 	InterpreterSimulator for it's version. dispatch... is a macro in the VM C code."

	self var: #functionID type: 'void *'.
	self dispatchFunctionPointer: functionID! !

!Interpreter methodsFor: 'plugin primitive support' stamp: 'ikp 8/3/2004 18:16'!
classNameOf: aClass Is: className 
	"Check if aClass's name is className"
	| srcName name length |
	self var: #className declareC: 'char *className'.
	self var: #srcName declareC: 'char *srcName'.
	(self lengthOf: aClass) <= 6 ifTrue: [^ false].

	"Not a class but might be behavior"
	name _ self fetchPointer: 6 ofObject: aClass.
	(self isBytes: name) ifFalse: [^ false].
	length _ self stSizeOf: name.
	srcName _ self cCoerce: (self arrayValueOf: name) to: 'char *'.
	0 to: length - 1 do: [:i | (srcName at: i) = (className at: i) ifFalse: [^ false]].
	"Check if className really ends at this point"
	^ (className at: length) = 0! !

!Interpreter methodsFor: 'plugin primitive support' stamp: 'di 7/4/2004 08:51'!
flushExternalPrimitiveOf: methodPtr
	"methodPtr is a CompiledMethod containing an external primitive. Flush the function address and session ID of the CM"
	| lit |
	(self literalCountOf: methodPtr) > 0 ifFalse:[^nil]. "Something's broken"
	lit _ self literal: 0 ofMethod: methodPtr.
	((self isArray: lit) and:[(self lengthOf: lit) = 4])
		ifFalse:[^nil]. "Something's broken"
	self storePointer: 2 ofObject: lit withValue: ConstZero.
	self storePointer: 3 ofObject: lit withValue: ConstZero.
! !

!Interpreter methodsFor: 'debug support' stamp: 'di 6/14/2004 17:52'!
balancedStack: delta afterPrimitive: primIdx withArgs: nArgs
	"Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)"
	(primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true].
	"81-88 are control primitives after which the stack may look unbalanced"
	successFlag ifTrue:[
		"Successful prim, stack must have exactly nArgs arguments popped off"
		^(stackPointer - activeContext + (nArgs * BytesPerWord)) = delta
	].
	"Failed prim must leave stack intact"
	^(stackPointer - activeContext) = delta
! !

!Interpreter methodsFor: 'debug support' stamp: 'ikp 3/26/2005 21:05'!
okayOop: signedOop
	"Verify that the given oop is legitimate. Check address, header, and size but not class."

	| sz type fmt unusedBit oop |
	self var: #oop type: 'usqInt'.
	oop := self cCoerce: signedOop to: 'usqInt'.

	"address and size checks"
	(self isIntegerObject: oop) ifTrue: [ ^true ].
	(oop < endOfMemory)
		ifFalse: [ self error: 'oop is not a valid address' ].
	((oop \\ BytesPerWord) = 0)
		ifFalse: [ self error: 'oop is not a word-aligned address' ].
	sz _ self sizeBitsOf: oop.
	(oop + sz) < endOfMemory
		ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ].

	"header type checks"
	type _ self headerType: oop.
	type = HeaderTypeFree
		ifTrue:  [ self error: 'oop is a free chunk, not an object' ].
	type = HeaderTypeShort ifTrue: [
		(((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0
			ifTrue:  [ self error: 'cannot have zero compact class field in a short header' ].
	].
	type = HeaderTypeClass ifTrue: [
		((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
			ifFalse: [ self error: 'class header word has wrong type' ].
	].
	type = HeaderTypeSizeAndClass ifTrue: [
		((oop >= (BytesPerWord*2)) and:
		 [(self headerType: oop - (BytesPerWord*2)) = type and:
		 [(self headerType: oop - BytesPerWord) = type]])
			ifFalse: [ self error: 'class header word has wrong type' ].
	].

	"format check"
	fmt _ self formatOf: oop.
	((fmt = 5) | (fmt = 7))
		ifTrue:  [ self error: 'oop has an unknown format type' ].

	"mark and root bit checks"
	unusedBit _ 16r20000000.
	BytesPerWord = 8
		ifTrue:
			[unusedBit _ unusedBit << 16.
			 unusedBit _ unusedBit << 16].
	((self longAt: oop) bitAnd: unusedBit) = 0
		ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ].
"xxx
	((self longAt: oop) bitAnd: MarkBit) = 0
		ifFalse: [ self error: 'mark bit should not be set except during GC' ].
xxx"
	(((self longAt: oop) bitAnd: RootBit) = 1 and:
	 [oop >= youngStart])
		ifTrue: [ self error: 'root bit is set in a young object' ].
	^true
! !

!Interpreter methodsFor: 'debug support' stamp: 'ikp 3/26/2005 21:06'!
oopHasOkayClass: signedOop
	"Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."

	| oop oopClass formatMask behaviorFormatBits oopFormatBits |
	self var: #oop type: 'usqInt'.
	self var: #oopClass type: 'usqInt'.

	oop := self cCoerce: signedOop to: 'usqInt'.
	self okayOop: oop.
	oopClass := self cCoerce: (self fetchClassOf: oop) to: 'usqInt'.

	(self isIntegerObject: oopClass)
		ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ].
	self okayOop: oopClass.
	((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3])
		ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ].
	(self isBytes: oop)
		ifTrue: [ formatMask _ 16rC00 ]  "ignore extra bytes size bits"
		ifFalse: [ formatMask _ 16rF00 ].

	behaviorFormatBits _ (self formatOfClass: oopClass) bitAnd: formatMask.
	oopFormatBits _ (self baseHeader: oop) bitAnd: formatMask.
	behaviorFormatBits = oopFormatBits
		ifFalse: [ self error: 'object and its class (behavior) formats differ' ].
	^true! !

!Interpreter methodsFor: 'utilities' stamp: 'di 6/23/2004 12:24'!
arrayValueOf: arrayOop
	"Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
	"Note: May be called by translated primitive code."

	self returnTypeC: 'void *'.
	((self isIntegerObject: arrayOop) not and:
	 [self isWordsOrBytes: arrayOop])
		ifTrue: [^ self cCode: '(void *)pointerForOop(arrayOop + BaseHeaderSize)'].
	self primitiveFail.
! !

!Interpreter methodsFor: 'utilities' stamp: 'ikp 6/10/2004 11:08'!
externalizeIPandSP
	"Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop."

	instructionPointer _ self oopForPointer: localIP.
	stackPointer _ self oopForPointer: localSP.
	theHomeContext _ localHomeContext.
! !

!Interpreter methodsFor: 'utilities' stamp: 'ikp 8/4/2004 11:42'!
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
	"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
	"Note: May be called by translated primitive code."

	| intOrFloat floatVal frac trunc |
	self inline: false.
	self var: #floatVal declareC: 'double floatVal'.
	self var: #frac declareC: 'double frac'.
	self var: #trunc declareC: 'double trunc'.

	intOrFloat _ self fetchPointer: fieldIndex ofObject: objectPointer.
	(self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
	self assertClassOf: intOrFloat is: (self splObj: ClassFloat).
	successFlag ifTrue: [
		self cCode: '' inSmalltalk: [floatVal _ Float new: 2].
		self fetchFloatAt: intOrFloat + BaseHeaderSize into: floatVal.
		self cCode: 'frac = modf(floatVal, &trunc)'.
		"the following range check is for C ints, with range -2^31..2^31-1"
		self flag: #Dan.		"The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
		self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.].
	successFlag
		ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]]
		ifFalse: [^ 0].
! !

!Interpreter methodsFor: 'utilities' stamp: 'di 6/14/2004 17:48'!
floatValueOf: oop
	"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
	"Note: May be called by translated primitive code."

	| result |
	self flag: #Dan.  "None of the float stuff has been converted for 64 bits"
	self returnTypeC: 'double'.
	self var: #result declareC: 'double result'.
	self assertClassOf: oop is: (self splObj: ClassFloat).
	successFlag
		ifTrue: [self cCode: '' inSmalltalk: [result _ Float new: 2].
				self fetchFloatAt: oop + BaseHeaderSize into: result]
		ifFalse: [result _ 0.0].
	^ result! !

!Interpreter methodsFor: 'utilities' stamp: 'ikp 6/10/2004 11:08'!
internalizeIPandSP
	"Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop."

	localIP _ self pointerForOop: instructionPointer.
	localSP _ self pointerForOop: stackPointer.
	localHomeContext _ theHomeContext.
! !

!Interpreter methodsFor: 'utilities' stamp: 'di 6/14/2004 17:49'!
makePointwithxValue: xValue yValue: yValue

	| pointResult |
	pointResult _ self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3*BytesPerWord fill: nilObj.
	self storePointer: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue).
	self storePointer: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue).
	^ pointResult! !

!Interpreter methodsFor: 'utilities' stamp: 'ikp 6/10/2004 14:23'!
sizeOfSTArrayFromCPrimitive: cPtr
	"Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
	"Note: Only called by translated primitive code."

	| oop |
	self var: #cPtr declareC: 'void *cPtr'.
	oop _ (self oopForPointer: cPtr) - BaseHeaderSize.
	(self isWordsOrBytes: oop) ifFalse: [
		self primitiveFail.
		^0].
	^self lengthOf: oop
! !

!Interpreter methodsFor: 'utilities' stamp: 'di 7/4/2004 08:59'!
storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue 
	"Note: May be called by translated primitive code."
	(self isIntegerValue: integerValue)
		ifTrue: [self storePointer: fieldIndex ofObject: objectPointer
					withValue: (self integerObjectOf: integerValue)]
		ifFalse: [self primitiveFail]! !

!Interpreter methodsFor: 'utilities' stamp: 'di 8/3/2004 14:33'!
transfer: count from: src to: dst 
	| in out lastIn |
	self flag: #Dan.  "Need to check all senders before converting this for 64 bits"
	self inline: true.
	in _ src - BytesPerWord.
	lastIn _ in + (count * BytesPerWord).
	out _ dst - BytesPerWord.
	[in < lastIn]
		whileTrue: [self
				longAt: (out _ out + BytesPerWord)
				put: (self longAt: (in _ in + BytesPerWord))]! !

!Interpreter methodsFor: 'utilities' stamp: 'di 6/15/2004 22:55'!
transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop
	"Transfer the specified fullword fields, as from calling context to called context"
	
	"Assume: beRootIfOld: will be called on toOop."
	| fromIndex toIndex lastFrom |
	self flag: #Dan.  "Need to check all senders before converting this for 64 bits"
	self inline: true.
	fromIndex _ fromOop + (firstFrom * BytesPerWord).
	toIndex _ toOop + (firstTo * BytesPerWord).
	lastFrom _ fromIndex + (count * BytesPerWord).
	[fromIndex < lastFrom]
		whileTrue: [fromIndex _ fromIndex + BytesPerWord.
			toIndex _ toIndex + BytesPerWord.
			self
				longAt: toIndex
				put: (self longAt: fromIndex)]! !

!Interpreter methodsFor: 'compiled methods' stamp: 'di 6/14/2004 17:02'!
primitiveNewMethod
	| header bytecodeCount class size theMethod literalCount |
	header _ self popStack.
	bytecodeCount _ self popInteger.
	self success: (self isIntegerObject: header).
	successFlag ifFalse: [self unPop: 2].
	class _ self popStack.
	size _ (self literalCountOfHeader: header) + 1 * BytesPerWord + bytecodeCount.
	theMethod _ self instantiateClass: class indexableSize: size.
	self storePointer: HeaderIndex ofObject: theMethod withValue: header.
	literalCount _ self literalCountOfHeader: header.
	1 to: literalCount do:
		[:i | self storePointer: i ofObject: theMethod withValue: nilObj].
	self push: theMethod! !

!Interpreter methodsFor: 'compiled methods' stamp: 'di 7/19/2004 14:59'!
tempCountOf: methodPointer
	^ ((self headerOf: methodPointer) >> 19) bitAnd: 16r3F! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 14:05'!
fetchContextRegisters: activeCntx 
	"Note: internalFetchContextRegisters: should track changes  to this method."
	| tmp |
	self inline: true.
	tmp _ self fetchPointer: MethodIndex ofObject: activeCntx.
	(self isIntegerObject: tmp)
		ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
			tmp _ self fetchPointer: HomeIndex ofObject: activeCntx.
			tmp < youngStart ifTrue: [self beRootIfOld: tmp]]
		ifFalse: ["otherwise, it is a method context and is its own home context "
			tmp _ activeCntx].
	theHomeContext _ tmp.
	receiver _ self fetchPointer: ReceiverIndex ofObject: tmp.
	method _ self fetchPointer: MethodIndex ofObject: tmp.

	"the instruction pointer is a pointer variable equal to 
	method oop + ip + BaseHeaderSize 
	-1 for 0-based addressing of fetchByte 
	-1 because it gets incremented BEFORE fetching currentByte "
	tmp _ self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
	instructionPointer _ method + tmp + BaseHeaderSize - 2.

	"the stack pointer is a pointer variable also..."
	tmp _ self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
	stackPointer _ activeCntx + BaseHeaderSize + (TempFrameStart + tmp - 1 * BytesPerWord)! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/23/2004 12:33'!
internalFetchContextRegisters: activeCntx
	"Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."

	| tmp |
	self inline: true.
	tmp _ self fetchPointer: MethodIndex ofObject: activeCntx.
	(self isIntegerObject: tmp) ifTrue: [
		"if the MethodIndex field is an integer, activeCntx is a block context"
		tmp _ self fetchPointer: HomeIndex ofObject: activeCntx.
		(tmp < youngStart) ifTrue: [ self beRootIfOld: tmp ].
	] ifFalse: [
		"otherwise, it is a method context and is its own home context"
		tmp _ activeCntx.
	].
	localHomeContext _ tmp.
	receiver _ self fetchPointer: ReceiverIndex ofObject: tmp.
	method _ self fetchPointer: MethodIndex ofObject: tmp.

	"the instruction pointer is a pointer variable equal to
		method oop + ip + BaseHeaderSize
		  -1 for 0-based addressing of fetchByte
		  -1 because it gets incremented BEFORE fetching currentByte"
	tmp _ self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
	localIP _ self pointerForOop: method + tmp + BaseHeaderSize - 2.

	"the stack pointer is a pointer variable also..."
	tmp _ self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
	localSP _ self pointerForOop: activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * BytesPerWord)! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:32'!
internalPop: nItems

	localSP _ localSP - (nItems * BytesPerWord).! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/23/2004 13:40'!
internalPop: nItems thenPush: oop

	self longAtPointer: (localSP _ localSP - ((nItems - 1) * BytesPerWord)) put: oop.
! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/23/2004 13:40'!
internalPush: object

	self longAtPointer: (localSP _ localSP + BytesPerWord) put: object.! !

!Interpreter methodsFor: 'contexts' stamp: 'ikp 6/10/2004 11:16'!
internalStackTop

	^ self longAtPointer: localSP! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/23/2004 13:40'!
internalStackValue: offset

	^ self longAtPointer: localSP - (offset * BytesPerWord)! !

!Interpreter methodsFor: 'contexts' stamp: 'di 7/4/2004 08:56'!
internalStoreContextRegisters: activeCntx
	"The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."

	"InstructionPointer is a pointer variable equal to
	method oop + ip + BaseHeaderSize
		-1 for 0-based addressing of fetchByte
		-1 because it gets incremented BEFORE fetching currentByte"

	self inline: true.
	self storePointer: InstructionPointerIndex ofObject: activeCntx
		withValue: (self integerObjectOf: 
			((self oopForPointer: localIP) + 2 - (method + BaseHeaderSize))).
	self storePointer: StackPointerIndex		  ofObject: activeCntx
		withValue: (self integerObjectOf:
			((((self oopForPointer: localSP) - (activeCntx + BaseHeaderSize)) >> ShiftForWord) - TempFrameStart + 1)).
! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:33'!
pop: nItems
	"Note: May be called by translated primitive code."

	stackPointer _ stackPointer - (nItems*BytesPerWord).! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:33'!
pop: nItems thenPush: oop

	| sp |
	self longAt: (sp _ stackPointer - ((nItems - 1) * BytesPerWord)) put: oop.
	stackPointer _ sp.
! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:34'!
popStack

	| top |
	top _ self longAt: stackPointer.
	stackPointer _ stackPointer - BytesPerWord.
	^ top! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:34'!
push: object

	| sp |
	self longAt: (sp _ stackPointer + BytesPerWord) put: object.
	stackPointer _ sp.! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:34'!
stackFloatValue: offset
	"Note: May be called by translated primitive code."
	| result floatPointer |
	self returnTypeC: 'double'.
	self var: #result declareC: 'double result'.
	floatPointer _ self longAt: stackPointer - (offset*BytesPerWord).
	(self fetchClassOf: floatPointer) = (self splObj: ClassFloat) 
		ifFalse:[self primitiveFail. ^0.0].
	self cCode: '' inSmalltalk: [result _ Float new: 2].
	self fetchFloatAt: floatPointer + BaseHeaderSize into: result.
	^ result! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:34'!
stackIntegerValue: offset
	| integerPointer |
	integerPointer _ self longAt: stackPointer - (offset*BytesPerWord).
	^self checkedIntegerValueOf: integerPointer! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:34'!
stackObjectValue: offset
	"Ensures that the given object is a real object, not a SmallInteger."

	| oop |
	oop _ self longAt: stackPointer - (offset * BytesPerWord).
	(self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
	^ oop
! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 14:14'!
stackPointerIndex
	"Return the 0-based index rel to the current context.
	(This is what stackPointer used to be before conversion to pointer"
	^ (stackPointer - activeContext - BaseHeaderSize) >> ShiftForWord! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:35'!
stackValue: offset
	^ self longAt: stackPointer - (offset*BytesPerWord)! !

!Interpreter methodsFor: 'contexts' stamp: 'di 7/4/2004 08:58'!
storeContextRegisters: activeCntx
	"Note: internalStoreContextRegisters: should track changes to this method."

	"InstructionPointer is a pointer variable equal to
	method oop + ip + BaseHeaderSize
		-1 for 0-based addressing of fetchByte
		-1 because it gets incremented BEFORE fetching currentByte"

	self inline: true.
	self storePointer: InstructionPointerIndex ofObject: activeCntx
		withValue: (self integerObjectOf: (instructionPointer - method - (BaseHeaderSize - 2))).
	self storePointer: StackPointerIndex ofObject: activeCntx
		withValue: (self integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
! !

!Interpreter methodsFor: 'contexts' stamp: 'di 7/4/2004 08:58'!
storeInstructionPointerValue: value inContext: contextPointer
	"Assume: value is an integerValue"

	self storePointer: InstructionPointerIndex ofObject: contextPointer withValue: (self integerObjectOf: value).! !

!Interpreter methodsFor: 'contexts' stamp: 'di 7/4/2004 08:59'!
storeStackPointerValue: value inContext: contextPointer
	"Assume: value is an integerValue"

	self storePointer: StackPointerIndex ofObject: contextPointer
		withValue: (self integerObjectOf: value).! !

!Interpreter methodsFor: 'contexts' stamp: 'di 6/14/2004 16:35'!
unPop: nItems
	stackPointer _ stackPointer + (nItems*BytesPerWord)! !

!Interpreter methodsFor: 'array and stream primitive support' stamp: 'ikp 8/4/2004 18:26'!
commonVariable: rcvr at: index cacheIndex: atIx 
	"This code assumes the reciever has been identified at location atIx in the atCache."
	| stSize fmt fixedFields result |

	stSize _ atCache at: atIx+AtCacheSize.
	((self cCoerce: index to: 'usqInt ') >= 1
		and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')])
	ifTrue:
		[fmt _ atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields _ atCache at: atIx+AtCacheFixedFields.
			^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr].
		fmt < 8 ifTrue:  "Bitmap"
			[result _ self fetchLong32: index - 1 ofObject: rcvr.
			result _ self positive32BitIntegerFor: result.
			^ result].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: "String"
			[^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)]
			ifFalse: "ByteArray"
			[^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]].

	self primitiveFail! !

!Interpreter methodsFor: 'array and stream primitive support' stamp: 'ikp 8/4/2004 18:27'!
commonVariable: rcvr at: index put: value cacheIndex: atIx
	"This code assumes the reciever has been identified at location atIx in the atCache."
	| stSize fmt fixedFields valToPut |
	self inline: true.

	stSize _ atCache at: atIx+AtCacheSize.
	((self cCoerce: index to: 'usqInt ') >= 1
		and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')])
	ifTrue:
		[fmt _ atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields _ atCache at: atIx+AtCacheFixedFields.
			^ self storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value].
		fmt < 8 ifTrue:  "Bitmap"
			[valToPut _ self positive32BitValueOf: value.
			successFlag ifTrue: [self storeLong32: index - 1 ofObject: rcvr withValue: valToPut].
			^ nil].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: [valToPut _ self asciiOfCharacter: value.
					successFlag ifFalse: [^ nil]]
			ifFalse: [valToPut _ value].
		(self isIntegerObject: valToPut) ifTrue:
			[valToPut _ self integerValueOf: valToPut.
			((valToPut >= 0) and: [valToPut <= 255]) ifFalse: [^ self primitiveFail].
			^ self storeByte: index - 1 ofObject: rcvr withValue: valToPut]].

	self primitiveFail! !

!Interpreter methodsFor: 'array and stream primitive support' stamp: 'ikp 8/4/2004 18:27'!
commonVariableInternal: rcvr at: index cacheIndex: atIx 
	"This code assumes the reciever has been identified at location atIx in the atCache."
	| stSize fmt fixedFields result |
	self inline: true.

	stSize _ atCache at: atIx+AtCacheSize.
	((self cCoerce: index to: 'usqInt ') >= 1
		and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')])
	ifTrue:
		[fmt _ atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields _ atCache at: atIx+AtCacheFixedFields.
			^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr].
		fmt < 8 ifTrue:  "Bitmap"
			[result _ self fetchLong32: index - 1 ofObject: rcvr.
			self externalizeIPandSP.
			result _ self positive32BitIntegerFor: result.
			self internalizeIPandSP.
			^ result].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: "String"
			[^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)]
			ifFalse: "ByteArray"
			[^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]].

	self primitiveFail! !

!Interpreter methodsFor: 'array and stream primitive support' stamp: 'di 7/4/2004 11:28'!
lengthOf: oop baseHeader: hdr format: fmt
	"Return the number of indexable bytes or words in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."

	| sz |
	self inline: true.
	(hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: LongSizeMask ]
		ifFalse: [ sz _ (hdr bitAnd: SizeMask)].
	sz _ sz - (hdr bitAnd: Size4Bit).
	fmt <= 4
		ifTrue: [ ^ (sz - BaseHeaderSize) >> ShiftForWord "words"].
	fmt < 8
		ifTrue: [ ^ (sz - BaseHeaderSize) >> 2 "32-bit longs"]
		ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3) "bytes"]! !

!Interpreter methodsFor: 'array and stream primitive support' stamp: 'ikp 8/4/2004 18:28'!
stObject: array at: index
	"Return what ST would return for <obj> at: index."

	| hdr fmt totalLength fixedFields stSize |
	self inline: false.
	hdr _ self baseHeader: array.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: array baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: array format: fmt length: totalLength.
	(fmt = 3 and: [self isContextHeader: hdr])
		ifTrue: [stSize _ self fetchStackPointerOf: array]
		ifFalse: [stSize _ totalLength - fixedFields].
	((self cCoerce: index to: 'usqInt ') >= 1
		and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')])
		ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt]
		ifFalse: [successFlag _ false.  ^ 0].! !

!Interpreter methodsFor: 'array and stream primitive support' stamp: 'ikp 8/4/2004 18:28'!
stObject: array at: index put: value
	"Do what ST would return for <obj> at: index put: value."
	| hdr fmt totalLength fixedFields stSize |
	self inline: false.
	hdr _ self baseHeader: array.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: array baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: array format: fmt length: totalLength.
	(fmt = 3 and: [self isContextHeader: hdr])
		ifTrue: [stSize _ self fetchStackPointerOf: array]
		ifFalse: [stSize _ totalLength - fixedFields].
	((self cCoerce: index to: 'usqInt ') >= 1
		and: [(self cCoerce: index to: 'usqInt ') <= (self cCoerce: stSize to: 'usqInt ')])
		ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
		ifFalse: [successFlag _ false]! !

!Interpreter methodsFor: 'array and stream primitive support' stamp: 'di 7/4/2004 08:43'!
subscript: array with: index format: fmt
	"Note: This method assumes that the index is within bounds!!"

	self inline: true.
	fmt <= 4 ifTrue: [  "pointer type objects"
		^ self fetchPointer: index - 1 ofObject: array].
	fmt < 8 ifTrue: [  "long-word type objects"
		^ self positive32BitIntegerFor:
			(self fetchLong32: index - 1 ofObject: array)
	] ifFalse: [  "byte-type objects"
		^ self integerObjectOf:
			(self fetchByte: index - 1 ofObject: array)
	].! !

!Interpreter methodsFor: 'array and stream primitive support' stamp: 'di 7/4/2004 09:00'!
subscript: array with: index storing: oopToStore format: fmt 
	"Note: This method assumes that the index is within bounds!!"
	| valueToStore |
	self inline: true.
	fmt <= 4
		ifTrue: ["pointer type objects"
			self storePointer: index - 1 ofObject: array
				withValue: oopToStore]
		ifFalse: [fmt < 8
				ifTrue: ["long-word type objects"
					valueToStore _ self positive32BitValueOf: oopToStore.
					successFlag
						ifTrue: [self storeLong32: index - 1 ofObject: array
									withValue: valueToStore]]
				ifFalse: ["byte-type objects"
					(self isIntegerObject: oopToStore)
						ifFalse: [successFlag _ false].
					valueToStore _ self integerValueOf: oopToStore.
					(valueToStore >= 0
							and: [valueToStore <= 255])
						ifFalse: [successFlag _ false].
					successFlag
						ifTrue: [self
								storeByte: index - 1
								ofObject: array
								withValue: valueToStore]]]! !

!Interpreter methodsFor: 'object format' stamp: 'di 6/14/2004 16:37'!
byteSizeOf: oop
	| slots |
self flag: #Dan.
	(self isIntegerObject: oop) ifTrue:[^0].
	slots _ self slotSizeOf: oop.
	(self isBytesNonInt: oop)
		ifTrue:[^slots]
		ifFalse:[^slots * 4]! !

!Interpreter methodsFor: 'object format' stamp: 'di 7/4/2004 13:33'!
floatObjectOf: aFloat
	| newFloatObj |
self flag: #Dan.
	self var: #aFloat declareC: 'double aFloat'.
	newFloatObj _ self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8+BaseHeaderSize fill: 0.
	self storeFloatAt: newFloatObj + BaseHeaderSize from: aFloat.
	^ newFloatObj.
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 8/4/2004 17:28'!
byteSwapByteObjectsFrom: startOop to: stopAddr 
	"Byte-swap the words of all bytes objects in a range of the 
	image, including Strings, ByteArrays, and CompiledMethods. 
	This returns these objects to their original byte ordering 
	after blindly byte-swapping the entire image. For compiled 
	methods, byte-swap only their bytecodes part."
	| oop fmt wordAddr methodHeader |
	oop _ startOop.
	[oop < stopAddr]
		whileTrue: [(self isFreeObject: oop)
				ifFalse: [fmt _ self formatOf: oop.
					fmt >= 8
						ifTrue: ["oop contains bytes"
							wordAddr _ oop + BaseHeaderSize.
							fmt >= 12
								ifTrue: ["compiled method; start after methodHeader and literals"
									methodHeader _ self longAt: oop + BaseHeaderSize.
									wordAddr _ wordAddr + BytesPerWord + ((methodHeader >> 10 bitAnd: 255) * BytesPerWord)].
							self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop)].
					(fmt = 6 and: [BytesPerWord = 8])
						ifTrue: ["Object contains 32-bit half-words packed into 64-bit machine words."
							wordAddr _ oop + BaseHeaderSize.
							self reverseWordsFrom: wordAddr to: oop + (self sizeBitsOf: oop)]].
			oop _ self objectAfter: oop]! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 9/22/2004 12:01'!
byteSwapped: w
	"Answer the given integer with its bytes in the reverse order."

	BytesPerWord = 4
		ifTrue:
			[^ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte0Mask)
			 + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte1Mask)
			 + ((w bitShift: Byte1Shift         ) bitAnd: Byte2Mask)
			 + ((w bitShift: Byte3Shift         ) bitAnd: Byte3Mask)]
		ifFalse:
			[^ ((w bitShift: Byte7ShiftNegated) bitAnd: Byte0Mask)
			 + ((w bitShift: Byte5ShiftNegated) bitAnd: Byte1Mask)
			 + ((w bitShift: Byte3ShiftNegated) bitAnd: Byte2Mask)
			 + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte3Mask)
			 + ((w bitShift: Byte1Shift         ) bitAnd: Byte4Mask)
			 + ((w bitShift: Byte3Shift         ) bitAnd: Byte5Mask)
			 + ((w bitShift: Byte5Shift         ) bitAnd: Byte6Mask)
			 + ((w bitShift: Byte7Shift         ) bitAnd: Byte7Mask)]! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 8/3/2004 19:49'!
checkImageVersionFrom: f startingAt: imageOffset
	"Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number."
	"This code is based on C code by Ian Piumarta."

	| version firstVersion |
	self var: #f declareC: 'sqImageFile f'.
	self var: #imageOffset declareC: 'squeakFileOffsetType imageOffset'.

	"check the version number"
	self sqImageFile: f Seek: imageOffset.
	version _ firstVersion _ self getLongFromFile: f swap: false.
	(self readableFormat: version) ifTrue: [^ false].

	"try with bytes reversed"
	self sqImageFile: f Seek: imageOffset.
	version _ self getLongFromFile: f swap: true.
	(self readableFormat: version) ifTrue: [^ true].

	"Note: The following is only meaningful if not reading an embedded image"
	imageOffset = 0 ifTrue:[
		"try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)"
		self sqImageFile: f Seek: 512.
		version _ self getLongFromFile: f swap: false.
		(self readableFormat: version) ifTrue: [^ false].

		"try skipping the first 512 bytes with bytes reversed"
		self sqImageFile: f Seek: 512.
		version _ self getLongFromFile: f swap: true.
		(self readableFormat: version) ifTrue: [^ true]].

	"hard failure; abort"
	self print: 'This interpreter (vers. '.
	self printNum: self imageFormatVersion.
	self print: ') cannot read image file (vers. '.
	self printNum: firstVersion.
	self print: ').'.
	self cr.
	self print: 'Press CR to quit...'.
	self getchar.
	self ioExit.
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 8/4/2004 11:38'!
getLongFromFile: aFile swap: swapFlag
	"Answer the next word read from aFile, byte-swapped according to the swapFlag."

	| w |
	self var: #aFile declareC: 'sqImageFile aFile'.
	w _ 0.
	self cCode: 'sqImageFileRead(&w, sizeof(w), 1, aFile)'.
	swapFlag
		ifTrue: [^ self byteSwapped: w]
		ifFalse: [^ w].
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 9/2/2004 15:38'!
imageFormatVersion
	"Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."

	BytesPerWord == 4
		ifTrue: [^6502]
		ifFalse: [^68000]! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 8/4/2004 11:37'!
putLong: aWord toFile: aFile
	"Append aWord to aFile in this platforms 'natural' byte order.  (Bytes will be swapped, if
	necessary, when the image is read on a different platform.) Set successFlag to false if
	the write fails."

	| objectsWritten |
	self var: #aFile declareC: 'sqImageFile aFile'.

	objectsWritten _ self cCode: 'sqImageFileWrite(&aWord, sizeof(aWord), 1, aFile)'.
	self success: objectsWritten = 1.
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 3/26/2005 14:05'!
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
	"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
	"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
	"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"

	| swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
	self var: #f declareC: 'sqImageFile f'.
	self var: #headerStart declareC: 'squeakFileOffsetType headerStart'.
	self var: #dataSize declareC: 'size_t dataSize'.
	self var: #imageOffset declareC: 'squeakFileOffsetType imageOffset'.

	swapBytes _ self checkImageVersionFrom: f startingAt: imageOffset.
	headerStart _ (self sqImageFilePosition: f) - BytesPerWord.  "record header start position"

	headerSize			_ self getLongFromFile: f swap: swapBytes.
	dataSize				_ self getLongFromFile: f swap: swapBytes.
	oldBaseAddr			_ self getLongFromFile: f swap: swapBytes.
	specialObjectsOop	_ self getLongFromFile: f swap: swapBytes.
	lastHash			_ self getLongFromFile: f swap: swapBytes.
	savedWindowSize	_ self getLongFromFile: f swap: swapBytes.
	fullScreenFlag		_ self getLongFromFile: f swap: swapBytes.
	extraVMMemory		_ self getLongFromFile: f swap: swapBytes.

	lastHash = 0 ifTrue: [
		"lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
		lastHash _ 999].

	"decrease Squeak object heap to leave extra memory for the VM"
	heapSize _ self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.

	"compare memory requirements with availability".
	minimumMemory _ dataSize + 100000.  "need at least 100K of breathing room"
	heapSize < minimumMemory ifTrue: [
		self insufficientMemorySpecifiedError].

	"allocate a contiguous block of memory for the Squeak heap"
	memory _ self cCode: 'sqAllocateMemory(minimumMemory, heapSize)'.
	memory = nil ifTrue: [self insufficientMemoryAvailableError].

	memStart _ self startOfMemory.
	memoryLimit _ (memStart + heapSize) - 24.  "decrease memoryLimit a tad for safety"
	endOfMemory _ memStart + dataSize.

	"position file after the header"
	self sqImageFile: f Seek: headerStart + headerSize.

	"read in the image in bulk, then swap the bytes if necessary"
	bytesRead _ self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
	bytesRead ~= dataSize ifTrue: [self unableToReadImageError].

	headerTypeBytes at: 0 put: BytesPerWord * 2.		"3-word header (type 0)"	
	headerTypeBytes at: 1 put: BytesPerWord.		"2-word header (type 1)"
	headerTypeBytes at: 2 put: 0.					"free chunk (type 2)"	
	headerTypeBytes at: 3 put: 0.					"1-word header (type 3)"

	swapBytes ifTrue: [self reverseBytesInImage].

	"compute difference between old and new memory base addresses"
	bytesToShift _ memStart - oldBaseAddr.
	self initializeInterpreter: bytesToShift.  "adjusts all oops to new location"
	^ dataSize
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'di 8/3/2004 14:26'!
reverseBytesFrom: startAddr to: stopAddr
	"Byte-swap the given range of memory (not inclusive of stopAddr!!)."
	| addr |
	self flag: #Dan.
	addr _ startAddr.
	[addr < stopAddr] whileTrue:
		[self longAt: addr put: (self byteSwapped: (self longAt: addr)).
		addr _ addr + BytesPerWord].! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 8/4/2004 17:24'!
reverseWordsFrom: startAddr to: stopAddr
	"Word-swap the given range of memory, excluding stopAddr."

	| addr |
	addr _ startAddr.
	[addr < stopAddr] whileTrue:
		[self longAt: addr put: (self wordSwapped: (self longAt: addr)).
		addr _ addr + BytesPerWord].! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 8/3/2004 18:24'!
snapshot: embedded 
	"update state of active context"
	| activeProc dataSize rcvr setMacType |
	self var: #setMacType type: 'void *'.
	compilerInitialized
		ifTrue: [self compilerPreSnapshot]
		ifFalse: [self storeContextRegisters: activeContext].

	"update state of active process"
	activeProc _ self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
	self
		storePointer: SuspendedContextIndex
		ofObject: activeProc
		withValue: activeContext.

	"compact memory and compute the size of the memory actually in use"
	self incrementalGC.

	"maximimize space for forwarding table"
	self fullGC.
	self snapshotCleanUp.

	dataSize _ freeBlock - self startOfMemory. "Assume all objects are below the start of the free block"
	successFlag
		ifTrue: [rcvr _ self popStack.
			"pop rcvr"
			self push: trueObj.
			self writeImageFile: dataSize.
			embedded
				ifFalse: ["set Mac file type and creator; this is a noop on other platforms"
					setMacType _ self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
					setMacType = 0
						ifFalse: [self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
			self pop: 1].

	"activeContext was unmarked in #snapshotCleanUp, mark it old "
	self beRootIfOld: activeContext.
	successFlag
		ifTrue: [self push: falseObj]
		ifFalse: [self push: rcvr].
	compilerInitialized
		ifTrue: [self compilerPostSnapshot]! !

!Interpreter methodsFor: 'image save/restore' stamp: 'di 6/14/2004 17:44'!
snapshotCleanUp
	"Clean up right before saving an image, sweeping memory and:
	* nilling out all fields of contexts above the stack pointer. 
	* flushing external primitives 
	* clearing the root bit of any object in the root table "
	| oop header fmt sz |
	oop _ self firstObject.
	[oop < endOfMemory]
		whileTrue: [(self isFreeObject: oop)
				ifFalse: [header _ self longAt: oop.
					fmt _ header >> 8 bitAnd: 15.
					"Clean out context"
					(fmt = 3 and: [self isContextHeader: header])
						ifTrue: [sz _ self sizeBitsOf: oop.
							(self lastPointerOf: oop) + BytesPerWord
								to: sz - BaseHeaderSize by: BytesPerWord
								do: [:i | self longAt: oop + i put: nilObj]].
					"Clean out external functions"
					fmt >= 12
						ifTrue: ["This is a compiled method"
							(self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
								ifTrue: ["It's primitiveExternalCall"
									self flushExternalPrimitiveOf: oop]]].
			oop _ self objectAfter: oop].
	self clearRootsTable! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 9/22/2004 12:05'!
wordSwapped: w
	"Return the given 64-bit integer with its halves in the reverse order."

	BytesPerWord = 8 ifFalse: [self error: 'This cannot happen.'].
	^   ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
	  + ((w bitShift: Byte4Shift         ) bitAnd: Bytes7to4Mask)
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 6/10/2004 12:10'!
writeImageFile: imageBytes

	| fn |
	self var: #fn declareC: 'void *fn'.
	self writeImageFileIO: imageBytes.
	"set Mac file type and creator; this is a noop on other platforms"
	fn _ self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
	fn = 0 ifFalse:[
		self cCode:'((sqInt (*)(char*, char*, char*))fn)(imageName, "STim", "FAST")'.
	].
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ikp 3/26/2005 16:41'!
writeImageFileIO: imageBytes

	| headerStart headerSize f bytesWritten sCWIfn okToWrite |
	self var: #f declareC: 'sqImageFile f'.
	self var: #headerStart declareC: 'squeakFileOffsetType headerStart'.
	self var: #sCWIfn declareC: 'void *sCWIfn'.

	"If the security plugin can be loaded, use it to check for write permission.
	If not, assume it's ok"
	sCWIfn _ self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
	sCWIfn ~= 0 ifTrue:[okToWrite _ self cCode: '((sqInt (*)(void))sCWIfn)()'.
		okToWrite ifFalse:[^self primitiveFail]].
	
	"local constants"
	headerStart _ 0.  
	headerSize _ 64.  "header size in bytes; do not change!!"

	f _ self cCode: 'sqImageFileOpen(imageName, "wb")'.
	f = nil ifTrue: [
		"could not open the image file for writing"
		self success: false.
		^ nil].

	headerStart _ self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
	self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
	"position file to start of header"
	self sqImageFile: f Seek: headerStart.

	self putLong: (self imageFormatVersion) toFile: f.
	self putLong: headerSize toFile: f.
	self putLong: imageBytes toFile: f.
	self putLong: (self startOfMemory) toFile: f.
	self putLong: specialObjectsOop toFile: f.
	self putLong: lastHash toFile: f.
	self putLong: (self ioScreenSize) toFile: f.
	self putLong: fullScreenFlag toFile: f.
	self putLong: extraVMMemory toFile: f.
	1 to: 7 do: [:i | self putLong: 0 toFile: f].  "fill remaining header words with zeros"
	successFlag ifFalse: [
		"file write or seek failure"
		self cCode: 'sqImageFileClose(f)'.
		^ nil].

	"position file after the header"
	self sqImageFile: f Seek: headerStart + headerSize.

	"write the image data"
	bytesWritten _ self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), imageBytes, f)'.
	self success: bytesWritten = imageBytes.
	self cCode: 'sqImageFileClose(f)'.

! !

!Interpreter methodsFor: 'I/O primitive support' stamp: 'di 7/7/2004 16:34'!
reverseDisplayFrom: startIndex to: endIndex 
	"Reverse the given range of Display words (at different bit 
	depths, this will reverse different numbers of pixels). Used to 
	give feedback during VM activities such as garbage 
	collection when debugging. It is assumed that the given 
	word range falls entirely within the first line of the Display."
	| displayObj dispBitsPtr w reversed |
	displayObj _ self splObj: TheDisplay.
	((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
	w _ self fetchInteger: 1 ofObject: displayObj.
	dispBitsPtr _ self fetchPointer: 0 ofObject: displayObj.
	(self isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
	dispBitsPtr _ dispBitsPtr + BaseHeaderSize.
	dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
		do: [:ptr | 
			reversed _ (self long32At: ptr) bitXor: 4294967295.
			self longAt: ptr put: reversed].
	successFlag _ true.
	self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
	self ioForceDisplayUpdate! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'di 8/3/2004 13:27'!
copyObj: oop toSegment: segmentWordArray addr: lastSeg stopAt: stopAddr saveOopAt: oopPtr headerAt: hdrPtr
	"Copy this object into the segment beginning at lastSeg.
	Install a forwarding pointer, and save oop and header.
	Fail if out of space.  Return the next segmentAddr if successful."

	"Copy the object..."
	| extraSize bodySize hdrAddr |
	self flag: #Dan.  "None of the imageSegment stuff has been updated for 64 bits"
	successFlag ifFalse: [^ lastSeg].
	extraSize _ self extraHeaderBytes: oop.
	bodySize _ self sizeBitsOf: oop.
	(lastSeg + extraSize + bodySize) >= stopAddr
		ifTrue: [^ self primitiveFail].
	self transfer: extraSize + bodySize // BytesPerWord  "wordCount"
		from: oop - extraSize
		to: lastSeg+BytesPerWord.

	"Clear root and mark bits of all headers copied into the segment"
	hdrAddr _ lastSeg+BytesPerWord + extraSize.
	self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: AllButRootBit - MarkBit).

	self forward: oop to: (lastSeg+BytesPerWord + extraSize - segmentWordArray)
		savingOopAt: oopPtr andHeaderAt: hdrPtr.

	"Return new end of segment"
	^ lastSeg + extraSize + bodySize! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'ikp 3/26/2005 21:05'!
oopHasAcceptableClass: signedOop
	"Similar to oopHasOkayClass:, except that it only returns true or false."

	| oopClass formatMask behaviorFormatBits oopFormatBits oop |
	(self isIntegerObject: signedOop) ifTrue: [^ true].

	self var: #oop type: 'usqInt'.
	self var: #oopClass type: 'usqInt'.

	oop := self cCoerce: signedOop to: 'usqInt'.

	oop < endOfMemory ifFalse: [^ false].
	((oop \\ BytesPerWord) = 0) ifFalse: [^ false].
	(oop + (self sizeBitsOf: oop)) < endOfMemory ifFalse: [^ false].
	oopClass := self cCoerce: (self fetchClassOf: oop) to: 'usqInt'.

	(self isIntegerObject: oopClass) ifTrue: [^ false].
	(oopClass < endOfMemory) ifFalse: [^ false].
	((oopClass \\ BytesPerWord) = 0) ifFalse: [^ false].
	(oopClass + (self sizeBitsOf: oopClass)) < endOfMemory ifFalse: [^ false].
	((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false].
	(self isBytes: oop)
		ifTrue: [ formatMask _ 16rC00 ]  "ignore extra bytes size bits"
		ifFalse: [ formatMask _ 16rF00 ].

	behaviorFormatBits _ (self formatOfClass: oopClass) bitAnd: formatMask.
	oopFormatBits _ (self baseHeader: oop) bitAnd: formatMask.
	behaviorFormatBits = oopFormatBits ifFalse: [^ false].
	^ true! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'di 8/3/2004 13:41'!
primitiveFailAfterCleanup: outPointerArray
	"If the storeSegment primitive fails, it must clean up first."

	| i lastAddr |   "Store nils throughout the outPointer array."
	lastAddr _ outPointerArray + (self lastPointerOf: outPointerArray).
	i _ outPointerArray + BaseHeaderSize.
	[i <= lastAddr] whileTrue:
		[self longAt: i put: nilObj.
		i _ i + BytesPerWord].

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self primitiveFail! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'di 8/3/2004 13:49'!
primitiveLoadImageSegment
	"This primitive is called from Squeak as...
		<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."

"This primitive will load a binary image segment created by primitiveStoreImageSegment.  It expects the outPointer array to be of the proper size, and the wordArray to be well formed.  It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero.  If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble.  But what more could you have done with it anyway?"

	| outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	outPointerArray _ self stackTop.
	lastOut _ outPointerArray + (self lastPointerOf: outPointerArray).
	segmentWordArray _ self stackValue: 1.
	endSeg _ segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.

	"Essential type checks"
	((self formatOf: outPointerArray) = 2				"Must be indexable pointers"
		and: [(self formatOf: segmentWordArray) = 6])	"Must be indexable words"
		ifFalse: [^ self primitiveFail].

	"Version check.  Byte order of the WordArray now"
	data _ self longAt: segmentWordArray + BaseHeaderSize.
	(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
		"Not readable -- try again with reversed bytes..."
		self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
		data _ self longAt: segmentWordArray + BaseHeaderSize.
		(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
			"Still NG -- put things back and fail"
			self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
			DoAssertionChecks ifTrue: [self verifyCleanHeaders].
			^ self primitiveFail]].
	"Reverse the Byte type objects if the data from opposite endian machine"
	"Test top byte.  $d on the Mac or $s on the PC.  Rest of word is equal"
	data = self imageSegmentVersion ifFalse: [
		"Reverse the byte-type objects once"
		segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
			 "Oop of first embedded object"
		self byteSwapByteObjectsFrom: segOop to: endSeg + BytesPerWord].

	"Proceed through the segment, remapping pointers..."
	segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
	[segOop <= endSeg] whileTrue:
		[(self headerType: segOop) <= 1
			ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
					fieldPtr _ segOop - BytesPerWord.  doingClass _ true]
			ifFalse: ["No class field -- start with first data field"
					fieldPtr _ segOop + BaseHeaderSize.  doingClass _ false].
		lastPtr _ segOop + (self lastPointerOf: segOop).	"last field"
		lastPtr > endSeg ifTrue: [
			DoAssertionChecks ifTrue: [self verifyCleanHeaders].
			^ self primitiveFail "out of bounds"].

		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop _ self longAt: fieldPtr.
			doingClass ifTrue:
				[hdrTypeBits _ self headerType: fieldPtr.
				fieldOop _ fieldOop - hdrTypeBits].
			(self isIntegerObject: fieldOop)
				ifTrue:
					["Integer -- nothing to do"
					fieldPtr _ fieldPtr + BytesPerWord]
				ifFalse:
					[(fieldOop bitAnd: 3) = 0 ifFalse: [^ self primitiveFail "bad oop"].
					(fieldOop bitAnd: 16r80000000) = 0
						ifTrue: ["Internal pointer -- add segment offset"
								mapOop _ fieldOop + segmentWordArray]
						ifFalse: ["External pointer -- look it up in outPointers"
								outPtr _ outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
								outPtr > lastOut ifTrue: [^ self primitiveFail "out of bounds"].
								mapOop _ self longAt: outPtr].
					doingClass
						ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
								fieldPtr _ fieldPtr + 8.
								doingClass _ false]
						ifFalse: [self longAt: fieldPtr put: mapOop.
								fieldPtr _ fieldPtr + BytesPerWord].
					segOop < youngStart
						ifTrue: [self possibleRootStoreInto: segOop value: mapOop].
					]].
		segOop _ self objectAfter: segOop].

	"Again, proceed through the segment checking consistency..."
	segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
	[segOop <= endSeg] whileTrue:
		[(self oopHasAcceptableClass: segOop) ifFalse: [^ self primitiveFail "inconsistency"].
		fieldPtr _ segOop + BaseHeaderSize.		"first field"
		lastPtr _ segOop + (self lastPointerOf: segOop).	"last field"
		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop _ self longAt: fieldPtr.
			(self oopHasAcceptableClass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"].
			fieldPtr _ fieldPtr + BytesPerWord].
		segOop _ self objectAfter: segOop].

	"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
	extraSize _ self extraHeaderBytes: segmentWordArray.
	hdrTypeBits _ self headerType: segmentWordArray.
	extraSize = 8
		ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
		ifFalse: [header _ self longAt: segmentWordArray.
				self longAt: segmentWordArray
					put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].	
	"and return the roots array which was first in the segment"
	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord).
! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'ikp 8/3/2004 20:01'!
primitiveStoreImageSegment
	"This primitive is called from Squeak as...
		<imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray."

"This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree).  All pointers from within the tree to objects outside the tree will be copied into the array of outpointers.  In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set."

"The primitive expects the array and wordArray to be more than adequately long.  In this case it returns normally, and truncates the two arrays to exactly the right size.  To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers).  If either array is too small, the primitive will fail, but in no other case.

During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values.  To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type).  Tables are kept of both kinds of oops, as well as of the original headers for restoration.

To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray.  Each grows oops from the bottom up, and preserved headers from halfway up.

In case of either success or failure, the headers must be restored.  In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded."

	| outPointerArray segmentWordArray savedYoungStart lastOut lastIn firstIn lastSeg endSeg segOop fieldPtr fieldOop mapOop doingClass lastPtr extraSize hdrTypeBits arrayOfRoots hdrBaseIn hdrBaseOut header firstOut versionOffset |

	outPointerArray _ self stackTop.
	segmentWordArray _ self stackValue: 1.
	arrayOfRoots _ self stackValue: 2.

	"Essential type checks"
	((self formatOf: arrayOfRoots) = 2				"Must be indexable pointers"
		and: [(self formatOf: outPointerArray) = 2				"Must be indexable pointers"
		and: [(self formatOf: segmentWordArray) = 6]])	"Must be indexable words"
		ifFalse: [^ self primitiveFail].
	((self headerType: outPointerArray) = HeaderTypeSizeAndClass	"Must be 3-word header"
		and: [(self headerType: segmentWordArray) = HeaderTypeSizeAndClass])	"Must be 3-word header"
		ifFalse: [^ self primitiveFail].

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	"Use the top half of outPointers for saved headers."
	firstOut _ outPointerArray + BaseHeaderSize.
	lastOut _ firstOut - BytesPerWord.
	hdrBaseOut _ outPointerArray + ((self lastPointerOf: outPointerArray) // (BytesPerWord*2) * BytesPerWord). "top half"

	lastSeg _ segmentWordArray.
	endSeg _ segmentWordArray + (self sizeBitsOf: segmentWordArray) - BytesPerWord.

	"Write a version number for byte order and version check"
	versionOffset _ BytesPerWord.
	lastSeg _ lastSeg + versionOffset.
	lastSeg > endSeg ifTrue: [^ self primitiveFail].
	self longAt: lastSeg put: self imageSegmentVersion.

	"Allocate top 1/8 of segment for table of internal oops and saved headers"
	firstIn _ endSeg - ((self sizeBitsOf: segmentWordArray) // (BytesPerWord*8) * BytesPerWord).  "Take 1/8 of seg"
	lastIn _ firstIn - BytesPerWord.
	hdrBaseIn _ firstIn + ((self sizeBitsOf: segmentWordArray) // (BytesPerWord*16) * BytesPerWord). "top half of that"

	"First mark the rootArray and all root objects."
	self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitOr: MarkBit).
	lastPtr _ arrayOfRoots + (self lastPointerOf: arrayOfRoots).
	fieldPtr _ arrayOfRoots + BaseHeaderSize.
	[fieldPtr <= lastPtr] whileTrue:
		[fieldOop _ self longAt: fieldPtr.
		(self isIntegerObject: fieldOop) ifFalse:
			[self longAt: fieldOop put: ((self longAt: fieldOop) bitOr: MarkBit)].
		fieldPtr _ fieldPtr + BytesPerWord].

	"Then do a mark pass over all objects.  This will stop at our marked roots,
	thus leaving our segment unmarked in their shadow."
	savedYoungStart _ youngStart.
	youngStart _ self startOfMemory.  "process all of memory"
		"clear the recycled context lists"
		freeContexts _ NilContext.
		freeLargeContexts _ NilContext.
	self markAndTraceInterpreterOops.	"and special objects array"
	youngStart _ savedYoungStart.
	
	"Finally unmark the rootArray and all root objects."
	self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitAnd: AllButMarkBit).
	fieldPtr _ arrayOfRoots + BaseHeaderSize.
	[fieldPtr <= lastPtr] whileTrue:
		[fieldOop _ self longAt: fieldPtr.
		(self isIntegerObject: fieldOop) ifFalse:
			[self longAt: fieldOop put: ((self longAt: fieldOop) bitAnd: AllButMarkBit)].
		fieldPtr _ fieldPtr + BytesPerWord].

	"All external objects, and only they, are now marked.
	Copy the array of roots into the segment, and forward its oop."
	lastIn _ lastIn + BytesPerWord.
	lastIn >= hdrBaseIn ifTrue: [successFlag _ false].
	lastSeg _ self copyObj: arrayOfRoots toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn).
	successFlag ifFalse:
		[lastIn _ lastIn - BytesPerWord.
		self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
		^ self primitiveFailAfterCleanup: outPointerArray].

	"Now run through the segment fixing up all the pointers.
	Note that more objects will be added to the segment as we make our way along."
	segOop _ self oopFromChunk: segmentWordArray + versionOffset + BaseHeaderSize.
	[segOop <= lastSeg] whileTrue:
		[(self headerType: segOop) <= 1
			ifTrue: ["This object has a class field (type=0 or 1) -- start with that."
					fieldPtr _ segOop - BytesPerWord.  doingClass _ true]
			ifFalse: ["No class field -- start with first data field"
					fieldPtr _ segOop + BaseHeaderSize.  doingClass _ false].
		lastPtr _ segOop + (self lastPointerOf: segOop).	"last field"

		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop _ self longAt: fieldPtr.
			doingClass ifTrue:
				[hdrTypeBits _ fieldOop bitAnd: TypeMask.
				fieldOop _ fieldOop - hdrTypeBits].
			(self isIntegerObject: fieldOop)
				ifTrue: ["Just an integer -- nothing to do"
						fieldPtr _ fieldPtr + BytesPerWord]
				ifFalse:
				[header _ self longAt: fieldOop.
				(header bitAnd: TypeMask) = HeaderTypeFree
					ifTrue: ["Has already been forwarded -- this is the link"
							mapOop _ header bitAnd: AllButTypeMask]
					ifFalse:
					[((self longAt: fieldOop) bitAnd: MarkBit) = 0
						ifTrue:
							["Points to an unmarked obj -- an internal pointer.
							Copy the object into the segment, and forward its oop."
							lastIn _ lastIn + BytesPerWord.
							lastIn >= hdrBaseIn ifTrue: [successFlag _ false].
							lastSeg _ self copyObj: fieldOop toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn).
							successFlag ifFalse:
								["Out of space in segment"
								lastIn _ lastIn - BytesPerWord.
								self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
								^ self primitiveFailAfterCleanup: outPointerArray].
							mapOop _ (self longAt: fieldOop) bitAnd: AllButTypeMask]
						ifFalse:
							["Points to a marked obj -- an external pointer.
							Map it as a tagged index in outPointers, and forward its oop."
							lastOut _ lastOut + BytesPerWord.
							lastOut >= hdrBaseOut ifTrue:
								["Out of space in outPointerArray"
								lastOut _ lastOut - BytesPerWord.
								self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
								^ self primitiveFailAfterCleanup: outPointerArray].
.							mapOop _ lastOut - outPointerArray bitOr: 16r80000000.
							self forward: fieldOop to: mapOop
								savingOopAt: lastOut andHeaderAt: hdrBaseOut + (lastOut - firstOut)]].
					"Replace the oop by its mapped value"
					doingClass
						ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
								fieldPtr _ fieldPtr + (BytesPerWord*2).
								doingClass _ false]
						ifFalse: [self longAt: fieldPtr put: mapOop.
								fieldPtr _ fieldPtr + BytesPerWord].
]].
		segOop _ self objectAfter: segOop].

	self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.

	"Truncate the outPointerArray..."
	((outPointerArray + (self lastPointerOf: outPointerArray) - lastOut) < 12
		or: [(endSeg - lastSeg) < 12]) ifTrue:
			["Not enough room to insert simple 3-word headers"
			^ self primitiveFailAfterCleanup: outPointerArray].
	extraSize _ self extraHeaderBytes: segmentWordArray.
	hdrTypeBits _ self headerType: segmentWordArray.
	"Copy the 3-word wordArray header to establish a free chunk."
	self transfer: 3
		from: segmentWordArray - extraSize
		to: lastOut+BytesPerWord.
	"Adjust the size of the original as well as the free chunk."
	self longAt: lastOut+BytesPerWord
		put: outPointerArray + (self lastPointerOf: outPointerArray) - lastOut - extraSize + hdrTypeBits.
	self longAt: outPointerArray-extraSize
		put: lastOut - firstOut + (BytesPerWord*2) + hdrTypeBits.
	"Note that pointers have been stored into roots table"
	self beRootIfOld: outPointerArray.

	"Truncate the image segment..."
	"Copy the 3-word wordArray header to establish a free chunk."
	self transfer: 3
		from: segmentWordArray - extraSize
		to: lastSeg+BytesPerWord.
	"Adjust the size of the original as well as the free chunk."
	self longAt: segmentWordArray-extraSize
		put: lastSeg - segmentWordArray + BaseHeaderSize + hdrTypeBits.
	self longAt: lastSeg+BytesPerWord
		put: endSeg - lastSeg - extraSize + hdrTypeBits.

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self pop: 3.  "...leaving the reciever on the stack as return value"
! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'di 8/3/2004 14:05'!
restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut

	"Restore headers smashed by forwarding links"
	| tablePtr oop header |
	tablePtr _ firstIn.
	[tablePtr <= lastIn] whileTrue:
		[oop _ self longAt: tablePtr.
		header _ self longAt: hdrBaseIn + (tablePtr-firstIn).
		self longAt: oop put: header.
		tablePtr _ tablePtr + BytesPerWord].
	tablePtr _ firstOut.
	[tablePtr <= lastOut] whileTrue:
		[oop _ self longAt: tablePtr.
		header _ self longAt: hdrBaseOut + (tablePtr-firstOut).
		self longAt: oop put: header.
		tablePtr _ tablePtr + BytesPerWord].
	
	"Clear all mark bits"
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[self longAt: oop put: ((self longAt: oop) bitAnd: AllButMarkBit)].
		oop _ self objectAfter: oop].
! !

!Interpreter methodsFor: 'debug printing' stamp: 'ikp 8/3/2004 21:39'!
printNameOfClass: classOop count: cnt
	"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."

	cnt <= 0 ifTrue: [ ^ self print: 'bad class' ].
	(self sizeBitsOf: classOop) = (7 * BytesPerWord)	"(Metaclass instSize+1 * 4)"
		ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop) 
					count: cnt - 1.
				self print: ' class']
	ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'ikp 6/10/2004 11:04'!
experimentalBytecode
	"Note: This bytecode is not currently generated by the compiler."
	"This range of six bytecodes can replace the pushTemporaryVariable[0..5] bytecode at the beginning of a sequence of either the form:
		pushTemp
		pushTemp | pushConstantOne | pushLiteralConstant
		<=
		longJumpIfFalse
or the form:
		pushTemp
		pushTemp | pushConstantOne | pushLiteralConstant
		+
		popIntoTemp (optional)

If two values pushed are not small integers, this bytecode acts like the pushTemp bytecode it replaces. However, if they are small integers, then the given arithmetic or comparison operation is performed. The result of that operation is either pushed onto the stack or, if one of the expected bytecodes follows it, then that bytecode is performed immediately. In such cases, the entire four instruction sequence is performed without doing any stack operations."

	| arg1 byte2 byte3 byte4 arg1Val arg2Val result offset |
	arg1 _ self temporary: currentBytecode - 138.
	byte2 _ self byteAtPointer: localIP + 1.  "fetch ahead"
	byte3 _ self byteAtPointer: localIP + 2.  "fetch ahead"
	byte4 _ self byteAtPointer: localIP + 3.  "fetch ahead"

	"check first arg"
	(self isIntegerObject: arg1) ifTrue: [
		arg1Val _ self integerValueOf: arg1.
	] ifFalse: [
		self fetchNextBytecode.
		^ self internalPush: arg1.  "abort; first arg is not an integer"
	].

	"get and check second arg"
	byte2 < 32 ifTrue: [
		arg2Val _ self temporary: (byte2 bitAnd: 16rF).
		(self isIntegerObject: arg2Val) ifTrue: [
			arg2Val _ self integerValueOf: arg2Val.
		] ifFalse: [
			self fetchNextBytecode.
			^ self internalPush: arg1.  "abort; second arg is not an integer"
		].
	] ifFalse: [
		byte2 > 64 ifTrue: [
			arg2Val _ 1.
		] ifFalse: [
			arg2Val _ self literal: (byte2 bitAnd: 16r1F).
			(self isIntegerObject: arg2Val) ifTrue: [
				arg2Val _ self integerValueOf: arg2Val.
			] ifFalse: [
				self fetchNextBytecode.
				^ self internalPush: arg1.  "abort; second arg is not an integer"
			].
		].
	].

	byte3 < 178 ifTrue: [
		"do addition, possibly followed by a storeAndPopTemp"
		result _ arg1Val + arg2Val.
		(self isIntegerValue: result) ifTrue: [
			((byte4 > 103) and: [byte4 < 112]) ifTrue: [
				"next instruction is a storeAndPopTemp"
				localIP _ localIP + 3.
				self storePointerUnchecked: (byte4 bitAnd: 7) + TempFrameStart
					ofObject: localHomeContext
					withValue: (self integerObjectOf: result).
			] ifFalse: [
				localIP _ localIP + 2.
				self internalPush: (self integerObjectOf: result).
			].
		] ifFalse: [
			self fetchNextBytecode.
			^ self internalPush: arg1.  "abort; result is not an integer"
		].
	] ifFalse: [
		"do comparison operation, followed by a longJumpIfFalse"
		offset _ self byteAtPointer: localIP + 4.
		arg1Val <= arg2Val
			ifTrue: [localIP _ localIP + 3 + 1]  "jump not taken; skip extra instruction byte"
			ifFalse: [localIP _ localIP + 3 + 1 + offset].
			self fetchNextBytecode.
	].
! !

!Interpreter methodsFor: 'primitive support' stamp: 'ikp 10/5/2004 15:47'!
positive32BitIntegerFor: integerValue

	| newLargeInteger |
	"Note - integerValue is interpreted as POSITIVE, eg, as the result of
		Bitmap>at:, or integer>bitAnd:."
	integerValue >= 0
		ifTrue: [(self isIntegerValue: integerValue)
					ifTrue: [^ self integerObjectOf: integerValue]].

	BytesPerWord = 4
	ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size."
			newLargeInteger _ self instantiateSmallClass: (self splObj: ClassLargePositiveInteger)
					sizeInBytes: BaseHeaderSize + 4 fill: 0]
	ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement."
			newLargeInteger _ self instantiateClass: (self splObj: ClassLargePositiveInteger)
					indexableSize: 4].
	self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
	self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
	self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
	self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
	^ newLargeInteger! !

!Interpreter methodsFor: 'primitive support' stamp: 'tpr 3/17/2005 17:47'!
positive64BitIntegerFor: integerValue

	| newLargeInteger value check |
	"Note - integerValue is interpreted as POSITIVE, eg, as the result of
		Bitmap>at:, or integer>bitAnd:."
	self var: 'integerValue' type: 'sqLong'.
 
	(self sizeof: integerValue) = 4 ifTrue: [^self positive32BitIntegerFor: integerValue].

  	self cCode: 'check = integerValue >> 32'.  "Why not run this in sim?"
	check = 0 ifTrue: [^self positive32BitIntegerFor: integerValue].
	
	newLargeInteger _
		self instantiateSmallClass: (self splObj: ClassLargePositiveInteger) sizeInBytes: BaseHeaderSize + 8 fill: 0.
	0 to: 7 do: [:i |
		self cCode: 'value = ( integerValue >> (i * 8)) & 255'.
		self storeByte: i ofObject: newLargeInteger withValue: value].
	^ newLargeInteger! !

!Interpreter methodsFor: 'primitive support' stamp: 'tpr 3/17/2005 17:47'!
positive64BitValueOf: oop
	"Convert the given object into an integer value.
	The object may be either a positive ST integer or a eight-byte LargePositiveInteger."

	| sz szsqLong value  |
	self returnTypeC: 'sqLong'.
	self var: 'value' type: 'sqLong'.
	(self isIntegerObject: oop) ifTrue: [
		value _ self integerValueOf: oop.
		value < 0 ifTrue: [^ self primitiveFail].
		^ value].

	self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger).
	successFlag ifFalse: [^ self primitiveFail].
	szsqLong _ self cCode: 'sizeof(sqLong)'.
	sz _ self lengthOf: oop.
	sz > szsqLong
		ifTrue: [^ self primitiveFail].
	value _ 0.
	0 to: sz - 1 do: [:i |
		value _ value + ((self cCoerce: (self fetchByte: i ofObject: oop) to: 'sqLong') <<  (i*8))].
	^value.! !

!Interpreter methodsFor: 'primitive support' stamp: 'tpr 3/17/2005 17:48'!
signed64BitIntegerFor: integerValue
	"Return a Large Integer object for the given integer value"
	| newLargeInteger value largeClass intValue check |
	self inline: false.
	self var: 'integerValue' type: 'sqLong'.
	self var: 'value' type: 'sqLong'.
	integerValue < 0
		ifTrue:[	largeClass _ self classLargeNegativeInteger.
				value _ 0 - integerValue]
		ifFalse:[	largeClass _ self classLargePositiveInteger.
				value _ integerValue].

	(self sizeof: value) = 4 ifTrue: [^self signed32BitIntegerFor: integerValue].

	self cCode: 'check = value >> 32'.
	check = 0 ifTrue: [^self signed32BitIntegerFor: integerValue].

	newLargeInteger _ self instantiateSmallClass: largeClass sizeInBytes:  12 fill: 0.
	0 to: 7 do: [:i |
		self cCode: 'intValue = ( value >> (i * 8)) & 255'.
		self storeByte: i ofObject: newLargeInteger withValue: intValue].
	^ newLargeInteger! !

!Interpreter methodsFor: 'primitive support' stamp: 'tpr 3/17/2005 17:48'!
signed64BitValueOf: oop
	"Convert the given object into an integer value.
	The object may be either a positive ST integer or a eight-byte LargeInteger."
	| sz value largeClass negative szsqLong |
	self inline: false.
	self returnTypeC: 'sqLong'.
	self var: 'value' type: 'sqLong'.
	(self isIntegerObject: oop) ifTrue: [^self cCoerce: (self integerValueOf: oop) to: 'sqLong'].
	largeClass _ self fetchClassOf: oop.
	largeClass = self classLargePositiveInteger
		ifTrue:[negative _ false]
		ifFalse:[largeClass = self classLargeNegativeInteger
					ifTrue:[negative _ true]
					ifFalse:[^self primitiveFail]].
	szsqLong _ self cCode: 'sizeof(sqLong)'.
	sz _ self lengthOf: oop.
	sz > szsqLong 
		ifTrue: [^ self primitiveFail].
	value _ 0.
	0 to: sz - 1 do: [:i |
		value _ value + ((self cCoerce: (self fetchByte: i ofObject: oop) to: 'sqLong') <<  (i*8))].
	negative
		ifTrue:[^0 - value]
		ifFalse:[^value]! !

!Interpreter methodsFor: 'interpreter shell' stamp: 'ikp 6/10/2004 11:01'!
fetchByte
	"This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator."

	^ self byteAtPointer: localIP preIncrement! !

!Interpreter methodsFor: 'plugin support' stamp: 'ikp 6/10/2004 12:26'!
addToExternalPrimitiveTable: functionAddress
	"Add the given function address to the external primitive table and return the index where it's stored. This function doesn't need to be fast since it is only called when an external primitive has been looked up (which takes quite a bit of time itself). So there's nothing specifically complicated here.
	Note: Return index will be one-based (ST convention)"

	self var: #functionAddress declareC: 'void *functionAddress'.

	0 to: MaxExternalPrimitiveTableSize-1 do: [ :i |
		(externalPrimitiveTable at: i) = 0 ifTrue: [
			externalPrimitiveTable at: i put: functionAddress.
			^i+1]].
	"if no space left, return zero so it'll looked up again"
	^0! !

!Interpreter methodsFor: 'plugin support' stamp: 'ikp 8/2/2004 16:52'!
findObsoleteNamedPrimitive: functionName length: functionLength
	"Search the obsolete named primitive table for the given function.
	Return the index if it's found, -1 otherwise."
	| entry index chIndex |
	self var: #functionName type:'char *'.
	self var: #entry type:'const char *'.
	index _ 0.
	[true] whileTrue:[
		entry _ self
			cCode: 'obsoleteNamedPrimitiveTable[index][0]'
			inSmalltalk: [ (CArrayAccessor on: (obsoleteNamedPrimitiveTable at: index)) at: 0 ].
		entry == nil ifTrue:[^-1]. "at end of table"
		self cCode: '' inSmalltalk: [ entry _ CArrayAccessor on: entry ].
		"Compare entry with functionName"
		chIndex _ 0.
		[(entry at: chIndex) = (self cCode: 'functionName[chIndex]'
								inSmalltalk: [self byteAtPointer: functionName + chIndex]) 
			and:[chIndex < functionLength]] whileTrue:[chIndex _ chIndex + 1].
		(chIndex = functionLength and:[(entry at: chIndex) = 0]) 
			ifTrue:[^index]. "match"
		index _ index + 1.
	].! !

!Interpreter methodsFor: 'plugin support' stamp: 'di 6/23/2004 12:26'!
firstFixedField: oop

	self returnTypeC: 'void *'.
	^ self pointerForOop: oop + BaseHeaderSize! !

!Interpreter methodsFor: 'plugin support' stamp: 'di 7/17/2004 13:02'!
firstIndexableField: oop
	"NOTE: copied in InterpreterSimulator, so please duplicate any changes"

	| hdr fmt totalLength fixedFields |
	self returnTypeC: 'void *'.
	hdr _ self baseHeader: oop.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: oop baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: oop format: fmt length: totalLength.
	fmt < 8 ifTrue:
		[fmt = 6 ifTrue:
			["32 bit field objects"
			^ self pointerForOop: oop + BaseHeaderSize + (fixedFields << 2)].
		"full word objects (pointer or bits)"
		^ self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)]
	ifFalse:
		["Byte objects"
		^ self pointerForOop: oop + BaseHeaderSize + fixedFields]! !

!Interpreter methodsFor: 'control primitives' stamp: 'di 7/4/2004 08:56'!
primitiveBlockCopy

	| context methodContext contextSize newContext initialIP |
	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+1+3) - (method+BaseHeaderSize).
	"Was instructionPointer + 3, but now it's greater 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."

	self storePointer: InitialIPIndex ofObject: newContext withValue: initialIP.
	self storePointer: InstructionPointerIndex ofObject: newContext withValue: initialIP.
	self storeStackPointerValue: 0 inContext: newContext.
	self storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
	self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
	self storePointerUnchecked: SenderIndex ofObject: newContext withValue: nilObj.

	self pop: 2 thenPush: newContext.! !

!Interpreter methodsFor: 'control primitives' stamp: 'tpr 3/23/2005 15:08'!
primitiveExecuteMethodArgsArray
	"receiver, argsArray, then method are on top of stack.  Execute method against receiver and args"

	| argCnt argumentArray |
	newMethod _ self popStack.
	primitiveIndex _ self primitiveIndexOf: newMethod.
	argCnt _ self argumentCountOf: newMethod.
	argumentArray _ self popStack.
	"If the argArray isnt actually an Array we have to unPop both the above"
	(self isArray: argumentArray) ifFalse:[self unPop: 2. ^self primitiveFail].
	successFlag ifTrue: [self success: (argCnt = (self fetchWordLengthOf: argumentArray))].
	successFlag
		ifTrue: [self transfer: argCnt from: argumentArray + BaseHeaderSize to: stackPointer + BytesPerWord.
			self unPop: argCnt.
			argumentCount _ argCnt.
			self executeNewMethod]
		ifFalse: [self unPop: 2].
! !

!Interpreter methodsFor: 'control primitives' stamp: 'tpr 3/23/2005 15:23'!
primitiveInvokeObjectAsMethod
	"Primitive. 'Invoke' an object like a function, sending the special message 
		run: originalSelector with: arguments in: aReceiver.
	"
	| runSelector runReceiver runArgs newReceiver lookupClass |
	runArgs _ self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
	self beRootIfOld: runArgs. "do we really need this?"
	self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * BytesPerWord) to: runArgs + BaseHeaderSize.

	runSelector _ messageSelector.
	runReceiver _ self stackValue: argumentCount.
	self pop: argumentCount+1.

	"stack is clean here"

	newReceiver _ newMethod.
	messageSelector _ self splObj: SelectorRunWithIn.
	argumentCount _ 3.

	self push: newReceiver.
	self push: runSelector.
	self push: runArgs.
	self push: runReceiver.

	lookupClass _ self fetchClassOf: newReceiver.
	self findNewMethodInClass: lookupClass.
	self executeNewMethodFromCache.  "Recursive xeq affects successFlag"
	successFlag _ true.
! !

!Interpreter methodsFor: 'jump bytecodes' stamp: 'ikp 6/10/2004 11:01'!
jump: offset

	localIP _ localIP + offset + 1.
	currentBytecode _ self byteAtPointer: localIP.
! !

!Interpreter methodsFor: 'float primitives' stamp: 'ikp 6/9/2004 16:23'!
primitiveExponent
	"Exponent part of this float."

	| rcvr frac pwr |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #frac declareC: 'double frac'.
	self var: #pwr declareC: 'int pwr'.
	rcvr _ self popFloat.
	successFlag
		ifTrue: [  "rcvr = frac * 2^pwr, where frac is in [0.5..1.0)"
			self cCode: 'frac = frexp(rcvr, &pwr)'
					inSmalltalk: [pwr _ rcvr exponent].
			self pushInteger: pwr - 1]
		ifFalse: [self unPop: 1].! !

!Interpreter methodsFor: 'float primitives' stamp: 'ikp 8/4/2004 11:42'!
primitiveTruncated 
	| rcvr frac trunc |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #frac declareC: 'double frac'.
	self var: #trunc declareC: 'double trunc'.
	rcvr _ self popFloat.
	successFlag ifTrue:
		[self cCode: 'frac = modf(rcvr, &trunc)'
			inSmalltalk: [trunc _ rcvr truncated].
		self flag: #Dan.		"The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
		self cCode: 'success((-1073741824.0 <= trunc) && (trunc <= 1073741823.0))'
			inSmalltalk: [self success: (trunc between: SmallInteger minVal and: SmallInteger maxVal)]].
	successFlag
		ifTrue: [self cCode: 'pushInteger((sqInt) trunc)' inSmalltalk: [self pushInteger: trunc]]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'object access primitives' stamp: 'di 8/3/2004 13:40'!
primitiveChangeClass
	"Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
	| arg rcvr argClass classHdr sizeHiBits byteSize argFormat rcvrFormat ccIndex |
	arg _ self stackObjectValue: 0.
	rcvr _ self stackObjectValue: 1.
	successFlag ifFalse:[^nil].

	"Get the class we want to convert the receiver into"
	argClass _ self fetchClassOf: arg.

	"Check what the format of the class says"
	classHdr _ self formatOfClass: argClass. "Low 2 bits are 0"

	"Compute the size of instances of the class (used for fixed field classes only)"
	sizeHiBits _ (classHdr bitAnd: 16r60000) >> 9.
	classHdr _ classHdr bitAnd: 16r1FFFF.
	byteSize _ (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"

	"Check the receiver's format against that of the class"
	argFormat _ (classHdr >> 8) bitAnd: 16rF.
	rcvrFormat _ self formatOf: rcvr.
	argFormat = rcvrFormat ifFalse:[^self primitiveFail]. "no way"

	"For fixed field classes, the sizes must match.
	Note: base header size is included in class size."
	argFormat < 2 ifTrue:[(byteSize - BaseHeaderSize) = (self byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].

	(self headerType: rcvr) = HeaderTypeShort
		ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex"
			ccIndex _ classHdr bitAnd: CompactClassMask.
			ccIndex = 0 ifTrue:[^self primitiveFail]. "class is not compact"
			self longAt: rcvr put:
				(((self longAt: rcvr) bitAnd: CompactClassMask bitInvert32)
					bitOr: ccIndex)]
		ifFalse:["Exchange the class pointer, which could make rcvr a root for argClass"
			self longAt: rcvr-BaseHeaderSize put: (argClass bitOr: (self headerType: rcvr)).
			(rcvr < youngStart) ifTrue: [self possibleRootStoreInto: rcvr value: argClass]].

	"Flush cache because rcvr's class has changed"
	self flushMethodCache.

	successFlag ifTrue: [ self pop: 1 ]! !

!Interpreter methodsFor: 'object access primitives' stamp: 'di 6/14/2004 17:26'!
primitiveObjectPointsTo
	| rcvr thang lastField |
	thang _ self popStack.
	rcvr _ self popStack.
	(self isIntegerObject: rcvr) ifTrue: [^self pushBool: false].

	lastField _ self lastPointerOf: rcvr.
	BaseHeaderSize to: lastField by: BytesPerWord do:
		[:i | (self longAt: rcvr + i) = thang
			ifTrue: [^ self pushBool: true]].
	self pushBool: false.! !

!Interpreter methodsFor: 'object access primitives' stamp: 'di 6/14/2004 17:27'!
primitiveStoreStackp
	"Atomic store into context stackPointer. 
	Also ensures that any newly accessible cells are initialized to nil "
	| ctxt newStackp stackp |
	ctxt _ self stackValue: 1.
	newStackp _ self stackIntegerValue: 0.
	self success: newStackp >= 0.
	self success: newStackp <= (LargeContextSize - BaseHeaderSize // BytesPerWord - CtxtTempFrameStart).
	successFlag ifFalse: [^ self primitiveFail].
	stackp _ self fetchStackPointerOf: ctxt.
	newStackp > stackp ifTrue: ["Nil any newly accessible cells"
			stackp + 1 to: newStackp do: [:i | self storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: nilObj]].
	self storeStackPointerValue: newStackp inContext: ctxt.
	self pop: 1! !

!Interpreter methodsFor: 'object access primitives' stamp: 'ikp 8/4/2004 18:28'!
sufficientSpaceToInstantiate: classOop indexableSize: size 
	"Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."
	"Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
	| format okay |
	self inline: true.
	format _ (self formatOfClass: classOop) >> 8 bitAnd: 15.
	"fail if attempting to call new: on non-indexable class"
	((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2])
		ifTrue: [^ false].
	format < 8
		ifTrue: ["indexable fields are words or pointers"
			okay _ self sufficientSpaceToAllocate: 2500 + (size * BytesPerWord)]
		ifFalse: ["indexable fields are bytes"
			okay _ self sufficientSpaceToAllocate: 2500 + size].
	^ okay! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'ikp 6/10/2004 12:15'!
install: rcvr inAtCache: cache at: atIx string: stringy
	"Install the oop of this object in the given cache (at or atPut), along with
	its size, format and fixedSize"
	| hdr fmt totalLength fixedFields |
	self var: #cache declareC: 'sqInt *cache'.

	hdr _ self baseHeader: rcvr.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	(fmt = 3 and: [self isContextHeader: hdr]) ifTrue:
		["Contexts must not be put in the atCache, since their size is not constant"
		^ self primitiveFail].
	totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength.

	cache at: atIx+AtCacheOop put: rcvr.
	stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16]  "special flag for strings"
			ifFalse: [cache at: atIx+AtCacheFmt put: fmt].
	cache at: atIx+AtCacheFixedFields put: fixedFields.
	cache at: atIx+AtCacheSize put: totalLength - fixedFields.
! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'ikp 3/29/2005 22:34'!
primitiveStringReplace
	" 
	<array> primReplaceFrom: start to: stop with: replacement 
	startingAt: repStart  
	<primitive: 105>
	"
	| array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex |
	array _ self stackValue: 4.
	start _ self stackIntegerValue: 3.
	stop _ self stackIntegerValue: 2.
	repl _ self stackValue: 1.
	replStart _ self stackIntegerValue: 0.

	successFlag ifFalse: [^ self primitiveFail].
	(self isIntegerObject: repl) ifTrue: ["can happen in LgInt copy"
			^ self primitiveFail].

	hdr _ self baseHeader: array.
	arrayFmt _ hdr >> 8 bitAnd: 15.
	totalLength _ self lengthOf: array baseHeader: hdr format: arrayFmt.
	arrayInstSize _ self fixedFieldsOf: array format: arrayFmt length: totalLength.
	(start >= 1 and: [start - 1 <= stop and: [stop + arrayInstSize <= totalLength]])
		ifFalse: [^ self primitiveFail].

	hdr _ self baseHeader: repl.
	replFmt _ hdr >> 8 bitAnd: 15.
	totalLength _ self lengthOf: repl baseHeader: hdr format: replFmt.
	replInstSize _ self fixedFieldsOf: repl format: replFmt length: totalLength.
	(replStart >= 1 and: [stop - start + replStart + replInstSize <= totalLength])
		ifFalse: [^ self primitiveFail].

	"Array formats (without byteSize bits, if bytes array) must be same "
	arrayFmt < 8
		ifTrue: [arrayFmt = replFmt
				ifFalse: [^ self primitiveFail]]
		ifFalse: [(arrayFmt bitAnd: 12) = (replFmt bitAnd: 12)
				ifFalse: [^ self primitiveFail]].

	srcIndex _ replStart + replInstSize - 1.
	"- 1 for 0-based access"

	arrayFmt <= 4
		ifTrue: ["pointer type objects"
			start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i |
				self storePointer: i ofObject: array withValue: (self fetchPointer: srcIndex ofObject: repl).
					srcIndex _ srcIndex + 1]]
		ifFalse: [arrayFmt < 8
				ifTrue: ["32-bit-word type objects"
					start + arrayInstSize - 1 to: stop + arrayInstSize - 1
						do: [:i | self storeLong32: i ofObject: array withValue: (self fetchLong32: srcIndex ofObject: repl).
							srcIndex _ srcIndex + 1]]
				ifFalse: ["byte-type objects"
					start + arrayInstSize - 1 to: stop + arrayInstSize - 1
						do: [:i |  self storeByte: i ofObject: array withValue: (self fetchByte: srcIndex ofObject: repl).
							srcIndex _ srcIndex + 1]]].
	"We might consider  comparing stop - start to some value here and using forceInterruptCheck"

	self pop: argumentCount "leave rcvr on stack"! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ikp 6/10/2004 14:05'!
displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
	"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."

	| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
	displayObj _ self splObj: TheDisplay.
	aForm = displayObj ifFalse: [^ nil].
	self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
	successFlag ifTrue: [
		dispBits _ self fetchPointer: 0 ofObject: displayObj.
		w _ self fetchInteger: 1 ofObject: displayObj.
		h _ self fetchInteger: 2 ofObject: displayObj.
		d _ self fetchInteger: 3 ofObject: displayObj.
	].
	l < 0 ifTrue:[left _ 0] ifFalse: [left _ l].
	r > w ifTrue: [right _ w] ifFalse: [right _ r].
	t < 0 ifTrue: [top _ 0] ifFalse: [top _ t].
	b > h ifTrue: [bottom _ h] ifFalse: [bottom _ b].
	((left <= right) and: [top <= bottom]) ifFalse: [^nil].
	successFlag ifTrue: [
		(self isIntegerObject: dispBits) ifTrue: [
			surfaceHandle _ self integerValueOf: dispBits.
			showSurfaceFn = 0 ifTrue: [
				showSurfaceFn _ self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
				showSurfaceFn = 0 ifTrue: [^self success: false]].
			self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
		] ifFalse: [
			dispBitsIndex _ dispBits + BaseHeaderSize.  "index in memory byte array"
			self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
				inSmalltalk: [self showDisplayBits: dispBitsIndex 
								w: w h: h d: d
								left: left right: right top: top bottom: bottom]
		].
	].! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'di 7/4/2004 08:41'!
primitiveBeCursor
	"Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."

	| cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |

self flag: #Dan.  "This is disabled until we convert bitmaps appropriately"
BytesPerWord = 8 ifTrue: [^ self pop: argumentCount].

	argumentCount = 0 ifTrue: [
		cursorObj _ self stackTop.
		maskBitsIndex _ nil].
	argumentCount = 1 ifTrue: [
		cursorObj _ self stackValue: 1.
		maskObj _ self stackTop].
	self success: (argumentCount < 2).

	self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
	successFlag ifTrue: [
		bitsObj _ self fetchPointer: 0 ofObject: cursorObj.
		extentX _ self fetchInteger: 1 ofObject: cursorObj.
		extentY _ self fetchInteger: 2 ofObject: cursorObj.
		depth _ self fetchInteger: 3 ofObject: cursorObj.
		offsetObj _ self fetchPointer: 4 ofObject: cursorObj].
		self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).

	successFlag ifTrue: [
		offsetX _ self fetchInteger: 0 ofObject: offsetObj.
		offsetY _ self fetchInteger: 1 ofObject: offsetObj.
		self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
		self success: ((offsetX >= -16) and: [offsetX <= 0]).
		self success: ((offsetY >= -16) and: [offsetY <= 0]).
		self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
		cursorBitsIndex _ bitsObj + BaseHeaderSize.
		self cCode: '' inSmalltalk:
			[ourCursor _ Cursor
				extent: extentX @ extentY
				fromArray: ((1 to: 16) collect: [:i |
					((self fetchLong32: i-1 ofObject: bitsObj) >> (BytesPerWord*8 - 16)) bitAnd: 16rFFFF])
				offset: offsetX  @ offsetY]].

	argumentCount = 1 ifTrue: [
		self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
		successFlag ifTrue: [
			bitsObj _ self fetchPointer: 0 ofObject: maskObj.
			extentX _ self fetchInteger: 1 ofObject: maskObj.
			extentY _ self fetchInteger: 2 ofObject: maskObj.
			depth _ self fetchInteger: 3 ofObject: maskObj].

		successFlag ifTrue: [
			self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
			self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
			maskBitsIndex _ bitsObj + BaseHeaderSize]].

	successFlag ifTrue: [
		argumentCount = 0
			ifTrue: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
						inSmalltalk: [ourCursor show]]
			ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
						inSmalltalk: [ourCursor show]].
		self pop: argumentCount].
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ikp 8/3/2004 19:59'!
primitiveFormPrint
	"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."

	| landscapeFlag vScale hScale rcvr bitsArray w h
	 depth pixelsPerWord wordsPerLine bitsArraySize ok |

	self var: #vScale declareC: 'double vScale'.
	self var: #hScale declareC: 'double hScale'.
	landscapeFlag _ self booleanValueOf: self stackTop.
	vScale _ self floatValueOf: (self stackValue: 1).
	hScale _ self floatValueOf: (self stackValue: 2).
	rcvr _ self stackValue: 3.
	(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
	successFlag ifTrue: [
		((self  isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
			ifFalse: [self success: false]].
	successFlag ifTrue: [
		bitsArray _ self fetchPointer: 0 ofObject: rcvr.
		w _ self fetchInteger: 1 ofObject: rcvr.
		h _ self fetchInteger: 2 ofObject: rcvr.
		depth _ self fetchInteger: 3 ofObject: rcvr.
		(w > 0 and: [h > 0]) ifFalse: [self success: false].
		pixelsPerWord _ 32 // depth.
		wordsPerLine _ (w + (pixelsPerWord - 1)) // pixelsPerWord.
		((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
			ifTrue: [
				bitsArraySize _ self byteLengthOf: bitsArray.
				self success: (bitsArraySize = (wordsPerLine * h * 4))]
			ifFalse: [self success: false]].	
	successFlag ifTrue: [
		BytesPerWord = 8
			ifTrue: [ok _ self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)']
			ifFalse: [ok _ self cCode: 'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'].
		self success: ok].
	successFlag ifTrue: [
		self pop: 3].  "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
! !

!Interpreter methodsFor: 'plugin primitives' stamp: 'tpr 3/23/2005 16:33'!
primitiveExternalCall
	"Call an external primitive. The external primitive methods 
	contain as first literal an array consisting of: 
	* The module name (String | Symbol) 
	* The function name (String | Symbol) 
	* The session ID (SmallInteger) [OBSOLETE] 
	* The function index (Integer) in the externalPrimitiveTable 
	For fast failures the primitive index of any method where the 
	external prim is not found is rewritten in the method cache 
	with zero. This allows for ultra fast responses as long as the 
	method stays in the cache. 
	The fast failure response relies on lkupClass being properly 
	set. This is done in 
	#addToMethodCacheSel:class:method:primIndex: to 
	compensate for execution of methods that are looked up in a 
	superclass (such as in primitivePerformAt). 
	With the latest modifications (e.g., actually flushing the 
	function addresses from the VM), the session ID is obsolete. 
	But for backward compatibility it is still kept around. Also, a 
	failed lookup is reported specially. If a method has been 
	looked up and not been found, the function address is stored 
	as -1 (e.g., the SmallInteger -1 to distinguish from 
	16rFFFFFFFF which may be returned from the lookup). 
	It is absolutely okay to remove the rewrite if we run into any 
	problems later on. It has an approximate speed difference of 
	30% per failed primitive call which may be noticable but if, 
	for any reasons, we run into problems (like with J3) we can 
	always remove the rewrite. 
	"
	| lit addr moduleName functionName moduleLength functionLength index |
	self var: #addr declareC: 'void *addr'.
	
	"Fetch the first literal of the method"
	self success: (self literalCountOf: newMethod) > 0. "@@: Could this be omitted for speed?!!"
	successFlag ifFalse: [^ nil].

	lit _ self literal: 0 ofMethod: newMethod. 
	"Check if it's an array of length 4"
	self success: ((self isArray: lit) and: [(self lengthOf: lit) = 4]).
	successFlag ifFalse: [^ nil].

	"Look at the function index in case it has been loaded before"
	index _ self fetchPointer: 3 ofObject: lit.
	index _ self checkedIntegerValueOf: index.
	successFlag ifFalse: [^ nil].
	"Check if we have already looked up the function and failed."
	index < 0
		ifTrue: ["Function address was not found in this session, 
			Rewrite the mcache entry with a zero primitive index."
			self
				rewriteMethodCacheSel: messageSelector
				class: lkupClass
				primIndex: 0.
			^ self success: false].

	"Try to call the function directly"
	(index > 0 and: [index <= MaxExternalPrimitiveTableSize])
		ifTrue: [addr _ externalPrimitiveTable at: index - 1.
			addr ~= 0
				ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
					self callExternalPrimitive: addr.
					^ nil].
			"if we get here, then an index to the external prim was 
			kept on the ST side although the underlying prim 
			table was already flushed"
			^ self primitiveFail].

	"Clean up session id and external primitive index"
	self storeInteger: 2 ofObject: lit withValue: ConstZero.
	self storeInteger: 3 ofObject: lit withValue: ConstZero.

	"The function has not been loaded yet. Fetch module and function name."
	moduleName _ self fetchPointer: 0 ofObject: lit.
	moduleName = nilObj
		ifTrue: [moduleLength _ 0]
		ifFalse: [self success: (self isBytes: moduleName).
				moduleLength _ self lengthOf: moduleName.
				self cCode: '' inSmalltalk:
					[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName))
						ifTrue: [moduleLength _ 0  "Cause all of these to fail"]]].
	functionName _ self fetchPointer: 1 ofObject: lit.
	self success: (self isBytes: functionName).
	functionLength _ self lengthOf: functionName.
	successFlag ifFalse: [^ nil].

	"Backward compatibility: 
	Attempt to map any old-style named primitives into the new 
	ones. The old ones are exclusively bound into the VM so we 
	don't need to check if a module is given."
	addr _ 0. "Addr ~= 0 indicates we have a compat match later"
	moduleLength = 0
		ifTrue: ["Search the obsolete named primitive table for a match "
		index _ self findObsoleteNamedPrimitive: ((self pointerForOop: functionName) + BaseHeaderSize) length: functionLength.
			"The returned value is the index into the obsolete primitive table. 
			If the index is found, use the 'C-style' version of the lookup. "
			index < 0 ifFalse: [addr _ self ioLoadFunction: (self cCoerce: ((obsoleteNamedPrimitiveTable at: index) at: 2) to: 'char*')
								From: (self cCoerce: ((obsoleteNamedPrimitiveTable at: index) at: 1) to: 'char*')]].
	addr = 0 ifTrue: ["Only if no compat version was found"
			addr _ self ioLoadExternalFunction: functionName + BaseHeaderSize
						OfLength: functionLength
						FromModule: moduleName + BaseHeaderSize
						OfLength: moduleLength].
	addr = 0
		ifTrue: [index _ -1]
		ifFalse: ["add the function to the external primitive table"
			index _ self addToExternalPrimitiveTable: addr].
	self success: index >= 0.
	"Store the index (or -1 if failure) back in the literal"
	self storePointer: 3 ofObject: lit withValue: (self integerObjectOf: index).

	"If the function has been successfully loaded process it"
	(successFlag and: [addr ~= 0])
		ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
				self callExternalPrimitive: addr]
		ifFalse: ["Otherwise rewrite the primitive index"
			self
				rewriteMethodCacheSel: messageSelector
				class: lkupClass
				primIndex: 0]! !

!Interpreter methodsFor: 'plugin primitives' stamp: 'tpr 3/23/2005 15:28'!
primitiveUnloadModule
	"Primitive. Unload the module with the given name."
	"Reloading of the module will happen *later* automatically, when a 
	function from it is called. This is ensured by invalidating current sessionID."
	| moduleName |
	self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
	moduleName _ self stackTop.
	(self isIntegerObject: moduleName) ifTrue:[^self primitiveFail].
	(self isBytes: moduleName) ifFalse:[^self primitiveFail].
	(self ioUnloadModule: (self oopForPointer: (self firstIndexableField: moduleName))
		OfLength: (self byteSizeOf: moduleName)) ifFalse:[^self primitiveFail].
	self flushExternalPrimitives.
	self forceInterruptCheck.
	self pop: 1 "pop moduleName; return receiver"! !

!Interpreter methodsFor: 'sound primitives' stamp: 'di 7/7/2004 16:21'!
primitiveConstantFill
	"Fill the receiver, which must be an indexable bytes or words 
	objects, with the given integer value."
	| fillValue rcvr rcvrIsBytes end i |
	fillValue _ self positive32BitValueOf: self stackTop.
	rcvr _ self stackValue: 1.
	self success: (self isWordsOrBytes: rcvr).
	rcvrIsBytes _ self isBytes: rcvr.
	rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])].
	successFlag
		ifTrue: [end _ rcvr + (self sizeBitsOf: rcvr).
			i _ rcvr + BaseHeaderSize.
			rcvrIsBytes
				ifTrue: [[i < end]
						whileTrue: [self byteAt: i put: fillValue.
							i _ i + 1]]
				ifFalse: [[i < end]
						whileTrue: [self long32At: i put: fillValue.
							i _ i + 4]].
			self pop: 1]! !

!Interpreter methodsFor: 'sound primitives' stamp: 'ikp 6/13/2004 22:22'!
primitiveIntegerAt
	"Return the 32bit signed integer contents of a words receiver"

	| index rcvr sz addr value |
	index _ self stackIntegerValue: 0.
	rcvr _ self stackValue: 1.
	(self isIntegerObject: rcvr) ifTrue: [^self success: false].
	(self isWords: rcvr) ifFalse: [^self success: false].
	sz _ self lengthOf: rcvr.  "number of fields"
	self success: ((index >= 1) and: [index <= sz]).
	successFlag ifTrue: [
		addr _ rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4).
		value _ self intAt: addr.
		self pop: 2.  "pop rcvr, index"
		"push element value"
		(self isIntegerValue: value)
			ifTrue: [self pushInteger: value]
			ifFalse: [self push: (self signed32BitIntegerFor: value)].
	].! !

!Interpreter methodsFor: 'sound primitives' stamp: 'ikp 6/13/2004 22:22'!
primitiveIntegerAtPut
	"Return the 32bit signed integer contents of a words receiver"
	| index rcvr sz addr value valueOop |
	valueOop _ self stackValue: 0.
	index _ self stackIntegerValue: 1.
	rcvr _ self stackValue: 2.
	(self isIntegerObject: rcvr) ifTrue:[^self success: false].
	(self isWords: rcvr) ifFalse:[^self success: false].
	sz _ self lengthOf: rcvr.  "number of fields"
	((index >= 1) and: [index <= sz]) ifFalse:[^self success: false].
	(self isIntegerObject: valueOop)
		ifTrue:[value _ self integerValueOf: valueOop]
		ifFalse:[value _ self signed32BitValueOf: valueOop].
	successFlag ifTrue:[
		addr _ rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4).
		value _ self intAt: addr put: value.
		self pop: 3 thenPush: valueOop. "pop all; return value"
	].
! !

!Interpreter methodsFor: 'sound primitives' stamp: 'ikp 6/11/2004 16:44'!
primitiveShortAt
	"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."

	| index rcvr sz addr value |
	index _ self stackIntegerValue: 0.
	rcvr _ self stackValue: 1.
	self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
	successFlag ifFalse: [ ^ nil ].
	sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2.  "number of 16-bit fields"
	self success: ((index >= 1) and: [index <= sz]).
	successFlag ifTrue: [
		addr _ rcvr + BaseHeaderSize + (2 * (index - 1)).
		value _ self shortAt: addr.
		self pop: 2.  "pop rcvr, index"
		self pushInteger: value.  "push element value"
	]! !

!Interpreter methodsFor: 'sound primitives' stamp: 'ikp 6/11/2004 16:44'!
primitiveShortAtPut
	"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."

	| index rcvr sz addr value |
	value _ self stackIntegerValue: 0.
	index _ self stackIntegerValue: 1.
	rcvr _ self stackValue: 2.
	self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
	successFlag ifFalse: [ ^ nil ].
	sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2.  "number of 16-bit fields"
	self success: ((index >= 1) and: [index <= sz]).
	self success: ((value >= -32768) and: [value <= 32767]).
	successFlag ifTrue: [
		addr _ rcvr + BaseHeaderSize + (2 * (index - 1)).
		self shortAt: addr put: value.
		self pop: 2.  "pop index and value; leave rcvr on stack"
	]! !

!Interpreter methodsFor: 'other primitives' stamp: 'ikp 6/10/2004 12:08'!
primitiveImageName
	"When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."

	| s sz sCRIfn okToRename |
	self var: #sCRIfn declareC: 'void *sCRIfn'.
	argumentCount = 1 ifTrue: [
		"If the security plugin can be loaded, use it to check for rename permission.
		If not, assume it's ok"
		sCRIfn _ self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'.
		sCRIfn ~= 0 ifTrue:[okToRename _ self cCode:' ((sqInt (*)(void))sCRIfn)()'.
			okToRename ifFalse:[^self primitiveFail]].
		s _ self stackTop.
		self assertClassOf: s is: (self splObj: ClassString).
		successFlag ifTrue: [
			sz _ self stSizeOf: s.
			self imageNamePut: (s + BaseHeaderSize) Length: sz.
			self pop: 1.  "pop s, leave rcvr on stack"
		].
	] ifFalse: [
		sz _ self imageNameSize.
		s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz.
		self imageNameGet: (s + BaseHeaderSize) Length: sz.
		self pop: 1.  "rcvr"
		self push: s.
	].
! !

!Interpreter methodsFor: 'other primitives' stamp: 'ikp 6/10/2004 14:15'!
primitiveObsoleteIndexedPrimitive
	"Primitive. Invoke an obsolete indexed primitive."

	| pluginName functionName functionAddress |
	self var: #pluginName declareC: 'char *pluginName'.
	self var: #functionName declareC: 'char *functionName'.
	self var: #functionAddress declareC: 'void *functionAddress'.
	functionAddress _ self cCoerce: ((obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 2) to: 'void *'.
	functionAddress = nil 
		ifFalse: [^self cCode: '((sqInt (*)(void))functionAddress)()'
					inSmalltalk: [self callExternalPrimitive: functionAddress]].
	pluginName _ (obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 0.
	functionName _ (obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 1.
	(pluginName = nil and: [functionName = nil]) 
		ifTrue: [^self primitiveFail].
	functionAddress _ self ioLoadFunction: functionName From: pluginName.
	functionAddress = 0 ifFalse: ["Cache for future use"
		(obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 2 put: 
			(self cCoerce: functionAddress to: 'char*').
		^self cCode: '((sqInt (*)(void))functionAddress)()'
				inSmalltalk: [self callExternalPrimitive: functionAddress]].
	^self primitiveFail! !

!Interpreter methodsFor: 'other primitives' stamp: 'ikp 3/31/2005 11:48'!
primitiveVMParameter
	"Behaviour depends on argument count:
		0 args:	return an Array of VM parameter values;
		1 arg:	return the indicated VM parameter;
		2 args:	set the VM indicated parameter.
	VM parameters are numbered as follows:
		1	end of old-space (0-based, read-only)
		2	end of young-space (read-only)
		3	end of memory (read-only)
		4	allocationCount (read-only)
		5	allocations between GCs (read-write)
		6	survivor count tenuring threshold (read-write)
		7	full GCs since startup (read-only)
		8	total milliseconds in full GCs since startup (read-only)
		9	incremental GCs since startup (read-only)
		10	total milliseconds in incremental GCs since startup (read-only)
		11	tenures of surving objects since startup (read-only)
		12-20 specific to the translating VM
		21	root table size (read-only)
		22	root table overflows since startup (read-only)
		23	bytes of extra memory to reserve for VM buffers, plugins, etc.

		24	memory headroom when growing object memory (rw)
		25	memory threshold above which shrinking object memory (rw)
		26	interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image is not calling getNextEvent often (rw)
		27	BytesPerWord for this image

	Note: Thanks to Ian Piumarta for this primitive."

	| mem paramsArraySize result arg index |
	mem _ self startOfMemory.
	paramsArraySize _ 27.
	argumentCount = 0 ifTrue: [
		result _ self instantiateClass: (self splObj: ClassArray) indexableSize: paramsArraySize.
		0 to: paramsArraySize - 1 do:
			[:i | self storePointer: i ofObject: result withValue: (self integerObjectOf: 0)].
		self storePointer: 0	ofObject: result withValue: (self integerObjectOf: youngStart - mem).
		self storePointer: 1		ofObject: result withValue: (self integerObjectOf: freeBlock - mem).
		self storePointer: 2	ofObject: result withValue: (self integerObjectOf: endOfMemory - mem).
		self storePointer: 3	ofObject: result withValue: (self integerObjectOf: allocationCount).
		self storePointer: 4	ofObject: result withValue: (self integerObjectOf: allocationsBetweenGCs).
		self storePointer: 5	ofObject: result withValue: (self integerObjectOf: tenuringThreshold).
		self storePointer: 6	ofObject: result withValue: (self integerObjectOf: statFullGCs).
		self storePointer: 7	ofObject: result withValue: (self integerObjectOf: statFullGCMSecs).
		self storePointer: 8	ofObject: result withValue: (self integerObjectOf: statIncrGCs).
		self storePointer: 9	ofObject: result withValue: (self integerObjectOf: statIncrGCMSecs).
		self storePointer: 10	ofObject: result withValue: (self integerObjectOf: statTenures).
		self storePointer: 20	ofObject: result withValue: (self integerObjectOf: rootTableCount).
		self storePointer: 21	ofObject: result withValue: (self integerObjectOf: statRootTableOverflows).
		self storePointer: 22	ofObject: result withValue: (self integerObjectOf: extraVMMemory).
		self storePointer: 23	ofObject: result withValue: (self integerObjectOf: shrinkThreshold).
		self storePointer: 24	ofObject: result withValue: (self integerObjectOf: growHeadroom).
		self storePointer: 25	ofObject: result withValue: (self integerObjectOf: interruptChecksEveryNms).
		self storePointer: 26	ofObject: result withValue: (self integerObjectOf: BytesPerWord).
		self pop: 1 thenPush: result.
		^nil].

	arg _ self stackTop.
	(self isIntegerObject: arg) ifFalse: [^self primitiveFail].
	arg _ self integerValueOf: arg.
	argumentCount = 1 ifTrue: [	 "read VM parameter"
		(arg < 1 or: [arg > paramsArraySize]) ifTrue: [^self primitiveFail].
		arg = 1		ifTrue: [result _ youngStart - mem].
		arg = 2		ifTrue: [result _ freeBlock - mem].
		arg = 3		ifTrue: [result _ endOfMemory - mem].
		arg = 4		ifTrue: [result _ allocationCount].
		arg = 5		ifTrue: [result _ allocationsBetweenGCs].
		arg = 6		ifTrue: [result _ tenuringThreshold].
		arg = 7		ifTrue: [result _ statFullGCs].
		arg = 8		ifTrue: [result _ statFullGCMSecs].
		arg = 9		ifTrue: [result _ statIncrGCs].
		arg = 10		ifTrue: [result _ statIncrGCMSecs].
		arg = 11		ifTrue: [result _ statTenures].
		((arg >= 12) and: [arg <= 20]) ifTrue: [result _ 0].
		arg = 21		ifTrue: [result _ rootTableCount].
		arg = 22		ifTrue: [result _ statRootTableOverflows].
		arg = 23		ifTrue: [result _ extraVMMemory].
		arg = 24		ifTrue: [result _ shrinkThreshold].
		arg = 25 	ifTrue: [result _ growHeadroom].
		arg = 26		ifTrue: [result _ interruptChecksEveryNms]. 
		arg = 27 	ifTrue: [result _ BytesPerWord].
		self pop: 2 thenPush: (self integerObjectOf: result).
		^nil].

	"write a VM parameter"
	argumentCount = 2 ifFalse: [^self primitiveFail].
	index _ self stackValue: 1.
	(self isIntegerObject: index) ifFalse: [^self primitiveFail].
	index _ self integerValueOf: index.
	index <= 0 ifTrue: [^self primitiveFail].
	successFlag _ false.
	index = 5 ifTrue: [
		result _ allocationsBetweenGCs.
		allocationsBetweenGCs _ arg.
		successFlag _ true].
	index = 6 ifTrue: [
		result _ tenuringThreshold.
		tenuringThreshold _ arg.
		successFlag _ true].
	index = 23 ifTrue: [
		result _ extraVMMemory.
		extraVMMemory _ arg.
		successFlag _ true].
	index = 24 ifTrue: [
		result _ shrinkThreshold.
		arg > 0 ifTrue:[
			shrinkThreshold _ arg.
			successFlag _ true]].
	index = 25 ifTrue: [
		result _ growHeadroom.
		arg > 0 ifTrue:[
			growHeadroom _ arg.
			successFlag _ true]].
	index = 26 ifTrue: [
		arg > 1 ifTrue:[
			result _ interruptChecksEveryNms.
			interruptChecksEveryNms _ arg.
			successFlag _ true]]. 

	successFlag ifTrue: [
		self pop: 3 thenPush: (self integerObjectOf: result).  "return old value"
		^ nil].

	self primitiveFail.  "attempting to write a read-only parameter"
! !

!Interpreter methodsFor: 'Ian fixes for missing stuff' stamp: 'ikp 8/2/2004 18:08'!
dispatchFunctionPointer: aFunctionPointer

	self var: #aFunctionPointer type: 'void *'.
	self cCode: '((void (*)(void))aFunctionPointer)()'
			inSmalltalk: [self error: 'my simulator should simulate me']! !

!Interpreter methodsFor: 'Ian fixes for missing stuff' stamp: 'ikp 8/2/2004 18:18'!
dispatchFunctionPointerOn: primIdx in: primTable
	"Call the primitive at index primIdx in the primitiveTable."

	self var: #primTable declareC: 'void *primTable[]'.
	^self dispatchFunctionPointer: (primTable at: primIdx)! !

!Interpreter methodsFor: 'bitblt support' stamp: 'ikp 6/10/2004 14:04'!
copyBits
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin_copyBits
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"

	| fn |
	self var: #fn declareC: 'void *fn'.
	fn _ self ioLoadFunction: 'copyBits' From: 'BitBltPlugin'.
	fn = 0 ifTrue: [^self primitiveFail].
	^self cCode: '((sqInt (*)(void))fn)()'! !

!Interpreter methodsFor: 'bitblt support' stamp: 'ikp 6/10/2004 11:47'!
copyBitsFrom: x0 to: x1 at: y
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin_copyBitsFrom:to:at:
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"

	| fn |
	self var: #fn declareC: 'void *fn'.
	fn _ self ioLoadFunction: 'copyBitsFromtoat' From: 'BitBltPlugin'.
	fn = 0 ifTrue: [^self primitiveFail].
	^self cCode: '((sqInt (*)(sqInt, sqInt, sqInt))fn)(x0, x1, y)'! !

!Interpreter methodsFor: 'bitblt support' stamp: 'ikp 6/10/2004 11:52'!
loadBitBltFrom: bb
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin_loadBitBltFrom
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"
	| fn |
	self var: #fn declareC: 'void *fn'.
	fn _ self ioLoadFunction: 'loadBitBltFrom' From: 'BitBltPlugin'.
	fn = 0 ifTrue: [^self primitiveFail].
	^self cCode: '((sqInt (*)(sqInt))fn)(bb)'! !


!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'ikp 8/2/2004 17:59'!
functionPointerFor: primIndex inClass: lookupClass
	"Override Interpreter to handle the external primitives caching.  See also 	internalExecuteNewMethod."

	^(primIndex between: 1 and: MaxPrimitiveIndex)
		ifTrue: [primitiveTable at: primIndex + 1]! !

!InterpreterSimulator methodsFor: 'interpreter shell' stamp: 'tpr 6/23/2004 15:12'!
internalExecuteNewMethod
"Override the Interpreter version to trap cached external prims.
These have a 'prim index' of 1000 + the externalPrimitiveTableIndex normally used"
	primitiveIndex < 1000 ifTrue:[^super internalExecuteNewMethod].
	self externalizeIPandSP.
	self callExternalPrimitive: (externalPrimitiveTable at: primitiveIndex - 1001).
	self internalizeIPandSP! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:09'!
byteAtPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	pointer is a raw address, and byte is an 8-bit quantity."

	^ self byteAt: pointer! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:13'!
byteAtPointer: pointer put: byteValue
	"This gets implemented by Macros in C, where its types will also be checked.
	pointer is a raw address, and byteValue is an 8-bit quantity."

	^ self byteAt: pointer  put: byteValue! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/17/2004 12:59'!
firstIndexableField: oop
	"NOTE: overridden from Interpreter to add coercion to CArray"

	| hdr fmt totalLength fixedFields |
	self returnTypeC: 'void *'.
	hdr _ self baseHeader: oop.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: oop baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: oop format: fmt length: totalLength.
	fmt < 8 ifTrue:
		[fmt = 6 ifTrue:
			["32 bit field objects"
			^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << 2)) to: 'int *'].
		"full word objects (pointer or bits)"
		^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)) to: 'oop *']
		ifFalse:
		["Byte objects"
		^ self cCoerce: (self pointerForOop: oop + BaseHeaderSize + fixedFields) to: 'char *']! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/16/2004 14:56'!
halfWordHighInLong32: long32
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/16/2004 14:57'!
halfWordLowInLong32: long32
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 8/5/2004 22:09'!
integerObjectOf: value
	"The simulator works with strictly positive bit patterns"
	value < 0
		ifTrue: [^ ((16r80000000 + value) << 1) + 1]
		ifFalse: [^ (value << 1) + 1]! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/3/2004 10:47'!
long32At: byteAddress
	"Return the 32-bit word at byteAddress which must be 0 mod 4."

	^ self longAt: byteAddress! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 7/3/2004 10:47'!
long32At: byteAddress put: a32BitValue
	"Store the 32-bit value at byteAddress which must be 0 mod 4."

	^ self longAt: byteAddress put: a32BitValue! !

!InterpreterSimulator methodsFor: 'memory access'!
longAt: byteAddress
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^memory at: (byteAddress // 4) + 1! !

!InterpreterSimulator methodsFor: 'memory access'!
longAt: byteAddress put: a32BitValue
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^memory at: (byteAddress // 4) + 1 put: a32BitValue! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:03'!
longAtPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	pointer is a raw address, and the result is the width of a machine word."

	^ self longAt: pointer! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:05'!
longAtPointer: pointer put: longValue
	"This gets implemented by Macros in C, where its types will also be checked.
	pointer is a raw address, and longValue is the width of a machine word."

	^ self longAt: pointer put: longValue! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:07'!
oopForPointer: pointer
	"This gets implemented by Macros in C, where its types will also be checked.
	oop is the width of a machine word, and pointer is a raw address."

	^ pointer! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:07'!
pointerForOop: oop
	"This gets implemented by Macros in C, where its types will also be checked.
	oop is the width of a machine word, and pointer is a raw address."

	^ oop! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:29'!
shortAt: byteAddress
    "Return the half-word at byteAddress which must be even."
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 6/23/2004 14:32'!
shortAt: byteAddress put: a16BitValue
	^ self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 5/11/2004 18:29'!
sqGrowMemory: oldLimit By: delta

	transcript show: 'grow memory from ', oldLimit printString, ' by ', delta printString; cr.
	memory _ memory , (memory class new: delta // 4).
	^ memory size * 4! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'di 5/11/2004 18:29'!
sqShrinkMemory: oldLimit By: delta
	transcript show: 'shrink memory from ', oldLimit printString, ' by ', delta printString, ' remember it doesn''t actually shrink in simulation'; cr.

	^ oldLimit! !

!InterpreterSimulator methodsFor: 'plugin support' stamp: 'di 7/17/2004 10:23'!
loadNewPlugin: pluginString
	| plugin simClass |
	transcript cr; show:'Looking for module ', pluginString.
	(#('FloatArrayPlugin' 'Matrix2x3Plugin')
		includes: pluginString) ifTrue:
		[transcript show: ' ... defeated'. ^ nil].
	plugin _ simClass _ nil.
	InterpreterPlugin allSubclassesDo:[:plg|
		plg moduleName asString = pluginString asString ifTrue:[
			simClass _ plg simulatorClass.
			plugin ifNil:[plugin _ simClass]
				ifNotNil:[plugin == simClass ifFalse:[^self error:'This won''t work...']].
		].
	].
	plugin ifNil:[transcript show: ' ... not found'. ^nil].
	plugin _ plugin new.
	plugin setInterpreter: self. "Ignore return value from setInterpreter"
	(plugin respondsTo: #initialiseModule) ifTrue:[
		plugin initialiseModule ifFalse:[transcript show: ' ... initialiser failed'.^nil]. "module initialiser failed"
	].
	pluginList _ pluginList copyWith: (pluginString asString -> plugin).
	transcript show:' ... loaded'.
	^pluginList last! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/20/2004 12:07'!
allObjectsDo: objBlock

	| oop |
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue:
			[(self isFreeObject: oop)
				ifFalse: [objBlock value: oop].
			oop _ self objectAfter: oop].
! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/20/2004 12:11'!
allObjectsSelect: objBlock
	"self allObjectsSelect: [:oop | (self baseHeader: oop) = 1234]"

	| oop selected |
	oop _ self firstObject.
	selected _ OrderedCollection new.
	[oop < endOfMemory] whileTrue:
			[(self isFreeObject: oop)
				ifFalse: [(objBlock value: oop) ifTrue: [selected addLast: oop]].
			oop _ self objectAfter: oop].
	^ selected! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/21/2004 15:05'!
byteCount
	"So you can call this from temp debug statements in, eg, Interpreter, such as
	self byteCount = 12661 ifTrue: [self halt].
	"

	^ byteCount! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/28/2004 17:24'!
checkForInterrupts
	"Prevent interrupts so that traces are consistent during detailed debugging"

	true ifTrue: [^ self].
	^ super checkForInterrupts! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/21/2004 15:58'!
fullDisplayUpdate
	"Preserve successFlag when call asynchronously from Simulator"
	| s |
	s _ successFlag.
	successFlag _ true.
	super fullDisplayUpdate.
	successFlag _ s! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 5/11/2004 18:26'!
fullGC
	transcript cr; show:'<Running full GC ...'.
	super fullGC.
	transcript show: ' done>'.! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 14:39'!
longPrint: oop
	| lastPtr val lastLong hdrType prevVal |
	(self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
	^ String streamContents:
		[:strm |
		lastPtr _ 64*BytesPerWord min: (self lastPointerOf: oop).
		hdrType _ self headerType: oop.
		hdrType = 2 ifTrue: [lastPtr _ 0].
		prevVal _ 0.
		(self headerStart: oop) to: lastPtr by: BytesPerWord do:
			[:a | val _ self longAt: oop+a.
			(a > 0 and: [(val = prevVal) & (a ~= lastPtr)])
			ifTrue:
			[prevVal = (self longAt: oop+a-(BytesPerWord*2)) ifFalse: [strm cr; nextPutAll: '        ...etc...']]
			ifFalse:
			[strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
				space; space; space; nextPutAll: val hex8; space; space.
			a = (BytesPerWord*2) negated ifTrue:
				[strm nextPutAll: 'size = ' , (val - hdrType) hex].
			a = BytesPerWord negated ifTrue:
				[strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>'].
			a = 0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)].
			a > 0 ifTrue: [strm nextPutAll: (self shortPrint: val)].
			a = BytesPerWord ifTrue:
				[(self fetchClassOf: oop) = (self splObj: ClassCompiledMethod) ifTrue:
							[strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]].
			prevVal _ val].
		lastLong _ 256 min: (self sizeBitsOf: oop) - BaseHeaderSize.
		hdrType = 2
			ifTrue:
			["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex;
			space; space; nextPutAll: (oop+(self longAt: oop)-2) printString]
			ifFalse:
			[(self formatOf: oop) = 3
			ifTrue:
				[strm cr; tab; nextPutAll: '/ next 3 fields are above SP... /'.
				lastPtr+BytesPerWord to: lastPtr+(3*BytesPerWord) by: BytesPerWord do:
					[:a | val _ self longAt: oop+a.
					strm cr; nextPutAll: a hex; 
						space; space; space; nextPutAll: val hex8; space; space.
					(self validOop: val) ifTrue: [strm nextPutAll: (self shortPrint: val)]]]
			ifFalse:
			[lastPtr+BytesPerWord to: lastLong by: BytesPerWord do:
				[:a | val _ self longAt: oop+a.
				strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
					space; space; space.
				strm nextPutAll: val hex8; space; space;
						nextPutAll: (self charsOfLong: val)]]].
	]! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/29/2004 14:27'!
lookupMethodInClass: class
	| currentClass dictionary found rclass |

	"This method overrides the interp, causing a halt on MNU."
	"true ifTrue: [^ super lookupMethodInClass: class]."    "Defeat debug support"

	currentClass _ class.
	[currentClass ~= nilObj]
		whileTrue:
		[dictionary _ self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
		dictionary = nilObj ifTrue:
			["MethodDict pointer is nil (hopefully due a swapped out stub)
				-- raise exception #cannotInterpret:."
			self pushRemappableOop: currentClass.  "may cause GC!!"
			self createActualMessageTo: class.
			currentClass _ self popRemappableOop.
			messageSelector _ self splObj: SelectorCannotInterpret.
			^ self lookupMethodInClass: (self superclassOf: currentClass)].

		found _ self lookupMethodInDictionary: dictionary.
		found ifTrue: [^ methodClass _ currentClass].
		currentClass _ self superclassOf: currentClass].

	"Could not find #doesNotUnderstand: -- unrecoverable error."
	messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue:
		[self error: 'Recursive not understood error encountered'].

self halt: (self stringOf: messageSelector).

	"Cound not find a normal message -- raise exception #doesNotUnderstand:"
	self pushRemappableOop: class.  "may cause GC!!"
	self createActualMessageTo: class.
	rclass _ self popRemappableOop.
	messageSelector _ self splObj: SelectorDoesNotUnderstand.
	^ self lookupMethodInClass: rclass! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/13/2004 07:00'!
nameOfClass: classOop
	(self sizeBitsOf: classOop) = (Metaclass instSize +1*BytesPerWord) ifTrue:
		[^ (self nameOfClass:
				(self fetchPointer: 5 "thisClass" ofObject: classOop)) , ' class'].
	^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 14:48'!
printStack
	^ self printStack: false! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 14:49'!
printStack: includeTemps
	| ctxt |
	ctxt _ activeContext.
	^ String streamContents:
		[:strm |
		[self printStackFrame: ctxt onStream: strm.
		includeTemps ifTrue: [self printStackTemps: ctxt onStream: strm].
		(ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj]
				whileFalse: [].
		]! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 14:49'!
printStackFrame: ctxt onStream: strm
	| classAndSel home |
	home _ (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
		ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
		ifFalse: [ctxt].
	classAndSel _ self
		classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
		forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
	strm cr; nextPutAll: ctxt hex8.
	ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
	strm space; nextPutAll: (self nameOfClass: classAndSel first).
	strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/20/2004 22:23'!
printStackTemps: ctxt onStream: strm
	| home cMethod nArgs nTemps oop |
	home _ (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
		ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
		ifFalse: [ctxt].
	cMethod _ self fetchPointer: MethodIndex ofObject: home.
	nArgs _ nTemps _ 0.

	home = ctxt ifTrue:
		[strm cr; tab; nextPutAll: 'args: '.
		nArgs _ self argumentCountOf: cMethod.
		1 to: nArgs do:
			[:i | oop _ self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
			strm nextPutAll: oop hex; space].

		strm cr; tab; nextPutAll: 'temps: '.
		nTemps _ self tempCountOf: cMethod.
		nArgs+1 to: nTemps do:
			[:i | oop _ self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
			strm nextPutAll: oop hex; space]].
	
	strm cr; tab; nextPutAll: 'stack: '.
	nTemps + 1 to: (self lastPointerOf: ctxt)//BytesPerWord - TempFrameStart do:
		[:i | oop _ self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
			strm nextPutAll: oop hex; space].
	! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 15:28'!
printStackWithTemps
	^ self printStack: true! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/15/2004 09:21'!
printTop: n
	"Print important fields of the top n contexts"
	| ctxt classAndSel home top ip sp |
	ctxt _ activeContext.
	^ String streamContents:
		[:strm | 1 to: n do:
			[:i |
			home _ (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
				ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
				ifFalse: [ctxt].
			classAndSel _ self
				classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
				forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
			strm cr; nextPutAll: ctxt hex8.
			ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
			strm space; nextPutAll: (self nameOfClass: classAndSel first).
			strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
			ctxt = activeContext
				ifTrue: [ip _ instructionPointer - method - (BaseHeaderSize - 2).
						sp _ self stackPointerIndex - TempFrameStart + 1.
						top _ self stackTop]
				ifFalse: [ip _ self integerValueOf:
							(self fetchPointer: InstructionPointerIndex ofObject: ctxt).
						sp _ self integerValueOf:
							(self fetchPointer: StackPointerIndex ofObject: ctxt).
						top _ self longAt: ctxt + (self lastPointerOf: ctxt)].
			strm cr; tab; nextPutAll: 'ip = '; print: ip.
			strm cr; tab; nextPutAll: 'sp = '; print: sp.
			strm cr; tab; nextPutAll: 'top = '; nextPutAll: (self shortPrint: top).
			(ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj
				ifTrue: [^strm contents].
			].
		]! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 7/19/2004 14:35'!
shortPrint: oop
	| name classOop |
	(self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString , 
		' (' , (self integerValueOf: oop) hex , ')'].
	classOop _ self fetchClassOf: oop.
	(self sizeBitsOf: classOop) = (Metaclass instSize +1*BytesPerWord) ifTrue: [
		^ 'class ' , (self nameOfClass: oop)].
	name _ self nameOfClass: classOop.
	name size = 0 ifTrue: [name _ '??'].
	name = 'String' ifTrue: [^ (self stringOf: oop) printString].
	name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
	name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf: 
				(self fetchPointer: 0 ofObject: oop))) printString].
	name = 'UndefinedObject' ifTrue: [^ 'nil'].
	name = 'False' ifTrue: [^ 'false'].
	name = 'True' ifTrue: [^ 'true'].
	name = 'Float' ifTrue: [successFlag _ true. ^ '=' , (self floatValueOf: oop) printString].
	name = 'Association' ifTrue: [^ '(' ,
				(self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
				' -> ' ,
				(self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')'].
	('AEIOU' includes: name first)
		ifTrue: [^ 'an ' , name]
		ifFalse: [^ 'a ' , name]! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 6/13/2004 07:07'!
stringOf: oop
	| size long nLongs chars |
	^ String streamContents:
		[:strm |
		size _ 100 min: (self stSizeOf: oop).
		nLongs _ size-1//BytesPerWord+1.
		1 to: nLongs do:
			[:i | long _ self longAt: oop + BaseHeaderSize + (i-1*BytesPerWord).
			chars _ self charsOfLong: long.
			strm nextPutAll: (i=nLongs
							ifTrue: [chars copyFrom: 1 to: size-1\\BytesPerWord+1]
							ifFalse: [chars])]]! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 7/9/2004 11:05'!
fullDisplay
	| t |
	displayForm == nil ifTrue: [^ self].
	t _ successFlag.  successFlag _ true.
	self displayBitsOf: (self splObj: TheDisplay) Left: 0 Top: 0 Right: displayForm width Bottom: displayForm height.
	successFlag _ t! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 4/20/2004 23:59'!
primitiveBeDisplay
	"Extended to create a scratch Form for use by showDisplayBits."

	| rcvr destWidth destHeight destDepth |
	rcvr _ self stackTop.
	self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
	successFlag ifTrue: [
		destWidth _ self fetchInteger: 1 ofObject: rcvr.
		destHeight _ self fetchInteger: 2 ofObject: rcvr.
		destDepth _ self fetchInteger: 3 ofObject: rcvr.
	].
	successFlag ifTrue: [
		"create a scratch form the same size as Smalltalk displayObj"
		displayForm _ Form extent: destWidth @ destHeight
							depth: destDepth.
		displayView ifNotNil: [displayView image: displayForm].
	].
	super primitiveBeDisplay.! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 4/21/2004 00:21'!
primitiveMousePoint

	| relPt |
	self pop: 1.
	displayForm == nil
		ifTrue: [self push: (self makePointwithxValue: 99 yValue: 66)]
		ifFalse: [relPt _ Sensor cursorPoint - self displayLocation.
				self push: (self makePointwithxValue: relPt x yValue: relPt y)]! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 7/6/2004 10:48'!
showDisplayBits: destBits w: w h: h d: d left: left right: right top: top bottom: bottom
	| raster pixPerWord simDisp realDisp rect |
	pixPerWord _ 32 // d.
	raster _ displayForm width + (pixPerWord - 1) // pixPerWord.
	simDisp _ Form new hackBits: memory.
	displayForm unhibernate.
	realDisp _ Form new hackBits: displayForm bits.
	realDisp
		copy: (0 @ (top * raster) extent: 4 @ (bottom - top * raster))
		from: 0 @ (destBits // 4 + (top * raster))
		in: simDisp
		rule: Form over.
	displayView ifNotNil: [^ displayView changed].
	
	"If running without a view, just blat the bits onto the screen..."
	rect _ 0 @ top corner: displayForm width @ bottom.
	Display
		copy: (rect translateBy: self displayLocation)
		from: rect topLeft
		in: displayForm
		rule: Form over! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 5/8/2004 16:42'!
convertToArray
	"I dont believe it -- this *just works*"
	
	memory _ memory as: Array! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 8/5/2004 22:10'!
initialize

	"Initialize the InterpreterSimulator when running the interpreter inside
	Smalltalk. The primary responsibility of this method is to allocate
	Smalltalk Arrays for variables that will be declared as statically-allocated
	global arrays in the translated code."

	"initialize class variables"
	ObjectMemory initBytesPerWord: self bytesPerWord.
	ObjectMemory initialize.
	Interpreter initialize.

	"Note: we must initialize ConstMinusOne differently for simulation,
		due to the fact that the simulator works only with +ve 32-bit values"
	ConstMinusOne _ self integerObjectOf: -1.

	methodCache _ Array new: MethodCacheSize.
	atCache _ Array new: AtCacheTotalSize.
	self flushMethodCache.
	rootTable _ Array new: RootTableSize.
	remapBuffer _ Array new: RemapBufferSize.
	semaphoresUseBufferA _ true.
	semaphoresToSignalA _ Array new: SemaphoresToSignalSize.
	semaphoresToSignalB _ Array new: SemaphoresToSignalSize.
	externalPrimitiveTable _ CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
	primitiveTable _ self class primitiveTable.
	obsoleteNamedPrimitiveTable _ 
		CArrayAccessor on: (self class obsoleteNamedPrimitiveTable copyWith: (Array new: 3)).
	obsoleteIndexedPrimitiveTable _ CArrayAccessor on: 
		(self class obsoleteIndexedPrimitiveTable collect:[:spec| 
			CArrayAccessor on:
				(spec ifNil:[Array new: 3] 
					  ifNotNil:[Array with: spec first with: spec second with: nil])]).
	pluginList _ #().
	mappedPluginEntries _ #().

	"initialize InterpreterSimulator variables used for debugging"
	byteCount _ 0.
	sendCount _ 0.
	quitBlock _ [^ self].
	traceOn _ true.
	myBitBlt _ BitBltSimulator new setInterpreter: self.
	filesOpen _ OrderedCollection new.
	headerTypeBytes _ CArrayAccessor on: (Array with: BytesPerWord*2 with: BytesPerWord with: 0 with: 0).
	transcript _ Transcript.
	displayForm _ 'Display has not yet been installed' asDisplayText form.
	! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 7/1/2004 14:15'!
openOn: fileName
	"(InterpreterSimulator new openOn: 'clonex.image') test"

	self openOn: fileName extraMemory: 2500000.! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 6/11/2004 13:17'!
openOn: fileName extraMemory: extraBytes
	"InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"

	| f version headerSize count oldBaseAddr bytesToShift swapBytes |
	"open image file and read the header"

	["begin ensure block..."
	f _ FileStream readOnlyFileNamed: fileName.
	imageName _ f fullName.
	f binary.
	version _ self nextLongFrom: f.  "current version: 16r1966 (=6502)"
	(self readableFormat: version)
		ifTrue: [swapBytes _ false]
		ifFalse: [(version _ self byteSwapped: version) = self imageFormatVersion
					ifTrue: [swapBytes _ true]
					ifFalse: [self error: 'incomaptible image format']].
	headerSize _ self nextLongFrom: f swap: swapBytes.
	endOfMemory _ self nextLongFrom: f swap: swapBytes.  "first unused location in heap"
	oldBaseAddr _ self nextLongFrom: f swap: swapBytes.  "object memory base address of image"
	specialObjectsOop _ self nextLongFrom: f swap: swapBytes.
	lastHash _ self nextLongFrom: f swap: swapBytes.  "Should be loaded from, and saved to the image header"
	lastHash = 0 ifTrue: [lastHash _ 999].

	savedWindowSize	_ self nextLongFrom: f swap: swapBytes.
	fullScreenFlag		_ self nextLongFrom: f swap: swapBytes.
	extraVMMemory		_ self nextLongFrom: f swap: swapBytes.

	"allocate interpreter memory"
	memoryLimit _ endOfMemory + extraBytes.

	"read in the image in bulk, then swap the bytes if necessary"
	f position: headerSize.
	memory _ Bitmap new: memoryLimit // 4.
	count _ f readInto: memory startingAt: 1 count: endOfMemory // 4.
	count ~= (endOfMemory // 4) ifTrue: [self halt].
	]
		ensure: [f close].

	swapBytes ifTrue: [Utilities informUser: 'Swapping bytes of foreign image...'
								during: [self reverseBytesInImage]].

	self initialize.
	bytesToShift _ 0 - oldBaseAddr.  "adjust pointers for zero base address"
	endOfMemory _ endOfMemory.
	Utilities informUser: 'Relocating object pointers...'
				during: [self initializeInterpreter: bytesToShift].
! !

!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 7/1/2004 13:55'!
ioMSecs
	"Return the value of the millisecond clock."
	"NOT.  Actually, we want something a lot slower and, for exact debugging,
	something more repeatable than real time.  IO have an idea: use the byteCount..."

	^ byteCount // 100
	
"At 20k bytecodes per second, this gives us aobut 200 ticks per second, or about 1/5 of what you'd expect for the real time clock.  This should still service events at one or two per second"! !

!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 8/3/2004 14:50'!
sizeof: var

	self flag: #Dan.
	^ 4! !

!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 5/11/2004 18:26'!
cr

	traceOn ifTrue: [ transcript cr; endEntry ].! !

!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 5/11/2004 18:28'!
print: s

	traceOn ifTrue: [ transcript show: s ]! !

!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 5/11/2004 18:28'!
printChar: aByte

	traceOn ifTrue: [ transcript nextPut: aByte asCharacter ].! !

!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 5/11/2004 18:28'!
printNum: anInteger

	traceOn ifTrue: [ transcript show: anInteger printString ].! !

!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 6/15/2004 09:53'!
symbolic: byte at: ip inMethod: meth
	"Print a bytecode in simple symbolic form"

	| type offset |
	type _ byte // 16.  
	offset _ byte \\ 16.  
	type=0 ifTrue: [^ 'pushRcvr ' , offset printString].
	type=1 ifTrue: [^ 'pushTemp ' , offset printString].
	type=2 ifTrue: [^ 'pushLit ' , offset printString].
	type=3 ifTrue: [^ 'pushLit ' , (offset+16) printString].
	type=4 ifTrue: [^ 'pushLitVar ' , offset printString].
	type=5 ifTrue: [^ 'pushLitVar ' , (offset+16) printString].
	type=6 ifTrue: [offset<8
					ifTrue: [^ 'storePopRcvr ' , offset printString]
					ifFalse: [^ 'storePopTemp ' , (offset-8) printString]].
	type=7 ifTrue: [offset=0 ifTrue: [^ 'pushRcvr'].
				offset<8 ifTrue: [^ 'pushConst ' , ( #(true false nil -1 0 1 2) at: offset) printString].
				offset=8 ifTrue: [^ 'returnSelf'].
				offset<12 ifTrue: [^ 'returnConst ' , ( #(true false nil -1 0 1 2) at: offset-8) printString].
				offset=12 ifTrue: [^ 'returnTop'].
				offset=13 ifTrue: [^ 'blockReturnTop'].
				offset>13 ifTrue: [^ 'unusedBytecode']].
	type=8 ifTrue: [^ self symbolicExtensions: offset at: ip inMethod: meth].
	type=9 ifTrue:  "short jumps"
			[offset<8 ifTrue: [^ 'jump ' , (offset+1) printString].
			^ 'jumpIfFalse ' , (offset-8+1) printString].
	type=10 ifTrue:  "long jumps"
			[offset<8 ifTrue: [^ 'extendedJump'].
			offset<12 ifTrue: [^ 'extendedJumpIfTrue'].
			true ifTrue: [^ 'extendedJumpIfFalse']].
	type=11 ifTrue: [^ 'sendSpl ' , (Smalltalk specialSelectorAt: offset+1)].
	type=12 ifTrue: [^ 'sendSpl ' , (Smalltalk specialSelectorAt: offset+17)].
	type>12 ifTrue: [^ 'send ' , (self stringOf: (self literal: offset))]! !

!InterpreterSimulator methodsFor: 'debug printing' stamp: 'di 6/15/2004 10:11'!
symbolicExtensions: offset at: ip inMethod: meth
	| type offset2 byte2 byte3 |
	offset <=6 ifTrue: 
		["Extended op codes 128-134"
		byte2 _ self byteAt: ip+1.
		offset <= 2 ifTrue:
			["128-130:  extended pushes and pops"
			type _ byte2 // 64.
			offset2 _ byte2 \\ 64.
			offset = 0 ifTrue: 
				[type = 0 ifTrue: [^ 'pushRcvr ' , offset2 printString].
				type = 1 ifTrue: [^ 'pushTemp ' , offset2 printString].
				type = 2  ifTrue: [^ 'pushLit ' , (offset2 + 1) printString].
				type = 3 ifTrue: [^ 'pushLitVar ' , (offset2 + 1) printString]].
			offset = 1 ifTrue: 
				[type = 0 ifTrue: [^ 'storeIntoRcvr ' , offset2 printString].
				type = 1 ifTrue: [^ 'storeIntoTemp ' , offset2 printString].
				type = 2 ifTrue: [^ 'illegalStore'].
				type = 3 ifTrue: [^ 'storeIntoLitVar ' , (offset2 + 1) printString]].
			offset = 2 ifTrue: 
				[type = 0 ifTrue: [^ 'storePopRcvr ' , offset2 printString].
				type = 1 ifTrue: [^ 'storePopTemp ' , offset2 printString].
				type = 2 ifTrue: [^ 'illegalStore'].
				type = 3  ifTrue: [^ 'storePopLitVar ' , (offset2 + 1) printString]]].
		"131-134: extended sends"
		offset = 3 ifTrue:  "Single extended send"
			[^ 'send ' , (self stringOf: (self literal: byte2 \\ 32))].
		offset = 4 ifTrue:    "Double extended do-anything"
			[byte3 _ self byteAt: ip+2.
			type _ byte2 // 32.
			type = 0 ifTrue: [^ 'send ' , (self stringOf: (self literal: byte3))].
			type = 1 ifTrue: [^ 'superSend ' , (self stringOf: (self literal: byte3))].
			type = 2 ifTrue: [^ 'pushRcvr ' , byte3 printString].
			type = 3 ifTrue: [^ 'pushLit ' , byte3 printString].
			type = 4 ifTrue: [^ 'pushLitVar ' , byte3 printString].
			type = 5 ifTrue: [^ 'storeIntoRcvr ' , byte3 printString].
			type = 6 ifTrue: [^ 'storePopRcvr ' , byte3 printString].
			type = 7 ifTrue: [^ 'storeIntoLitVar ' , byte3 printString]].
		offset = 5 ifTrue:  "Single extended send to super"
			[^ 'superSend ' , (self stringOf: (self literal: byte2 \\ 32))].
		offset = 6 ifTrue:   "Second extended send"
			[^ 'send ' , (self stringOf: (self literal: byte2 \\ 64))]].
	offset = 7 ifTrue: [^ 'doPop'].
	offset = 8 ifTrue: [^ 'doDup'].
	offset = 9 ifTrue: [^ 'pushActiveContext'].
	^ 'unusedBytecode'! !

!InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 6/13/2004 10:31'!
fetchFloatAt: floatBitsAddress into: aFloat

	aFloat at: 1 put: (self long32At: floatBitsAddress).
	aFloat at: 2 put: (self long32At: floatBitsAddress+4).
! !

!InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 6/13/2004 10:45'!
storeFloatAt: floatBitsAddress from: aFloat.

	self long32At: floatBitsAddress put: (aFloat at: 1).
	self long32At: floatBitsAddress+4 put: (aFloat at: 2).
! !

!InterpreterSimulator methodsFor: 'file primitives' stamp: 'di 7/2/2004 12:35'!
primitiveDirectoryLookup
	| index pathName array result |
	index _ self stackIntegerValue: 0.
	pathName _ (self stringOf: (self stackValue: 1)).
	
	successFlag ifFalse: [
		^self primitiveFail.
	].

	array _ FileDirectory default primLookupEntryIn: pathName index: index.

	array == nil ifTrue: [
		self pop: 3.
		self push: nilObj.
		^array.
	].
	array == #badDirectoryPath ifTrue: [self halt.
		^self primitiveFail.
	].

	result _ self makeDirEntryName: (array at: 1) size: (array at: 1) size
				createDate: (array at: 2) modDate: (array at: 3)
				isDir: (array at: 4)  fileSize: (array at: 5).
	self pop: 3.
	self push: result.
! !

!InterpreterSimulator methodsFor: 'file primitives' stamp: 'di 7/2/2004 14:20'!
primitiveImageName
	"Note: For now, this only implements getting, not setting, the image file name."
	| result imageNameSize |
	self pop: 1.
	imageNameSize _ imageName size.
	result _ self instantiateClass: (self splObj: ClassString)
				   indexableSize: imageNameSize.
	1 to: imageNameSize do:
		[:i | self storeByte: i-1 ofObject: result
			withValue: (imageName at: i) asciiValue].
	self push: result.! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/21/2004 15:40'!
logOfBytesVerify: nBytes fromFileNamed: fileName fromStart: loggingStart
	"Verify a questionable interpreter against a successful run"
	"self logOfBytesVerify: 10000 fromFileNamed: 'clone32Bytecodes.log' "
	
	| logFile rightByte prevCtxt |
	logFile _ (FileStream readOnlyFileNamed: fileName) binary.
	logging _ loggingStart.
	transcript clear.
	byteCount _ 0.
	quitBlock _ [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	prevCtxt _ 0.  prevCtxt _ prevCtxt.
	[byteCount < nBytes] whileTrue:
		[
"
byteCount > 14560 ifTrue:
[self externalizeIPandSP.
prevCtxt = activeContext ifFalse:
 [prevCtxt _ activeContext.
 transcript cr; nextPutAll: (self printTop: 2); endEntry].
transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space;
 print: (instructionPointer - method - (BaseHeaderSize - 2));
 nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space;
 nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
 print: (self stackPointerIndex - TempFrameStart + 1); endEntry.
byteCount = 14590 ifTrue: [self halt]].
"
		logging ifTrue: [rightByte _ logFile next.
						currentBytecode = rightByte ifFalse: [self halt]].
		self dispatchOn: currentBytecode in: BytecodeTable.
		byteCount _ byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
	self externalizeIPandSP.
	logFile close.
	self inform: nBytes printString , ' bytecodes verfied.'! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/21/2004 15:52'!
logOfBytesWrite: nBytes toFileNamed: fileName fromStart: loggingStart
	"Write a log file for testing a flaky interpreter on the same image"
	"self logOfBytesWrite: 10000 toFileNamed: 'clone32Bytecodes.log' "
	
	| logFile |
	logFile _ (FileStream newFileNamed: fileName) binary.
	logging _ loggingStart.
	transcript clear.
	byteCount _ 0.
	quitBlock _ [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	[logging not or: [byteCount < nBytes]] whileTrue:
		[logging ifTrue: [logFile nextPut: currentBytecode].
		self dispatchOn: currentBytecode in: BytecodeTable.
		byteCount _ byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
	self externalizeIPandSP.
	logFile close.
! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/21/2004 15:39'!
logOfSendsVerify: nSends fromFileNamed: fileName fromStart: loggingStart
	"Write a log file for testing a flaky interpreter on the same image"
	"self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' "
	
	| logFile priorContext rightSelector prevCtxt |
	logFile _ FileStream readOnlyFileNamed: fileName.
	logging _ loggingStart.
	transcript clear.
	byteCount _ 0.
	sendCount _ 0.
	priorContext _ activeContext.
	quitBlock _ [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	prevCtxt _ 0.  prevCtxt _ prevCtxt.
	[sendCount < nSends] whileTrue:
		[
"
byteCount>500 ifTrue:
[byteCount>550 ifTrue: [self halt].
self externalizeIPandSP.
prevCtxt = activeContext ifFalse:
 [prevCtxt _ activeContext.
 transcript cr; nextPutAll: (self printTop: 2); endEntry].
transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space;
 print: (instructionPointer - method - (BaseHeaderSize - 2));
 nextPutAll: ': <' , (self byteAt: localIP) hex , '>'; space;
 nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
 print: (self stackPointerIndex - TempFrameStart + 1); endEntry.
].
"
		self dispatchOn: currentBytecode in: BytecodeTable.
		activeContext == priorContext ifFalse:
			[sendCount _ sendCount + 1.
			logging ifTrue: [rightSelector _ logFile nextLine.
							(self stringOf: messageSelector) = rightSelector ifFalse: [self halt]].
			priorContext _ activeContext].
		byteCount _ byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
	self externalizeIPandSP.
	logFile close.
	self inform: nSends printString , ' sends verfied.'! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/21/2004 15:53'!
logOfSendsWrite: nSends toFileNamed: fileName fromStart: loggingStart
	"Write a log file for testing a flaky interpreter on the same image"
	"self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' "
	
	| logFile priorContext |
	logFile _ FileStream newFileNamed: fileName.
	logging _ loggingStart.
	transcript clear.
	byteCount _ 0.
	sendCount _ 0.
	priorContext _ activeContext.
	quitBlock _ [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	[logging not or: [sendCount < nSends]] whileTrue:
		[self dispatchOn: currentBytecode in: BytecodeTable.
		activeContext == priorContext ifFalse:
			[logging ifTrue: [sendCount _ sendCount + 1.
							logFile nextPutAll: (self stringOf: messageSelector); cr].
			priorContext _ activeContext].
		byteCount _ byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
	self externalizeIPandSP.
	logFile close.
! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 5/11/2004 18:28'!
profile: nBytecodes
	"(InterpreterSimulator new openOn: 'clonex.image') profile: 60000"
	transcript clear.
	byteCount _ 0.
	MessageTally spyOn: [self runForNBytes: nBytecodes].
	self close! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 8/3/2004 14:52'!
stats
	| oop fieldAddr fieldOop last stats v d |
	stats _ Bag new.
	oop _ self firstObject.

'Scanning the image...' displayProgressAt: Sensor cursorPoint
	from: oop to: endOfMemory
	during: [:bar |

	[oop < endOfMemory] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[stats add: #objects.
			fieldAddr _ oop + (self lastPointerOf: oop).
			[fieldAddr > oop] whileTrue:
				[fieldOop _ self longAt: fieldAddr.
				(self isIntegerObject: fieldOop)
					ifTrue: [v _ self integerValueOf: fieldOop.
							(v between: -16000 and: 16000)
								ifTrue: [stats add: #ints32k]
								ifFalse: [stats add: #intsOther]]
					ifFalse: [fieldOop = nilObj ifTrue: [stats add: #nil]
							ifFalse:
							[d _ fieldOop - oop.
							(d between: -16000 and: 16000)
								ifTrue: [stats add: #oops32k]
								ifFalse: [stats add: #oopsOther]]].
				fieldAddr _ fieldAddr - BytesPerWord]].
		bar value: oop.
		last _ oop.
		last _ last.
		oop _ self objectAfter: oop]].
	^ stats sortedElements! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/19/2004 17:30'!
test
	transcript clear.
	byteCount _ 0.
	quitBlock _ [^ self].
	self internalizeIPandSP.
	self fetchNextBytecode.
	[true] whileTrue:
		[self dispatchOn: currentBytecode in: BytecodeTable.
		byteCount _ byteCount + 1.
		byteCount \\ 10000 = 0 ifTrue: [self fullDisplay]].
	self externalizeIPandSP.
! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 5/11/2004 18:30'!
validate
	| oop prev |
	transcript show: 'Validating...'.
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue: [
		self validate: oop.
		prev _ oop.  "look here if debugging prev obj overlapping this one"
		oop _ self objectAfter: oop.
	].
	prev _ prev.  "Don't offer to delete this please"
	transcript show: 'done.'; cr! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 7/1/2004 17:29'!
validate: oop
	| header type cc sz fmt nextChunk | 
	header _ self longAt: oop.
	type _ header bitAnd: 3.
	type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].
	sz _ (header bitAnd: SizeMask) >> 2.
	(self isFreeObject: oop)
		ifTrue: [ nextChunk _ oop + (self sizeOfFree: oop) ]
		ifFalse: [  nextChunk _ oop + (self sizeBitsOf: oop) ].
	nextChunk > endOfMemory
		ifTrue: [oop = endOfMemory ifFalse: [self halt]].
	(self headerType: nextChunk) = 0 ifTrue: [
		(self headerType: (nextChunk + (BytesPerWord*2))) = 0 ifFalse: [self halt]].
	(self headerType: nextChunk) = 1 ifTrue: [
		(self headerType: (nextChunk + BytesPerWord)) = 1 ifFalse: [self halt]].
	type = 2 ifTrue:
		["free block" ^ self].
	fmt _ (header >> 8) bitAnd: 16rF.
	cc _ (header >> 12) bitAnd: 31.
	cc > 16 ifTrue: [self halt].	"up to 32 are legal, but not used"
	type = 0 ifTrue:
		["three-word header"
		((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
		((self longAt: oop-(BytesPerWord*2)) bitAnd: 3) = type ifFalse: [self halt].
		((self longAt: oop-BytesPerWord) = type) ifTrue: [self halt].	"Class word is 0"
		sz = 0 ifFalse: [self halt]].
	type = 1 ifTrue:
		["two-word header"
		((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
		cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
		sz = 0 ifTrue: [self halt]].
	type = 3 ifTrue:
		["one-word header"
		cc = 0 ifTrue: [self halt]].
	fmt = 5 ifTrue: [self halt].
	fmt = 7 ifTrue: [self halt].
	fmt >= 12 ifTrue:
		["CompiledMethod -- check for integer header"
		(self isIntegerObject: (self longAt: oop + BytesPerWord)) ifFalse: [self halt]].! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'ikp 8/3/2004 18:43'!
validateOopsIn: object
	| fieldPtr limit former header | 
	"for each oop in me see if it is legal"
	fieldPtr _ object + BaseHeaderSize.	"first field"
	limit _ object + (self lastPointerOf: object).	"a good field"
	[fieldPtr > limit] whileFalse: [
		former _ self longAt: fieldPtr.
		(self validOop: former) ifFalse: [self error: 'invalid oop in pointers object'].
		fieldPtr _ fieldPtr + BytesPerWord].
	"class"
	header _ self baseHeader: object.
	(header bitAnd: CompactClassMask) = 0 ifTrue: [	
		former _ (self classHeader: object) bitAnd: AllButTypeMask.
		(self validOop: former) ifFalse: [self halt]].! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 7/4/2004 09:01'!
primBitmapdecompressfromByteArrayat
	| indexInt index baOop bmOop baSize bmSize ba bm |
	indexInt _ self stackTop.
	(self isIntegerValue: indexInt) ifFalse: [^ self primitiveFail].
	index _ self integerValueOf: indexInt.
	baOop _ self stackValue: 1.
	bmOop _ self stackValue: 2.
	baSize _ self stSizeOf: baOop.
	bmSize _ self stSizeOf: bmOop.
	ba _ ByteArray new: baSize.
	bm _ Bitmap new: bmSize.

	"Copy the byteArray into ba"
	1 to: baSize do: [:i | ba at: i put: (self fetchByte: i-1 ofObject: baOop)].

	"Decompress ba into bm"
	bm decompress: bm fromByteArray: ba at: index.

	"Then copy bm into the Bitmap"
	1 to: bmSize do: [:i | self storeLong32: i-1 ofObject: bmOop withValue: (bm at: i)].
	self pop: 3! !

!InterpreterSimulator methodsFor: 'image save/restore' stamp: 'di 8/3/2004 14:57'!
writeImageFileIO: numberOfBytesToWrite
	"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."

	| headerSize file |
	BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
	headerSize _ 64.

	[
		file _ (FileStream fileNamed: imageName) binary.
		file == nil ifTrue: [^nil].
	
		{
			self imageFormatVersion.
			headerSize.
			numberOfBytesToWrite.
			self startOfMemory.
			specialObjectsOop.
			lastHash.
			self ioScreenSize.
			fullScreenFlag.
			extraVMMemory
		}
			do: [:long | self putLong: long toFile: file].
	
		"Pad the rest of the header."
		7 timesRepeat: [self putLong: 0 toFile: file].
	
		"Position the file after the header."
		file position: headerSize.
	
		"Write the object memory."
		1
			to: numberOfBytesToWrite // 4
			do: [:index |
				self
					putLong: (memory at: index)
					toFile: file].
	
		self success: true
	]
		ensure: [file close]! !

!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/20/2004 11:58'!
allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord 

	| newObj |
	newObj _ super allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord.
	"byteCount < 600000 ifTrue: [^ newObj]."
	"(self baseHeader: newObj) =  16r0FCC0600 ifTrue: [self halt]."
	^ newObj! !

!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/22/2004 18:36'!
normalSend
	"Catch errors before we start the whole morphic error process"

	"(byteCount > 4000000 and: [(self stringOf: messageSelector) = 'sorts:before:'])
		ifTrue: [self halt]."
	^ super normalSend! !

!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/20/2004 10:57'!
primitiveFail

"(primitiveIndex = 61 and: [byteCount > 210000]) ifTrue: [self halt]."
	successFlag _ false.! !

!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/22/2004 12:31'!
primitiveResume
	"Catch errors before we start the whole morphic error process"

	byteCount > 1000000 ifTrue: [self halt].  "Ignore early process activity"
	^ super primitiveResume! !

!InterpreterSimulator methodsFor: 'debugging traps' stamp: 'di 7/22/2004 12:31'!
primitiveSuspend
	"Catch errors before we start the whole morphic error process"

	byteCount > 1000000 ifTrue: [self halt].  "Ignore early process activity"
	^ super primitiveSuspend! !

!InterpreterSimulator methodsFor: 'UI' stamp: 'di 4/21/2004 00:09'!
byteCountText
	^ byteCount printString asText! !

!InterpreterSimulator methodsFor: 'UI' stamp: 'di 4/21/2004 00:31'!
openAsMorph
	"Open a morphic view on this simulation."
	| window localImageName |
	localImageName _ FileDirectory default localNameFor: imageName.
	window _ (SystemWindow labelled: 'Simulation of ' , localImageName) model: self.

	window addMorph: (displayView _ ImageMorph new image: displayForm)
		frame: (0@0 corner: 1@0.8).

	transcript _ TranscriptStream on: (String new: 10000).
	window addMorph: (PluggableTextMorph on: transcript text: nil accept: nil
			readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0@0.8 corner: 0.7@1).

	window addMorph: (PluggableTextMorph on: self
						text: #byteCountText accept: nil) hideScrollBarIndefinitely
		frame: (0.7@0.8 corner: 1@1).

	window openInWorld! !


!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'di 7/16/2004 14:59'!
halfWordHighInLong32: long32
	"Used by Balloon"

	^ long32 bitAnd: 16rFFFF! !

!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'di 7/16/2004 14:59'!
halfWordLowInLong32: long32
	"Used by Balloon"

	^ long32 bitShift: -16! !

!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'di 6/23/2004 14:29'!
shortAt: byteAddress
    "Return the half-word at byteAddress which must be even."
	| lowBits long |
	lowBits _ byteAddress bitAnd: 2.
	long _ self longAt: byteAddress - lowBits.
	^ lowBits = 2
		ifTrue: [ long bitShift: -16 ]
		ifFalse: [ long bitAnd: 16rFFFF ].
! !

!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'di 6/23/2004 14:31'!
shortAt: byteAddress put: a16BitValue
    "Return the half-word at byteAddress which must be even."
	| lowBits long longAddress |
	lowBits _ byteAddress bitAnd: 2.
	lowBits = 0
		ifTrue:
		[ "storing into LS word"
		long _ self longAt: byteAddress.
		self longAt: byteAddress
				put: ((long bitAnd: 16rFFFF0000) bitOr: a16BitValue)
		]
		ifFalse:
		[longAddress _ byteAddress - 2.
		long _ self longAt: longAddress.
		self longAt: longAddress
				put: ((long bitAnd: 16rFFFF) bitOr: (a16BitValue bitShift: 16))
		]! !

!InterpreterSimulatorLSB methodsFor: 'initialization' stamp: 'di 6/22/2004 14:53'!
nextLongFrom: aStream
	"Read a 32- or 64-bit quantity from the given (binary) stream."

	^ aStream nextLittleEndianNumber: BytesPerWord! !


!InterpreterSimulatorLSB64 methodsFor: 'as yet unclassified' stamp: 'di 6/13/2004 10:55'!
bytesPerWord
	"overridden for 64-bit images..."

	^ 8! !

!InterpreterSimulatorLSB64 methodsFor: 'as yet unclassified' stamp: 'di 6/13/2004 10:56'!
long32At: byteAddress

	"Return the 32-bit word at byteAddress which must be 0 mod 4."
	| lowBits long |
	lowBits _ byteAddress bitAnd: 4.
	long _ self longAt: byteAddress - lowBits.
	^ lowBits = 4
		ifTrue: [ long bitShift: -32 ]
		ifFalse: [ long bitAnd: 16rFFFFFFFF ].
! !

!InterpreterSimulatorLSB64 methodsFor: 'as yet unclassified' stamp: 'di 6/13/2004 11:01'!
long32At: byteAddress put: a32BitValue
	"Store the 32-bit value at byteAddress which must be 0 mod 4."
	| lowBits long64 longAddress |
	lowBits _ byteAddress bitAnd: 4.
	lowBits = 0
		ifTrue:
		[ "storing into LS word"
		long64 _ self longAt: byteAddress.
		self longAt: byteAddress
				put: ((long64 bitAnd: 16rFFFFFFFF00000000) bitOr: a32BitValue)
		]
		ifFalse:
		[longAddress _ byteAddress - 4.
		long64 _ self longAt: longAddress.
		self longAt: longAddress
				put: ((long64 bitAnd: 16rFFFFFFFF) bitOr: (a32BitValue bitShift: 32))
		]! !


!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'di 6/22/2004 14:52'!
byteAt: byteAddress
	| lowBits bpwMinus1 |
	bpwMinus1 _ BytesPerWord-1.
	lowBits _ byteAddress bitAnd: bpwMinus1.
	^ ((self longAt: byteAddress - lowBits)
		bitShift: (lowBits - bpwMinus1) * 8)
		bitAnd: 16rFF! !

!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'di 7/3/2004 11:00'!
byteAt: byteAddress put: byte
	| longWord shift lowBits bpwMinus1 longAddress |
	bpwMinus1 _ BytesPerWord-1.
	lowBits _ byteAddress bitAnd: bpwMinus1.
	longAddress _ byteAddress - lowBits.
	longWord _ self longAt: longAddress.
	shift _ (bpwMinus1 - lowBits) * 8.
	longWord _ longWord
				- (longWord bitAnd: (16rFF bitShift: shift))
				+ (byte bitShift: shift).
	self longAt: longAddress put: longWord! !

!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'di 7/16/2004 14:58'!
halfWordHighInLong32: long32
	"Used by Balloon"

	^ long32 bitShift: -16! !

!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'di 7/16/2004 14:58'!
halfWordLowInLong32: long32
	"Used by Balloon"

	^ long32 bitAnd: 16rFFFF! !

!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'di 7/3/2004 11:06'!
shortAt: byteAddress
    "Return the half-word at byteAddress which must be even."
	| lowBits bpwMinus2 |
	bpwMinus2 _ BytesPerWord-2.
	lowBits _ byteAddress bitAnd: bpwMinus2.
	^ ((self longAt: byteAddress - lowBits)
		bitShift: (lowBits - bpwMinus2) * 8)
		bitAnd: 16rFFFF
! !

!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'di 7/3/2004 11:00'!
shortAt: byteAddress put: a16BitValue
    "Return the half-word at byteAddress which must be even."
	| longWord shift lowBits bpwMinus2 longAddress |
	bpwMinus2 _ BytesPerWord-2.
	lowBits _ byteAddress bitAnd: bpwMinus2.
	longAddress _ byteAddress - lowBits.
	longWord _ self longAt: longAddress.
	shift _ (bpwMinus2 - lowBits) * 8.
	longWord _ longWord
				- (longWord bitAnd: (16rFFFF bitShift: shift))
				+ (a16BitValue bitShift: shift).
	self longAt: longAddress put: longWord
! !

!InterpreterSimulatorMSB methodsFor: 'debug support' stamp: 'di 6/22/2004 14:52'!
charsOfLong: long
	^ (BytesPerWord to: 1 by: -1) collect:
		[:i | ((long digitAt: i) between: 14 and: 126)
					ifTrue: [(long digitAt: i) asCharacter]
					ifFalse: [$?]]! !

!InterpreterSimulatorMSB methodsFor: 'initialization' stamp: 'di 6/22/2004 14:52'!
nextLongFrom: aStream 
	"Read a 32- or 64-bit quantity from the given (binary) stream."

	^ aStream nextNumber: BytesPerWord! !


!InterpreterSimulatorMSB64 methodsFor: 'as yet unclassified' stamp: 'di 6/9/2004 12:17'!
byteSwapped: w
	"Return the given integer with its bytes in the reverse order."

	^ (super byteSwapped: ((w bitShift: -32) bitAnd: 16rFFFFFFFF)) +
	  ((super byteSwapped: (w bitAnd: 16rFFFFFFFF)) bitShift: 32)! !

!InterpreterSimulatorMSB64 methodsFor: 'as yet unclassified' stamp: 'di 6/3/2004 16:16'!
bytesPerWord
	"overridden for 64-bit images..."

	^ 8! !

!InterpreterSimulatorMSB64 methodsFor: 'as yet unclassified' stamp: 'di 7/3/2004 10:40'!
long32At: byteAddress
	"Return the 32-bit word at byteAddress which must be 0 mod 4."

	^ super longAt: byteAddress! !

!InterpreterSimulatorMSB64 methodsFor: 'as yet unclassified' stamp: 'di 7/3/2004 10:41'!
long32At: byteAddress put: a32BitValue
	"Store the 32-bit value at byteAddress which must be 0 mod 4."

	super longAt: byteAddress put: a32BitValue! !

!InterpreterSimulatorMSB64 methodsFor: 'as yet unclassified' stamp: 'di 6/9/2004 15:43'!
longAt: byteAddress
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^ ((super longAt: byteAddress) bitShift: 32) bitOr: (super longAt: byteAddress + 4)! !

!InterpreterSimulatorMSB64 methodsFor: 'as yet unclassified' stamp: 'di 6/9/2004 15:48'!
longAt: byteAddress put: a64BitValue
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	super longAt: byteAddress put: (a64BitValue bitShift: -32).
	super longAt: byteAddress + 4 put: (a64BitValue bitAnd: 16rFFFFFFFF).
	^ a64BitValue! !


!ObjectMemory class methodsFor: 'translation' stamp: 'ikp 3/26/2005 14:20'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator var: #memory type:#'usqInt'.
	aCCodeGenerator
		var: #remapBuffer
		declareC: 'sqInt remapBuffer[', (RemapBufferSize + 1) printString, ']'.
	aCCodeGenerator
		var: #rootTable
		declareC: 'sqInt rootTable[', (RootTableSize + 1) printString, ']'.
	aCCodeGenerator
		var: #headerTypeBytes
		declareC: 'sqInt headerTypeBytes[4]'.
	
	aCCodeGenerator var: #youngStart type: 'usqInt'.
	aCCodeGenerator var: #endOfMemory type: 'usqInt'.
	aCCodeGenerator var: #memoryLimit type: 'usqInt'.
	aCCodeGenerator var: #youngStartLocal type: 'usqInt'.
! !

!ObjectMemory class methodsFor: 'translation' stamp: 'ikp 8/3/2004 20:17'!
unsignedIntegerSuffix
	"Answer the suffix that should be appended to unsigned integer literals in generated code."

	^BytesPerWord = 4 ifTrue: ['U'] ifFalse: ['ULL']! !

!ObjectMemory class methodsFor: 'initialization' stamp: 'ikp 9/22/2004 12:05'!
initBytesPerWord: nBytes

	BytesPerWord _ nBytes.
	ShiftForWord _ (BytesPerWord log: 2) rounded.
	"The following is necessary to avoid confusing the compiler with shifts that are larger than the width of the type on which they operate.  In gcc, such shifts cause incorrect code to be generated."
	BytesPerWord = 8
		ifTrue:					"64-bit VM"
			[Byte0Mask _ 16r00000000000000FF.	Byte0Shift _ 0.
			 Byte1Mask _ 16r000000000000FF00.	Byte1Shift _ 8.
			 Byte2Mask _ 16r0000000000FF0000.	Byte2Shift _ 16.
			 Byte3Mask _ 16r00000000FF000000.	Byte3Shift _ 24.
			 Byte4Mask _ 16r000000FF00000000.	Byte4Shift _ 32.
			 Byte5Mask _ 16r0000FF0000000000.	Byte5Shift _ 40.
			 Byte6Mask _ 16r00FF000000000000.	Byte6Shift _ 48.
			 Byte7Mask _ 16rFF00000000000000.	Byte7Shift _ 56.
			 Bytes3to0Mask _ 16r00000000FFFFFFFF.
			 Bytes7to4Mask _ 16rFFFFFFFF00000000]
		ifFalse:					"32-bit VM"
			[Byte0Mask _ 16r00000000000000FF.	Byte0Shift _ 0.
			 Byte1Mask _ 16r000000000000FF00.	Byte1Shift _ 8.
			 Byte2Mask _ 16r0000000000FF0000.	Byte2Shift _ 16.
			 Byte3Mask _ 16r00000000FF000000.	Byte3Shift _ 24.
			 Byte4Mask _ 16r0000000000000000.	Byte4Shift _ 0.		"unused"
			 Byte5Mask _ 16r0000000000000000.	Byte5Shift _ 0.		"unused"
			 Byte6Mask _ 16r0000000000000000.	Byte6Shift _ 0.		"unused"
			 Byte7Mask _ 16r0000000000000000.	Byte7Shift _ 0.		"unused"
			 Bytes3to0Mask _ 16r0000000000000000.					"unused"
			 Bytes7to4Mask _ 16r0000000000000000					"unused"].
	Byte1ShiftNegated _ Byte1Shift negated.
	Byte3ShiftNegated _ Byte3Shift negated.
	Byte4ShiftNegated _ Byte4Shift negated.
	Byte5ShiftNegated _ Byte5Shift negated.
	Byte7ShiftNegated _ Byte7Shift negated.! !

!ObjectMemory class methodsFor: 'initialization' stamp: 'di 7/20/2004 10:50'!
initialize
	"ObjectMemory initialize"

	"Translation flags (booleans that control code generation via conditional translation):"
	DoAssertionChecks _ false.  "generate assertion checks"
	DoBalanceChecks _ false. "generate stack balance checks"

	self initializeSpecialObjectIndices.
	self initializeObjectHeaderConstants.

	CtxtTempFrameStart _ 6.  "Copy of TempFrameStart in Interp"
	ContextFixedSizePlusHeader _ CtxtTempFrameStart + 1.
	SmallContextSize _ ContextFixedSizePlusHeader + 16 * BytesPerWord.  "16 indexable fields"
	"Large contexts have 56 indexable fileds.  Max with single header word."
	"However note that in 64 bits, for now, large contexts have 3-word headers"
	LargeContextSize _ ContextFixedSizePlusHeader + 56 * BytesPerWord.
	
	LargeContextBit _ 16r40000.  "This bit set in method headers if large context is needed."
	NilContext _ 1.  "the oop for the integer 0; used to mark the end of context lists"

	RemapBufferSize _ 25.
	RootTableSize _ 2500.  	"number of root table entries (4 bytes/entry)"
	RootTableRedZone _ RootTableSize - 100.	"red zone of root table - when reached we force IGC"

	"tracer actions"
	StartField _ 1.
	StartObj _ 2.
	Upward _ 3.
	Done _ 4.! !

!ObjectMemory class methodsFor: 'initialization' stamp: 'di 7/1/2004 14:44'!
initializeObjectHeaderConstants

	BytesPerWord ifNil: [BytesPerWord _ 4].  "May get called on fileIn, so supply default"
	BaseHeaderSize _ BytesPerWord.
	WordMask _ (1 bitShift: BytesPerWord*8) - 1.
	
	"masks for type field"
	TypeMask _ 3.
	AllButTypeMask _ WordMask - TypeMask.

	"type field values"
	HeaderTypeSizeAndClass _ 0.
	HeaderTypeClass _ 1.
	HeaderTypeFree _ 2.
	HeaderTypeShort _ 3.

	"type field values used during the mark phase of GC"
	HeaderTypeGC _ 2.
	GCTopMarker _ 3.  "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase."

	"Base header word bit fields"
	HashBits _ 16r1FFE0000.
	AllButHashBits _ WordMask - HashBits.
	HashBitsOffset _ 17.
	SizeMask _ 16rFC.
	Size4Bit _ 0.
BytesPerWord = 8 ifTrue:
		[SizeMask _ 16rF8.  "Lose the 4 bit in temp 64-bit chunk format"
		Size4Bit _ 4].  "But need it for ST size"
	"Note SizeMask + Size4Bit gives the mask needed for size fits of format word in classes.
		This is used in instantiateClass:indexableSize: "
	LongSizeMask _ WordMask - 16rFF + SizeMask.
	CompactClassMask _ 16r1F000.

	"masks for root and mark bits"
	MarkBit _ 1 bitShift: BytesPerWord*8 - 1.  "Top bit"
	RootBit _ 1 bitShift: BytesPerWord*8 - 2.  "Next-to-Top bit"
	AllButMarkBit _ WordMask - MarkBit.
	AllButRootBit _ WordMask - RootBit.

	AllButMarkBitAndTypeMask _ AllButTypeMask - MarkBit.! !

!ObjectMemory class methodsFor: 'accessing' stamp: 'ikp 9/2/2004 14:08'!
bytesPerWord
	"Answer the width of an object pointer, in bytes."

	^BytesPerWord! !


!Interpreter class methodsFor: 'translation' stamp: 'tpr 3/17/2005 11:36'!
declareCVarsIn: aCCodeGenerator

	aCCodeGenerator 
		var: #interpreterProxy 
		type: #'struct VirtualMachine*'.
	aCCodeGenerator
		var: #primitiveTable
		declareC: 'void *primitiveTable[', (MaxPrimitiveIndex +2) printString, '] = ',	self primitiveTableString.
	aCCodeGenerator
		var: #primitiveFunctionPointer
		declareC: 'void *primitiveFunctionPointer'				.		"xxxx FIX THIS STUPIDITY xxxx - ikp. What he means is use a better type than void *, apparently - tpr"
	aCCodeGenerator
		var: #methodCache
		declareC: 'long methodCache[', (MethodCacheSize + 1) printString, ']'.
	aCCodeGenerator
		var: #atCache
		declareC: 'sqInt atCache[', (AtCacheTotalSize + 1) printString, ']'.
	aCCodeGenerator var: #localIP type: #'char*'.
	aCCodeGenerator var: #localSP type: #'char*'.
	aCCodeGenerator var: #showSurfaceFn type: #'void*'.
	aCCodeGenerator var: 'semaphoresToSignalA'
		declareC: 'sqInt semaphoresToSignalA[', (SemaphoresToSignalSize + 1) printString, ']'.
	aCCodeGenerator var: 'semaphoresToSignalB'
		declareC: 'sqInt semaphoresToSignalB[', (SemaphoresToSignalSize + 1) printString, ']'.
	aCCodeGenerator
		var: #compilerHooks
		declareC: 'sqInt (*compilerHooks[', (CompilerHooksSize + 1) printString, '])()'.
	aCCodeGenerator
		var: #interpreterVersion
		declareC: 'const char *interpreterVersion = "', Smalltalk datedVersion, ' [', Smalltalk lastUpdateString,']"'.
	aCCodeGenerator
		var: #obsoleteIndexedPrimitiveTable
		declareC: 'char* obsoleteIndexedPrimitiveTable[][3] = ', self obsoleteIndexedPrimitiveTableString.
	aCCodeGenerator
		var: #obsoleteNamedPrimitiveTable
		declareC: 'const char* obsoleteNamedPrimitiveTable[][3] = ', self obsoleteNamedPrimitiveTableString.
	aCCodeGenerator
		var: #externalPrimitiveTable
		declareC: 'void *externalPrimitiveTable[', (MaxExternalPrimitiveTableSize + 1) printString, ']'.
! !

!Interpreter class methodsFor: 'initialization' stamp: 'tpr 3/17/2005 10:40'!
initializeCaches

	| atCacheEntrySize |
	MethodCacheEntries _ 512. 
	MethodCacheSelector _ 1.
	MethodCacheClass _ 2.
	MethodCacheMethod _ 3.
	MethodCachePrim _ 4.
	MethodCacheNative _ 5.
	MethodCachePrimFunction _ 6.
	MethodCacheEntrySize _ 8.  "Must be power of two for masking scheme."
	MethodCacheMask _ (MethodCacheEntries - 1) * MethodCacheEntrySize.
	MethodCacheSize _ MethodCacheEntries * MethodCacheEntrySize.
	CacheProbeMax _ 3.

	AtCacheEntries _ 8.  "Must be a power of two"
	AtCacheOop _ 1.
	AtCacheSize _ 2.
	AtCacheFmt _ 3.
	AtCacheFixedFields _ 4.
	atCacheEntrySize _ 4.  "Must be power of two for masking scheme."
	AtCacheMask _ (AtCacheEntries-1) * atCacheEntrySize.
	AtPutBase _ AtCacheEntries * atCacheEntrySize.
	AtCacheTotalSize _ AtCacheEntries * atCacheEntrySize * 2.
! !

!Interpreter class methodsFor: 'initialization' stamp: 'di 6/14/2004 18:03'!
initializeContextIndices
	"Class MethodContext"
	SenderIndex _ 0.
	InstructionPointerIndex _ 1.
	StackPointerIndex _ 2.
	MethodIndex _ 3.
	ReceiverIndex _ 5.
	TempFrameStart _ 6.  "Note this is in two places!!"

	"Class BlockContext"
	CallerIndex _ 0.
	BlockArgumentCountIndex _ 3.
	InitialIPIndex _ 4.
	HomeIndex _ 5.

	"Class BlockClosure"
	BlockMethodIndex _ 0.
! !

!Interpreter class methodsFor: 'initialization' stamp: 'tpr 3/17/2005 11:32'!
primitiveTableString
	"Interpreter initializePrimitiveTable primitiveTableString"
	| table |
	table := self primitiveTable.
	^ String
		streamContents: [:s | 
			s nextPut: ${.
			table
				withIndexDo: [:primSpec :index | s cr; tab;
					nextPutAll: '/* ';
					nextPutAll: (index - 1) printString;
					nextPutAll: '*/ ';
					nextPutAll: '(void *)';
					nextPutAll: primSpec;
					nextPut: $,].
			s cr; nextPutAll: ' 0 }']! !


!SmalltalkImage methodsFor: 'vm parameters' stamp: 'tpr 3/17/2005 12:56'!
vmParameterAt: parameterIndex
	"parameterIndex is a positive integer corresponding to one of the VM's internal
	parameter/metric registers.  Answer with the current value of that register.
	Fail if parameterIndex has no corresponding register.
	VM parameters are numbered as follows:
		1	end of old-space (0-based, read-only)
		2	end of young-space (read-only)
		3	end of memory (read-only)
		4	allocationCount (read-only)
		5	allocations between GCs (read-write)
		6	survivor count tenuring threshold (read-write)
		7	full GCs since startup (read-only)
		8	total milliseconds in full GCs since startup (read-only)
		9	incremental GCs since startup (read-only)
		10	total milliseconds in incremental GCs since startup (read-only)
		11	tenures of surving objects since startup (read-only)
		12-20 specific to the translating VM
		21	root table size (read-only)
		22	root table overflows since startup (read-only)
		23	bytes of extra memory to reserve for VM buffers, plugins, etc.

		24	memory headroom when growing object memory (rw)
		25	memory threshold above which shrinking object memory (rw)
		26	number of mSecs between VM forced interrupt checks (rw)
		27  VM word size - 4 or 8 (read-only)"

	<primitive: 254>
	self primitiveFailed! !


!SystemDictionary methodsFor: 'sources, change log' stamp: 'ikp 3/26/2005 21:59'!
wordSize
	"Answer the size (in bytes) of an object pointer."
	"Smalltalk wordSize"

	^[SmalltalkImage current vmParameterAt: 27] on: Error do: [4]! !

!SystemDictionary methodsFor: 'deprecated' stamp: 'tpr 3/17/2005 12:55'!
vmParameterAt: parameterIndex
	"parameterIndex is a positive integer corresponding to one of the VM's internal
	parameter/metric registers.  Answer with the current value of that register.
	Fail if parameterIndex has no corresponding register.
	VM parameters are numbered as follows:
		1	end of old-space (0-based, read-only)
		2	end of young-space (read-only)
		3	end of memory (read-only)
		4	allocationCount (read-only)
		5	allocations between GCs (read-write)
		6	survivor count tenuring threshold (read-write)
		7	full GCs since startup (read-only)
		8	total milliseconds in full GCs since startup (read-only)
		9	incremental GCs since startup (read-only)
		10	total milliseconds in incremental GCs since startup (read-only)
		11	tenures of surving objects since startup (read-only)
		12-20 specific to the translating VM
		21	root table size (read-only)
		22	root table overflows since startup (read-only)
		23	bytes of extra memory to reserve for VM buffers, plugins, etc.

		24	memory headroom when growing object memory (rw)
		25	memory threshold above which shrinking object memory (rw)
26		26	number of mSecs between VM forced interrupt checks (rw)
		27  VM word size - 4 or 8 (read-only)"

	^ self deprecated: 'Use SmalltalkImage current vmParameterAt:'
		block: [SmalltalkImage current vmParameterAt: parameterIndex]
	! !


!TMethod methodsFor: 'inlining' stamp: 'ikp 6/9/2004 16:15'!
inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: aCodeGen
	"Answer a collection of statments to replace the given send. directReturn indicates that the send is the expression of a return statement, so returns can be left in the body of the inlined method. If exitVar is nil, the value returned by the send is not used; thus, returns need not assign to the output variable."

	| sel meth exitLabel labelUsed inlineStmts |
	sel _ aSendNode selector.
	meth _ (aCodeGen methodNamed: sel) copy.
	meth renameVarsForInliningInto: self in: aCodeGen.
	meth renameLabelsForInliningInto: self.
	self addVarsDeclarationsAndLabelsOf: meth.
	meth hasReturn ifTrue: [
		directReturn ifTrue: [
			"propagate the return type, if necessary"
			returnType = meth returnType ifFalse: [ self halt ].  "caller's return type should be declared by user"
			returnType _ meth returnType.
		] ifFalse: [
			exitLabel _ self unusedLabelForInliningInto: self.
			labelUsed _ meth exitVar: exitVar label: exitLabel.
			labelUsed
				ifTrue: [ labels add: exitLabel ]
				ifFalse: [ exitLabel _ nil ].
		].
		"propagate type info if necessary"
		((exitVar ~= nil) and: [meth returnType ~= 'sqInt']) ifTrue: [
			declarations at: exitVar put: meth returnType, ' ', exitVar.
		].
	].
	inlineStmts _ OrderedCollection new: 100.
	inlineStmts add: (TLabeledCommentNode new setComment: 'begin ', sel).
	inlineStmts addAll:
		(self argAssignmentsFor: meth args: aSendNode args in: aCodeGen).
	inlineStmts addAll: meth statements.  "method body"
	(directReturn and: [meth endsWithReturn not]) ifTrue: [
		inlineStmts add: (TReturnNode new setExpression: (TVariableNode new setName: 'nil')).
	].
	exitLabel ~= nil ifTrue: [
		inlineStmts add:
			(TLabeledCommentNode new
				setLabel: exitLabel comment: 'end ', meth selector).
	].
	^inlineStmts! !

!TMethod methodsFor: 'C code generation' stamp: 'ikp 6/9/2004 16:15'!
emitCFunctionPrototype: aStream generator: aCodeGen
	"Emit a C function header for this method onto the given stream."

	| arg |
	export 
		ifTrue:[aStream nextPutAll:'EXPORT('; nextPutAll: returnType; nextPutAll:') ']
		ifFalse:[(aCodeGen isGeneratingPluginCode and:[self isStatic]) 
					ifTrue:[aStream nextPutAll:'static '].
				aStream nextPutAll: returnType; space].
	aStream nextPutAll: (aCodeGen cFunctionNameFor: selector), '('.
	args isEmpty ifTrue: [ aStream nextPutAll: 'void' ].
	1 to: args size do: [ :i |
		arg _ args at: i.
		(declarations includesKey: arg) ifTrue: [
			aStream nextPutAll: (declarations at: arg).
		] ifFalse: [
			aStream nextPutAll: 'sqInt ', (args at: i).
		].
		i < args size ifTrue: [ aStream nextPutAll: ', ' ].
	].
	aStream nextPutAll: ')'.! !

!TMethod methodsFor: 'C code generation' stamp: 'ikp 6/9/2004 16:15'!
emitCHeaderOn: aStream generator: aCodeGen
	"Emit a C function header for this method onto the given stream."

	aStream cr. 
	self emitCFunctionPrototype: aStream generator: aCodeGen.
	aStream nextPutAll: ' {'; cr.
	self emitGlobalStructReferenceOn: aStream.
	locals do: [ :var |
		aStream nextPutAll: '    '.
		aStream nextPutAll: (declarations at: var ifAbsent: [ 'sqInt ', var]), ';'; cr.
	].
	locals isEmpty ifFalse: [ aStream cr ].! !

!TMethod methodsFor: 'C code generation' stamp: 'ikp 6/9/2004 16:15'!
emitInlineOn: aStream level: level generator: aCodeGen
	"Emit C code for this method onto the given stream. All calls to inlined methods should already have been expanded."
	self removeUnusedTemps.
	sharedLabel ifNotNil:[
		aStream crtab: level-1; nextPutAll: sharedLabel; nextPutAll:':'.
		aStream crtab: level.
		aStream nextPutAll: '/* '; nextPutAll: selector; nextPutAll: ' */'.
		aStream crtab: level.
	].
	aStream nextPutAll:'{'; cr.
	locals do: [ :var |
		aStream tab: level+1.
		aStream nextPutAll: (declarations at: var ifAbsent: [ 'sqInt ', var]), ';'; cr.
	].
	parseTree emitCCodeOn: aStream level: level+1 generator: aCodeGen.
	aStream tab: level; nextPutAll: '}'; cr.! !

!TMethod methodsFor: 'C code generation' stamp: 'ikp 6/9/2004 16:15'!
emitProxyFunctionPrototype: aStream generator: aCodeGen
	"Emit an indirect C function header for this method onto the given stream."

	| arg |
	aStream nextPutAll: returnType; space.
	aStream nextPutAll: '(*', (aCodeGen cFunctionNameFor: selector), ')('.
	args isEmpty ifTrue: [ aStream nextPutAll: 'void' ].
	1 to: args size do: [ :i |
		arg _ args at: i.
		(declarations includesKey: arg) ifTrue: [
			aStream nextPutAll: (declarations at: arg).
		] ifFalse: [
			aStream nextPutAll: 'sqInt ', (args at: i).
		].
		i < args size ifTrue: [ aStream nextPutAll: ', ' ].
	].
	aStream nextPutAll: ')'.! !

!TMethod methodsFor: 'initialization' stamp: 'ikp 6/9/2004 16:16'!
setSelector: sel args: argList locals: localList block: aBlockNode primitive: aNumber
	"Initialize this method using the given information."

	selector _ sel.
	returnType _ 'sqInt'. 	 "assume return type is long for now"
	args _ argList asOrderedCollection collect: [:arg | arg key].
	locals _ localList asOrderedCollection collect: [:arg | arg key].
	declarations _ Dictionary new.
	primitive _ aNumber.
	parseTree _ aBlockNode asTranslatorNode.
	labels _ OrderedCollection new.
	complete _ false.  "set to true when all possible inlining has been done"
	export _ self extractExportDirective.
	static _ self extractStaticDirective.
	self extractSharedCase.
	self removeFinalSelfReturn.
	self recordDeclarations.
	globalStructureBuildMethodHasFoo _ 0.! !


!VMMaker methodsFor: 'target directories' stamp: 'ikp 9/2/2004 14:11'!
interpreterFilename
	"Answer the filename for the core interpreter.  Default is 'interp.c'."

	^'interp.c'! !

!VMMaker methodsFor: 'target directories' stamp: 'ikp 9/2/2004 14:11'!
interpreterHeaderName
	"Answer the filename for the core interpreter header.  Default is 'interp.h'."

	^'interp.h'! !

!VMMaker methodsFor: 'initialize' stamp: 'svp 11/14/2002 21:01'!
initialize
	logger := Transcript.
	inline _ true.
	forBrowser _ false.
	internalPlugins _ SortedCollection new.
	externalPlugins _ SortedCollection new.
	platformName _ self class machinesDirName.
	allFilesList _ Dictionary new.
	interpreterClassName _ 'Interpreter'.! !

!VMMaker methodsFor: 'generate sources' stamp: 'ikp 9/2/2004 14:13'!
generateInterpreterFile
	"Translate the Smalltalk description of the virtual machine into C.  If 'self doInlining' is true, small method bodies are inlined to reduce procedure call overhead.  On the PPC, this results in a factor of three speedup with only 30% increase in code size.  Subclasses can use specialised versions of CCodeGenerator and interpreterClass."

	self needsToRegenerateInterpreterFile ifFalse: [^nil].
	self interpreterClass initialize.
	ObjectMemory initialize.
	self createCodeGenerator
		addClass: self interpreterClass;
		addClass: ObjectMemory;
		storeHeaderOnFile: self interpreterHeaderPath bytesPerWord: ObjectMemory bytesPerWord;
		storeCodeOnFile: self interpreterFilePath doInlining: self doInlining! !

!VMMaker methodsFor: 'generate sources' stamp: 'ikp 9/2/2004 14:09'!
interpreterFilePath
	"Answer the fully-qualified path for the generated interpreter file."

	^self coreVMDirectory fullNameFor: self interpreterFilename! !

!VMMaker methodsFor: 'generate sources' stamp: 'ikp 9/2/2004 14:10'!
interpreterHeaderPath
	"Answer the fully-qualified path for the generated interpreter header file."

	^self coreVMDirectory fullNameFor: self interpreterHeaderName! !


!RiscOSVMMaker methodsFor: 'generate sources' stamp: 'tpr 3/17/2005 16:26'!
interpreterHeaderPath
	"return the full path for the interpreter header file"
	"RiscOS keeps the interp file in a 'h' subdirectory of coreVMDirectory"
	self coreVMDirectory assureExistenceOfPath: 'h'.
	^(self coreVMDirectory directoryNamed: 'h') fullNameFor: self interpreterFilename! !


!VMPluginCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 6/9/2004 17:36'!
emitCHeaderOn: aStream
	"Write a C file header onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */';cr.

	aStream nextPutAll:'
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

/* Default EXPORT macro that does nothing (see comment in sq.h): */
#define EXPORT(returnType) returnType

/* Do not include the entire sq.h file but just those parts needed. */
/*  The virtual machine proxy definition */
#include "sqVirtualMachine.h"
/* Configuration options */
#include "sqConfig.h"
/* Platform specific definitions */
#include "sqPlatformSpecific.h"

#define true 1
#define false 0
#define null 0  /* using ''null'' because nil is predefined in Think C */
#ifdef SQUEAK_BUILTIN_PLUGIN
#undef EXPORT
// was #undef EXPORT(returnType) but screws NorCroft cc
#define EXPORT(returnType) static returnType
#endif
'.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].


	aStream nextPutAll: '
#include "sqMemoryAccess.h"

'.
	aStream cr.! !

ObjectMemory initialize!
InterpreterSimulatorMSB removeSelector: #halfWordAt:!
InterpreterSimulatorMSB removeSelector: #halfWordAt:put:!
InterpreterSimulatorLSB removeSelector: #halfWordAt:!
InterpreterSimulatorLSB removeSelector: #halfWordAt:put:!
Interpreter subclass: #InterpreterSimulator
	instanceVariableNames: 'byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
Object subclass: #ObjectMemory
	instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop 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 totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal'
	classVariableNames: 'AllButHashBits AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit AllButTypeMask BaseHeaderSize BlockContextProto Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask BytesPerWord 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 ContextFixedSizePlusHeader CtxtTempFrameStart DoAssertionChecks DoBalanceChecks Done ExternalObjectsArray FalseObject FloatProto GCTopMarker HashBits HashBitsOffset HeaderTypeClass HeaderTypeFree HeaderTypeGC HeaderTypeShort HeaderTypeSizeAndClass LargeContextBit LargeContextSize LongSizeMask MarkBit MethodContextProto NilContext NilObject RemapBufferSize RootBit RootTableRedZone RootTableSize SchedulerAssociation SelectorAboutToReturn SelectorCannotInterpret SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SelectorRunWithIn ShiftForWord Size4Bit SizeMask SmallContextSize SpecialSelectors StackStart StartField StartObj TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject TypeMask Upward WordMask'
	poolDictionaries: ''
	category: 'VMMaker-Interpreter'!
LargeIntegersPlugin removeSelector: #flag:!

!FilePluginSimulator reorganize!
('simulation' fileValueOf: makeDirEntryName:size:createDate:modDate:isDir:fileSize: oopForPointer: primitiveDirectoryLookup primitiveFileDelete primitiveFileOpen primitiveFileRename sqFile:Read:Into:At: sqFile:SetPosition: sqFile:Truncate: sqFile:Write:From:At: sqFileAtEnd: sqFileClose: sqFileFlush: sqFileGetPosition: sqFileSize:)
('file security' ioCanCreatePath:OfSize: ioCanDeleteFile:OfSize: ioCanDeletePath:OfSize: ioCanGetFileType:OfSize: ioCanListPath:OfSize: ioCanOpenFile:OfSize:Writable: ioCanRenameFile:OfSize: ioCanSetFileType:OfSize:)
!


!BitBltSimulator reorganize!
('debug support' dstLongAt: dstLongAt:put: srcLongAt:)
('simulation' initBBOpTable initializeDitherTables mergeFn:with: tableLookup:at:)
!

BalloonEnginePlugin subclass: #BalloonEngineSimulation
	instanceVariableNames: 'bbObj workBufferArray'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMMaker-InterpreterSimulation'!
BalloonEngineBase removeSelector: #fillSpan:from:to:max:!