[Vm-dev] Re: [Pharo-project] InterpreterSimulator reloaded
David T. Lewis
lewis at mail.msen.com
Wed Mar 9 00:38:27 UTC 2011
Pavel,
Thank you! I am CC'ing the vm-dev list with a copy of your change
set to update the interpreter simulator.
Dave
On Tue, Mar 08, 2011 at 11:25:21PM +0100, Pavel Krivanek wrote:
> I collected the changes from the image. See the attachment.
>
> To load the simulator in Pharo 1.3 do:
>
> Gofer new
> squeaksource: 'MetacelloRepository';
> package: 'ConfigurationOfVMMaker';
> load.
>
> (ConfigurationOfVMMaker project version: '1.5') load.
>
> proceed all deprecation warnings...
> load the attached fix.
> run the simulator:
>
> (InterpreterSimulator new openOn: 'cuis.image') test
>
> A good option is the Juan's small Cuis image (1.9MB with some next
> shrinking). The classical mini.image doesn't work on this version of
> the interpreter.
>
> Cheers,
> -- Pavel
>
>
>
> On Tue, Mar 8, 2011 at 10:47 PM, Pavel Krivanek
> <pavel.krivanek at gmail.com> wrote:
> > Hi,
> >
> > I tried to make the IneterpreterSimulator working on and with latest
> > images. The result is a Pharo image that you can download here:
> >
> > https://gforge.inria.fr/frs/shownotes.php?release_id=5897
> >
> > It is still far from perfect however it can be used for simulations of
> > small headless images etc. It would be great if some VM guy will help
> > with integration of the changes.
> >
> > Cheers,
> > -- Pavel
> >
-------------- next part --------------
'From Pharo1.3a of ''18 January 2011'' [Latest update: #13069] on 8 March 2011 at 11:05:02 pm'!
Interpreter subclass: #InterpreterSimulator
instanceVariableNames: 'bytesPerWord byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging lastContext '
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-InterpreterSimulation'!
!Interpreter methodsFor: 'object access primitives' stamp: 'pavelkrivanek 3/7/2011 13:00'!
primitiveNewWithArg
"Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free."
| size class spaceOkay |
<var: #size type: 'usqInt'>
self isDefinedTrueExpression: 'SQ_IMAGE64 && SQ_HOST64'
inSmalltalk: [false "size := self positive32BitValueOf: self stackTop" "TODO"]
comment: 'permit large object allocation on 64 bit image and host'
ifTrue: [size := self positive64BitValueOf: self stackTop]
ifFalse: [size := self positive32BitValueOf: self stackTop].
class := self stackValue: 1.
self success: size >= 0.
successFlag
ifTrue: ["The following may cause GC!!"
spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: size.
self success: spaceOkay.
class := self stackValue: 1].
successFlag ifTrue: [self pop: 2 thenPush: (self instantiateClass: class indexableSize: size)]! !
!Interpreter methodsFor: 'primitive support' stamp: 'pavelkrivanek 3/8/2011 21:52'!
signed64BitIntegerFor: integerValue
"Return a Large Integer object for the given integer value"
| newLargeInteger magnitude largeClass intValue highWord sz |
<inline: false>
<var: 'integerValue' type: 'sqLong'>
<var: 'magnitude' type: 'unsigned sqLong'>
<var: 'highWord' type: 'usqInt'>
integerValue < 0
ifTrue:[ largeClass := self classLargeNegativeInteger.
magnitude := 0 - integerValue]
ifFalse:[ largeClass := self classLargePositiveInteger.
magnitude := integerValue].
magnitude <= 16r7FFFFFFF ifTrue:[^self signed32BitIntegerFor: integerValue].
highWord := self cCode: 'magnitude >> 32' inSmalltalk: [ magnitude bitShift: -32]. "shift is coerced to usqInt otherwise"
highWord = 0
ifTrue:[sz := 4]
ifFalse:[
sz := 5.
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
].
newLargeInteger := self instantiateClass: largeClass indexableSize: sz.
0 to: sz-1 do: [:i |
intValue := self cCode: '(magnitude >> (i * 8)) & 255' inSmalltalk: [(magnitude bitShift: (i*8) negated) bitAnd: 255].
self storeByte: i ofObject: newLargeInteger withValue: intValue].
^ newLargeInteger! !
!Interpreter methodsFor: 'primitive support' stamp: 'pavelkrivanek 3/8/2011 21:46'!
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 |
<inline: false>
<returnTypeC: 'sqLong'>
<var: 'value' type: 'sqLong'>
(self isIntegerObject: oop) ifTrue: [^self cCoerce: (self integerValueOf: oop) to: 'sqLong'].
sz := self lengthOf: oop.
sz > 8 ifTrue: [^ self primitiveFail].
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)' inSmalltalk: [4].
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))].
"Fail if value exceeds range of a 64-bit two's-complement signed integer."
negative
ifTrue:[value := 0 - value.
value >= 0 ifTrue: [^ self primitiveFail]]
ifFalse:[value < 0 ifTrue:[^ self primitiveFail]].
^ value! !
!Interpreter methodsFor: 'memory space primitives' stamp: 'pavelkrivanek 3/8/2011 17:55'!
primitiveSetGCBiasToGrowGCLimit
"Primitive. If the GC logic has bias to grow, set growth limit"
| value |
<export: true>
value := self stackIntegerValue: 0.
successFlag ifTrue:[
gcBiasToGrowGCLimit := value.
self cCode: [gcBiasToGrowThreshold := youngStart - (self cCoerce: memory to: 'int').]
inSmalltalk: [gcBiasToGrowThreshold := youngStart - memory size.].
self pop: argumentCount.
].! !
!Interpreter methodsFor: 'plugin primitives' stamp: 'pavelkrivanek 3/8/2011 19:08'!
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 externalFunctionName |
<var: #addr type: 'void *'>
"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 storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
self storePointerUnchecked: 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].
externalFunctionName := self getExternalFunctionName: functionName + self baseHeaderSize
OfLength: functionLength
FromModule: moduleName + self baseHeaderSize
OfLength: moduleLength.
self cCode:'' inSmalltalk:[
(externalFunctionName value = #primitiveSetGCBiasToGrowGCLimit)
ifTrue: [ self primitiveSetGCBiasToGrowGCLimit. ^ self ].
(externalFunctionName value = #primitiveSetGCBiasToGrow)
ifTrue: [ self primitiveSetGCBiasToGrow. ^ self ].
].
addr := self ioLoadFunction: externalFunctionName value From: externalFunctionName key.
" addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
OfLength: functionLength
FromModule: moduleName + self 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 storePointerUnchecked: 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]! !
!InterpreterSimulator methodsFor: 'debug support' stamp: 'pavelkrivanek 3/7/2011 13:01'!
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: 'pavelkrivanek 3/7/2011 13:03'!
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 * self 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 = 'ByteSymbol' 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 + self baseHeaderSize)) ,
' -> ' ,
(self longAt: oop + self baseHeaderSize + self bytesPerWord) hex8 , ')'].
('AEIOU' includes: name first)
ifTrue: [^ 'an ' , name]
ifFalse: [^ 'a ' , name]! !
!InterpreterSimulator methodsFor: 'plugin support' stamp: 'pavelkrivanek 3/8/2011 17:41'!
getExternalFunctionName: functionName OfLength: functionLength FromModule: moduleName OfLength: moduleLength
"Load and return the requested function from a module"
| pluginString functionString |
pluginString := String new: moduleLength.
1 to: moduleLength do:[:i| pluginString byteAt: i put: (self byteAt: moduleName+i-1)].
functionString := String new: functionLength.
1 to: functionLength do:[:i| functionString byteAt: i put: (self byteAt: functionName+i-1)].
functionString := functionString asSymbol.
^ pluginString -> functionString! !
!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'pavelkrivanek 3/7/2011 14:30'!
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: 'pavelkrivanek 3/8/2011 21:39'!
primitiveMouseButtons
| buttons |
self pop: 1.
buttons := Sensor mouseButtons.
self pushInteger: buttons! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'pavelkrivanek 3/8/2011 18:54'!
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 initializeConstants.
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.
weakRoots := Array new: RootTableSize + RemapBufferSize + 100.
remapBuffer := Array new: RemapBufferSize.
semaphoresUseBufferA := true.
semaphoresToSignalA := Array new: SemaphoresToSignalSize.
semaphoresToSignalB := Array new: SemaphoresToSignalSize.
externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
primitiveTable := self class primitiveTable.
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: self bytesPerWord * 2 with: self bytesPerWord with: 0 with: 0).
transcript := Transcript.
displayForm := 'Display has not yet been installed' asDisplayText form.
! !
!InterpreterSimulator methodsFor: 'initialization' stamp: 'pavelkrivanek 3/7/2011 14:33'!
openOn: fileName extraMemory: extraBytes
"InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"
| f version headerSize count oldBaseAddr bytesToShift swapBytes hasPlatformFloatOrdering versionToRun |
"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)"
versionToRun := version bitAnd: -2. "permit loading images with platform float ordering"
hasPlatformFloatOrdering := version ~= (version bitAnd: -2). "is low order bit set?"
(self readableFormat: versionToRun) "permit loading images with platform float ordering"
ifTrue: [swapBytes := false]
ifFalse: [(versionToRun := self byteSwapped: version) = self imageFormatVersion
ifTrue: [swapBytes := true]
ifFalse: [self error: 'incompatible 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 oldFormatFullScreenFlag: (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: [UIManager default informUser: 'Swapping bytes of foreign image...'
during: [self reverseBytesInImage]].
self initialize.
bytesToShift := 0 - oldBaseAddr. "adjust pointers for zero base address"
endOfMemory := endOfMemory.
UIManager default informUser: 'Relocating object pointers...'
during: [self initializeInterpreter: bytesToShift].
hasPlatformFloatOrdering ifTrue: [UIManager default informUser: 'Swapping words in float objects...'
during: [self normalizeFloatOrderingInImage]].
! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'pavelkrivanek 3/8/2011 13:31'!
logStep: aStream
lastContext = activeContext ifFalse: [
self printStackFrame: activeContext onStream: aStream.
aStream flush.
].
lastContext := activeContext.
! !
!InterpreterSimulator methodsFor: 'testing' stamp: 'pavelkrivanek 3/8/2011 21:53'!
test
| log |
log := FileStream forceNewFileNamed: 'log.txt'.
transcript clear.
byteCount := 0.
quitBlock := [^ self].
self internalizeIPandSP.
self fetchNextBytecode.
[true] whileTrue: [.
"self logStep: log."
self dispatchOn: currentBytecode in: BytecodeTable.
byteCount := byteCount + 1.
byteCount \\ 1000 = 0 ifTrue: [self fullDisplay]].
self externalizeIPandSP.
! !
!ObjectMemory class methodsFor: '*Alien-VMMaker-Support-override' stamp: 'pavelkrivanek 3/7/2011 12:58'!
initialize
#( #ClassAlien #ClassUnsafeAlien #InvokeCallbackSelector #SelectorAttemptToAssign)
do: [:c |
[ObjectMemory addClassVarNamed: c] ifError: []].! !
!ObjectMemory class methodsFor: '*Alien-VMMaker-Support-override' stamp: 'pavelkrivanek 3/8/2011 20:10'!
initializeSpecialObjectIndices
"Initialize indices into specialObjects array."
NilObject := 0.
FalseObject := 1.
TrueObject := 2.
SchedulerAssociation := 3.
ClassBitmap := 4.
ClassInteger := 5.
ClassString := 6.
ClassArray := 7.
"SmalltalkDictionary := 8." "Do not delete!!"
ClassFloat := 9.
ClassMethodContext := 10.
ClassBlockContext := 11.
ClassPoint := 12.
ClassLargePositiveInteger := 13.
TheDisplay := 14.
ClassMessage := 15.
ClassCompiledMethod := 16.
TheLowSpaceSemaphore := 17.
ClassSemaphore := 18.
ClassCharacter := 19.
SelectorDoesNotUnderstand := 20.
SelectorCannotReturn := 21.
ProcessSignalingLowSpace := 22. "was TheInputSemaphore"
SpecialSelectors := 23.
CharacterTable := 24.
SelectorMustBeBoolean := 25.
ClassByteArray := 26.
ClassProcess := 27.
CompactClasses := 28.
TheTimerSemaphore := 29.
TheInterruptSemaphore := 30.
SelectorCannotInterpret := 34.
"Was MethodContextProto := 35."
ClassBlockClosure := 36.
"Was BlockContextProto := 37."
ExternalObjectsArray := 38.
ClassPseudoContext := 39.
ClassTranslatedMethod := 40.
TheFinalizationSemaphore := 41.
ClassLargeNegativeInteger := 42.
ClassExternalAddress := 43.
ClassExternalStructure := 44.
ClassExternalData := 45.
ClassExternalFunction := 46.
ClassExternalLibrary := 47.
SelectorAboutToReturn := 48.
SelectorRunWithIn := 49.
SelectorAttemptToAssign := 50.
"PrimErrTableIndex := 51. in Interpreter class>>initializePrimitiveErrorCodes"
ClassAlien := 52.
InvokeCallbackSelector := 53.
ClassUnsafeAlien := 54.
ClassWeakFinalizer := 55
! !
!Interpreter class methodsFor: '*Alien-VMMaker-Support-override' stamp: 'pavelkrivanek 3/7/2011 12:58'!
initialize
"Interpreter initialize"
#(#PrimErrBadArgument #PrimErrBadIndex #PrimErrBadNumArgs #PrimErrBadReceiver #PrimErrGenericFailure #PrimErrInappropriate #PrimErrNoCMemory #PrimErrNoMemory #PrimErrNoModification #PrimErrNotFound #PrimErrTableIndex #PrimErrUnsupported #PrimNoErr )
do: [:c |
[Interpreter addClassVarNamed: c] ifError: []].
#(#primFailCode)
do: [:i | [Interpreter addInstVarNamed: i] ifError: []].
super initialize. "initialize ObjectMemory constants"
self initializeAssociationIndex.
self initializeBytecodeTable.
self initializeCaches.
self initializeCharacterIndex.
self initializeCharacterScannerIndices.
self initializeClassIndices.
self initializeCompilerHooks.
self initializeContextIndices.
self initializeDirectoryLookupResultCodes.
self initializeMessageIndices.
self initializeMethodIndices.
self initializePointIndices.
self initializePrimitiveTable.
self initializeSchedulerIndices.
self initializeSmallIntegers.
self initializeStreamIndices.
SemaphoresToSignalSize := 500.
PrimitiveExternalCallIndex := 117. "Primitive index for #primitiveExternalCall"
MillisecondClockMask := 16r1FFFFFFF.
"Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)"
MaxExternalPrimitiveTableSize := 4096. "entries"
MaxJumpBuf := 32. "max. callback depth"! !
!BitBltSimulation methodsFor: 'memory access' stamp: 'pavelkrivanek 3/8/2011 19:30'!
halftoneAt: idx
"Return a value from the halftone pattern."
^interpreterProxy long32At: halftoneBase + (idx \\ halftoneHeight * 4)! !
!BitBltSimulation methodsFor: 'primitives' stamp: 'pavelkrivanek 3/8/2011 21:56'!
primitiveDisplayString
| kernDelta xTable glyphMap stopIndex startIndex sourceString bbObj maxGlyph ascii glyphIndex sourcePtr left quickBlt |
<export: true>
<var: #sourcePtr type: '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: 'pavelkrivanek 3/8/2011 19:30'!
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'].
^ interpreterProxy long32At: dstIndex! !
!BitBltSimulator methodsFor: 'debug support' stamp: 'pavelkrivanek 3/8/2011 19:30'!
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'].
^interpreterProxy long32At: dstIndex put: value! !
!BitBltSimulator methodsFor: 'debug support' stamp: 'pavelkrivanek 3/8/2011 21:34'!
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'].
^ interpreterProxy long32At: srcIndex! !
!BitBltSimulator methodsFor: 'simulation' stamp: 'pavelkrivanek 3/8/2011 21:56'!
tableLookup: table at: index
^ interpreterProxy long32At: (table + (index * 4))! !
!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'pavelkrivanek 3/8/2011 23:19'!
+ increment
^self shallowCopy += increment! !
Interpreter initialize!
ObjectMemory initialize!
Interpreter subclass: #InterpreterSimulator
instanceVariableNames: 'bytesPerWord byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging lastContext'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-InterpreterSimulation'!
More information about the Vm-dev
mailing list