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
> <[email protected]> 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
> >
'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'!
