[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
|