David T. Lewis uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-dtl.422.mcz ==================== Summary ==================== Name: VMMaker-dtl.422 Author: dtl Time: 30 December 2020, 8:11:52.023 pm UUID: dfc32d36-1caa-4251-9d0d-824cf8222611 Ancestors: VMMaker-dtl.421 VMMaker 4.19.5 Refactoring - move duplicated variables and methods from StackInterpreter and ContextInterpreter up to Interpreter. Remove stack interpreter support methods from ContextInterpreter, they are only sent from NewObjectMemory and StackInterpreter. Move duplicated stack bytecodes methods up to Interpreter. Move primitiveSetGCSemaphore up to Interpreter. Move duplicated common selector sends methods up to Interpreter. Move duplicated bitbit support methods up to Interpreter. Move duplicated array primitive support methods up to Interpreter. Move duplicated arithmetic primitive support methods up to Interpreter and remove unsent checkIntegerResult:.. Move duplicated I/O primitive methods up to Interpreter. =============== Diff against VMMaker-dtl.421 =============== Item was changed: Interpreter subclass: #ContextInterpreter + instanceVariableNames: 'activeContext theHomeContext receiver localHomeContext localReturnContext primitiveIndex reclaimableContextCount nextPollTick nextWakeupTick lastTick compilerInitialized compilerHooks newNativeMethod methodClass receiverClass interpreterVersion imageFormatVersionNumber interruptCheckCounter interruptCheckCounterFeedBackReset interruptChecksEveryNms primitiveTableDefaults jmpMax imageFormatInitialVersion allowAccessBeyondSP' + classVariableNames: 'BlockArgumentCountIndex BytecodeTable CacheProbeMax CallerIndex CompilerHooksSize DirBadPath DirEntryFound DirNoMoreEntries DoBalanceChecks HomeIndex InitialIPIndex MessageDictionaryIndex MethodCacheNative TempFrameStart' - instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector currentBytecode primitiveIndex primitiveFunctionPointer methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptPending savedWindowSize deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks newNativeMethod methodClass receiverClass interpreterVersion imageFormatVersionNumber interpreterProxy showSurfaceFn interruptCheckCounter interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTableDefaults jmpBuf jmpDepth jmpMax suspendedCallbacks suspendedMethods imageFormatInitialVersion allowAccessBeyondSP' - classVariableNames: 'BlockArgumentCountIndex BytecodeTable CacheProbeMax CallerIndex CompilerHooksSize DirBadPath DirEntryFound DirNoMoreEntries DoBalanceChecks HomeIndex InitialIPIndex MaxJumpBuf MessageDictionaryIndex MethodCacheNative TempFrameStart' poolDictionaries: 'VMMethodCacheConstants VMSqueakV3BytecodeConstants' category: 'VMMaker-Interpreter'! !ContextInterpreter commentStamp: '<historical>' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas. It has been modernized with 32-bit pointers, better management of Contexts, and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms. In addition to SmallInteger arithmetic and Floats, it supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a copletely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item). 2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the systemTracer. A better solution would be to reserve one of the format codes for Contexts only. 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. ! Item was changed: ----- Method: ContextInterpreter class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator aCCodeGenerator addHeaderFile: '<setjmp.h>'. - aCCodeGenerator var: #interpreterProxy type: #'struct VirtualMachine*'. - "declare primitiveTable as an array of pointers to a function returning void, taking no arguments" - aCCodeGenerator var: #primitiveFunctionPointer declareC: 'void (*primitiveFunctionPointer)(void)'. - aCCodeGenerator var: #methodCache declareC: 'long methodCache[' , (MethodCacheSize + 1) printString , ']'. - aCCodeGenerator var: #atCache declareC: 'sqInt atCache[' , (AtCacheTotalSize + 1) printString , ']'. aCCodeGenerator var: #statGCTime type: #sqLong. aCCodeGenerator var: #statFullGCMSecs type: #sqLong. aCCodeGenerator var: #statIGCDeltaTime type: #sqLong. aCCodeGenerator var: #statIncrGCMSecs type: #sqLong. - aCCodeGenerator var: #localIP type: #'char*'. - aCCodeGenerator var: #localSP type: #'char*'. - aCCodeGenerator var: #showSurfaceFn type: #'void*'. aCCodeGenerator var: #compilerHooks declareC: 'sqInt (*compilerHooks[' , (CompilerHooksSize + 1) printString , '])()'. aCCodeGenerator var: #interpreterVersion declareC: 'const char *interpreterVersion = "' , SmalltalkImage current datedVersion , ' [' , SmalltalkImage current lastUpdateString , ']"'. + self declareCAsOop: {#newMethod. #activeContext. #theHomeContext} in: aCCodeGenerator. - self declareCAsOop: {#instructionPointer. #method. #newMethod. #activeContext. #theHomeContext. #stackPointer} in: aCCodeGenerator. - aCCodeGenerator var: #jmpBuf declareC: 'jmp_buf jmpBuf[' , (MaxJumpBuf + 1) printString , ']'. - aCCodeGenerator var: #suspendedCallbacks declareC: 'sqInt suspendedCallbacks[' , (MaxJumpBuf + 1) printString , ']'. - aCCodeGenerator var: #suspendedMethods declareC: 'sqInt suspendedMethods[' , (MaxJumpBuf + 1) printString , ']'. "Reinitialized at interpreter entry by #initializeImageFormatVersion" aCCodeGenerator var: #imageFormatVersionNumber declareC: 'sqInt imageFormatVersionNumber = 0'. "Declared here to prevent inclusion in foo struct by CCodeGeneratorGlobalStructure" aCCodeGenerator var: #imageFormatInitialVersion declareC: 'sqInt imageFormatInitialVersion = 0'. aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[', MaxPrimitiveIndex asString, '])(void)'. aCCodeGenerator var: #primitiveTableDefaults declareC: 'void (*primitiveTableDefaults[' , (MaxPrimitiveIndex + 2) printString , '] )(void)= ' , self primitiveTableString. - aCCodeGenerator var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[' , (MaxExternalPrimitiveTableSize + 1) printString , '])(void)'. ! Item was changed: ----- Method: ContextInterpreter class>>initialize (in category 'initialization') ----- initialize "Interpreter initialize" 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 initializeStreamIndices. self initializeInterpreterSourceVersion. PrimitiveExternalCallIndex := 117. "Primitive index for #primitiveExternalCall" MillisecondClockMask := 16r1FFFFFFF. - MaxJumpBuf := 32. "max. callback depth" - "Translation flags (booleans that control code generation via conditional translation):" DoBalanceChecks := false. "generate stack balance checks" ! Item was removed: - ----- Method: ContextInterpreter>>argCount (in category 'message sending') ----- - argCount - ^ argumentCount! Item was removed: - ----- Method: ContextInterpreter>>asciiOfCharacter: (in category 'array primitive support') ----- - asciiOfCharacter: characterObj "Returns an integer object" - - <inline: false> - self assertClassOf: characterObj is: (objectMemory splObj: ClassCharacter). - self successful - ifTrue: [^ objectMemory fetchPointer: CharacterValueIndex ofObject: characterObj] - ifFalse: [^ ConstZero] "in case some code needs an int"! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimAdd (in category 'common selector sends') ----- - bytecodePrimAdd - | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) - ifTrue: [result := (objectMemory integerValueOf: rcvr) + (objectMemory integerValueOf: arg). - (objectMemory isIntegerValue: result) ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). - ^ self fetchNextBytecode "success"]] - ifFalse: [self initPrimCall. - self externalizeIPandSP. - self primitiveFloatAdd: rcvr toArg: arg. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]]. - - messageSelector := self specialSelector: 0. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimAtEnd (in category 'common selector sends') ----- - bytecodePrimAtEnd - messageSelector := self specialSelector: 21. - argumentCount := 0. - self normalSend.! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimBitAnd (in category 'common selector sends') ----- - bytecodePrimBitAnd - - self initPrimCall. - self externalizeIPandSP. - self primitiveBitAnd. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 14. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimBitOr (in category 'common selector sends') ----- - bytecodePrimBitOr - - self initPrimCall. - self externalizeIPandSP. - self primitiveBitOr. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 15. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimBitShift (in category 'common selector sends') ----- - bytecodePrimBitShift - - self initPrimCall. - self externalizeIPandSP. - self primitiveBitShift. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 12. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimDiv (in category 'common selector sends') ----- - bytecodePrimDiv - | quotient | - self initPrimCall. - quotient := self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0). - self successful ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: quotient). - ^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 13. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimDivide (in category 'common selector sends') ----- - bytecodePrimDivide - | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) - ifTrue: [rcvr := objectMemory integerValueOf: rcvr. - arg := objectMemory integerValueOf: arg. - (arg ~= 0 and: [rcvr \\ arg = 0]) - ifTrue: [result := rcvr // arg. - "generates C / operation" - (objectMemory isIntegerValue: result) - ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). - ^ self fetchNextBytecode"success"]]] - ifFalse: [self initPrimCall. - self externalizeIPandSP. - self primitiveFloatDivide: rcvr byArg: arg. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode"success"]]. - - messageSelector := self specialSelector: 9. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimDo (in category 'common selector sends') ----- - bytecodePrimDo - - messageSelector := self specialSelector: 27. - argumentCount := 1. - self normalSend. - ! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimEqual (in category 'common selector sends') ----- - bytecodePrimEqual - | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr = arg]. - - self initPrimCall. - aBool := self primitiveFloatEqual: rcvr toArg: arg. - self successful ifTrue: [^self booleanCheat: aBool]. - - messageSelector := self specialSelector: 6. - argumentCount := 1. - self normalSend - ! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimEquivalent (in category 'common selector sends') ----- - bytecodePrimEquivalent - - | rcvr arg | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - self booleanCheat: rcvr = arg.! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimMakePoint (in category 'common selector sends') ----- - bytecodePrimMakePoint - - self initPrimCall. - self externalizeIPandSP. - self primitiveMakePoint. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 11. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimMod (in category 'common selector sends') ----- - bytecodePrimMod - | mod | - self initPrimCall. - mod := self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0). - self successful ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: mod). - ^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 10. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimNew (in category 'common selector sends') ----- - bytecodePrimNew - - messageSelector := self specialSelector: 28. - argumentCount := 0. - self normalSend. - ! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimNewWithArg (in category 'common selector sends') ----- - bytecodePrimNewWithArg - - messageSelector := self specialSelector: 29. - argumentCount := 1. - self normalSend. - ! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimNext (in category 'common selector sends') ----- - bytecodePrimNext - messageSelector := self specialSelector: 19. - argumentCount := 0. - self normalSend.! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimNextPut (in category 'common selector sends') ----- - bytecodePrimNextPut - messageSelector := self specialSelector: 20. - argumentCount := 1. - self normalSend.! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimNotEqual (in category 'common selector sends') ----- - bytecodePrimNotEqual - | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr ~= arg]. - - self initPrimCall. - aBool := self primitiveFloatEqual: rcvr toArg: arg. - self successful ifTrue: [^self booleanCheat: aBool not]. - - messageSelector := self specialSelector: 7. - argumentCount := 1. - self normalSend - ! Item was removed: - ----- Method: ContextInterpreter>>bytecodePrimSubtract (in category 'common selector sends') ----- - bytecodePrimSubtract - | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) - ifTrue: [result := (objectMemory integerValueOf: rcvr) - (objectMemory integerValueOf: arg). - (objectMemory isIntegerValue: result) ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). - ^self fetchNextBytecode "success"]] - ifFalse: [self initPrimCall. - self externalizeIPandSP. - self primitiveFloatSubtract: rcvr fromArg: arg. - self internalizeIPandSP. - self successful ifTrue: [^self fetchNextBytecode "success"]]. - - messageSelector := self specialSelector: 1. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: ContextInterpreter>>characterForAscii: (in category 'array primitive support') ----- - characterForAscii: ascii "Arg must lie in range 0-255!!" - <inline: true> - ^ objectMemory fetchPointer: ascii ofObject: (objectMemory splObj: CharacterTable)! Item was removed: - ----- Method: ContextInterpreter>>checkBooleanResult: (in category 'arithmetic primitive support') ----- - checkBooleanResult: result - self successful - ifTrue: [self pushBool: result] - ifFalse: [self unPop: 2]! Item was removed: - ----- Method: ContextInterpreter>>checkCodeIntegrity: (in category 'stack interpreter support') ----- - checkCodeIntegrity: fullGCFlag - "This is a no-op in the Interpreter and the StackVM" - ^true! Item was removed: - ----- Method: ContextInterpreter>>checkIntegerResult: (in category 'arithmetic primitive support') ----- - checkIntegerResult: integerResult - (self successful and: [objectMemory isIntegerValue: integerResult]) - ifTrue: [self pushInteger: integerResult] - ifFalse: [self unPop: 2]! Item was removed: - ----- Method: ContextInterpreter>>checkInterpreterIntegrity (in category 'stack interpreter support') ----- - checkInterpreterIntegrity - "Perform an integrity/leak check using the heapMap. Assume - clearLeakMapAndMapAccessibleObjects has set a bit at each - object's header. Check that all oops in the interpreter's state - points to a header. Answer if all checks pass." - - ^true! Item was removed: - ----- Method: ContextInterpreter>>checkStackIntegrity (in category 'stack interpreter support') ----- - checkStackIntegrity - "Perform an integrity/leak check using the heapMap. Assume - clearLeakMapAndMapAccessibleObjects has set a bit at each - object's header. Scan all objects accessible from the stack - checking that every pointer points to a header. Answer if no - dangling pointers were detected." - - ^true! Item was removed: - ----- Method: ContextInterpreter>>compare31or32Bits:equal: (in category 'arithmetic primitive support') ----- - compare31or32Bits: obj1 equal: obj2 - "May set success to false" - - "First compare two ST integers..." - ((objectMemory isIntegerObject: obj1) - and: [objectMemory isIntegerObject: obj2]) - ifTrue: [^ obj1 = obj2]. - - "Now compare, assuming positive integers, but setting fail if not" - ^ (self positive32BitValueOf: obj1) = (self positive32BitValueOf: obj2)! Item was removed: - ----- Method: ContextInterpreter>>copyBits (in category 'bitblt support') ----- - copyBits - "This entry point needs to be implemented for the interpreter proxy. - Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBits - and call it. This entire mechanism should eventually go away and be - replaced with a dynamic lookup from BitBltPlugin itself but for backward - compatibility this stub is provided" - - | fn | - <var: #fn type: 'void *'> - fn := self ioLoadFunction: 'copyBits' From: 'BitBltPlugin'. - fn = 0 ifTrue: [^self primitiveFail]. - ^self cCode: '((sqInt (*)(void))fn)()'! Item was removed: - ----- Method: ContextInterpreter>>copyBitsFrom:to:at: (in category 'bitblt support') ----- - copyBitsFrom: x0 to: x1 at: y - "This entry point needs to be implemented for the interpreter proxy. - Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBitsFrom:to:at: - and call it. This entire mechanism should eventually go away and be - replaced with a dynamic lookup from BitBltPlugin itself but for backward - compatibility this stub is provided" - - | fn | - <var: #fn type: 'void *'> - fn := self ioLoadFunction: 'copyBitsFromtoat' From: 'BitBltPlugin'. - fn = 0 ifTrue: [^self primitiveFail]. - ^self cCode: '((sqInt (*)(sqInt, sqInt, sqInt))fn)(x0, x1, y)'! Item was removed: - ----- Method: ContextInterpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') ----- - displayBitsOf: aForm Left: l Top: t Right: r Bottom: b - "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." - - | displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle | - displayObj := objectMemory splObj: TheDisplay. - aForm = displayObj ifFalse: [^ nil]. - self success: ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]). - self successful ifTrue: [ - dispBits := objectMemory fetchPointer: 0 ofObject: displayObj. - w := self fetchInteger: 1 ofObject: displayObj. - h := self fetchInteger: 2 ofObject: displayObj. - d := self fetchInteger: 3 ofObject: displayObj. - ]. - l < 0 ifTrue:[left := 0] ifFalse: [left := l]. - r > w ifTrue: [right := w] ifFalse: [right := r]. - t < 0 ifTrue: [top := 0] ifFalse: [top := t]. - b > h ifTrue: [bottom := h] ifFalse: [bottom := b]. - ((left <= right) and: [top <= bottom]) ifFalse: [^nil]. - self successful ifTrue: [ - (objectMemory isIntegerObject: dispBits) ifTrue: [ - surfaceHandle := objectMemory integerValueOf: dispBits. - showSurfaceFn = 0 ifTrue: [ - showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'. - showSurfaceFn = 0 ifTrue: [^self success: false]]. - self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'. - ] ifFalse: [ - dispBitsIndex := dispBits + objectMemory baseHeaderSize. "index in memory byte array" - self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)' - inSmalltalk: [self showDisplayBits: dispBitsIndex - w: w h: h d: d - left: left right: right top: top bottom: bottom] - ]. - ].! Item was removed: - ----- Method: ContextInterpreter>>doPrimitiveDiv:by: (in category 'arithmetic primitive support') ----- - doPrimitiveDiv: rcvr by: arg - "Rounds negative results towards negative infinity, rather than zero." - | result posArg posRcvr integerRcvr integerArg | - (self areIntegers: rcvr and: arg) - ifTrue: [integerRcvr := objectMemory integerValueOf: rcvr. - integerArg := objectMemory integerValueOf: arg. - self success: integerArg ~= 0] - ifFalse: [self primitiveFail]. - self successful ifFalse: [^ 1 "fail"]. - - integerRcvr > 0 - ifTrue: [integerArg > 0 - ifTrue: [result := integerRcvr // integerArg] - ifFalse: ["round negative result toward negative infinity" - posArg := 0 - integerArg. - result := 0 - ((integerRcvr + (posArg - 1)) // posArg)]] - ifFalse: [posRcvr := 0 - integerRcvr. - integerArg > 0 - ifTrue: ["round negative result toward negative infinity" - result := 0 - ((posRcvr + (integerArg - 1)) // integerArg)] - ifFalse: [posArg := 0 - integerArg. - result := posRcvr // posArg]]. - self success: (objectMemory isIntegerValue: result). - ^ result! Item was removed: - ----- Method: ContextInterpreter>>doPrimitiveMod:by: (in category 'arithmetic primitive support') ----- - doPrimitiveMod: rcvr by: arg - | integerResult integerRcvr integerArg | - (self areIntegers: rcvr and: arg) - ifTrue: [integerRcvr := objectMemory integerValueOf: rcvr. - integerArg := objectMemory integerValueOf: arg. - self success: integerArg ~= 0] - ifFalse: [self primitiveFail]. - self successful ifFalse: [^ 1 "fail"]. - - integerResult := integerRcvr \\ integerArg. - - "ensure that the result has the same sign as the integerArg" - integerArg < 0 - ifTrue: [integerResult > 0 - ifTrue: [integerResult := integerResult + integerArg]] - ifFalse: [integerResult < 0 - ifTrue: [integerResult := integerResult + integerArg]]. - self success: (objectMemory isIntegerValue: integerResult). - ^ integerResult - ! Item was removed: - ----- Method: ContextInterpreter>>duplicateTopBytecode (in category 'stack bytecodes') ----- - duplicateTopBytecode - - self fetchNextBytecode. - self internalPush: self internalStackTop. - ! Item was removed: - ----- Method: ContextInterpreter>>extendedPushBytecode (in category 'stack bytecodes') ----- - extendedPushBytecode - - | descriptor variableType variableIndex | - descriptor := self fetchByte. - self fetchNextBytecode. - variableType := (descriptor >> 6) bitAnd: 16r3. - variableIndex := descriptor bitAnd: 16r3F. - variableType=0 ifTrue: [^self pushReceiverVariable: variableIndex]. - variableType=1 ifTrue: [^self pushTemporaryVariable: variableIndex]. - variableType=2 ifTrue: [^self pushLiteralConstant: variableIndex]. - variableType=3 ifTrue: [^self pushLiteralVariable: variableIndex]. - ! Item was removed: - ----- Method: ContextInterpreter>>fetchByte (in category 'interpreter shell') ----- - fetchByte - "This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator." - - ^ objectMemory byteAtPointer: localIP preIncrement! Item was removed: - ----- Method: ContextInterpreter>>fullDisplayUpdate (in category 'I/O primitive support') ----- - fullDisplayUpdate - "Repaint the entire smalltalk screen, ignoring the affected rectangle. Used in some platform's code when the Smalltalk window is brought to the front or uncovered." - - | displayObj w h | - displayObj := objectMemory splObj: TheDisplay. - ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifTrue: [ - w := self fetchInteger: 1 ofObject: displayObj. - h := self fetchInteger: 2 ofObject: displayObj. - self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: h. - self ioForceDisplayUpdate]. - ! Item was removed: - ----- Method: ContextInterpreter>>getCurrentBytecode (in category 'interpreter shell') ----- - getCurrentBytecode - "currentBytecode will be private to the main dispatch loop in the generated code. This method allows the currentBytecode to be retrieved from global variables." - - ^ objectMemory byteAt: instructionPointer! Item was removed: - ----- Method: ContextInterpreter>>interpreterAllocationReserveBytes (in category 'stack interpreter support') ----- - interpreterAllocationReserveBytes - "Extra allocation space in the object memory required by StackInterpreter" - ^ 0 - ! Item was removed: - ----- Method: ContextInterpreter>>isMarriedOrWidowedContext: (in category 'stack interpreter support') ----- - isMarriedOrWidowedContext: aContext - ^false! Item was removed: - ----- Method: ContextInterpreter>>jump: (in category 'jump bytecodes') ----- - jump: offset - - localIP := localIP + offset + 1. - currentBytecode := objectMemory byteAtPointer: localIP. - ! Item was removed: - ----- Method: ContextInterpreter>>loadBitBltFrom: (in category 'bitblt support') ----- - loadBitBltFrom: bb - "This entry point needs to be implemented for the interpreter proxy. - Since BitBlt is now a plugin we need to look up BitBltPlugin:=loadBitBltFrom - and call it. This entire mechanism should eventually go away and be - replaced with a dynamic lookup from BitBltPlugin itself but for backward - compatibility this stub is provided" - | fn | - <var: #fn type: 'void *'> - fn := self ioLoadFunction: 'loadBitBltFrom' From: 'BitBltPlugin'. - fn = 0 ifTrue: [^self primitiveFail]. - ^self cCode: '((sqInt (*)(sqInt))fn)(bb)'! Item was removed: - ----- Method: ContextInterpreter>>longJumpIfFalse (in category 'jump bytecodes') ----- - longJumpIfFalse - - self jumplfFalseBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! Item was removed: - ----- Method: ContextInterpreter>>longJumpIfTrue (in category 'jump bytecodes') ----- - longJumpIfTrue - - self jumplfTrueBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! Item was removed: - ----- Method: ContextInterpreter>>markAndTraceAndMaybeFreeStackPages: (in category 'stack interpreter support') ----- - markAndTraceAndMaybeFreeStackPages: fullGCFlag - "This is a no-op in Interpreter" - ! Item was removed: - ----- Method: ContextInterpreter>>markAndTraceOrFreeMachineCode: (in category 'stack interpreter support') ----- - markAndTraceOrFreeMachineCode: fullGCFlag - "This is a no-op in Interpreter" - ! Item was removed: - ----- Method: ContextInterpreter>>popStackBytecode (in category 'stack bytecodes') ----- - popStackBytecode - - self fetchNextBytecode. - self internalPop: 1. - ! Item was removed: - ----- Method: ContextInterpreter>>primitiveSetGCSemaphore (in category 'memory space primitives') ----- - primitiveSetGCSemaphore - "Primitive. Indicate the semaphore to be signalled for upon garbage collection" - | index | - <export: true> - index := self stackIntegerValue: 0. - self successful ifTrue:[ - objectMemory setGcSemaphoreIndex: index. - self pop: argumentCount. - ].! Item was removed: - ----- Method: ContextInterpreter>>pushConstantMinusOneBytecode (in category 'stack bytecodes') ----- - pushConstantMinusOneBytecode - - self fetchNextBytecode. - self internalPush: ConstMinusOne. - ! Item was removed: - ----- Method: ContextInterpreter>>pushConstantOneBytecode (in category 'stack bytecodes') ----- - pushConstantOneBytecode - - self fetchNextBytecode. - self internalPush: ConstOne. - ! Item was removed: - ----- Method: ContextInterpreter>>pushConstantTwoBytecode (in category 'stack bytecodes') ----- - pushConstantTwoBytecode - - self fetchNextBytecode. - self internalPush: ConstTwo. - ! Item was removed: - ----- Method: ContextInterpreter>>pushConstantZeroBytecode (in category 'stack bytecodes') ----- - pushConstantZeroBytecode - - self fetchNextBytecode. - self internalPush: ConstZero. - ! Item was removed: - ----- Method: ContextInterpreter>>pushFloat: (in category 'stack bytecodes') ----- - pushFloat: f - - <var: #f type: 'double '> - self push: (self floatObjectOf: f).! Item was removed: - ----- Method: ContextInterpreter>>pushLiteralConstant: (in category 'stack bytecodes') ----- - pushLiteralConstant: literalIndex - - self internalPush: (self literal: literalIndex).! Item was removed: - ----- Method: ContextInterpreter>>pushLiteralVariable: (in category 'stack bytecodes') ----- - pushLiteralVariable: literalIndex - - self internalPush: - (objectMemory fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).! Item was removed: - ----- Method: ContextInterpreter>>pushRemoteTempLongBytecode (in category 'stack bytecodes') ----- - pushRemoteTempLongBytecode - | remoteTempIndex tempVectorIndex | - remoteTempIndex := self fetchByte. - tempVectorIndex := self fetchByte. - self fetchNextBytecode. - self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex! Item was removed: - ----- Method: ContextInterpreter>>shortConditionalJump (in category 'jump bytecodes') ----- - shortConditionalJump - - self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.! Item was removed: - ----- Method: ContextInterpreter>>showDisplayBits:Left:Top:Right:Bottom: (in category 'I/O primitive support') ----- - showDisplayBits: aForm Left: l Top: t Right: r Bottom: b - "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." - deferDisplayUpdates ifTrue: [^ nil]. - self displayBitsOf: aForm Left: l Top: t Right: r Bottom: b! Item was removed: - ----- Method: ContextInterpreter>>specialSelector: (in category 'message sending') ----- - specialSelector: index - - ^ objectMemory fetchPointer: (index * 2) ofObject: (objectMemory splObj: SpecialSelectors)! Item was removed: - ----- Method: ContextInterpreter>>storeAndPopRemoteTempLongBytecode (in category 'stack bytecodes') ----- - storeAndPopRemoteTempLongBytecode - self storeRemoteTempLongBytecode. - self internalPop: 1! Item was removed: - ----- Method: ContextInterpreter>>storeRemoteTempLongBytecode (in category 'stack bytecodes') ----- - storeRemoteTempLongBytecode - | remoteTempIndex tempVectorIndex | - remoteTempIndex := self fetchByte. - tempVectorIndex := self fetchByte. - self fetchNextBytecode. - self storeRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex! Item was removed: - ----- Method: ContextInterpreter>>superclassOf: (in category 'message sending') ----- - superclassOf: classPointer - - ^ objectMemory fetchPointer: SuperclassIndex ofObject: classPointer! Item was changed: InterpreterPrimitives subclass: #Interpreter + instanceVariableNames: 'currentBytecode semaphoresUseBufferA semaphoresToSignalA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB extraVMMemory globalSessionID method instructionPointer stackPointer localIP localSP localReturnValue messageSelector currentByteCode primitiveFunctionPointer methodCache atCache lkupClass interruptPending savedWindowSize deferDisplayUpdates pendingFinalizationSignals interpreterProxy showSurfaceFn externalPrimitiveTable jmpBuf jmpDepth suspendedCallbacks suspendedMethods' + classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex SemaphoresToSignalSize' + poolDictionaries: 'VMMethodCacheConstants' - instanceVariableNames: 'semaphoresUseBufferA semaphoresToSignalA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB extraVMMemory globalSessionID' - classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase MaxExternalPrimitiveTableSize MaxPrimitiveIndex SemaphoresToSignalSize' - poolDictionaries: '' category: 'VMMaker-Interpreter'! !Interpreter commentStamp: 'dtl 4/22/2016 22:14' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas. ContextInterpreter is the Squeak interpreter VM as originally implemented by Dan Ingalls. StackInterpreter is the stack mapped interpreter by Eliot Miranda, which provides the basis for later Cog and Spur VMs.! Item was changed: ----- Method: Interpreter class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator + aCCodeGenerator + var: #interpreterProxy type: #'struct VirtualMachine*'. aCCodeGenerator var: 'semaphoresToSignalA' declareC: 'sqInt semaphoresToSignalA[' , (SemaphoresToSignalSize + 1) printString , ']'. aCCodeGenerator var: 'semaphoresToSignalB' declareC: 'sqInt semaphoresToSignalB[' , (SemaphoresToSignalSize + 1) printString , ']'. + self declareC: #(instructionPointer method) + as: #usqInt + in: aCCodeGenerator. + self declareC: #(stackPointer localIP localSP) + as: #'char *' + in: aCCodeGenerator. + aCCodeGenerator + var: #primitiveFunctionPointer + declareC: 'void (*primitiveFunctionPointer)()'. + aCCodeGenerator + var: #methodCache + declareC: 'long methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'. + aCCodeGenerator + var: #atCache + declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]'. + aCCodeGenerator + var: #showSurfaceFn + type: #'void *'. + aCCodeGenerator + var: #externalPrimitiveTable + declareC: 'void (*externalPrimitiveTable[' , (MaxExternalPrimitiveTableSize + 1) printString , '])(void)'. + aCCodeGenerator + var: #jmpBuf + declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'. + aCCodeGenerator + var: #suspendedCallbacks + declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'. + aCCodeGenerator + var: #suspendedMethods + declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'. + + ! Item was changed: ----- Method: Interpreter class>>initialize (in category 'initialization') ----- initialize "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" self initializeCaches. SemaphoresToSignalSize := 500. ! Item was added: + ----- Method: Interpreter>>asciiOfCharacter: (in category 'indexing primitive support') ----- + asciiOfCharacter: characterObj "Returns an integer object" + + <inline: false> + self assertClassOf: characterObj is: (objectMemory splObj: ClassCharacter). + self successful + ifTrue: [^ objectMemory fetchPointer: CharacterValueIndex ofObject: characterObj] + ifFalse: [^ ConstZero] "in case some code needs an int"! Item was added: + ----- Method: Interpreter>>bytecodePrimAdd (in category 'common selector sends') ----- + bytecodePrimAdd + | rcvr arg result | + rcvr := self internalStackValue: 1. + arg := self internalStackValue: 0. + (self areIntegers: rcvr and: arg) + ifTrue: [result := (objectMemory integerValueOf: rcvr) + (objectMemory integerValueOf: arg). + (objectMemory isIntegerValue: result) ifTrue: + [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + ^ self fetchNextBytecode "success"]] + ifFalse: [self initPrimCall. + self externalizeIPandSP. + self primitiveFloatAdd: rcvr toArg: arg. + self internalizeIPandSP. + self successful ifTrue: [^ self fetchNextBytecode "success"]]. + + messageSelector := self specialSelector: 0. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimAtEnd (in category 'common selector sends') ----- + bytecodePrimAtEnd + messageSelector := self specialSelector: 21. + argumentCount := 0. + self normalSend.! Item was added: + ----- Method: Interpreter>>bytecodePrimBitAnd (in category 'common selector sends') ----- + bytecodePrimBitAnd + + self initPrimCall. + self externalizeIPandSP. + self primitiveBitAnd. + self internalizeIPandSP. + self successful ifTrue: [^ self fetchNextBytecode "success"]. + + messageSelector := self specialSelector: 14. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimBitOr (in category 'common selector sends') ----- + bytecodePrimBitOr + + self initPrimCall. + self externalizeIPandSP. + self primitiveBitOr. + self internalizeIPandSP. + self successful ifTrue: [^ self fetchNextBytecode "success"]. + + messageSelector := self specialSelector: 15. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimBitShift (in category 'common selector sends') ----- + bytecodePrimBitShift + + self initPrimCall. + self externalizeIPandSP. + self primitiveBitShift. + self internalizeIPandSP. + self successful ifTrue: [^ self fetchNextBytecode "success"]. + + messageSelector := self specialSelector: 12. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimDiv (in category 'common selector sends') ----- + bytecodePrimDiv + | quotient | + self initPrimCall. + quotient := self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0). + self successful ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: quotient). + ^ self fetchNextBytecode "success"]. + + messageSelector := self specialSelector: 13. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimDivide (in category 'common selector sends') ----- + bytecodePrimDivide + | rcvr arg result | + rcvr := self internalStackValue: 1. + arg := self internalStackValue: 0. + (self areIntegers: rcvr and: arg) + ifTrue: [rcvr := objectMemory integerValueOf: rcvr. + arg := objectMemory integerValueOf: arg. + (arg ~= 0 and: [rcvr \\ arg = 0]) + ifTrue: [result := rcvr // arg. + "generates C / operation" + (objectMemory isIntegerValue: result) + ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + ^ self fetchNextBytecode"success"]]] + ifFalse: [self initPrimCall. + self externalizeIPandSP. + self primitiveFloatDivide: rcvr byArg: arg. + self internalizeIPandSP. + self successful ifTrue: [^ self fetchNextBytecode"success"]]. + + messageSelector := self specialSelector: 9. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimDo (in category 'common selector sends') ----- + bytecodePrimDo + + messageSelector := self specialSelector: 27. + argumentCount := 1. + self normalSend. + ! Item was added: + ----- Method: Interpreter>>bytecodePrimEqual (in category 'common selector sends') ----- + bytecodePrimEqual + | rcvr arg aBool | + rcvr := self internalStackValue: 1. + arg := self internalStackValue: 0. + (self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr = arg]. + + self initPrimCall. + aBool := self primitiveFloatEqual: rcvr toArg: arg. + self successful ifTrue: [^self booleanCheat: aBool]. + + messageSelector := self specialSelector: 6. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimEquivalent (in category 'common selector sends') ----- + bytecodePrimEquivalent + + | rcvr arg | + rcvr := self internalStackValue: 1. + arg := self internalStackValue: 0. + self booleanCheat: rcvr = arg.! Item was added: + ----- Method: Interpreter>>bytecodePrimMakePoint (in category 'common selector sends') ----- + bytecodePrimMakePoint + + self initPrimCall. + self externalizeIPandSP. + self primitiveMakePoint. + self internalizeIPandSP. + self successful ifTrue: [^ self fetchNextBytecode "success"]. + + messageSelector := self specialSelector: 11. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimMod (in category 'common selector sends') ----- + bytecodePrimMod + | mod | + self initPrimCall. + mod := self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0). + self successful ifTrue: + [self internalPop: 2 thenPush: (objectMemory integerObjectOf: mod). + ^ self fetchNextBytecode "success"]. + + messageSelector := self specialSelector: 10. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimNew (in category 'common selector sends') ----- + bytecodePrimNew + + messageSelector := self specialSelector: 28. + argumentCount := 0. + self normalSend. + ! Item was added: + ----- Method: Interpreter>>bytecodePrimNewWithArg (in category 'common selector sends') ----- + bytecodePrimNewWithArg + + messageSelector := self specialSelector: 29. + argumentCount := 1. + self normalSend. + ! Item was added: + ----- Method: Interpreter>>bytecodePrimNext (in category 'common selector sends') ----- + bytecodePrimNext + messageSelector := self specialSelector: 19. + argumentCount := 0. + self normalSend.! Item was added: + ----- Method: Interpreter>>bytecodePrimNextPut (in category 'common selector sends') ----- + bytecodePrimNextPut + messageSelector := self specialSelector: 20. + argumentCount := 1. + self normalSend.! Item was added: + ----- Method: Interpreter>>bytecodePrimNotEqual (in category 'common selector sends') ----- + bytecodePrimNotEqual + | rcvr arg aBool | + rcvr := self internalStackValue: 1. + arg := self internalStackValue: 0. + (self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr ~= arg]. + + self initPrimCall. + aBool := self primitiveFloatEqual: rcvr toArg: arg. + self successful ifTrue: [^self booleanCheat: aBool not]. + + messageSelector := self specialSelector: 7. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>bytecodePrimSubtract (in category 'common selector sends') ----- + bytecodePrimSubtract + | rcvr arg result | + rcvr := self internalStackValue: 1. + arg := self internalStackValue: 0. + (self areIntegers: rcvr and: arg) + ifTrue: [result := (objectMemory integerValueOf: rcvr) - (objectMemory integerValueOf: arg). + (objectMemory isIntegerValue: result) ifTrue: + [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). + ^self fetchNextBytecode "success"]] + ifFalse: [self initPrimCall. + self externalizeIPandSP. + self primitiveFloatSubtract: rcvr fromArg: arg. + self internalizeIPandSP. + self successful ifTrue: [^self fetchNextBytecode "success"]]. + + messageSelector := self specialSelector: 1. + argumentCount := 1. + self normalSend! Item was added: + ----- Method: Interpreter>>characterForAscii: (in category 'indexing primitive support') ----- + characterForAscii: ascii "Arg must lie in range 0-255!!" + <inline: true> + ^ objectMemory fetchPointer: ascii ofObject: (objectMemory splObj: CharacterTable)! Item was added: + ----- Method: Interpreter>>checkBooleanResult: (in category 'arithmetic primitive support') ----- + checkBooleanResult: result + self successful + ifTrue: [self pushBool: result] + ifFalse: [self unPop: 2]! Item was added: + ----- Method: Interpreter>>compare31or32Bits:equal: (in category 'arithmetic primitive support') ----- + compare31or32Bits: obj1 equal: obj2 + "May set success to false" + + "First compare two ST integers..." + ((objectMemory isIntegerObject: obj1) + and: [objectMemory isIntegerObject: obj2]) + ifTrue: [^ obj1 = obj2]. + + "Now compare, assuming positive integers, but setting fail if not" + ^ (self positive32BitValueOf: obj1) = (self positive32BitValueOf: obj2)! Item was added: + ----- Method: Interpreter>>copyBits (in category 'bitblt support') ----- + copyBits + "This entry point needs to be implemented for the interpreter proxy. + Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBits + and call it. This entire mechanism should eventually go away and be + replaced with a dynamic lookup from BitBltPlugin itself but for backward + compatibility this stub is provided" + + | fn | + <var: #fn type: 'void *'> + fn := self ioLoadFunction: 'copyBits' From: 'BitBltPlugin'. + fn = 0 ifTrue: [^self primitiveFail]. + ^self cCode: '((sqInt (*)(void))fn)()'! Item was added: + ----- Method: Interpreter>>copyBitsFrom:to:at: (in category 'bitblt support') ----- + copyBitsFrom: x0 to: x1 at: y + "This entry point needs to be implemented for the interpreter proxy. + Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBitsFrom:to:at: + and call it. This entire mechanism should eventually go away and be + replaced with a dynamic lookup from BitBltPlugin itself but for backward + compatibility this stub is provided" + + | fn | + <var: #fn type: 'void *'> + fn := self ioLoadFunction: 'copyBitsFromtoat' From: 'BitBltPlugin'. + fn = 0 ifTrue: [^self primitiveFail]. + ^self cCode: '((sqInt (*)(sqInt, sqInt, sqInt))fn)(x0, x1, y)'! Item was added: + ----- Method: Interpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') ----- + displayBitsOf: aForm Left: l Top: t Right: r Bottom: b + "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." + + | displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle | + displayObj := objectMemory splObj: TheDisplay. + aForm = displayObj ifFalse: [^ nil]. + self success: ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]). + self successful ifTrue: [ + dispBits := objectMemory fetchPointer: 0 ofObject: displayObj. + w := self fetchInteger: 1 ofObject: displayObj. + h := self fetchInteger: 2 ofObject: displayObj. + d := self fetchInteger: 3 ofObject: displayObj. + ]. + l < 0 ifTrue:[left := 0] ifFalse: [left := l]. + r > w ifTrue: [right := w] ifFalse: [right := r]. + t < 0 ifTrue: [top := 0] ifFalse: [top := t]. + b > h ifTrue: [bottom := h] ifFalse: [bottom := b]. + ((left <= right) and: [top <= bottom]) ifFalse: [^nil]. + self successful ifTrue: [ + (objectMemory isIntegerObject: dispBits) ifTrue: [ + surfaceHandle := objectMemory integerValueOf: dispBits. + showSurfaceFn = 0 ifTrue: [ + showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'. + showSurfaceFn = 0 ifTrue: [^self success: false]]. + self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'. + ] ifFalse: [ + dispBitsIndex := dispBits + objectMemory baseHeaderSize. "index in memory byte array" + self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)' + inSmalltalk: [self showDisplayBits: dispBitsIndex + w: w h: h d: d + left: left right: right top: top bottom: bottom] + ]. + ].! Item was added: + ----- Method: Interpreter>>doPrimitiveDiv:by: (in category 'arithmetic primitive support') ----- + doPrimitiveDiv: rcvr by: arg + "Rounds negative results towards negative infinity, rather than zero." + | result posArg posRcvr integerRcvr integerArg | + (self areIntegers: rcvr and: arg) + ifTrue: [integerRcvr := objectMemory integerValueOf: rcvr. + integerArg := objectMemory integerValueOf: arg. + self success: integerArg ~= 0] + ifFalse: [self primitiveFail]. + self successful ifFalse: [^ 1 "fail"]. + + integerRcvr > 0 + ifTrue: [integerArg > 0 + ifTrue: [result := integerRcvr // integerArg] + ifFalse: ["round negative result toward negative infinity" + posArg := 0 - integerArg. + result := 0 - ((integerRcvr + (posArg - 1)) // posArg)]] + ifFalse: [posRcvr := 0 - integerRcvr. + integerArg > 0 + ifTrue: ["round negative result toward negative infinity" + result := 0 - ((posRcvr + (integerArg - 1)) // integerArg)] + ifFalse: [posArg := 0 - integerArg. + result := posRcvr // posArg]]. + self success: (objectMemory isIntegerValue: result). + ^ result! Item was added: + ----- Method: Interpreter>>doPrimitiveMod:by: (in category 'arithmetic primitive support') ----- + doPrimitiveMod: rcvr by: arg + | integerResult integerRcvr integerArg | + (self areIntegers: rcvr and: arg) + ifTrue: [integerRcvr := objectMemory integerValueOf: rcvr. + integerArg := objectMemory integerValueOf: arg. + self success: integerArg ~= 0] + ifFalse: [self primitiveFail]. + self successful ifFalse: [^ 1 "fail"]. + + integerResult := integerRcvr \\ integerArg. + + "ensure that the result has the same sign as the integerArg" + integerArg < 0 + ifTrue: [integerResult > 0 + ifTrue: [integerResult := integerResult + integerArg]] + ifFalse: [integerResult < 0 + ifTrue: [integerResult := integerResult + integerArg]]. + self success: (objectMemory isIntegerValue: integerResult). + ^ integerResult! Item was added: + ----- Method: Interpreter>>duplicateTopBytecode (in category 'stack bytecodes') ----- + duplicateTopBytecode + + self fetchNextBytecode. + self internalPush: self internalStackTop. + ! Item was added: + ----- Method: Interpreter>>extendedPushBytecode (in category 'stack bytecodes') ----- + extendedPushBytecode + + | descriptor variableType variableIndex | + descriptor := self fetchByte. + self fetchNextBytecode. + variableType := (descriptor >> 6) bitAnd: 16r3. + variableIndex := descriptor bitAnd: 16r3F. + variableType=0 ifTrue: [^self pushReceiverVariable: variableIndex]. + variableType=1 ifTrue: [^self pushTemporaryVariable: variableIndex]. + variableType=2 ifTrue: [^self pushLiteralConstant: variableIndex]. + variableType=3 ifTrue: [^self pushLiteralVariable: variableIndex]. + ! Item was added: + ----- Method: Interpreter>>fetchByte (in category 'interpreter shell') ----- + fetchByte + "This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator." + + ^objectMemory byteAtPointer: localIP preIncrement! Item was added: + ----- Method: Interpreter>>fullDisplayUpdate (in category 'I/O primitive support') ----- + fullDisplayUpdate + "Repaint the entire smalltalk screen, ignoring the affected rectangle. Used in some platform's code when the Smalltalk window is brought to the front or uncovered." + + | displayObj w h | + displayObj := objectMemory splObj: TheDisplay. + ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifTrue: [ + w := self fetchInteger: 1 ofObject: displayObj. + h := self fetchInteger: 2 ofObject: displayObj. + self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: h. + self ioForceDisplayUpdate]. + ^nil! Item was added: + ----- Method: Interpreter>>getCurrentBytecode (in category 'interpreter shell') ----- + getCurrentBytecode + "currentBytecode will be private to the main dispatch loop in the generated code. This method allows the currentBytecode to be retrieved from global variables." + + ^objectMemory byteAt: instructionPointer! Item was added: + ----- Method: Interpreter>>jump: (in category 'jump bytecodes') ----- + jump: offset + localIP := localIP + offset + 1. + currentBytecode := objectMemory byteAtPointer: localIP! Item was added: + ----- Method: Interpreter>>loadBitBltFrom: (in category 'bitblt support') ----- + loadBitBltFrom: bb + "This entry point needs to be implemented for the interpreter proxy. + Since BitBlt is now a plugin we need to look up BitBltPlugin:=loadBitBltFrom + and call it. This entire mechanism should eventually go away and be + replaced with a dynamic lookup from BitBltPlugin itself but for backward + compatibility this stub is provided" + | fn | + <var: #fn type: 'void *'> + fn := self ioLoadFunction: 'loadBitBltFrom' From: 'BitBltPlugin'. + fn = 0 ifTrue: [^self primitiveFail]. + ^self cCode: '((sqInt (*)(sqInt))fn)(bb)'! Item was added: + ----- Method: Interpreter>>longJumpIfFalse (in category 'jump bytecodes') ----- + longJumpIfFalse + + self jumplfFalseBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! Item was added: + ----- Method: Interpreter>>longJumpIfTrue (in category 'jump bytecodes') ----- + longJumpIfTrue + + self jumplfTrueBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! Item was added: + ----- Method: Interpreter>>popStackBytecode (in category 'stack bytecodes') ----- + popStackBytecode + + self fetchNextBytecode. + self internalPop: 1. + ! Item was added: + ----- Method: Interpreter>>primitiveSetGCSemaphore (in category 'memory space primitives') ----- + primitiveSetGCSemaphore + "Primitive. Indicate the semaphore to be signalled for upon garbage collection" + | index | + <export: true> + index := self stackIntegerValue: 0. + self successful ifTrue:[ + objectMemory setGcSemaphoreIndex: index. + self pop: argumentCount. + ].! Item was added: + ----- Method: Interpreter>>pushConstantMinusOneBytecode (in category 'stack bytecodes') ----- + pushConstantMinusOneBytecode + + self fetchNextBytecode. + self internalPush: ConstMinusOne. + ! Item was added: + ----- Method: Interpreter>>pushConstantOneBytecode (in category 'stack bytecodes') ----- + pushConstantOneBytecode + + self fetchNextBytecode. + self internalPush: ConstOne. + ! Item was added: + ----- Method: Interpreter>>pushConstantTwoBytecode (in category 'stack bytecodes') ----- + pushConstantTwoBytecode + + self fetchNextBytecode. + self internalPush: ConstTwo. + ! Item was added: + ----- Method: Interpreter>>pushConstantZeroBytecode (in category 'stack bytecodes') ----- + pushConstantZeroBytecode + + self fetchNextBytecode. + self internalPush: ConstZero. + ! Item was added: + ----- Method: Interpreter>>pushFloat: (in category 'stack bytecodes') ----- + pushFloat: f + + <var: #f type: #double> + self push: (self floatObjectOf: f).! Item was added: + ----- Method: Interpreter>>pushLiteralConstant: (in category 'stack bytecodes') ----- + pushLiteralConstant: literalIndex + + self internalPush: (self literal: literalIndex).! Item was added: + ----- Method: Interpreter>>pushLiteralVariable: (in category 'stack bytecodes') ----- + pushLiteralVariable: literalIndex + + self internalPush: + (objectMemory fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).! Item was added: + ----- Method: Interpreter>>pushRemoteTempLongBytecode (in category 'stack bytecodes') ----- + pushRemoteTempLongBytecode + | remoteTempIndex tempVectorIndex | + remoteTempIndex := self fetchByte. + tempVectorIndex := self fetchByte. + self fetchNextBytecode. + self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex! Item was added: + ----- Method: Interpreter>>shortConditionalJump (in category 'jump bytecodes') ----- + shortConditionalJump + + self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.! Item was added: + ----- Method: Interpreter>>showDisplayBits:Left:Top:Right:Bottom: (in category 'I/O primitive support') ----- + showDisplayBits: aForm Left: l Top: t Right: r Bottom: b + "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." + deferDisplayUpdates ifTrue: [^ nil]. + self displayBitsOf: aForm Left: l Top: t Right: r Bottom: b! Item was added: + ----- Method: Interpreter>>specialSelector: (in category 'message sending') ----- + specialSelector: index + + ^ objectMemory fetchPointer: (index * 2) ofObject: (objectMemory splObj: SpecialSelectors)! Item was added: + ----- Method: Interpreter>>storeAndPopRemoteTempLongBytecode (in category 'stack bytecodes') ----- + storeAndPopRemoteTempLongBytecode + self storeRemoteTempLongBytecode. + self internalPop: 1! Item was added: + ----- Method: Interpreter>>storeRemoteTempLongBytecode (in category 'stack bytecodes') ----- + storeRemoteTempLongBytecode + | remoteTempIndex tempVectorIndex | + remoteTempIndex := self fetchByte. + tempVectorIndex := self fetchByte. + self fetchNextBytecode. + self storeRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex! Item was added: + ----- Method: Interpreter>>superclassOf: (in category 'message sending') ----- + superclassOf: classPointer + + ^ objectMemory fetchPointer: SuperclassIndex ofObject: classPointer! Item was changed: Interpreter subclass: #StackInterpreter + instanceVariableNames: 'localFP stackLimit stackPage stackPages framePointer highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents imageHeaderFlags externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBytes interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals classByteArrayCompactIndex profileProcess nextProfileTick profileMethod profileSemaphore' + classVariableNames: 'BytecodeTable BytesPerWord COGMTVM COGVM CacheProbeMax DirBadPath DirEntryFound DirNoMoreEntries DumpStackOnLowSpace EnclosingMixinIndex EnclosingObjectIndex FailImbalancedPrimitives HeaderFlagBitPosition IMMUTABILITY MULTIPLEBYTECODESETS MaxQuickPrimitiveIndex MixinIndex NewspeakVM STACKVM VMBIGENDIAN' - instanceVariableNames: 'currentBytecode localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue primitiveFunctionPointer methodCache atCache lkupClass highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptPending savedWindowSize imageHeaderFlags deferDisplayUpdates pendingFinalizationSignals interpreterProxy showSurfaceFn externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBytes interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered te mpOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals classByteArrayCompactIndex messageSelector profileProcess nextProfileTick profileMethod profileSemaphore' - classVariableNames: 'BytecodeTable BytesPerWord COGMTVM COGVM CacheProbeMax DirBadPath DirEntryFound DirNoMoreEntries DumpStackOnLowSpace EnclosingMixinIndex EnclosingObjectIndex FailImbalancedPrimitives HeaderFlagBitPosition IMMUTABILITY MULTIPLEBYTECODESETS MaxJumpBuf MaxQuickPrimitiveIndex MixinIndex NewspeakVM STACKVM VMBIGENDIAN' poolDictionaries: 'VMBasicConstants VMMethodCacheConstants VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants VMStackFrameOffsets' category: 'VMMaker-Interpreter'! !StackInterpreter commentStamp: '<historical>' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas. This VM supports Closures but *not* old-style BlockContexts. It has been modernized with 32-bit pointers, better management of Contexts (see next item), and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms. The VM does not use Contexts directly. Instead Contexts serve as proxies for a more conventional stack format that is invisible to the image. There is considerable explanation at http://www.mirandabanda.org/cogblog/2009/01/14/under-cover-contexts-and-the-big-frame-up. The VM maintains a fixed-size stack zone divided into pages, each page being capable of holding several method/block activations. A send establishes a new frame in the current stack page, a return returns to the previous frame. This eliminates allocation/deallocation of contexts and the moving of receiver and arguments from caller to callee on each send/return. Contexts are created lazily when an activation needs a context (creating a block, explicit use of thisContext, access to sender when sender is a frame, or linking of stack pages together). Contexts are either conventional and heap-resident ("single") or "married" and serve as proxies for their corresponding frame or "widowed", meaning that their spouse f rame has been returned from (died). A married context is specially marked (more details in the code) and refers to its frame. Likewise a married frame is specially marked and refers to its context. In addition to SmallInteger arithmetic and Floats, the VM supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a completely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item). 2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the SystemTracer. A better solution would be to reserve one of the format codes for Contexts only. 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. 5. Moving to a 2 bit immediate tag and having immediate Characters is a good choice for Unicode and the JIT 6. If Eliot Miranda's 2 word header scheme is acceptable in terms of footprint (we estimate about a 10% increase in image size with about 35 reclaimed by better representation of CompiledMethod - loss of MethodProperties) then the in-line cache for the JIT is simplified, class access is faster and header access is the same in 32-bit and full 64-bit images.! Item was changed: ----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses" aCCodeGenerator addHeaderFile:'<stddef.h> /* for e.g. alloca */'; addHeaderFile:'<setjmp.h>'; addHeaderFile:'"vmCallback.h"'. self declareInterpreterVersionIn: aCCodeGenerator defaultName: 'Stack'. aCCodeGenerator - var: #interpreterProxy type: #'struct VirtualMachine*'. - aCCodeGenerator declareVar: #sendTrace type: 'volatile int'; declareVar: #byteCount type: 'unsigned long'. "These need to be pointers or unsigned." + self declareC: #(newMethod) - self declareC: #(instructionPointer method newMethod) as: #usqInt in: aCCodeGenerator. "These are all pointers; char * because Slang has no support for C pointer arithmetic." + self declareC: #(localFP framePointer stackLimit stackMemory) - self declareC: #(localIP localSP localFP stackPointer framePointer stackLimit stackMemory) as: #'char *' in: aCCodeGenerator. self declareC: #(stackPage overflowedPage) as: #'StackPage *' in: aCCodeGenerator. aCCodeGenerator removeVariable: 'stackPages'. "this is an implicit receiver in the translated code." - aCCodeGenerator - var: #methodCache - declareC: 'long methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'. - aCCodeGenerator - var: #atCache - declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]'. self primitiveTable do: [:symbolOrNot| (symbolOrNot isSymbol and: [symbolOrNot ~~ #primitiveFail]) ifTrue: [(aCCodeGenerator methodNamed: symbolOrNot) ifNotNilDo: [:tMethod| tMethod returnType: #void]]]. aCCodeGenerator - var: #primitiveFunctionPointer - declareC: 'void (*primitiveFunctionPointer)()'. - aCCodeGenerator var: #showSurfaceFn type: #'void *'. - aCCodeGenerator - var: #jmpBuf - declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'. - aCCodeGenerator - var: #suspendedCallbacks - declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'. - aCCodeGenerator - var: #suspendedMethods - declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'. - aCCodeGenerator var: #interruptCheckChain declareC: 'void (*interruptCheckChain)(void) = 0'. aCCodeGenerator var: #breakSelector type: #'char *'; var: #breakSelectorLength declareC: 'sqInt breakSelectorLength = -1'. self declareC: #(nextPollUsecs nextWakeupUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs) as: #usqLong in: aCCodeGenerator. aCCodeGenerator var: #nextProfileTick type: #sqLong. aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[' , (MaxPrimitiveIndex + 2) printString , '] )(void)= ' , self primitiveTableString. - aCCodeGenerator var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[' , (MaxExternalPrimitiveTableSize + 1) printString , '])(void)'. ! Item was changed: ----- Method: StackInterpreter class>>initializeMiscConstantsWith: (in category 'initialization') ----- initializeMiscConstantsWith: optionsDictionary super initializeMiscConstantsWith: optionsDictionary. STACKVM := true. NewspeakVM := optionsDictionary at: #NewspeakVM ifAbsent: [false]. "N.B. Not yet implemented!!!!" IMMUTABILITY := optionsDictionary at: #IMMUTABILITY ifAbsent: [false]. DumpStackOnLowSpace := 0. PrimitiveExternalCallIndex := 117. "Primitive index for #primitiveExternalCall" MillisecondClockMask := 16r1FFFFFFF. - MaxJumpBuf := 32. "max. callback depth" FailImbalancedPrimitives := true! Item was removed: - ----- Method: StackInterpreter>>asciiOfCharacter: (in category 'indexing primitive support') ----- - asciiOfCharacter: characterObj "Returns an integer object" - - <inline: false> - self assertClassOf: characterObj is: (objectMemory splObj: ClassCharacter). - self successful - ifTrue: [^ objectMemory fetchPointer: CharacterValueIndex ofObject: characterObj] - ifFalse: [^ ConstZero] "in case some code needs an int"! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimAdd (in category 'common selector sends') ----- - bytecodePrimAdd - | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) - ifTrue: [result := (objectMemory integerValueOf: rcvr) + (objectMemory integerValueOf: arg). - (objectMemory isIntegerValue: result) ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). - ^ self fetchNextBytecode "success"]] - ifFalse: [self initPrimCall. - self externalizeIPandSP. - self primitiveFloatAdd: rcvr toArg: arg. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]]. - - messageSelector := self specialSelector: 0. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimAtEnd (in category 'common selector sends') ----- - bytecodePrimAtEnd - messageSelector := self specialSelector: 21. - argumentCount := 0. - self normalSend.! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimBitAnd (in category 'common selector sends') ----- - bytecodePrimBitAnd - - self initPrimCall. - self externalizeIPandSP. - self primitiveBitAnd. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 14. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimBitOr (in category 'common selector sends') ----- - bytecodePrimBitOr - - self initPrimCall. - self externalizeIPandSP. - self primitiveBitOr. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 15. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimBitShift (in category 'common selector sends') ----- - bytecodePrimBitShift - - self initPrimCall. - self externalizeIPandSP. - self primitiveBitShift. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 12. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimDiv (in category 'common selector sends') ----- - bytecodePrimDiv - | quotient | - self initPrimCall. - quotient := self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0). - self successful ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: quotient). - ^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 13. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimDivide (in category 'common selector sends') ----- - bytecodePrimDivide - | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) - ifTrue: [rcvr := objectMemory integerValueOf: rcvr. - arg := objectMemory integerValueOf: arg. - (arg ~= 0 and: [rcvr \\ arg = 0]) - ifTrue: [result := rcvr // arg. - "generates C / operation" - (objectMemory isIntegerValue: result) - ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). - ^ self fetchNextBytecode"success"]]] - ifFalse: [self initPrimCall. - self externalizeIPandSP. - self primitiveFloatDivide: rcvr byArg: arg. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode"success"]]. - - messageSelector := self specialSelector: 9. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimDo (in category 'common selector sends') ----- - bytecodePrimDo - - messageSelector := self specialSelector: 27. - argumentCount := 1. - self normalSend. - ! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimEqual (in category 'common selector sends') ----- - bytecodePrimEqual - | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr = arg]. - - self initPrimCall. - aBool := self primitiveFloatEqual: rcvr toArg: arg. - self successful ifTrue: [^self booleanCheat: aBool]. - - messageSelector := self specialSelector: 6. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimEquivalent (in category 'common selector sends') ----- - bytecodePrimEquivalent - - | rcvr arg | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - self booleanCheat: rcvr = arg.! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimMakePoint (in category 'common selector sends') ----- - bytecodePrimMakePoint - - self initPrimCall. - self externalizeIPandSP. - self primitiveMakePoint. - self internalizeIPandSP. - self successful ifTrue: [^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 11. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimMod (in category 'common selector sends') ----- - bytecodePrimMod - | mod | - self initPrimCall. - mod := self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0). - self successful ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: mod). - ^ self fetchNextBytecode "success"]. - - messageSelector := self specialSelector: 10. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimNew (in category 'common selector sends') ----- - bytecodePrimNew - - messageSelector := self specialSelector: 28. - argumentCount := 0. - self normalSend. - ! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimNewWithArg (in category 'common selector sends') ----- - bytecodePrimNewWithArg - - messageSelector := self specialSelector: 29. - argumentCount := 1. - self normalSend. - ! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimNext (in category 'common selector sends') ----- - bytecodePrimNext - messageSelector := self specialSelector: 19. - argumentCount := 0. - self normalSend.! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimNextPut (in category 'common selector sends') ----- - bytecodePrimNextPut - messageSelector := self specialSelector: 20. - argumentCount := 1. - self normalSend.! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimNotEqual (in category 'common selector sends') ----- - bytecodePrimNotEqual - | rcvr arg aBool | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr ~= arg]. - - self initPrimCall. - aBool := self primitiveFloatEqual: rcvr toArg: arg. - self successful ifTrue: [^self booleanCheat: aBool not]. - - messageSelector := self specialSelector: 7. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>bytecodePrimSubtract (in category 'common selector sends') ----- - bytecodePrimSubtract - | rcvr arg result | - rcvr := self internalStackValue: 1. - arg := self internalStackValue: 0. - (self areIntegers: rcvr and: arg) - ifTrue: [result := (objectMemory integerValueOf: rcvr) - (objectMemory integerValueOf: arg). - (objectMemory isIntegerValue: result) ifTrue: - [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result). - ^self fetchNextBytecode "success"]] - ifFalse: [self initPrimCall. - self externalizeIPandSP. - self primitiveFloatSubtract: rcvr fromArg: arg. - self internalizeIPandSP. - self successful ifTrue: [^self fetchNextBytecode "success"]]. - - messageSelector := self specialSelector: 1. - argumentCount := 1. - self normalSend! Item was removed: - ----- Method: StackInterpreter>>characterForAscii: (in category 'indexing primitive support') ----- - characterForAscii: ascii "Arg must lie in range 0-255!!" - <inline: true> - ^ objectMemory fetchPointer: ascii ofObject: (objectMemory splObj: CharacterTable)! Item was removed: - ----- Method: StackInterpreter>>checkBooleanResult: (in category 'arithmetic primitive support') ----- - checkBooleanResult: result - self successful - ifTrue: [self pushBool: result] - ifFalse: [self unPop: 2]! Item was removed: - ----- Method: StackInterpreter>>compare31or32Bits:equal: (in category 'arithmetic primitive support') ----- - compare31or32Bits: obj1 equal: obj2 - "May set success to false" - - "First compare two ST integers..." - ((objectMemory isIntegerObject: obj1) - and: [objectMemory isIntegerObject: obj2]) - ifTrue: [^ obj1 = obj2]. - - "Now compare, assuming positive integers, but setting fail if not" - ^ (self positive32BitValueOf: obj1) = (self positive32BitValueOf: obj2)! Item was removed: - ----- Method: StackInterpreter>>copyBits (in category 'bitblt support') ----- - copyBits - "This entry point needs to be implemented for the interpreter proxy. - Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBits - and call it. This entire mechanism should eventually go away and be - replaced with a dynamic lookup from BitBltPlugin itself but for backward - compatibility this stub is provided" - - | fn | - <var: #fn type: 'void *'> - fn := self ioLoadFunction: 'copyBits' From: 'BitBltPlugin'. - fn = 0 ifTrue: [^self primitiveFail]. - ^self cCode: '((sqInt (*)(void))fn)()'! Item was removed: - ----- Method: StackInterpreter>>copyBitsFrom:to:at: (in category 'bitblt support') ----- - copyBitsFrom: x0 to: x1 at: y - "This entry point needs to be implemented for the interpreter proxy. - Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBitsFrom:to:at: - and call it. This entire mechanism should eventually go away and be - replaced with a dynamic lookup from BitBltPlugin itself but for backward - compatibility this stub is provided" - - | fn | - <var: #fn type: 'void *'> - fn := self ioLoadFunction: 'copyBitsFromtoat' From: 'BitBltPlugin'. - fn = 0 ifTrue: [^self primitiveFail]. - ^self cCode: '((sqInt (*)(sqInt, sqInt, sqInt))fn)(x0, x1, y)'! Item was removed: - ----- Method: StackInterpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') ----- - displayBitsOf: aForm Left: l Top: t Right: r Bottom: b - "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." - - | displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle | - displayObj := objectMemory splObj: TheDisplay. - aForm = displayObj ifFalse: [^ nil]. - self success: ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]). - self successful ifTrue: [ - dispBits := objectMemory fetchPointer: 0 ofObject: displayObj. - w := self fetchInteger: 1 ofObject: displayObj. - h := self fetchInteger: 2 ofObject: displayObj. - d := self fetchInteger: 3 ofObject: displayObj. - ]. - l < 0 ifTrue:[left := 0] ifFalse: [left := l]. - r > w ifTrue: [right := w] ifFalse: [right := r]. - t < 0 ifTrue: [top := 0] ifFalse: [top := t]. - b > h ifTrue: [bottom := h] ifFalse: [bottom := b]. - ((left <= right) and: [top <= bottom]) ifFalse: [^nil]. - self successful ifTrue: [ - (objectMemory isIntegerObject: dispBits) ifTrue: [ - surfaceHandle := objectMemory integerValueOf: dispBits. - showSurfaceFn = 0 ifTrue: [ - showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'. - showSurfaceFn = 0 ifTrue: [^self success: false]]. - self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'. - ] ifFalse: [ - dispBitsIndex := dispBits + objectMemory baseHeaderSize. "index in memory byte array" - self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)' - inSmalltalk: [self showDisplayBits: dispBitsIndex - w: w h: h d: d - left: left right: right top: top bottom: bottom] - ]. - ]! Item was removed: - ----- Method: StackInterpreter>>doPrimitiveDiv:by: (in category 'arithmetic primitive support') ----- - doPrimitiveDiv: rcvr by: arg - "Rounds negative results towards negative infinity, rather than zero." - | result posArg posRcvr integerRcvr integerArg | - (self areIntegers: rcvr and: arg) - ifTrue: [integerRcvr := objectMemory integerValueOf: rcvr. - integerArg := objectMemory integerValueOf: arg. - self success: integerArg ~= 0] - ifFalse: [self primitiveFail]. - self successful ifFalse: [^ 1 "fail"]. - - integerRcvr > 0 - ifTrue: [integerArg > 0 - ifTrue: [result := integerRcvr // integerArg] - ifFalse: ["round negative result toward negative infinity" - posArg := 0 - integerArg. - result := 0 - ((integerRcvr + (posArg - 1)) // posArg)]] - ifFalse: [posRcvr := 0 - integerRcvr. - integerArg > 0 - ifTrue: ["round negative result toward negative infinity" - result := 0 - ((posRcvr + (integerArg - 1)) // integerArg)] - ifFalse: [posArg := 0 - integerArg. - result := posRcvr // posArg]]. - self success: (objectMemory isIntegerValue: result). - ^ result! Item was removed: - ----- Method: StackInterpreter>>doPrimitiveMod:by: (in category 'arithmetic primitive support') ----- - doPrimitiveMod: rcvr by: arg - | integerResult integerRcvr integerArg | - (self areIntegers: rcvr and: arg) - ifTrue: [integerRcvr := objectMemory integerValueOf: rcvr. - integerArg := objectMemory integerValueOf: arg. - self success: integerArg ~= 0] - ifFalse: [self primitiveFail]. - self successful ifFalse: [^ 1 "fail"]. - - integerResult := integerRcvr \\ integerArg. - - "ensure that the result has the same sign as the integerArg" - integerArg < 0 - ifTrue: [integerResult > 0 - ifTrue: [integerResult := integerResult + integerArg]] - ifFalse: [integerResult < 0 - ifTrue: [integerResult := integerResult + integerArg]]. - self success: (objectMemory isIntegerValue: integerResult). - ^ integerResult! Item was removed: - ----- Method: StackInterpreter>>duplicateTopBytecode (in category 'stack bytecodes') ----- - duplicateTopBytecode - - self fetchNextBytecode. - self internalPush: self internalStackTop. - ! Item was removed: - ----- Method: StackInterpreter>>extendedPushBytecode (in category 'stack bytecodes') ----- - extendedPushBytecode - - | descriptor variableType variableIndex | - descriptor := self fetchByte. - self fetchNextBytecode. - variableType := (descriptor >> 6) bitAnd: 16r3. - variableIndex := descriptor bitAnd: 16r3F. - variableType=0 ifTrue: [^self pushReceiverVariable: variableIndex]. - variableType=1 ifTrue: [^self pushTemporaryVariable: variableIndex]. - variableType=2 ifTrue: [^self pushLiteralConstant: variableIndex]. - variableType=3 ifTrue: [^self pushLiteralVariable: variableIndex]. - ! Item was removed: - ----- Method: StackInterpreter>>fetchByte (in category 'interpreter shell') ----- - fetchByte - "This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator." - - ^objectMemory byteAtPointer: localIP preIncrement! Item was removed: - ----- Method: StackInterpreter>>fullDisplayUpdate (in category 'I/O primitive support') ----- - fullDisplayUpdate - "Repaint the entire smalltalk screen, ignoring the affected rectangle. Used in some platform's code when the Smalltalk window is brought to the front or uncovered." - - | displayObj w h | - displayObj := objectMemory splObj: TheDisplay. - ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifTrue: [ - w := self fetchInteger: 1 ofObject: displayObj. - h := self fetchInteger: 2 ofObject: displayObj. - self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: h. - self ioForceDisplayUpdate]. - ^nil! Item was removed: - ----- Method: StackInterpreter>>getCurrentBytecode (in category 'interpreter shell') ----- - getCurrentBytecode - "currentBytecode will be private to the main dispatch loop in the generated code. This method allows the currentBytecode to be retrieved from global variables." - - ^objectMemory byteAt: instructionPointer! Item was removed: - ----- Method: StackInterpreter>>jump: (in category 'jump bytecodes') ----- - jump: offset - localIP := localIP + offset + 1. - currentBytecode := objectMemory byteAtPointer: localIP! Item was removed: - ----- Method: StackInterpreter>>loadBitBltFrom: (in category 'bitblt support') ----- - loadBitBltFrom: bb - "This entry point needs to be implemented for the interpreter proxy. - Since BitBlt is now a plugin we need to look up BitBltPlugin:=loadBitBltFrom - and call it. This entire mechanism should eventually go away and be - replaced with a dynamic lookup from BitBltPlugin itself but for backward - compatibility this stub is provided" - | fn | - <var: #fn type: 'void *'> - fn := self ioLoadFunction: 'loadBitBltFrom' From: 'BitBltPlugin'. - fn = 0 ifTrue: [^self primitiveFail]. - ^self cCode: '((sqInt (*)(sqInt))fn)(bb)'! Item was removed: - ----- Method: StackInterpreter>>longJumpIfFalse (in category 'jump bytecodes') ----- - longJumpIfFalse - - self jumplfFalseBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! Item was removed: - ----- Method: StackInterpreter>>longJumpIfTrue (in category 'jump bytecodes') ----- - longJumpIfTrue - - self jumplfTrueBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! Item was removed: - ----- Method: StackInterpreter>>popStackBytecode (in category 'stack bytecodes') ----- - popStackBytecode - - self fetchNextBytecode. - self internalPop: 1. - ! Item was removed: - ----- Method: StackInterpreter>>pushConstantMinusOneBytecode (in category 'stack bytecodes') ----- - pushConstantMinusOneBytecode - - self fetchNextBytecode. - self internalPush: ConstMinusOne. - ! Item was removed: - ----- Method: StackInterpreter>>pushConstantOneBytecode (in category 'stack bytecodes') ----- - pushConstantOneBytecode - - self fetchNextBytecode. - self internalPush: ConstOne. - ! Item was removed: - ----- Method: StackInterpreter>>pushConstantTwoBytecode (in category 'stack bytecodes') ----- - pushConstantTwoBytecode - - self fetchNextBytecode. - self internalPush: ConstTwo. - ! Item was removed: - ----- Method: StackInterpreter>>pushConstantZeroBytecode (in category 'stack bytecodes') ----- - pushConstantZeroBytecode - - self fetchNextBytecode. - self internalPush: ConstZero. - ! Item was removed: - ----- Method: StackInterpreter>>pushFloat: (in category 'stack bytecodes') ----- - pushFloat: f - - <var: #f type: #double> - self push: (self floatObjectOf: f).! Item was removed: - ----- Method: StackInterpreter>>pushLiteralConstant: (in category 'stack bytecodes') ----- - pushLiteralConstant: literalIndex - - self internalPush: (self literal: literalIndex).! Item was removed: - ----- Method: StackInterpreter>>pushLiteralVariable: (in category 'stack bytecodes') ----- - pushLiteralVariable: literalIndex - - self internalPush: - (objectMemory fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).! Item was removed: - ----- Method: StackInterpreter>>pushRemoteTempLongBytecode (in category 'stack bytecodes') ----- - pushRemoteTempLongBytecode - | remoteTempIndex tempVectorIndex | - remoteTempIndex := self fetchByte. - tempVectorIndex := self fetchByte. - self fetchNextBytecode. - self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex! Item was removed: - ----- Method: StackInterpreter>>shortConditionalJump (in category 'jump bytecodes') ----- - shortConditionalJump - - self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.! Item was removed: - ----- Method: StackInterpreter>>showDisplayBits:Left:Top:Right:Bottom: (in category 'I/O primitive support') ----- - showDisplayBits: aForm Left: l Top: t Right: r Bottom: b - "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." - deferDisplayUpdates ifTrue: [^ nil]. - self displayBitsOf: aForm Left: l Top: t Right: r Bottom: b! Item was removed: - ----- Method: StackInterpreter>>specialSelector: (in category 'message sending') ----- - specialSelector: index - - ^ objectMemory fetchPointer: (index * 2) ofObject: (objectMemory splObj: SpecialSelectors)! Item was removed: - ----- Method: StackInterpreter>>storeAndPopRemoteTempLongBytecode (in category 'stack bytecodes') ----- - storeAndPopRemoteTempLongBytecode - self storeRemoteTempLongBytecode. - self internalPop: 1! Item was removed: - ----- Method: StackInterpreter>>storeRemoteTempLongBytecode (in category 'stack bytecodes') ----- - storeRemoteTempLongBytecode - | remoteTempIndex tempVectorIndex | - remoteTempIndex := self fetchByte. - tempVectorIndex := self fetchByte. - self fetchNextBytecode. - self storeRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex! Item was removed: - ----- Method: StackInterpreter>>superclassOf: (in category 'message sending') ----- - superclassOf: classPointer - <inline: true> - ^objectMemory fetchPointer: SuperclassIndex ofObject: classPointer! Item was removed: - ----- Method: StackInterpreterPrimitives>>primitiveSetGCSemaphore (in category 'memory space primitives') ----- - primitiveSetGCSemaphore - "Primitive. Indicate the semaphore to be signalled for upon garbage collection" - | index | - <export: true> - index := self stackIntegerValue: 0. - self successful ifTrue:[ - objectMemory setGcSemaphoreIndex: index. - self pop: argumentCount. - ]! Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString "VMMaker versionString" + ^'4.19.5'! - ^'4.19.4'! |
Free forum by Nabble | Edit this page |