[FIX][3.0] for better simulation

Yoshiki Ohshima ohshima at is.titech.ac.jp
Wed Feb 7 19:24:51 UTC 2001


  Hi,

  Attached change set fixes couples of primitives for better
interpreter simulation.  At least, this makes 'VM statistics' in
simulated image to work.

  -- Yoshiki
-------------- next part --------------
'From Squeak3.0 of 4 February 2001 [latest update: #3414] on 7 February 2001 at 10:55:58 am'!

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

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


More information about the Squeak-dev mailing list