[FIX]Re: [BUG] InterpreterSimulator

Yoshiki Ohshima ohshima at is.titech.ac.jp
Wed Feb 14 22:21:14 UTC 2001


  Hello,

  When I posted the fix, I also hadn't tried a full set
image.  I fixed other places and I somehow manage to bring
the 3.0 image to run on the top of 3.0.  Attached it a
change set that seems enable it.  Hopefully it should be
enough (or good start point) to fix "hosed image."

  {\Huge but}, it turned out that the situation is a bit
more complicated.  Currently, there is a method named
#cCode:inSmalltalk:, which is used to change the behavior of
VM code so that the code runs both in Smalltalk and
translated C.  The assumption of this method is that there
are only two cases, in C or in Smalltalk.  However, there is
actually another case: when the code is running in the
simulator.  In this case, an addresses is merely an integer
index to the "memory" WordArray so #at: or #at:put: message
send to the object doesn't work.

  When an address is used in plugin code, it should be
always manipulated via CAccessors.  We should collect all
sender of #at: and #at:put: fro the plugins and fix them.

  -- Yoshiki
-------------- next part --------------
'From Squeak3.0 of 4 February 2001 [latest update: #3414] on 14 February 2001 at 2:18:37 pm'!
Interpreter subclass: #InterpreterSimulator
	instanceVariableNames: 'byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!

!BitBltSimulation methodsFor: 'primitives' stamp: 'yo 2/14/2001 12:43'!
primitiveDisplayString
	| kernDelta xTable glyphMap stopIndex startIndex sourceString bbObj maxGlyph ascii glyphIndex sourcePtr left |
	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].
	left _ destX.
	sourcePtr _ interpreterProxy firstIndexableField: sourceString.
	startIndex to: stopIndex do:[:charIndex|
		ascii _ interpreterProxy byteAt: 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: [self copyBits].
		interpreterProxy failed ifTrue:[^nil].
		destX _ destX + width + kernDelta.
	 ].
	affectedL _ left.
	self showDisplayBits.
	interpreterProxy pop: 6. "pop args, return rcvr"! !


!Interpreter methodsFor: 'float primitives' stamp: 'yo 2/1/2001 23:49'!
primitiveExponent

	"Exponent part of this float."



	| rcvr frac pwr |

	self var: #rcvr declareC: 'double rcvr'.

	self var: #frac declareC: 'double frac'.

	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: 'other primitives' stamp: 'yo 2/7/2001 10:49'!
primitiveObsoleteIndexedPrimitive

	"Primitive. Invoke an obsolete indexed primitive."

	| pluginName functionName functionAddress |

	self var: #pluginName declareC:'char *pluginName'.

	self var: #functionName declareC:'char *functionName'.

	functionAddress _ 

		self cCoerce: ((obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 2) to: 'int'.

	functionAddress = nil 

		ifFalse:[^self cCode: '((int (*) (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: '((int (*) (void))functionAddress)()'

				inSmalltalk:[self callExternalPrimitive: functionAddress]].

	^self primitiveFail! !

!Interpreter methodsFor: 'other primitives' stamp: 'yo 2/1/2001 23:50'!
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.

	Note: Thanks to Ian Piumarta for this primitive."



	| mem paramsArraySize result arg index |

	mem _ self cCoerce: memory to: 'int'.

	self cCode: '' inSmalltalk: [mem _ 0].

	argumentCount = 0 ifTrue: [

		paramsArraySize _ 23.

		result _ self instantiateClass: (self splObj: ClassArray) indexableSize: paramsArraySize.

		0 to: paramsArraySize - 1 do:

			[:i | self storeWord: i ofObject: result withValue: (self integerObjectOf: 0)].

		self storeWord: 0	ofObject: result withValue: (self integerObjectOf: youngStart - mem).

		self storeWord: 1		ofObject: result withValue: (self integerObjectOf: freeBlock - mem).

		self storeWord: 2	ofObject: result withValue: (self integerObjectOf: endOfMemory - mem).

		self storeWord: 3	ofObject: result withValue: (self integerObjectOf: allocationCount).

		self storeWord: 4	ofObject: result withValue: (self integerObjectOf: allocationsBetweenGCs).

		self storeWord: 5	ofObject: result withValue: (self integerObjectOf: tenuringThreshold).

		self storeWord: 6	ofObject: result withValue: (self integerObjectOf: statFullGCs).

		self storeWord: 7	ofObject: result withValue: (self integerObjectOf: statFullGCMSecs).

		self storeWord: 8	ofObject: result withValue: (self integerObjectOf: statIncrGCs).

		self storeWord: 9	ofObject: result withValue: (self integerObjectOf: statIncrGCMSecs).

		self storeWord: 10	ofObject: result withValue: (self integerObjectOf: statTenures).

		self storeWord: 20	ofObject: result withValue: (self integerObjectOf: rootTableCount).

		self storeWord: 21	ofObject: result withValue: (self integerObjectOf: statRootTableOverflows).

		self storeWord: 22	ofObject: result withValue: (self integerObjectOf: extraVMMemory).

		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 > 23]) 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].

		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].

	successFlag ifTrue: [

		self pop: 3 thenPush: (self integerObjectOf: result).  "return old value"

		^ nil].



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

! !


!InterpreterSimulator methodsFor: 'initialization' stamp: 'yo 2/7/2001 10:47'!
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 initialize.

	Interpreter initialize.



	methodCache _ Array new: MethodCacheSize.

	atCache _ Array new: AtCacheTotalSize.

	rootTable _ Array new: RootTableSize.

	remapBuffer _ Array new: RemapBufferSize.

	semaphoresUseBufferA _ true.

	semaphoresToSignalA _ Array new: SemaphoresToSignalSize.

	semaphoresToSignalB _ Array new: SemaphoresToSignalSize.

	externalPrimitiveTable _ CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).



	obsoleteNamedPrimitiveTable _ 

		CArrayAccessor on: self class obsoleteNamedPrimitiveTable.

	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.

	traceOn _ true.

	myBitBlt _ BitBltSimulator new setInterpreter: self.

	displayForm _ nil.  "displayForm is created in response to primitiveBeDisplay"

	filesOpen _ OrderedCollection new.

! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'yo 2/7/2001 10:53'!
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"

	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"

	savedWindowSize _ self nextLongFrom: f swap: swapBytes.

	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].

	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' stamp: 'yo 2/14/2001 14:17'!
ioGetNextEvent: evtBuf

	self primitiveFail.
! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'yo 2/14/2001 14:17'!
ioSetInputSemaphore: index

	self primitiveFail! !

!InterpreterSimulator methodsFor: 'file primitives' stamp: 'yo 2/14/2001 12:04'!
primitiveFileOpen
	| namePointer writeFlag fileName f |
	writeFlag _ self booleanValueOf: self stackTop.
	namePointer _ self stackValue: 1.
	self success: (self isBytes: namePointer).
	successFlag ifTrue:
		[fileName _ self stringOf: namePointer.
		filesOpen addLast: (writeFlag
			ifTrue: [f _ FileStream fileNamed: fileName.
					f ifNil: [^ self primitiveFail] ifNotNil: [f binary]]
			ifFalse: [(StandardFileStream isAFileNamed: fileName)
				ifTrue: [f _ (FileStream readOnlyFileNamed: fileName).
						f ifNil:[^self primitiveFail] ifNotNil:[f binary]]
				ifFalse: [^ self primitiveFail]]).
		self pop: 3.  "rcvr, name, write"
		self pushInteger: filesOpen size]! !

!InterpreterSimulator methodsFor: 'plugin support' stamp: 'yo 2/14/2001 11:15'!
classNameOf: aClass Is: className
	"Check if aClass' name is className"
	| name |
	(self lengthOf: aClass) <= 6 ifTrue:[^false]. "Not a class but maybe behavior" 
	name _ self fetchPointer: 6 ofObject: aClass.
	(self isBytes: name) ifFalse:[^false].
	^ className = (self stringOf: name).
! !


!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'yo 2/14/2001 11:56'!
cBytesCopyFrom: pFrom to: pTo len: len 
	""
	| limit |
	self returnTypeC: 'int'.
	self var: #pFrom declareC: 'unsigned char * pFrom'.
	self var: #pTo declareC: 'unsigned char * pTo'.
	self var: #len declareC: 'int len'.
	self var: #limit declareC: 'int limit'.

	self cCode: '' inSmalltalk: [
		(interpreterProxy isKindOf: InterpreterSimulator) ifTrue: [
			"called from InterpreterSimulator"
				limit _ len - 1.
				0 to: limit do: [:i |
					interpreterProxy byteAt: pTo + i
						put: (interpreterProxy byteAt: pFrom + i)
				].
			^ 0
		].
	].	
	limit _ len - 1.
	0 to: limit do: [:i | pTo at: i put: (pFrom at: i)].
	^ 0! !



More information about the Squeak-dev mailing list