[Vm-dev] VM Maker: VMMaker-dtl.381.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Apr 23 03:25:42 UTC 2016
David T. Lewis uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-dtl.381.mcz
==================== Summary ====================
Name: VMMaker-dtl.381
Author: dtl
Time: 22 April 2016, 11:25:04.907 pm
UUID: c52f75d2-b8e5-4c23-ab32-371b84baa753
Ancestors: VMMaker-dtl.380
Let the classic interpreter be ContextInterpreter, the stack interpreter be StackInterpreter, and both inherit from Interpreter. Begin associated refactorings.
No change to generate code for context interpreter.
=============== Diff against VMMaker-dtl.380 ===============
Item was added:
+ Interpreter subclass: #ContextInterpreter
+ instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector currentBytecode primitiveIndex primitiveFunctionPointer methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptPending semaphoresToSignalA semaphoresUseBufferA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks extraVMMemory newNativeMethod methodClass receiverClass interpreterVersion imageFormatVersionNumber interpreterProxy showSurfaceFn interruptCheckCounter interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable globalSessionID jmpBuf jmpDepth jmpMax suspendedCallbacks suspendedMethods imageFormatInitialVersion'
+ classVariableNames: 'BlockArgumentCountIndex BytecodeTable CacheProbeMax CallerIndex CompilerHooksSize DirBadPath DirEntryFound DirNoMoreEntries DoBalanceChecks HomeIndex InitialIPIndex MaxJumpBuf MessageDictionaryIndex MethodCacheNative SemaphoresToSignalSize 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 added:
+ ----- Method: ContextInterpreter class>>additionalHeadersDo: (in category 'translation') -----
+ additionalHeadersDo: aBinaryBlock
+ "Evaluate aBinaryBlock with the names and contents of
+ any additional header files that need to be generated."!
Item was added:
+ ----- Method: ContextInterpreter class>>bytecodeTable (in category 'constants') -----
+ bytecodeTable
+
+ ^ BytecodeTable!
Item was added:
+ ----- Method: ContextInterpreter class>>constMinusOne (in category 'constants') -----
+ constMinusOne
+ ^ConstMinusOne!
Item was added:
+ ----- 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)'.
+ "keep this matching the declaration for primitiveTable"
+ self primitiveTable do:
+ [:symbolOrNot|
+ (symbolOrNot isSymbol
+ and: [symbolOrNot ~~ #primitiveFail]) ifTrue:
+ [(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil:
+ [:tMethod| tMethod returnType: #void]]].
+ "make sure al the primitves are declared returning 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: 'semaphoresToSignalA' declareC: 'sqInt semaphoresToSignalA[' , (SemaphoresToSignalSize + 1) printString , ']'.
+ aCCodeGenerator var: 'semaphoresToSignalB' declareC: 'sqInt semaphoresToSignalB[' , (SemaphoresToSignalSize + 1) printString , ']'.
+ aCCodeGenerator var: #compilerHooks declareC: 'sqInt (*compilerHooks[' , (CompilerHooksSize + 1) printString , '])()'.
+ aCCodeGenerator var: #interpreterVersion declareC: 'const char *interpreterVersion = "' , SmalltalkImage current datedVersion , ' [' , SmalltalkImage current lastUpdateString , ']"'.
+ 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'!
Item was added:
+ ----- 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.
+
+ SemaphoresToSignalSize := 500.
+ 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 added:
+ ----- Method: ContextInterpreter class>>initializeAssociationIndex (in category 'initialization') -----
+ initializeAssociationIndex
+ ValueIndex := 1!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeBytecodeTable (in category 'initialization') -----
+ initializeBytecodeTable
+ "Interpreter initializeBytecodeTable"
+ "Note: This table will be used to generate a C switch statement."
+
+ BytecodeTable := Array new: 256.
+ self table: BytecodeTable from:
+ #(
+ ( 0 15 pushReceiverVariableBytecode)
+ ( 16 31 pushTemporaryVariableBytecode)
+ ( 32 63 pushLiteralConstantBytecode)
+ ( 64 95 pushLiteralVariableBytecode)
+ ( 96 103 storeAndPopReceiverVariableBytecode)
+ (104 111 storeAndPopTemporaryVariableBytecode)
+ (112 pushReceiverBytecode)
+ (113 pushConstantTrueBytecode)
+ (114 pushConstantFalseBytecode)
+ (115 pushConstantNilBytecode)
+ (116 pushConstantMinusOneBytecode)
+ (117 pushConstantZeroBytecode)
+ (118 pushConstantOneBytecode)
+ (119 pushConstantTwoBytecode)
+ (120 returnReceiver)
+ (121 returnTrue)
+ (122 returnFalse)
+ (123 returnNil)
+ (124 returnTopFromMethod)
+ (125 returnTopFromBlock)
+
+ (126 127 unknownBytecode)
+
+ (128 extendedPushBytecode)
+ (129 extendedStoreBytecode)
+ (130 extendedStoreAndPopBytecode)
+ (131 singleExtendedSendBytecode)
+ (132 doubleExtendedDoAnythingBytecode)
+ (133 singleExtendedSuperBytecode)
+ (134 secondExtendedSendBytecode)
+ (135 popStackBytecode)
+ (136 duplicateTopBytecode)
+
+ (137 pushActiveContextBytecode)
+ (138 pushNewArrayBytecode)
+ (139 unknownBytecode)
+ (140 pushRemoteTempLongBytecode)
+ (141 storeRemoteTempLongBytecode)
+ (142 storeAndPopRemoteTempLongBytecode)
+ (143 pushClosureCopyCopiedValuesBytecode)
+
+ (144 151 shortUnconditionalJump)
+ (152 159 shortConditionalJump)
+ (160 167 longUnconditionalJump)
+ (168 171 longJumpIfTrue)
+ (172 175 longJumpIfFalse)
+
+ "176-191 were sendArithmeticSelectorBytecode"
+ (176 bytecodePrimAdd)
+ (177 bytecodePrimSubtract)
+ (178 bytecodePrimLessThan)
+ (179 bytecodePrimGreaterThan)
+ (180 bytecodePrimLessOrEqual)
+ (181 bytecodePrimGreaterOrEqual)
+ (182 bytecodePrimEqual)
+ (183 bytecodePrimNotEqual)
+ (184 bytecodePrimMultiply)
+ (185 bytecodePrimDivide)
+ (186 bytecodePrimMod)
+ (187 bytecodePrimMakePoint)
+ (188 bytecodePrimBitShift)
+ (189 bytecodePrimDiv)
+ (190 bytecodePrimBitAnd)
+ (191 bytecodePrimBitOr)
+
+ "192-207 were sendCommonSelectorBytecode"
+ (192 bytecodePrimAt)
+ (193 bytecodePrimAtPut)
+ (194 bytecodePrimSize)
+ (195 bytecodePrimNext)
+ (196 bytecodePrimNextPut)
+ (197 bytecodePrimAtEnd)
+ (198 bytecodePrimEquivalent)
+ (199 bytecodePrimClass)
+ (200 bytecodePrimBlockCopy)
+ (201 bytecodePrimValue)
+ (202 bytecodePrimValueWithArg)
+ (203 bytecodePrimDo)
+ (204 bytecodePrimNew)
+ (205 bytecodePrimNewWithArg)
+ (206 bytecodePrimPointX)
+ (207 bytecodePrimPointY)
+
+ (208 255 sendLiteralSelectorBytecode)
+ ).!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeCaches (in category 'initialization') -----
+ initializeCaches
+
+ MethodCacheEntries := 512.
+ MethodCacheSelector := 1.
+ MethodCacheClass := 2.
+ MethodCacheMethod := 3.
+ MethodCachePrim := 4.
+ MethodCacheNative := 5.
+ MethodCachePrimFunction := 6.
+ MethodCacheEntrySize := 8. "Must be power of two for masking scheme."
+ MethodCacheMask := (MethodCacheEntries - 1) * MethodCacheEntrySize.
+ MethodCacheSize := MethodCacheEntries * MethodCacheEntrySize.
+ CacheProbeMax := 3.
+ !
Item was added:
+ ----- Method: ContextInterpreter class>>initializeCharacterIndex (in category 'initialization') -----
+ initializeCharacterIndex
+ CharacterValueIndex := 0!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeCharacterScannerIndices (in category 'initialization') -----
+ initializeCharacterScannerIndices
+ CrossedX := 258.
+ EndOfRun := 257
+ !
Item was added:
+ ----- Method: ContextInterpreter class>>initializeClassIndices (in category 'initialization') -----
+ initializeClassIndices
+ "Class Class"
+ SuperclassIndex := 0.
+ MessageDictionaryIndex := 1.
+ InstanceSpecificationIndex := 2.
+ "Fields of a message dictionary"
+ MethodArrayIndex := 1.
+ SelectorStart := 2!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeCodeGenerator: (in category 'translation') -----
+ initializeCodeGenerator: cg
+ "Load a code generator with classes in a manner suitable for generating
+ code for this class."
+
+ super initializeCodeGenerator: cg.
+ self initializeClassicObjectMemoryInCodeGenerator: cg.
+ VMMaker addMemoryAccessTo: cg.
+ ^cg
+ "^ self initializeNewObjectMemoryInCodeGenerator: cg"
+ !
Item was added:
+ ----- Method: ContextInterpreter class>>initializeCompilerHooks (in category 'initialization') -----
+ initializeCompilerHooks
+ "Interpreter initializeCompilerHooks"
+
+ "compilerHooks[] indices:
+ 1 void compilerTranslateMethodHook(void)
+ 2 void compilerFlushCacheHook(CompiledMethod *oldMethod)
+ 3 void compilerPreGCHook(int fullGCFlag)
+ 4 void compilerMapHook(int memStart, int memEnd)
+ 5 void compilerPostGCHook(void)
+ 6 void compilerProcessChangeHook(void)
+ 7 void compilerPreSnapshotHook(void)
+ 8 void compilerPostSnapshotHook(void)
+ 9 void compilerMarkHook(void)
+ 10 void compilerActivateMethodHook(void)
+ 11 void compilerNewActiveContextHook(int sendFlag)
+ 12 void compilerGetInstructionPointerHook(void)
+ 13 void compilerSetInstructionPointerHook(void)
+ 14 void compilerCreateActualMessageHook(void)"
+
+ CompilerHooksSize := 15.!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeContextIndices (in category 'initialization') -----
+ initializeContextIndices
+ "Class MethodContext"
+ SenderIndex := 0.
+ InstructionPointerIndex := 1.
+ StackPointerIndex := 2.
+ MethodIndex := 3.
+ ClosureIndex := 4. "N.B. Called receiverMap in the image."
+ ReceiverIndex := 5.
+ TempFrameStart := 6. "Note this is in two places!!"
+
+ "Class BlockContext"
+ CallerIndex := 0.
+ BlockArgumentCountIndex := 3.
+ InitialIPIndex := 4.
+ HomeIndex := 5.
+
+ "Class BlockClosure"
+ ClosureOuterContextIndex := 0.
+ ClosureStartPCIndex := 1.
+ ClosureNumArgsIndex := 2.
+ ClosureFirstCopiedValueIndex := 3.
+
+ CtxtTempFrameStart := 6. "Copy of TempFrameStart in Interp"
+
+ "n.b. The constants SmallContextSize and LargeContextSize are not required.
+ See ObjectMemory>>smallContextSize and ObjectMemory>>largeContextSize
+ for implementations that work for both 32 and 64 bit object memory."
+ !
Item was added:
+ ----- Method: ContextInterpreter class>>initializeDirectoryLookupResultCodes (in category 'initialization') -----
+ initializeDirectoryLookupResultCodes
+
+ DirEntryFound := 0.
+ DirNoMoreEntries := 1.
+ DirBadPath := 2.!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeInterpreterSourceVersion (in category 'initialization') -----
+ initializeInterpreterSourceVersion
+ "Identify the VMMaker source version that generated the C code for an
+ interpreter. Provides a runtime version identification test."
+
+ Smalltalk at: #VMMaker
+ ifPresent: [:vmm | ^ InterpreterSourceVersion := vmm versionString].
+ ^ InterpreterSourceVersion := ''!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeMessageIndices (in category 'initialization') -----
+ initializeMessageIndices
+ MessageSelectorIndex := 0.
+ MessageArgumentsIndex := 1.
+ MessageLookupClassIndex := 2.!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeMethodIndices (in category 'initialization') -----
+ initializeMethodIndices
+ "Class CompiledMethod"
+ HeaderIndex := 0.
+ LiteralStart := 1!
Item was added:
+ ----- Method: ContextInterpreter class>>initializePointIndices (in category 'initialization') -----
+ initializePointIndices
+ XIndex := 0.
+ YIndex := 1!
Item was added:
+ ----- Method: ContextInterpreter class>>initializePrimitiveTable (in category 'initialization') -----
+ initializePrimitiveTable
+ "This table generates a C function address table use in primitiveResponse along with dispatchFunctionPointerOn:in:"
+
+ "NOTE: The real limit here is 2047 because of the method header layout but there is no point in going over the needed size"
+ MaxPrimitiveIndex := 575.
+ PrimitiveTable := Array new: MaxPrimitiveIndex + 1.
+ self table: PrimitiveTable from:
+ #( "Integer Primitives (0-19)"
+ (0 primitiveFail)
+ (1 primitiveAdd)
+ (2 primitiveSubtract)
+ (3 primitiveLessThan)
+ (4 primitiveGreaterThan)
+ (5 primitiveLessOrEqual)
+ (6 primitiveGreaterOrEqual)
+ (7 primitiveEqual)
+ (8 primitiveNotEqual)
+ (9 primitiveMultiply)
+ (10 primitiveDivide)
+ (11 primitiveMod)
+ (12 primitiveDiv)
+ (13 primitiveQuo)
+ (14 primitiveBitAnd)
+ (15 primitiveBitOr)
+ (16 primitiveBitXor)
+ (17 primitiveBitShift)
+ (18 primitiveMakePoint)
+ (19 primitiveFail) "Guard primitive for simulation -- *must* fail"
+
+ "LargeInteger Primitives (20-39)"
+ (20 primitiveRemLargeIntegers)
+ (21 primitiveAddLargeIntegers)
+ (22 primitiveSubtractLargeIntegers)
+ (23 primitiveLessThanLargeIntegers)
+ (24 primitiveGreaterThanLargeIntegers)
+ (25 primitiveLessOrEqualLargeIntegers)
+ (26 primitiveGreaterOrEqualLargeIntegers)
+ (27 primitiveEqualLargeIntegers)
+ (28 primitiveNotEqualLargeIntegers)
+ (29 primitiveMultiplyLargeIntegers)
+ (30 primitiveDivideLargeIntegers)
+ (31 primitiveModLargeIntegers)
+ (32 primitiveDivLargeIntegers)
+ (33 primitiveQuoLargeIntegers)
+ (34 primitiveBitAndLargeIntegers)
+ (35 primitiveBitOrLargeIntegers)
+ (36 primitiveBitXorLargeIntegers)
+ (37 primitiveBitShiftLargeIntegers)
+
+ "Float Primitives (38-59)"
+ (38 primitiveFloatAt)
+ (39 primitiveFloatAtPut)
+ (40 primitiveAsFloat)
+ (41 primitiveFloatAdd)
+ (42 primitiveFloatSubtract)
+ (43 primitiveFloatLessThan)
+ (44 primitiveFloatGreaterThan)
+ (45 primitiveFloatLessOrEqual)
+ (46 primitiveFloatGreaterOrEqual)
+ (47 primitiveFloatEqual)
+ (48 primitiveFloatNotEqual)
+ (49 primitiveFloatMultiply)
+ (50 primitiveFloatDivide)
+ (51 primitiveTruncated)
+ (52 primitiveFractionalPart)
+ (53 primitiveExponent)
+ (54 primitiveTimesTwoPower)
+ (55 primitiveSquareRoot)
+ (56 primitiveSine)
+ (57 primitiveArctan)
+ (58 primitiveLogN)
+ (59 primitiveExp)
+
+ "Subscript and Stream Primitives (60-67)"
+ (60 primitiveAt)
+ (61 primitiveAtPut)
+ (62 primitiveSize)
+ (63 primitiveStringAt)
+ (64 primitiveStringAtPut)
+ (65 primitiveFail) "was primitiveNext which no longer pays its way (normal Smalltalk code is faster)"
+ (66 primitiveFail) "was primitiveNextPut which no longer pays its way (normal Smalltalk code is faster)"
+ (67 primitiveFail) "was primitiveAtEnd which no longer pays its way (normal Smalltalk code is faster)"
+
+ "StorageManagement Primitives (68-79)"
+ (68 primitiveObjectAt)
+ (69 primitiveObjectAtPut)
+ (70 primitiveNew)
+ (71 primitiveNewWithArg)
+ (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome"
+ (73 primitiveInstVarAt)
+ (74 primitiveInstVarAtPut)
+ (75 primitiveAsOop)
+ (76 primitiveStoreStackp) "Blue Book: primitiveAsObject"
+ (77 primitiveSomeInstance)
+ (78 primitiveNextInstance)
+ (79 primitiveNewMethod)
+
+ "Control Primitives (80-89)"
+ (80 primitiveBlockCopy)
+ (81 primitiveValue)
+ (82 primitiveValueWithArgs)
+ (83 primitivePerform)
+ (84 primitivePerformWithArgs)
+ (85 primitiveSignal)
+ (86 primitiveWait)
+ (87 primitiveResume)
+ (88 primitiveSuspend)
+ (89 primitiveFlushCache)
+
+ "Input/Output Primitives (90-109)"
+ (90 primitiveMousePoint)
+ (91 primitiveTestDisplayDepth) "Blue Book: primitiveCursorLocPut"
+ (92 primitiveSetDisplayMode) "Blue Book: primitiveCursorLink"
+ (93 primitiveInputSemaphore)
+ (94 primitiveGetNextEvent) "Blue Book: primitiveSampleInterval"
+ (95 primitiveInputWord)
+ (96 primitiveFail) "primitiveCopyBits"
+ (97 primitiveSnapshot)
+ (98 primitiveStoreImageSegment)
+ (99 primitiveLoadImageSegment)
+ (100 primitivePerformInSuperclass) "Blue Book: primitiveSignalAtTick"
+ (101 primitiveBeCursor)
+ (102 primitiveBeDisplay)
+ (103 primitiveScanCharacters)
+ (104 primitiveFail) "primitiveDrawLoop"
+ (105 primitiveStringReplace)
+ (106 primitiveScreenSize)
+ (107 primitiveMouseButtons)
+ (108 primitiveKbdNext)
+ (109 primitiveKbdPeek)
+
+ "System Primitives (110-119)"
+ (110 primitiveIdentical)
+ (111 primitiveClass)
+ (112 primitiveBytesLeft)
+ (113 primitiveQuit)
+ (114 primitiveExitToDebugger)
+ (115 primitiveChangeClass) "Blue Book: primitiveOopsLeft"
+ (116 primitiveFlushCacheByMethod)
+ (117 primitiveExternalCall)
+ (118 primitiveDoPrimitiveWithArgs)
+ (119 primitiveFlushCacheBySelector)
+ "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116.
+ Both are supported for backward compatibility."
+
+ "Miscellaneous Primitives (120-127)"
+ (120 primitiveCalloutToFFI)
+ (121 primitiveImageName)
+ (122 primitiveNoop) "Blue Book: primitiveImageVolume"
+ (123 primitiveValueUninterruptably) "@@@: Remove this when all VMs have support"
+ (124 primitiveLowSpaceSemaphore)
+ (125 primitiveSignalAtBytesLeft)
+
+ "Squeak Primitives Start Here"
+
+ "Squeak Miscellaneous Primitives (128-149)"
+ (126 primitiveDeferDisplayUpdates)
+ (127 primitiveShowDisplayRect)
+ (128 primitiveArrayBecome)
+ (129 primitiveSpecialObjectsOop)
+ (130 primitiveFullGC)
+ (131 primitiveIncrementalGC)
+ (132 primitiveObjectPointsTo)
+ (133 primitiveSetInterruptKey)
+ (134 primitiveInterruptSemaphore)
+ (135 primitiveMillisecondClock)
+ (136 primitiveSignalAtMilliseconds)
+ (137 primitiveSecondsClock)
+ (138 primitiveSomeObject)
+ (139 primitiveNextObject)
+ (140 primitiveBeep)
+ (141 primitiveClipboardText)
+ (142 primitiveVMPath)
+ (143 primitiveShortAt)
+ (144 primitiveShortAtPut)
+ (145 primitiveConstantFill)
+ "NOTE: When removing the obsolete indexed primitives,
+ the following two should go become #primitiveIntegerAt / atPut"
+ (146 primitiveFail) "primitiveReadJoystick"
+ (147 primitiveFail) "primitiveWarpBits"
+ (148 primitiveClone)
+ (149 primitiveGetAttribute)
+
+ "File Primitives (150-169) - NO LONGER INDEXED"
+ (150 159 primitiveFail)
+ (160 primitiveAdoptInstance)
+ (161 primitiveSetIdentityHash) "CogMemoryManager primitives"
+ (162 164 primitiveFail)
+ (165 primitiveIntegerAt) "hacked in here for now"
+ (166 primitiveIntegerAtPut)
+ (167 primitiveYield)
+ (168 primitiveCopyObject)
+ (169 primitiveNotIdentical)
+
+ "Sound Primitives (170-199) - NO LONGER INDEXED"
+ (170 174 primitiveFail)
+
+ "CogMemoryManager primitives"
+ (175 primitiveBehaviorHash)
+ (176 primitiveMaxIdentityHash)
+ (177 184 primitiveFail)
+
+ "CriticalSection primitives"
+ (185 primitiveExitCriticalSection) "similar to signal hence index = signal + 100"
+ (186 primitiveEnterCriticalSection) "similar to wait hence index = wait + 100. was primitiveClosureValue"
+ (187 primitiveTestAndSetOwnershipOfCriticalSection) "was primitiveClosureValueWithArgs"
+
+ "Perform method directly"
+ (188 primitiveExecuteMethodArgsArray)
+ (189 primitiveExecuteMethod)
+
+ "Sound Primitives (continued) - NO LONGER INDEXED"
+ (190 194 primitiveFail)
+
+ "Unwind primitives"
+ (195 primitiveFindNextUnwindContext)
+ (196 primitiveTerminateTo)
+ (197 primitiveFindHandlerContext)
+ (198 primitiveMarkUnwindMethod)
+ (199 primitiveMarkHandlerMethod)
+
+ "new closure primitives (were Networking primitives)"
+ (200 primitiveClosureCopyWithCopiedValues)
+ (201 primitiveClosureValue) "value"
+ (202 primitiveClosureValue) "value:"
+ (203 primitiveClosureValue) "value:value:"
+ (204 primitiveClosureValue) "value:value:value:"
+ (205 primitiveClosureValue) "value:value:value:value:"
+ (206 primitiveClosureValueWithArgs) "valueWithArguments:"
+
+ (207 209 primitiveFail) "reserved for Cog primitives"
+
+ (210 primitiveAt) "Compatibility with Cog StackInterpreter Context primitives"
+ (211 primitiveAtPut) "Compatibility with Cog StackInterpreter Context primitives"
+ (212 primitiveSize) "Compatibility with Cog StackInterpreter Context primitives"
+ (213 219 primitiveFail) "reserved for Cog primitives"
+
+ (220 primitiveFail) "reserved for Cog primitives"
+
+ (221 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch"
+ (222 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch:"
+
+ (223 229 primitiveFail) "reserved for Cog primitives"
+
+ (230 primitiveRelinquishProcessor)
+ (231 primitiveForceDisplayUpdate)
+ (232 primitiveFormPrint)
+ (233 primitiveSetFullScreen)
+ (234 primitiveFail) "primBitmapdecompressfromByteArrayat"
+ (235 primitiveFail) "primStringcomparewithcollated"
+ (236 primitiveFail) "primSampledSoundconvert8bitSignedFromto16Bit"
+ (237 primitiveFail) "primBitmapcompresstoByteArray"
+ (238 239 primitiveFail) "serial port primitives"
+ (240 primitiveUTCMicrosecondClock) "was serial port primitive"
+ (241 primitiveLocalMicrosecondClock) "was serial port primitive"
+ (242 primitiveSignalAtUTCMicroseconds)
+ (243 primitiveFail) "primStringtranslatefromtotable"
+ (244 primitiveFail) "primStringfindFirstInStringinSetstartingAt"
+ (245 primitiveFail) "primStringindexOfAsciiinStringstartingAt"
+ (246 primitiveFail) "primStringfindSubstringinstartingAtmatchTable"
+ (247 primitiveSnapshotEmbedded)
+ (248 primitiveInvokeObjectAsMethod)
+ (249 primitiveArrayBecomeOneWayCopyHash)
+
+ "VM Implementor Primitives (250-255)"
+ (250 clearProfile)
+ (251 dumpProfile)
+ (252 startProfiling)
+ (253 stopProfiling)
+ (254 primitiveVMParameter)
+ (255 primitiveFail) "primitiveInstVarsPutFromStack. Never used except in Disney tests. Remove after 2.3 release."
+
+ "Quick Push Const Methods"
+ (256 primitivePushSelf)
+ (257 primitivePushTrue)
+ (258 primitivePushFalse)
+ (259 primitivePushNil)
+ (260 primitivePushMinusOne)
+ (261 primitivePushZero)
+ (262 primitivePushOne)
+ (263 primitivePushTwo)
+
+ "Quick Push Const Methods"
+ (264 519 primitiveLoadInstVar)
+
+ "These ranges used to be used by obsiolete indexed primitives."
+ (520 529 primitiveFail)
+ (530 539 primitiveFail)
+ (540 549 primitiveFail)
+ (550 559 primitiveFail)
+ (560 569 primitiveFail)
+
+ "External primitive support primitives"
+ (570 primitiveFlushExternalPrimitives)
+ (571 primitiveUnloadModule)
+ (572 primitiveListBuiltinModule)
+ (573 primitiveListExternalModule)
+ (574 primitiveFail) "reserved for addl. external support prims"
+
+ "Unassigned Primitives"
+ (575 primitiveFail)).
+ !
Item was added:
+ ----- Method: ContextInterpreter class>>initializeSchedulerIndices (in category 'initialization') -----
+ initializeSchedulerIndices
+ "Class ProcessorScheduler"
+ ProcessListsIndex := 0.
+ ActiveProcessIndex := 1.
+ "Class LinkedList"
+ FirstLinkIndex := 0.
+ LastLinkIndex := 1.
+ "Class Semaphore"
+ ExcessSignalsIndex := 2.
+ "Class Link"
+ NextLinkIndex := 0.
+ "Class Process"
+ SuspendedContextIndex := 1.
+ PriorityIndex := 2.
+ MyListIndex := 3!
Item was added:
+ ----- Method: ContextInterpreter class>>initializeStreamIndices (in category 'initialization') -----
+ initializeStreamIndices
+ StreamArrayIndex := 0.
+ StreamIndexIndex := 1.
+ StreamReadLimitIndex := 2.
+ StreamWriteLimitIndex := 3.!
Item was added:
+ ----- Method: ContextInterpreter class>>isInterpreterClass (in category 'translation') -----
+ isInterpreterClass
+ ^true!
Item was added:
+ ----- Method: ContextInterpreter class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
+ isNonArgumentImplicitReceiverVariableName: aString
+ aString = 'interpreterProxy' ifTrue: [self halt].
+ ^'self' = aString!
Item was added:
+ ----- Method: ContextInterpreter class>>patchInterp: (in category 'translation') -----
+ patchInterp: fileName
+ "Interpreter patchInterp: 'Squeak VM PPC'"
+ "This will patch out the unneccesary range check (a compare
+ and branch) in the inner interpreter dispatch loop."
+ "NOTE: You must edit in the Interpeter file name, and the
+ number of instructions (delta) to count back to find the compare
+ and branch that we want to get rid of."
+
+ | delta f code len remnant i |
+ delta := 6.
+ f := FileStream fileNamed: fileName.
+ f binary.
+ code := Bitmap new: (len := f size) // 4.
+ f nextInto: code.
+ remnant := f next: len - (code size * 4).
+ i := 0.
+ ["Look for a BCTR instruction"
+ (i := code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue:
+ ["Look for a CMPLWI FF, 6 instrs back"
+ ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r280000FF ifTrue:
+ ["Copy dispatch instrs back over the compare"
+ self inform: 'Patching at ', i hex.
+ 0 to: delta - 2 do: [ :j |
+ code at: (i - delta) + j put: (code at: (i - delta) + j + 2)]]].
+ f position: 0; nextPutAll: code; nextPutAll: remnant.
+ f close.
+ !
Item was added:
+ ----- Method: ContextInterpreter class>>patchInterpGCCPPC: (in category 'translation') -----
+ patchInterpGCCPPC: fileName
+ "Interpreter patchInterpGCCPPC: 'Squeak copy 1'"
+ "This will patch out the unneccesary range check (a compare
+ and branch) in the inner interpreter dispatch loop. for the PPC version of the GCC compiled
+ version of Squeak under MPW"
+ "NOTE: You must edit in the Interpeter file name"
+
+ | delta f code len remnant i |
+ delta := 7.
+ f := FileStream fileNamed: fileName.
+ f binary.
+ code := Bitmap new: (len := f size) // 4.
+ f nextInto: code.
+ remnant := f next: len - (code size * 4).
+ i := 0.
+ ["Look for a BCTR instruction"
+ (i := code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue:
+ ["Look for a CMPLWI cr1,rxx,FF, 7 instrs back"
+ ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r288000FF ifTrue:
+ ["Copy dispatch instrs back over the compare"
+ self inform: 'Patching at ', i hex.
+ 0 to: delta - 2 do: [ :j |
+ code at: (i - delta) + j put: (code at: (i - delta) + j + 2)]]].
+ f position: 0; nextPutAll: code; nextPutAll: remnant.
+ f close!
Item was added:
+ ----- Method: ContextInterpreter class>>primitiveTableString (in category 'initialization') -----
+ primitiveTableString
+ "Interpreter initializePrimitiveTable primitiveTableString"
+ | table |
+ table := self primitiveTable.
+ ^ String
+ streamContents: [:s |
+ s nextPut: ${.
+ table
+ withIndexDo: [:primSpec :index | s cr; tab;
+ nextPutAll: '/* ';
+ nextPutAll: (index - 1) printString;
+ nextPutAll: '*/ ';
+ nextPutAll: '(void (*)(void))'; "keep this matching the declaration of primitiveTable in Interpreter class>declareCVarsIn:"
+ nextPutAll: primSpec;
+ nextPut: $,].
+ s cr; nextPutAll: ' 0 }']!
Item was added:
+ ----- Method: ContextInterpreter class>>requiredMethodNames (in category 'translation') -----
+ requiredMethodNames
+ "return the list of method names that should be retained for export or other support reasons"
+ | requiredList |
+ requiredList := Set new:400.
+ "A number of methods required by VM support code, jitter, specific platforms etc"
+ requiredList addAll: #(fullDisplayUpdate interpret printCallStack printAllStacks readImageFromFile:HeapSize:StartingAt: success: readableFormat: getCurrentBytecode characterForAscii: findClassOfMethod:forReceiver: findSelectorOfMethod:forReceiver: loadInitialContext nullCompilerHook setCompilerInitialized: getFullScreenFlag getInterruptCheckCounter getInterruptKeycode getInterruptPending getNextWakeupTick getSavedWindowSize setFullScreenFlag: setInterruptCheckCounter: setInterruptKeycode: setInterruptPending: setNextWakeupTick: setSavedWindowSize: forceInterruptCheck getThisSessionID setMicroSeconds:andOffset:).
+
+ "Nice to actually have all the primitives available"
+ requiredList addAll: self primitiveTable.
+
+ "InterpreterProxy is the internal analogue of sqVirtualMachine.c, so make sure to keep all those"
+ InterpreterProxy organization categories do: [:cat |
+ ((cat ~= 'initialize') and: [cat ~= 'private']) ifTrue: [
+ requiredList addAll: (InterpreterProxy organization listAtCategoryNamed: cat)]].
+
+ ^requiredList!
Item was added:
+ ----- Method: ContextInterpreter class>>table:from: (in category 'initialization') -----
+ table: anArray from: specArray
+ "SpecArray is an array of either (index selector) or (index1
+ index2 selector)."
+ | contiguous |
+ contiguous := 0.
+ specArray do: [:spec |
+ (spec at: 1) = contiguous
+ ifFalse: [self error: 'Non-contiguous table entry'].
+ spec size = 2
+ ifTrue: [anArray at: (spec at: 1) + 1
+ put: (spec at: 2).
+ contiguous := contiguous + 1]
+ ifFalse: [(spec at: 1) to: (spec at: 2) do: [:i | anArray at: i + 1 put: (spec at: 3)].
+ contiguous := contiguous + ((spec at: 2) - (spec at: 1)) + 1]]!
Item was added:
+ ----- Method: ContextInterpreter class>>wantsLabels (in category 'translation') -----
+ wantsLabels
+ "Only label the VM, not plugins (internal or external). This to cut down the scope
+ of problems with labels being duplicated by C compiler optimizer inlining and
+ loop unrolling. We use the asmLabel: directive to control labelling in the
+ interpreter proper. But it is too much work doing that for plugins too."
+ ^true!
Item was added:
+ ----- Method: ContextInterpreter>>activateNewClosureMethod: (in category 'control primitives') -----
+ activateNewClosureMethod: blockClosure
+ "Similar to activateNewMethod but for Closure and newMethod."
+ | theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
+
+ DoAssertionChecks ifTrue:
+ [objectMemory okayOop: blockClosure].
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
+ DoAssertionChecks ifTrue:
+ [objectMemory okayOop: outerContext].
+ closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
+ methodHeader := self headerOf: closureMethod.
+ objectMemory pushRemappableOop: blockClosure.
+ newContext := objectMemory allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
+
+ "allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
+ theBlockClosure := objectMemory popRemappableOop.
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
+ numCopied := (objectMemory fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
+
+ "Assume: newContext will be recorded as a root if necessary by the
+ call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + objectMemory baseHeaderSize.
+ objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord)
+ put: activeContext.
+ objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord)
+ put: (objectMemory fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
+ objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord)
+ put: (objectMemory integerObjectOf: argumentCount + numCopied).
+ objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord)
+ put: (objectMemory fetchPointer: MethodIndex ofObject: outerContext).
+ objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord)
+ put: theBlockClosure.
+ objectMemory longAt: where + (ReceiverIndex << objectMemory shiftForWord)
+ put: (objectMemory fetchPointer: ReceiverIndex ofObject: outerContext).
+
+ "Copy the arguments..."
+ 1 to: argumentCount do:
+ [:i | objectMemory longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord)
+ put: (self stackValue: argumentCount-i)].
+
+ "Copy the copied values..."
+ where := newContext + objectMemory baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << objectMemory shiftForWord).
+ 0 to: numCopied - 1 do:
+ [:i| objectMemory longAt: where + (i << objectMemory shiftForWord)
+ put: (objectMemory fetchPointer: i + ClosureFirstCopiedValueIndex
+ ofObject: theBlockClosure)].
+
+ "The initial instructions in the block nil-out remaining temps."
+
+ self pop: argumentCount + 1.
+ self newActiveContext: newContext!
Item was added:
+ ----- Method: ContextInterpreter>>activateNewMethod (in category 'message sending') -----
+ activateNewMethod
+ | newContext methodHeader initialIP tempCount nilOop where |
+
+ methodHeader := self headerOf: newMethod.
+ newContext := objectMemory allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).
+
+ initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1.
+ tempCount := (methodHeader >> 19) bitAnd: 16r3F.
+
+ "Assume: newContext will be recorded as a root if necessary by the
+ call to newActiveContext: below, so we can use unchecked stores."
+
+ where := newContext + objectMemory baseHeaderSize.
+ objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
+ objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: initialIP).
+ objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
+ objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
+ objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory getNilObj.
+
+ "Copy the receiver and arguments..."
+ 0 to: argumentCount do:
+ [:i | objectMemory longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord) put: (self stackValue: argumentCount-i)].
+
+ "clear remaining temps to nil in case it has been recycled"
+ nilOop := objectMemory getNilObj.
+ argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: nilOop].
+
+ self pop: argumentCount + 1.
+ reclaimableContextCount := reclaimableContextCount + 1.
+ self newActiveContext: newContext.!
Item was added:
+ ----- Method: ContextInterpreter>>addNewMethodToCache (in category 'method lookup cache') -----
+ addNewMethodToCache
+ "Add the given entry to the method cache.
+ The policy is as follows:
+ Look for an empty entry anywhere in the reprobe chain.
+ If found, install the new entry there.
+ If not found, then install the new entry at the first probe position
+ and delete the entries in the rest of the reprobe chain.
+ This has two useful purposes:
+ If there is active contention over the first slot, the second
+ or third will likely be free for reentry after ejection.
+ Also, flushing is good when reprobe chains are getting full."
+ | probe hash |
+ <inline: false>
+ self compilerTranslateMethodHook. "newMethod x lkupClass -> newNativeMethod (may cause GC !!)"
+ hash := messageSelector bitXor: lkupClass. "drop low-order zeros from addresses"
+
+ primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: lkupClass.
+
+ 0 to: CacheProbeMax-1 do:
+ [:p | probe := (hash >> p) bitAnd: MethodCacheMask.
+ (methodCache at: probe + MethodCacheSelector) = 0 ifTrue:
+ ["Found an empty entry -- use it"
+ methodCache at: probe + MethodCacheSelector put: messageSelector.
+ methodCache at: probe + MethodCacheClass put: lkupClass.
+ methodCache at: probe + MethodCacheMethod put: newMethod.
+ methodCache at: probe + MethodCachePrim put: primitiveIndex.
+ methodCache at: probe + MethodCacheNative put: newNativeMethod.
+ methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').
+ ^ nil]].
+
+ "OK, we failed to find an entry -- install at the first slot..."
+ probe := hash bitAnd: MethodCacheMask. "first probe"
+ methodCache at: probe + MethodCacheSelector put: messageSelector.
+ methodCache at: probe + MethodCacheClass put: lkupClass.
+ methodCache at: probe + MethodCacheMethod put: newMethod.
+ methodCache at: probe + MethodCachePrim put: primitiveIndex.
+ methodCache at: probe + MethodCacheNative put: newNativeMethod.
+ methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').
+
+ "...and zap the following entries"
+ 1 to: CacheProbeMax-1 do:
+ [:p | probe := (hash >> p) bitAnd: MethodCacheMask.
+ methodCache at: probe + MethodCacheSelector put: 0].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>addToExternalPrimitiveTable: (in category 'plugin support') -----
+ addToExternalPrimitiveTable: functionAddress
+ "Add the given function address to the external primitive table and return the index where it's stored. This function doesn't need to be fast since it is only called when an external primitive has been looked up (which takes quite a bit of time itself). So there's nothing specifically complicated here.
+ Note: Return index will be one-based (ST convention)"
+
+ <var: #functionAddress declareC: 'void (*functionAddress)(void)'>
+
+ 0 to: MaxExternalPrimitiveTableSize-1 do: [ :i |
+ (externalPrimitiveTable at: i) = 0 ifTrue: [
+ externalPrimitiveTable at: i put: functionAddress.
+ ^i+1]].
+ "if no space left, return zero so it'll looked up again"
+ ^0!
Item was added:
+ ----- Method: ContextInterpreter>>allAccessibleObjectsOkay (in category 'debug support') -----
+ allAccessibleObjectsOkay
+ "Ensure that all accessible objects in the heap are okay."
+
+ | oop |
+ oop := objectMemory firstAccessibleObject.
+ [oop = nil] whileFalse: [
+ self okayFields: oop.
+ oop := objectMemory accessibleObjectAfter: oop.
+ ].!
Item was added:
+ ----- Method: ContextInterpreter>>argCount (in category 'message sending') -----
+ argCount
+ ^ argumentCount!
Item was added:
+ ----- Method: ContextInterpreter>>argumentCountOf: (in category 'compiled methods') -----
+ argumentCountOf: methodPointer
+ ^ ((self headerOf: methodPointer) >> 25) bitAnd: 16r0F!
Item was added:
+ ----- Method: ContextInterpreter>>argumentCountOfBlock: (in category 'contexts') -----
+ argumentCountOfBlock: blockPointer
+
+ | localArgCount |
+ localArgCount := objectMemory fetchPointer: BlockArgumentCountIndex ofObject: blockPointer.
+ ^self checkedIntegerValueOf: localArgCount!
Item was added:
+ ----- Method: ContextInterpreter>>argumentCountOfClosure: (in category 'contexts') -----
+ argumentCountOfClosure: closurePointer
+
+ ^self quickFetchInteger: ClosureNumArgsIndex ofObject: closurePointer!
Item was added:
+ ----- Method: ContextInterpreter>>argumentCountOfMethodHeader: (in category 'compiled methods') -----
+ argumentCountOfMethodHeader: header
+ ^ (header >> 25) bitAnd: 16r0F!
Item was added:
+ ----- Method: ContextInterpreter>>arrayValueOf: (in category 'utilities') -----
+ arrayValueOf: arrayOop
+ "Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
+ "Note: May be called by translated primitive code."
+
+ <returnTypeC: 'void *'>
+ ((objectMemory isIntegerObject: arrayOop) not and:
+ [objectMemory isWordsOrBytes: arrayOop])
+ ifTrue: [^ objectMemory pointerForOop: (arrayOop + objectMemory baseHeaderSize)].
+ self primitiveFail.
+ !
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>assertClassOf:is: (in category 'utilities') -----
+ assertClassOf: oop is: classOop
+ "Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."
+
+ | ccIndex cl |
+ <inline: true>
+ (objectMemory isIntegerObject: oop)
+ ifTrue: [ self primitiveFail. ^ nil ].
+
+ ccIndex := ((objectMemory baseHeader: oop) >> 12) bitAnd: 16r1F.
+ ccIndex = 0
+ ifTrue: [ cl := ((objectMemory classHeader: oop) bitAnd: objectMemory allButTypeMask) ]
+ ifFalse: [
+ "look up compact class"
+ cl := (objectMemory fetchPointer: (ccIndex - 1)
+ ofObject: (objectMemory fetchPointer: CompactClasses ofObject: objectMemory getSpecialObjectsOop))].
+
+ self success: cl = classOop.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>balancedStack:afterPrimitive:withArgs: (in category 'debug support') -----
+ balancedStack: delta afterPrimitive: primIdx withArgs: nArgs
+ "Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)"
+ (primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true].
+ "81-88 are control primitives after which the stack may look unbalanced"
+ self successful ifTrue:[
+ "Successful prim, stack must have exactly nArgs arguments popped off"
+ ^(stackPointer - activeContext + (nArgs * objectMemory bytesPerWord)) = delta
+ ].
+ "Failed prim must leave stack intact"
+ ^(stackPointer - activeContext) = delta
+ !
Item was added:
+ ----- Method: ContextInterpreter>>booleanCheat: (in category 'utilities') -----
+ booleanCheat: cond
+ "cheat the interpreter out of the pleasure of handling the next bytecode IFF it is a jump-on-boolean. Which it is, often enough when the current bytecode is something like bytecodePrimEqual"
+ | bytecode offset |
+ <inline: true>
+
+ bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)"
+ self internalPop: 2.
+ (bytecode < 160 and: [bytecode > 151]) ifTrue: [ "short jumpIfFalse"
+ cond
+ ifTrue: [^ self fetchNextBytecode]
+ ifFalse: [^ self jump: bytecode - 151]].
+
+ bytecode = 172 ifTrue: [ "long jumpIfFalse"
+ offset := self fetchByte.
+ cond
+ ifTrue: [^ self fetchNextBytecode]
+ ifFalse: [^ self jump: offset]].
+
+ "not followed by a jumpIfFalse; undo instruction fetch and push boolean result"
+ localIP := localIP - 1.
+ self fetchNextBytecode.
+ cond
+ ifTrue: [self internalPush: objectMemory getTrueObj]
+ ifFalse: [self internalPush: objectMemory getFalseObj].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>booleanValueOf: (in category 'utilities') -----
+ booleanValueOf: obj
+ "convert true and false (Smalltalk) to true or false(C)"
+ obj = objectMemory getTrueObj ifTrue: [ ^ true ].
+ obj = objectMemory getFalseObj ifTrue: [ ^ false ].
+ self primitiveFail.
+ ^ nil!
Item was added:
+ ----- Method: ContextInterpreter>>byteLengthOf: (in category 'array primitive support') -----
+ byteLengthOf: oop
+ "Return the number of indexable bytes in the given object. This is basically a special copy of lengthOf: for BitBlt."
+ | header sz fmt |
+ header := objectMemory baseHeader: oop.
+ (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ sz := (objectMemory sizeHeader: oop) bitAnd: objectMemory allButTypeMask ]
+ ifFalse: [ sz := header bitAnd: objectMemory sizeMask ].
+ fmt := (header >> 8) bitAnd: 16rF.
+ fmt < 8
+ ifTrue: [ ^ (sz - objectMemory baseHeaderSize)] "words"
+ ifFalse: [ ^ (sz - objectMemory baseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was added:
+ ----- Method: ContextInterpreter>>byteSwapByteObjects (in category 'image save/restore') -----
+ byteSwapByteObjects
+ "Byte-swap the words of all bytes objects in the image. This returns these objects to their original byte ordering after blindly byte-swapping the entire image."
+
+ self byteSwapByteObjectsFrom: objectMemory firstObject to: objectMemory getEndOfMemory!
Item was added:
+ ----- Method: ContextInterpreter>>byteSwapByteObjectsFrom:to: (in category 'image save/restore') -----
+ byteSwapByteObjectsFrom: startOop to: stopAddr
+ "Byte-swap the words of all bytes objects in a range of the
+ image, including Strings, ByteArrays, and CompiledMethods.
+ This returns these objects to their original byte ordering
+ after blindly byte-swapping the entire image. For compiled
+ methods, byte-swap only their bytecodes part."
+ | oop fmt wordAddr methodHeader |
+ oop := startOop.
+ [objectMemory oop: oop isLessThan: stopAddr]
+ whileTrue: [(objectMemory isFreeObject: oop)
+ ifFalse: [fmt := objectMemory formatOf: oop.
+ fmt >= 8
+ ifTrue: ["oop contains bytes"
+ wordAddr := oop + objectMemory baseHeaderSize.
+ fmt >= 12
+ ifTrue: ["compiled method; start after methodHeader and literals"
+ methodHeader := objectMemory longAt: oop + objectMemory baseHeaderSize.
+ wordAddr := wordAddr + objectMemory bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * objectMemory bytesPerWord)].
+ objectMemory reverseBytesFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)].
+ (fmt = 6 and: [objectMemory bytesPerWord = 8])
+ ifTrue: ["Object contains 32-bit half-words packed into 64-bit machine words."
+ wordAddr := oop + objectMemory baseHeaderSize.
+ objectMemory reverseWordsFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)]].
+ oop := objectMemory objectAfter: oop]!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>bytecodePrimAt (in category 'common selector sends') -----
+ bytecodePrimAt
+ "BytecodePrimAt will only succeed if the receiver is in the atCache.
+ Otherwise it will fail so that the more general primitiveAt will put it in the
+ cache after validating that message lookup results in a primitive response."
+ | index rcvr result atIx |
+ index := self internalStackTop.
+ rcvr := self internalStackValue: 1.
+ ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isIntegerObject: index])
+ ifTrue: [atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
+ (atCache at: atIx+AtCacheOop) = rcvr
+ ifTrue: [result := self
+ commonVariableInternal: rcvr
+ at: (objectMemory integerValueOf: index)
+ cacheIndex: atIx.
+ self successful ifTrue:
+ [self fetchNextBytecode.
+ ^self internalPop: 2 thenPush: result]]]
+ ifFalse: [self primitiveFail].
+ messageSelector := self specialSelector: 16.
+ argumentCount := 1.
+ self normalSend.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimAtEnd (in category 'common selector sends') -----
+ bytecodePrimAtEnd
+ messageSelector := self specialSelector: 21.
+ argumentCount := 0.
+ self normalSend.!
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimAtPut (in category 'common selector sends') -----
+ bytecodePrimAtPut
+ "BytecodePrimAtPut will only succeed if the receiver is in the atCache.
+ Otherwise it will fail so that the more general primitiveAtPut will put it in the
+ cache after validating that message lookup results in a primitive response."
+ | index rcvr atIx value |
+ value := self internalStackTop.
+ index := self internalStackValue: 1.
+ rcvr := self internalStackValue: 2.
+ ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isIntegerObject: index])
+ ifTrue: [atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
+ (atCache at: atIx+AtCacheOop) = rcvr
+ ifTrue: [self
+ commonVariable: rcvr
+ at: (objectMemory integerValueOf: index)
+ put: value cacheIndex: atIx.
+ self successful ifTrue: [self fetchNextBytecode.
+ ^self internalPop: 3 thenPush: value]]]
+ ifFalse: [self primitiveFail].
+ messageSelector := self specialSelector: 17.
+ argumentCount := 2.
+ self normalSend!
Item was added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>bytecodePrimBlockCopy (in category 'common selector sends') -----
+ bytecodePrimBlockCopy
+
+ | rcvr hdr |
+ rcvr := self internalStackValue: 1.
+ self initPrimCall.
+ hdr := objectMemory baseHeader: rcvr.
+ self success: (self isContextHeader: hdr).
+ self successful ifTrue: [self externalizeIPandSP.
+ self primitiveBlockCopy.
+ self internalizeIPandSP].
+ self successful ifFalse: [messageSelector := self specialSelector: 24.
+ argumentCount := 1.
+ ^ self normalSend].
+ self fetchNextBytecode.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimClass (in category 'common selector sends') -----
+ bytecodePrimClass
+ | rcvr |
+ rcvr := self internalStackTop.
+ self internalPop: 1 thenPush: (objectMemory fetchClassOf: rcvr).
+ self fetchNextBytecode.
+ !
Item was added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>bytecodePrimDo (in category 'common selector sends') -----
+ bytecodePrimDo
+
+ messageSelector := self specialSelector: 27.
+ argumentCount := 1.
+ self normalSend.
+ !
Item was added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>bytecodePrimGreaterOrEqual (in category 'common selector sends') -----
+ bytecodePrimGreaterOrEqual
+ | rcvr arg aBool |
+ rcvr := self internalStackValue: 1.
+ arg := self internalStackValue: 0.
+ (self areIntegers: rcvr and: arg) ifTrue:
+ [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) >= (objectMemory integerValueOf: arg)].
+ ^self booleanCheat: rcvr >= arg].
+
+ self initPrimCall.
+ aBool := self primitiveFloatGreaterOrEqual: rcvr toArg: arg.
+ self successful ifTrue: [^self booleanCheat: aBool].
+
+ messageSelector := self specialSelector: 5.
+ argumentCount := 1.
+ self normalSend!
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimGreaterThan (in category 'common selector sends') -----
+ bytecodePrimGreaterThan
+ | rcvr arg aBool |
+ rcvr := self internalStackValue: 1.
+ arg := self internalStackValue: 0.
+ (self areIntegers: rcvr and: arg) ifTrue:
+ [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) > (objectMemory integerValueOf: arg)].
+ ^self booleanCheat: rcvr > arg].
+
+ self initPrimCall.
+ aBool := self primitiveFloatGreater: rcvr thanArg: arg.
+ self successful ifTrue: [^self booleanCheat: aBool].
+
+ messageSelector := self specialSelector: 3.
+ argumentCount := 1.
+ self normalSend
+ !
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimLessOrEqual (in category 'common selector sends') -----
+ bytecodePrimLessOrEqual
+ | rcvr arg aBool |
+ rcvr := self internalStackValue: 1.
+ arg := self internalStackValue: 0.
+ (self areIntegers: rcvr and: arg) ifTrue:
+ [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) <= (objectMemory integerValueOf: arg)].
+ ^ self booleanCheat: rcvr <= arg].
+
+ self initPrimCall.
+ aBool := self primitiveFloatLessOrEqual: rcvr toArg: arg.
+ self successful ifTrue: [^self booleanCheat: aBool].
+
+ messageSelector := self specialSelector: 4.
+ argumentCount := 1.
+ self normalSend!
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimLessThan (in category 'common selector sends') -----
+ bytecodePrimLessThan
+ | rcvr arg aBool |
+ rcvr := self internalStackValue: 1.
+ arg := self internalStackValue: 0.
+ (self areIntegers: rcvr and: arg) ifTrue:
+ [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) < (objectMemory integerValueOf: arg)].
+ ^ self booleanCheat: rcvr < arg].
+
+ self initPrimCall.
+ aBool := self primitiveFloatLess: rcvr thanArg: arg.
+ self successful ifTrue: [^ self booleanCheat: aBool].
+
+ messageSelector := self specialSelector: 2.
+ argumentCount := 1.
+ self normalSend
+ !
Item was added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>bytecodePrimMultiply (in category 'common selector sends') -----
+ bytecodePrimMultiply
+ | 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.
+ result := rcvr * arg.
+ (arg = 0 or: [(result // arg) = rcvr and: [objectMemory isIntegerValue: result]])
+ ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
+ ^ self fetchNextBytecode "success"]]
+ ifFalse: [self initPrimCall.
+ self externalizeIPandSP.
+ self primitiveFloatMultiply: rcvr byArg: arg.
+ self internalizeIPandSP.
+ self successful ifTrue: [^ self fetchNextBytecode "success"]].
+
+ messageSelector := self specialSelector: 8.
+ argumentCount := 1.
+ self normalSend.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimNew (in category 'common selector sends') -----
+ bytecodePrimNew
+
+ messageSelector := self specialSelector: 28.
+ argumentCount := 0.
+ self normalSend.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimNewWithArg (in category 'common selector sends') -----
+ bytecodePrimNewWithArg
+
+ messageSelector := self specialSelector: 29.
+ argumentCount := 1.
+ self normalSend.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimNext (in category 'common selector sends') -----
+ bytecodePrimNext
+ messageSelector := self specialSelector: 19.
+ argumentCount := 0.
+ self normalSend.!
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimNextPut (in category 'common selector sends') -----
+ bytecodePrimNextPut
+ messageSelector := self specialSelector: 20.
+ argumentCount := 1.
+ self normalSend.!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>bytecodePrimPointX (in category 'common selector sends') -----
+ bytecodePrimPointX
+
+ | rcvr |
+ self initPrimCall.
+ rcvr := self internalStackTop.
+ self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
+ self successful
+ ifTrue: [self internalPop: 1 thenPush: (objectMemory fetchPointer: XIndex ofObject: rcvr).
+ ^ self fetchNextBytecode "success"].
+
+ messageSelector := self specialSelector: 30.
+ argumentCount := 0.
+ self normalSend!
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimPointY (in category 'common selector sends') -----
+ bytecodePrimPointY
+
+ | rcvr |
+ self initPrimCall.
+ rcvr := self internalStackTop.
+ self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
+ self successful
+ ifTrue: [self internalPop: 1 thenPush: (objectMemory fetchPointer: YIndex ofObject: rcvr).
+ ^ self fetchNextBytecode "success"].
+
+ messageSelector := self specialSelector: 31.
+ argumentCount := 0.
+ self normalSend!
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimSize (in category 'common selector sends') -----
+ bytecodePrimSize
+ messageSelector := self specialSelector: 18.
+ argumentCount := 0.
+ self normalSend!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>bytecodePrimValue (in category 'common selector sends') -----
+ bytecodePrimValue
+ "In-line value for BlockClosure and BlockContext"
+ | maybeBlock rcvrClass |
+ maybeBlock := self internalStackTop.
+ argumentCount := 0.
+ self initPrimCall.
+ (objectMemory isNonIntegerObject: maybeBlock) ifTrue:
+ [rcvrClass := objectMemory fetchClassOfNonInt: maybeBlock.
+ rcvrClass = (objectMemory splObj: ClassBlockClosure)
+ ifTrue:
+ [self externalizeIPandSP.
+ self primitiveClosureValue.
+ self internalizeIPandSP]
+ ifFalse:
+ [rcvrClass = (objectMemory splObj: ClassBlockContext)
+ ifTrue:
+ [self externalizeIPandSP.
+ self primitiveValue.
+ self internalizeIPandSP]
+ ifFalse:
+ [self primitiveFail]]].
+ self successful ifFalse:
+ [messageSelector := self specialSelector: 25.
+ ^self normalSend].
+ self fetchNextBytecode!
Item was added:
+ ----- Method: ContextInterpreter>>bytecodePrimValueWithArg (in category 'common selector sends') -----
+ bytecodePrimValueWithArg
+ "In-line value: for BlockClosure and BlockContext"
+ | maybeBlock rcvrClass |
+ maybeBlock := self internalStackValue: 1.
+ argumentCount := 1.
+ self initPrimCall.
+ (objectMemory isNonIntegerObject: maybeBlock) ifTrue:
+ [rcvrClass := objectMemory fetchClassOfNonInt: maybeBlock.
+ rcvrClass = (objectMemory splObj: ClassBlockClosure)
+ ifTrue:
+ [self externalizeIPandSP.
+ self primitiveClosureValue.
+ self internalizeIPandSP]
+ ifFalse:
+ [rcvrClass = (objectMemory splObj: ClassBlockContext)
+ ifTrue:
+ [self externalizeIPandSP.
+ self primitiveValue.
+ self internalizeIPandSP]
+ ifFalse:
+ [self primitiveFail]]].
+ self successful ifFalse:
+ [messageSelector := self specialSelector: 26.
+ ^self normalSend].
+ self fetchNextBytecode!
Item was added:
+ ----- Method: ContextInterpreter>>callExternalPrimitive: (in category 'plugin primitive support') -----
+ callExternalPrimitive: functionID
+ "Call the external plugin function identified. In the VM this is an address, see InterpreterSimulator for it's version. "
+
+ <var: #functionID declareC: 'void (*functionID)(void)'>
+ self dispatchFunctionPointer: functionID!
Item was added:
+ ----- Method: ContextInterpreter>>callInterpreter (in category 'interpreter shell') -----
+ callInterpreter
+ "External call into the interpreter"
+
+ <inline: false>
+ <export: true>
+ self interpret.!
Item was added:
+ ----- Method: ContextInterpreter>>callbackEnter: (in category 'callback support') -----
+ callbackEnter: callbackID
+ "Re-enter the interpreter for executing a callback"
+ | result activeProc |
+ <export: true>
+ <var: #callbackID declareC: 'sqInt *callbackID'>
+
+ "For now, do not allow a callback unless we're in a primitiveResponse"
+ primitiveIndex = 0 ifTrue:[^false].
+
+ "Check if we've exceeded the callback depth"
+ jmpDepth >= jmpMax ifTrue:[^false].
+ jmpDepth := jmpDepth + 1.
+
+ "Suspend the currently active process"
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex
+ ofObject: self schedulerPointer.
+ suspendedCallbacks at: jmpDepth put: activeProc.
+ "We need to preserve newMethod explicitly since it is not activated yet
+ and therefore no context has been created for it. If the caller primitive
+ for any reason decides to fail we need to make sure we execute the correct
+ method and not the one 'last used' in the call back"
+ suspendedMethods at: jmpDepth put: newMethod.
+ self transferTo: self wakeHighestPriority.
+
+ "Typically, invoking the callback means that some semaphore has been
+ signaled to indicate the callback. Force an interrupt check right away."
+ self forceInterruptCheck.
+
+ result := self setjmp: (jmpBuf at: jmpDepth).
+ result == 0 ifTrue:["Fill in callbackID"
+ callbackID at: 0 put: jmpDepth.
+ "This is ugly but the inliner treats interpret() in very special and strange ways and calling any kind of 'self interpret' either directly or even via cCode:inSmalltalk: will cause this entire method to vanish."
+ self cCode: 'interpret()'.
+ ].
+
+ "Transfer back to the previous process so that caller can push result"
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex
+ ofObject: self schedulerPointer.
+ self putToSleep: activeProc.
+ activeProc := suspendedCallbacks at: jmpDepth.
+ newMethod := suspendedMethods at: jmpDepth. "see comment above"
+ self transferTo: activeProc.
+ jmpDepth := jmpDepth-1.
+ ^true!
Item was added:
+ ----- Method: ContextInterpreter>>callbackLeave: (in category 'callback support') -----
+ callbackLeave: cbID
+ "Leave from a previous callback"
+ <export: true>
+
+ "For now, do not allow a callback unless we're in a primitiveResponse"
+ primitiveIndex = 0 ifTrue:[^false].
+
+ "Check if this is the top-level callback"
+ cbID = jmpDepth ifFalse:[^false].
+ cbID < 1 ifTrue:[^false].
+ "This is ugly but necessary, or otherwise the Mac will not build"
+ self long: (jmpBuf at: jmpDepth) jmp: 1.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>caller (in category 'contexts') -----
+ caller
+ ^objectMemory fetchPointer: CallerIndex ofObject: activeContext!
Item was added:
+ ----- Method: ContextInterpreter>>capturePendingFinalizationSignals (in category 'debug support') -----
+ capturePendingFinalizationSignals
+ objectMemory setStatpendingFinalizationSignals: pendingFinalizationSignals.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>changeClassOf:to: (in category 'object access primitives') -----
+ changeClassOf: rcvr to: argClass
+ "Change the class of the receiver into the class specified by the argument given that the format of the receiver matches the format of the argument. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
+ | classHdr sizeHiBits byteSize argFormat rcvrFormat ccIndex |
+ "Check what the format of the class says"
+ classHdr := objectMemory formatOfClass: argClass. "Low 2 bits are 0"
+
+ "Compute the size of instances of the class (used for fixed field classes only)"
+ sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
+ classHdr := classHdr bitAnd: 16r1FFFF.
+ byteSize := (classHdr bitAnd: objectMemory sizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
+
+ "Check the receiver's format against that of the class"
+ argFormat := (classHdr >> 8) bitAnd: 16rF.
+ rcvrFormat := objectMemory formatOf: rcvr.
+ argFormat = rcvrFormat ifFalse:[^self primitiveFail]. "no way"
+
+ "For fixed field classes, the sizes must match.
+ Note: byteSize-4 because base header is included in class size."
+ argFormat < 2 ifTrue:[(byteSize - 4) = (objectMemory byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].
+
+ (objectMemory headerType: rcvr) = HeaderTypeShort
+ ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex"
+ ccIndex := classHdr bitAnd: CompactClassMask.
+ ccIndex = 0 ifTrue:[^self primitiveFail]. "class is not compact"
+ objectMemory longAt: rcvr put:
+ (((objectMemory longAt: rcvr) bitAnd: CompactClassMask bitInvert32)
+ bitOr: ccIndex)]
+ ifFalse:["Exchange the class pointer, which could make rcvr a root for argClass"
+ objectMemory longAt: rcvr - objectMemory baseHeaderSize put: (argClass bitOr: (objectMemory headerType: rcvr)).
+ (objectMemory oop: rcvr isLessThan: objectMemory getYoungStart)
+ ifTrue: [objectMemory possibleRootStoreInto: rcvr value: argClass]]!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>characterTable (in category 'plugin support') -----
+ characterTable
+ ^objectMemory splObj: CharacterTable!
Item was added:
+ ----- Method: ContextInterpreter>>checkBooleanResult: (in category 'arithmetic primitive support') -----
+ checkBooleanResult: result
+ self successful
+ ifTrue: [self pushBool: result]
+ ifFalse: [self unPop: 2]!
Item was added:
+ ----- Method: ContextInterpreter>>checkCodeIntegrity: (in category 'stack interpreter support') -----
+ checkCodeIntegrity: fullGCFlag
+ "This is a no-op in the Interpreter and the StackVM"
+ ^true!
Item was added:
+ ----- Method: ContextInterpreter>>checkForInterrupts (in category 'process primitive support') -----
+ checkForInterrupts
+ "Check for possible interrupts and handle one if necessary."
+ | sema now |
+ <inline: false>
+
+ "Mask so same wrapping as primitiveMillisecondClock"
+ now := self ioMSecs bitAnd: MillisecondClockMask.
+
+ self interruptCheckForced ifFalse: [
+ "don't play with the feedback if we forced a check. It only makes life difficult"
+ now - lastTick < interruptChecksEveryNms
+ ifTrue: ["wrapping is not a concern, it'll get caught quickly
+ enough. This clause is trying to keep a reasonable
+ guess of how many times per interruptChecksEveryNms we are calling
+ quickCheckForInterrupts. Not sure how effective it really is."
+ interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset + 10]
+ ifFalse: [interruptCheckCounterFeedBackReset <= 1000
+ ifTrue: [interruptCheckCounterFeedBackReset := 1000]
+ ifFalse: [interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset - 12]]].
+
+ "reset the interrupt check counter"
+ interruptCheckCounter := interruptCheckCounterFeedBackReset.
+
+ objectMemory getSignalLowSpace
+ ifTrue: [objectMemory setSignalLowSpace: false. "reset flag"
+ sema := objectMemory splObj: TheLowSpaceSemaphore.
+ sema = objectMemory getNilObj ifFalse: [self synchronousSignal: sema]].
+
+ now < lastTick
+ ifTrue: ["millisecond clock wrapped so correct the nextPollTick"
+ nextPollTick := nextPollTick - MillisecondClockMask - 1].
+ now >= nextPollTick
+ ifTrue: [self ioProcessEvents.
+ "sets interruptPending if interrupt key pressed"
+ nextPollTick := now + 200
+ "msecs to wait before next call to ioProcessEvents.
+ Note that strictly speaking we might need to update
+ 'now' at this point since ioProcessEvents could take a
+ very long time on some platforms"].
+ interruptPending
+ ifTrue: [interruptPending := false.
+ "reset interrupt flag"
+ sema := objectMemory splObj: TheInterruptSemaphore.
+ sema = objectMemory getNilObj
+ ifFalse: [self synchronousSignal: sema]].
+
+ nextWakeupTick ~= 0
+ ifTrue: [now < lastTick
+ ifTrue: ["the clock has wrapped. Subtract the wrap
+ interval from nextWakeupTick - this might just
+ possibly result in 0. Since this is used as a flag
+ value for 'no timer' we do the 0 check above"
+ nextWakeupTick := nextWakeupTick - MillisecondClockMask - 1].
+ now >= nextWakeupTick
+ ifTrue: [nextWakeupTick := 0.
+ "set timer interrupt to 0 for 'no timer'"
+ sema := objectMemory splObj: TheTimerSemaphore.
+ sema = objectMemory getNilObj ifFalse: [self synchronousSignal: sema]]].
+
+ "signal any pending finalizations"
+ pendingFinalizationSignals > 0
+ ifTrue: [sema := objectMemory splObj: TheFinalizationSemaphore.
+ (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
+ ifTrue: [self synchronousSignal: sema].
+ pendingFinalizationSignals := 0].
+
+ "signal all semaphores in semaphoresToSignal"
+ (semaphoresToSignalCountA > 0 or: [semaphoresToSignalCountB > 0])
+ ifTrue: [self signalExternalSemaphores].
+
+ "update the tracking value"
+ lastTick := now!
Item was added:
+ ----- Method: ContextInterpreter>>checkImageVersionFrom:startingAt: (in category 'image save/restore') -----
+ checkImageVersionFrom: f startingAt: imageOffset
+ "Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number."
+ "This code is based on C code by Ian Piumarta."
+
+ | firstVersion |
+ <var: #f type: 'sqImageFile '>
+ <var: #imageOffset type: 'squeakFileOffsetType '>
+
+ "check the version number"
+ self sqImageFile: f Seek: imageOffset.
+ imageFormatInitialVersion := firstVersion := self getLongFromFile: f swap: false.
+ (self readableFormat: imageFormatInitialVersion) ifTrue: [^ false].
+
+ "try with bytes reversed"
+ self sqImageFile: f Seek: imageOffset.
+ imageFormatInitialVersion := self getLongFromFile: f swap: true.
+ (self readableFormat: imageFormatInitialVersion) ifTrue: [^ true].
+
+ "Note: The following is only meaningful if not reading an embedded image"
+ imageOffset = 0 ifTrue:[
+ "try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)"
+ self sqImageFile: f Seek: 512.
+ imageFormatInitialVersion := self getLongFromFile: f swap: false.
+ (self readableFormat: imageFormatInitialVersion) ifTrue: [^ false].
+
+ "try skipping the first 512 bytes with bytes reversed"
+ self sqImageFile: f Seek: 512.
+ imageFormatInitialVersion := self getLongFromFile: f swap: true.
+ (self readableFormat: imageFormatInitialVersion) ifTrue: [^ true]].
+
+ "hard failure; abort"
+ self print: 'This interpreter (vers. '.
+ self printNum: self imageFormatVersion.
+ self print: ') cannot read image file (vers. '.
+ self printNum: firstVersion.
+ self print: ').'.
+ self cr.
+ self print: 'Press CR to quit...'.
+ self getchar.
+ self ioExit.
+ !
Item was added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>classNameOf:Is: (in category 'plugin primitive support') -----
+ classNameOf: aClass Is: className
+ "Check if aClass's name is className"
+ | srcName name length |
+ <var: #className type: 'char *'>
+ <var: #srcName type: 'char *'>
+ (objectMemory lengthOf: aClass) <= 6 ifTrue: [^ false].
+
+ "Not a class but might be behavior"
+ name := objectMemory fetchPointer: 6 ofObject: aClass.
+ (objectMemory isBytes: name) ifFalse: [^ false].
+ length := self stSizeOf: name.
+ srcName := self cCoerce: (self arrayValueOf: name) to: 'char *'.
+ 0 to: length - 1 do: [:i | (srcName at: i) = (className at: i) ifFalse: [^ false]].
+ "Check if className really ends at this point"
+ ^ (className at: length) = 0!
Item was added:
+ ----- Method: ContextInterpreter>>closureNumArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
+ closureNumArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
+ | newClosure |
+ <inline: true>
+ newClosure := objectMemory
+ instantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
+ sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize.
+ "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
+ objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
+ "It is up to the caller to store the outer context and copiedValues."
+ ^newClosure!
Item was added:
+ ----- Method: ContextInterpreter>>commonAt: (in category 'array primitive support') -----
+ commonAt: stringy
+ "This code is called if the receiver responds primitively to at:.
+ If this is so, it will be installed in the atCache so that subsequent calls of at:
+ or next may be handled immediately in bytecode primitive routines."
+ | index rcvr atIx result |
+ index := self positive32BitValueOf: (self stackTop). "Sets primFailCode"
+ rcvr := self stackValue: 1.
+ self successful & (objectMemory isIntegerObject: rcvr) not
+ ifFalse: [^ self primitiveFail].
+
+ "NOTE: The at-cache, since it is specific to the non-super response to #at:.
+ Therefore we must determine that the message is #at: (not, eg, #basicAt:),
+ and that the send is not a super-send, before using the at-cache."
+ (messageSelector = (self specialSelector: 16)
+ and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)])
+ ifTrue:
+ ["OK -- look in the at-cache"
+ atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
+ (atCache at: atIx+AtCacheOop) = rcvr ifFalse:
+ ["Rcvr not in cache. Install it..."
+ self install: rcvr inAtCache: atCache at: atIx string: stringy].
+ self successful ifTrue:
+ [result := self commonVariable: rcvr at: index cacheIndex: atIx].
+ self successful ifTrue:
+ [^ self pop: argumentCount+1 thenPush: result]].
+
+ "The slow but sure way..."
+ self initPrimCall.
+ result := self stObject: rcvr at: index.
+ self successful ifTrue:
+ [stringy ifTrue: [result := self characterForAscii: (objectMemory integerValueOf: result)].
+ ^ self pop: argumentCount+1 thenPush: result]!
Item was added:
+ ----- Method: ContextInterpreter>>commonAtPut: (in category 'array primitive support') -----
+ commonAtPut: stringy
+ "This code is called if the receiver responds primitively to at:Put:.
+ If this is so, it will be installed in the atPutCache so that subsequent calls of at:
+ or next may be handled immediately in bytecode primitive routines."
+ | value index rcvr atIx |
+ value := self stackTop.
+ index := self positive32BitValueOf: (self stackValue: 1). "Sets primFailCode"
+ rcvr := self stackValue: 2.
+ self successful & (objectMemory isIntegerObject: rcvr) not
+ ifFalse: [^ self primitiveFail].
+
+ "NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:.
+ Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:),
+ and that the send is not a super-send, before using the at-cache."
+ (messageSelector = (self specialSelector: 17)
+ and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)])
+ ifTrue:
+ ["OK -- look in the at-cache"
+ atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
+ (atCache at: atIx+AtCacheOop) = rcvr ifFalse:
+ ["Rcvr not in cache. Install it..."
+ self install: rcvr inAtCache: atCache at: atIx string: stringy].
+ self successful ifTrue:
+ [self commonVariable: rcvr at: index put: value cacheIndex: atIx].
+ self successful ifTrue:
+ [^ self pop: argumentCount+1 thenPush: value]].
+
+ "The slow but sure way..."
+ self initPrimCall.
+ stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
+ ifFalse: [self stObject: rcvr at: index put: value].
+ self successful ifTrue: [^ self pop: argumentCount+1 thenPush: value].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>commonReturn (in category 'return bytecodes') -----
+ commonReturn
+ "Note: Assumed to be inlined into the dispatch loop."
+
+ | nilOop thisCntx contextOfCaller localCntx localVal unwindMarked |
+ <inline: true>
+ self sharedCodeNamed: 'commonReturn' inCase: 120.
+
+ nilOop := objectMemory getNilObj. "keep in a register"
+ thisCntx := activeContext.
+ localCntx := localReturnContext.
+ localVal := localReturnValue.
+
+ "make sure we can return to the given context"
+ ((localCntx = nilOop) or:
+ [(objectMemory fetchPointer: InstructionPointerIndex ofObject: localCntx) = nilOop]) ifTrue: [
+ "error: sender's instruction pointer or context is nil; cannot return"
+ ^self internalCannotReturn: localVal].
+
+ "If this return is not to our immediate predecessor (i.e. from a method to its sender, or from a block to its caller), scan the stack for the first unwind marked context and inform this context and let it deal with it. This provides a chance for ensure unwinding to occur."
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: activeContext.
+
+ "Just possibly a faster test would be to compare the homeContext and activeContext - they are of course different for blocks. Thus we might be able to optimise a touch by having a different returnTo for the blockreteurn (since we know that must return to caller) and then if active ~= home we must be doing a non-local return. I think. Maybe."
+ [thisCntx = localCntx] whileFalse: [
+ thisCntx = nilOop ifTrue:[
+ "error: sender's instruction pointer or context is nil; cannot return"
+ ^self internalCannotReturn: localVal].
+ "Climb up stack towards localCntx. Break out to a send of #aboutToReturn:through: if an unwind marked context is found"
+ unwindMarked := self isUnwindMarked: thisCntx.
+ unwindMarked ifTrue:[
+ "context is marked; break out"
+ ^self internalAboutToReturn: localVal through: thisCntx].
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
+ ].
+
+ "If we get here there is no unwind to worry about. Simply terminate the stack up to the localCntx - often just the sender of the method"
+ thisCntx := activeContext.
+ [thisCntx = localCntx]
+ whileFalse:
+ ["climb up stack to localCntx"
+ contextOfCaller := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
+
+ "zap exited contexts so any future attempted use will be caught"
+ objectMemory storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.
+ reclaimableContextCount > 0 ifTrue:
+ ["try to recycle this context"
+ reclaimableContextCount := reclaimableContextCount - 1.
+ objectMemory recycleContextIfPossible: thisCntx].
+ thisCntx := contextOfCaller].
+
+ activeContext := thisCntx.
+ (objectMemory oop: thisCntx isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: thisCntx ].
+
+ self internalFetchContextRegisters: thisCntx. "updates local IP and SP"
+ self fetchNextBytecode.
+ self internalPush: localVal.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>commonSend (in category 'message sending') -----
+ commonSend
+ "Send a message, starting lookup with the receiver's class."
+ "Assume: messageSelector and argumentCount have been set, and that
+ the receiver and arguments have been pushed onto the stack,"
+ "Note: This method is inlined into the interpreter dispatch loop."
+ self sharedCodeNamed: 'commonSend' inCase: 131.
+ self internalFindNewMethod.
+ self internalExecuteNewMethod.
+ self fetchNextBytecode!
Item was added:
+ ----- Method: ContextInterpreter>>commonVariable:at:cacheIndex: (in category 'array primitive support') -----
+ commonVariable: rcvr at: index cacheIndex: atIx
+ "This code assumes the receiver has been identified at location atIx in the atCache."
+ | stSize fmt fixedFields result |
+
+ stSize := atCache at: atIx+AtCacheSize.
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
+ ifTrue:
+ [fmt := atCache at: atIx+AtCacheFmt.
+ fmt <= 4 ifTrue:
+ [fixedFields := atCache at: atIx+AtCacheFixedFields.
+ ^ objectMemory fetchPointer: index + fixedFields - 1 ofObject: rcvr].
+ fmt < 8 ifTrue: "Bitmap"
+ [result := objectMemory fetchLong32: index - 1 ofObject: rcvr.
+ result := objectMemory positive32BitIntegerFor: result.
+ ^ result].
+ fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
+ ifTrue: "String"
+ [^ self characterForAscii: (objectMemory fetchByte: index - 1 ofObject: rcvr)]
+ ifFalse: "ByteArray"
+ [^ objectMemory integerObjectOf: (objectMemory fetchByte: index - 1 ofObject: rcvr)]].
+
+ self primitiveFail!
Item was added:
+ ----- Method: ContextInterpreter>>commonVariable:at:put:cacheIndex: (in category 'array primitive support') -----
+ commonVariable: rcvr at: index put: value cacheIndex: atIx
+ "This code assumes the receiver has been identified at location atIx in the atCache."
+ | stSize fmt fixedFields valToPut |
+ <inline: true>
+
+ stSize := atCache at: atIx+AtCacheSize.
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
+ ifTrue:
+ [fmt := atCache at: atIx+AtCacheFmt.
+ fmt <= 4 ifTrue:
+ [fixedFields := atCache at: atIx+AtCacheFixedFields.
+ ^ objectMemory storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value].
+ fmt < 8 ifTrue: "Bitmap"
+ [valToPut := self positive32BitValueOf: value.
+ self successful ifTrue: [objectMemory storeLong32: index - 1 ofObject: rcvr withValue: valToPut].
+ ^ nil].
+ fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
+ ifTrue: [valToPut := self asciiOfCharacter: value.
+ self successful ifFalse: [^ nil]]
+ ifFalse: [valToPut := value].
+ (objectMemory isIntegerObject: valToPut) ifTrue:
+ [valToPut := objectMemory integerValueOf: valToPut.
+ ((valToPut >= 0) and: [valToPut <= 255]) ifFalse: [^ self primitiveFail].
+ ^ objectMemory storeByte: index - 1 ofObject: rcvr withValue: valToPut]].
+
+ self primitiveFail!
Item was added:
+ ----- Method: ContextInterpreter>>commonVariableInternal:at:cacheIndex: (in category 'array primitive support') -----
+ commonVariableInternal: rcvr at: index cacheIndex: atIx
+ "This code assumes the receiver has been identified at location atIx in the atCache."
+ | stSize fmt fixedFields result |
+ <inline: true>
+
+ stSize := atCache at: atIx+AtCacheSize.
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
+ ifTrue:
+ [fmt := atCache at: atIx+AtCacheFmt.
+ fmt <= 4 ifTrue:
+ [fixedFields := atCache at: atIx+AtCacheFixedFields.
+ ^ objectMemory fetchPointer: index + fixedFields - 1 ofObject: rcvr].
+ fmt < 8 ifTrue: "Bitmap"
+ [result := objectMemory fetchLong32: index - 1 ofObject: rcvr.
+ self externalizeIPandSP.
+ result := objectMemory positive32BitIntegerFor: result.
+ self internalizeIPandSP.
+ ^ result].
+ fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
+ ifTrue: "String"
+ [^ self characterForAscii: (objectMemory fetchByte: index - 1 ofObject: rcvr)]
+ ifFalse: "ByteArray"
+ [^ objectMemory integerObjectOf: (objectMemory fetchByte: index - 1 ofObject: rcvr)]].
+
+ self primitiveFail!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>compilerCreateActualMessage:storingArgs: (in category 'compiler support') -----
+ compilerCreateActualMessage: aMessage storingArgs: argArray
+ ^self cCode: 'compilerHooks[14](aMessage, argArray)'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerFlushCache: (in category 'compiler support') -----
+ compilerFlushCache: aCompiledMethod
+ ^self cCode: 'compilerHooks[2](aCompiledMethod)'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerFlushCacheHook: (in category 'compiler support') -----
+ compilerFlushCacheHook: aCompiledMethod
+ <inline: true>
+ compilerInitialized ifTrue: [self compilerFlushCache: aCompiledMethod]!
Item was added:
+ ----- Method: ContextInterpreter>>compilerMapFrom:to: (in category 'compiler support') -----
+ compilerMapFrom: memStart to: memEnd
+ ^self cCode: 'compilerHooks[4](memStart, memEnd)'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerMapHookFrom:to: (in category 'compiler support') -----
+ compilerMapHookFrom: memStart to: memEnd
+ <inline: true>
+ compilerInitialized ifTrue: [self compilerMapFrom: memStart to: memEnd]!
Item was added:
+ ----- Method: ContextInterpreter>>compilerMark (in category 'compiler support') -----
+ compilerMark
+ ^self cCode: 'compilerHooks[9]()'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerMarkHook (in category 'compiler support') -----
+ compilerMarkHook
+ <inline: true>
+ compilerInitialized ifTrue: [self compilerMark]!
Item was added:
+ ----- Method: ContextInterpreter>>compilerPostGC (in category 'compiler support') -----
+ compilerPostGC
+ ^self cCode: 'compilerHooks[5]()'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerPostGCHook (in category 'compiler support') -----
+ compilerPostGCHook
+ <inline: true>
+ compilerInitialized ifTrue: [self compilerPostGC]!
Item was added:
+ ----- Method: ContextInterpreter>>compilerPostSnapshot (in category 'compiler support') -----
+ compilerPostSnapshot
+ ^self cCode: 'compilerHooks[8]()'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerPostSnapshotHook (in category 'compiler support') -----
+ compilerPostSnapshotHook
+ <inline: true>
+ compilerInitialized ifTrue: [self compilerPostSnapshot]!
Item was added:
+ ----- Method: ContextInterpreter>>compilerPreGC: (in category 'compiler support') -----
+ compilerPreGC: fullGCFlag
+ ^self cCode: 'compilerHooks[3](fullGCFlag)'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerPreGCHook: (in category 'compiler support') -----
+ compilerPreGCHook: fullGCFlag
+ <inline: true>
+ compilerInitialized ifTrue: [self compilerPreGC: fullGCFlag]!
Item was added:
+ ----- Method: ContextInterpreter>>compilerPreSnapshot (in category 'compiler support') -----
+ compilerPreSnapshot
+ ^self cCode: 'compilerHooks[7]()'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerPreSnapshotHook (in category 'compiler support') -----
+ compilerPreSnapshotHook
+ <inline: true>
+ compilerInitialized ifTrue: [self compilerPreSnapshot]!
Item was added:
+ ----- Method: ContextInterpreter>>compilerProcessChange (in category 'compiler support') -----
+ compilerProcessChange
+ ^self cCode: 'compilerHooks[6]()'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerProcessChange:to: (in category 'compiler support') -----
+ compilerProcessChange: oldProc to: newProc
+ ^self cCode: 'compilerHooks[6](oldProc, newProc)'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerProcessChangeHook (in category 'compiler support') -----
+ compilerProcessChangeHook
+ <inline: true>
+ compilerInitialized ifTrue: [self compilerProcessChange]!
Item was added:
+ ----- Method: ContextInterpreter>>compilerTranslateMethod (in category 'compiler support') -----
+ compilerTranslateMethod
+ ^self cCode: 'compilerHooks[1]()'!
Item was added:
+ ----- Method: ContextInterpreter>>compilerTranslateMethodHook (in category 'compiler support') -----
+ compilerTranslateMethodHook
+ <inline: true>
+ ^compilerInitialized and: [self compilerTranslateMethod]!
Item was added:
+ ----- Method: ContextInterpreter>>constMinusOne (in category 'constants') -----
+ constMinusOne
+ ^ConstMinusOne!
Item was added:
+ ----- Method: ContextInterpreter>>context:hasSender: (in category 'contexts') -----
+ context: thisCntx hasSender: aContext
+ "Does thisCntx have aContext in its sender chain?"
+ | s nilOop |
+ <inline: true>
+ thisCntx == aContext ifTrue: [^false].
+ nilOop := objectMemory getNilObj.
+ s := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
+ [s == nilOop]
+ whileFalse: [s == aContext ifTrue: [^true].
+ s := objectMemory fetchPointer: SenderIndex ofObject: s].
+ ^false!
Item was added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>cr (in category 'debug printing') -----
+ cr
+ "For testing in Smalltalk, this method should be overridden in a subclass."
+
+ self printf: '\n'.!
Item was added:
+ ----- Method: ContextInterpreter>>createActualMessageTo: (in category 'message sending') -----
+ createActualMessageTo: aClass
+ "Bundle up the selector, arguments and lookupClass into a Message object.
+ In the process it pops the arguments off the stack, and pushes the message object.
+ This can then be presented as the argument of e.g. #doesNotUnderstand:.
+ ikp 11/20/1999 03:59 -- added hook for external runtime compilers."
+ "remap lookupClass in case GC happens during allocation"
+ | argumentArray message lookupClass |
+ objectMemory pushRemappableOop: aClass.
+ argumentArray := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount.
+ "remap argumentArray in case GC happens during allocation"
+ objectMemory pushRemappableOop: argumentArray.
+ message := objectMemory instantiateClass: (objectMemory splObj: ClassMessage) indexableSize: 0.
+ argumentArray := objectMemory popRemappableOop.
+ lookupClass := objectMemory popRemappableOop.
+ objectMemory beRootIfOld: argumentArray.
+
+ compilerInitialized
+ ifTrue: [self compilerCreateActualMessage: message storingArgs: argumentArray]
+ ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * objectMemory bytesPerWord) to: argumentArray + objectMemory baseHeaderSize.
+ self pop: argumentCount thenPush: message].
+
+ argumentCount := 1.
+ objectMemory storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector.
+ objectMemory storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray.
+ (objectMemory lastPointerOf: message) >= (MessageLookupClassIndex * objectMemory bytesPerWord + objectMemory baseHeaderSize)
+ ifTrue: ["Only store lookupClass if message has 3 fields (old images don't)"
+ objectMemory storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]!
Item was added:
+ ----- Method: ContextInterpreter>>disableCompiler (in category 'compiler support') -----
+ disableCompiler
+ compilerInitialized := false!
Item was added:
+ ----- Method: ContextInterpreter>>dispatchFunctionPointer: (in category 'message sending') -----
+ dispatchFunctionPointer: aFunctionPointer
+ <var: #aFunctionPointer declareC: 'void (*aFunctionPointer)(void)'>
+ self
+ cCode: '(aFunctionPointer)()'
+ inSmalltalk: [self error: 'my simulator should simulate me']!
Item was added:
+ ----- Method: ContextInterpreter>>dispatchFunctionPointerOn:in: (in category 'message sending') -----
+ dispatchFunctionPointerOn: primIdx in: primTable
+ "Call the primitive at index primIdx in the primitiveTable."
+
+ <var: #primTable declareC: 'void (*primTable[])(void)'>
+ ^self dispatchFunctionPointer: (primTable at: primIdx)!
Item was added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>doubleExtendedDoAnythingBytecode (in category 'send bytecodes') -----
+ doubleExtendedDoAnythingBytecode
+ "Replaces the Blue Book double-extended send [132], in which the first byte was wasted on 8 bits of argument count.
+ Here we use 3 bits for the operation sub-type (opType), and the remaining 5 bits for argument count where needed.
+ The last byte give access to 256 instVars or literals.
+ See also secondExtendedSendBytecode"
+ | byte2 byte3 opType top |
+ byte2 := self fetchByte.
+ byte3 := self fetchByte.
+ opType := byte2 >> 5.
+ opType = 0 ifTrue: [messageSelector := self literal: byte3.
+ argumentCount := byte2 bitAnd: 31.
+ ^ self normalSend].
+ opType = 1 ifTrue: [messageSelector := self literal: byte3.
+ argumentCount := byte2 bitAnd: 31.
+ ^ self superclassSend].
+ self fetchNextBytecode.
+ opType = 2 ifTrue: [^ self pushReceiverVariable: byte3].
+ opType = 3 ifTrue: [^ self pushLiteralConstant: byte3].
+ opType = 4 ifTrue: [^ self pushLiteralVariable: byte3].
+ opType = 5 ifTrue: [top := self internalStackTop.
+ ^ objectMemory storePointer: byte3 ofObject: receiver withValue: top].
+ opType = 6
+ ifTrue: [top := self internalStackTop.
+ self internalPop: 1.
+ ^ objectMemory storePointer: byte3 ofObject: receiver withValue: top].
+ opType = 7
+ ifTrue: [top := self internalStackTop.
+ ^ objectMemory storePointer: ValueIndex ofObject: (self literal: byte3) withValue: top]!
Item was added:
+ ----- Method: ContextInterpreter>>dummyReferToProxy (in category 'initialization') -----
+ dummyReferToProxy
+ <inline: false>
+ interpreterProxy := interpreterProxy!
Item was added:
+ ----- Method: ContextInterpreter>>dumpImage: (in category 'image save/restore') -----
+ dumpImage: fileName
+ "Dump the entire image out to the given file. Intended for debugging only."
+ | f dataSize result |
+ <export: true>
+ <var: #fileName type: 'char *'>
+ <var: #f type: 'sqImageFile'>
+
+ f := self cCode: 'sqImageFileOpen(fileName, "wb")'.
+ f = nil ifTrue: [^-1].
+ dataSize := objectMemory getEndOfMemory - objectMemory startOfMemory.
+ result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
+ self cCode: 'sqImageFileClose(f)'.
+ ^result
+ !
Item was added:
+ ----- Method: ContextInterpreter>>duplicateTopBytecode (in category 'stack bytecodes') -----
+ duplicateTopBytecode
+
+ self fetchNextBytecode.
+ self internalPush: self internalStackTop.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>enableCompiler (in category 'compiler support') -----
+ enableCompiler
+ "Calling this before loading the compiler will provoke a nullCompilerHook error"
+
+ compilerInitialized := true!
Item was added:
+ ----- Method: ContextInterpreter>>executeNewMethod (in category 'message sending') -----
+ executeNewMethod
+ "execute a method not found in the mCache - which means that
+ primitiveIndex must be manually set. Used by primitiveClosureValue & primitiveExecuteMethod, where no lookup is previously done"
+ primitiveIndex > 0
+ ifTrue: [self primitiveResponse.
+ self successful ifTrue: [^ nil]].
+ "if not primitive, or primitive failed, activate the method"
+ self activateNewMethod.
+ "check for possible interrupts at each real send"
+ self quickCheckForInterrupts!
Item was added:
+ ----- Method: ContextInterpreter>>executeNewMethodFromCache (in category 'message sending') -----
+ executeNewMethodFromCache
+ "execute a method found in the mCache - which means that
+ primitiveIndex & primitiveFunctionPointer are already set. Any sender
+ needs to have previously sent findMethodInClass: or equivalent"
+ | nArgs delta |
+ primitiveIndex > 0
+ ifTrue: [DoBalanceChecks ifTrue: ["check stack balance"
+ nArgs := argumentCount.
+ delta := stackPointer - activeContext].
+ self initPrimCall.
+ self dispatchFunctionPointer: primitiveFunctionPointer.
+ "branch direct to prim function from address stored in mcache"
+ DoBalanceChecks
+ ifTrue: [(self balancedStack: delta afterPrimitive: primitiveIndex withArgs: nArgs)
+ ifFalse: [self printUnbalancedStack: primitiveIndex]].
+ self successful ifTrue: [^ nil]].
+ "if not primitive, or primitive failed, activate the method"
+ self activateNewMethod.
+ "check for possible interrupts at each real send"
+ self quickCheckForInterrupts!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>extendedStoreAndPopBytecode (in category 'stack bytecodes') -----
+ extendedStoreAndPopBytecode
+
+ self extendedStoreBytecode.
+ self internalPop: 1.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>extendedStoreBytecode (in category 'stack bytecodes') -----
+ extendedStoreBytecode
+ | descriptor variableType variableIndex association |
+ <inline: true>
+ descriptor := self fetchByte.
+ self fetchNextBytecode.
+ variableType := descriptor >> 6 bitAnd: 3.
+ variableIndex := descriptor bitAnd: 63.
+ variableType = 0
+ ifTrue: [^ objectMemory storePointer: variableIndex ofObject: receiver withValue: self internalStackTop].
+ variableType = 1
+ ifTrue: [^ objectMemory storePointerUnchecked: variableIndex + TempFrameStart ofObject: localHomeContext withValue: self internalStackTop].
+ variableType = 2
+ ifTrue: [self error: 'illegal store'].
+ variableType = 3
+ ifTrue: [association := self literal: variableIndex.
+ ^ objectMemory storePointer: ValueIndex ofObject: association withValue: self internalStackTop]!
Item was added:
+ ----- Method: ContextInterpreter>>externalizeIPandSP (in category 'utilities') -----
+ externalizeIPandSP
+ "Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop."
+
+ instructionPointer := objectMemory oopForPointer: localIP.
+ stackPointer := objectMemory oopForPointer: localSP.
+ theHomeContext := localHomeContext.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>fetchArray:ofObject: (in category 'utilities') -----
+ fetchArray: fieldIndex ofObject: objectPointer
+ "Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
+ "Note: May be called by translated primitive code."
+
+ | arrayOop |
+ <returnTypeC: 'void *'>
+ arrayOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
+ ^ self arrayValueOf: arrayOop
+ !
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>fetchContextRegisters: (in category 'contexts') -----
+ fetchContextRegisters: activeCntx
+ "Note: internalFetchContextRegisters: should track changes to this method."
+ | tmp |
+ <inline: true>
+ tmp := objectMemory fetchPointer: MethodIndex ofObject: activeCntx.
+ (objectMemory isIntegerObject: tmp)
+ ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
+ tmp := objectMemory fetchPointer: HomeIndex ofObject: activeCntx.
+ (objectMemory oop: tmp isLessThan: objectMemory getYoungStart) ifTrue: [objectMemory beRootIfOld: tmp]]
+ ifFalse: ["otherwise, it is a method context and is its own home context "
+ tmp := activeCntx].
+ theHomeContext := tmp.
+ receiver := objectMemory fetchPointer: ReceiverIndex ofObject: tmp.
+ method := objectMemory fetchPointer: MethodIndex ofObject: tmp.
+
+ "the instruction pointer is a pointer variable equal to
+ method oop + ip + objectMemory baseHeaderSize
+ -1 for 0-based addressing of fetchByte
+ -1 because it gets incremented BEFORE fetching currentByte "
+ tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ instructionPointer := method + tmp + objectMemory baseHeaderSize - 2.
+
+ "the stack pointer is a pointer variable also..."
+ tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ stackPointer := activeCntx + objectMemory baseHeaderSize + (TempFrameStart + tmp - 1 * objectMemory bytesPerWord)!
Item was added:
+ ----- Method: ContextInterpreter>>fetchFloat:ofObject: (in category 'utilities') -----
+ fetchFloat: fieldIndex ofObject: objectPointer
+ "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
+ "Note: May be called by translated primitive code."
+
+ | floatOop |
+ <returnTypeC: 'double'>
+ floatOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
+ ^ self floatValueOf: floatOop!
Item was added:
+ ----- Method: ContextInterpreter>>fetchInteger:ofObject: (in category 'utilities') -----
+ fetchInteger: fieldIndex ofObject: objectPointer
+ "Note: May be called by translated primitive code."
+
+ | intOop |
+ <inline: false>
+ intOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
+ ^self checkedIntegerValueOf: intOop!
Item was added:
+ ----- Method: ContextInterpreter>>fetchIntegerOrTruncFloat:ofObject: (in category 'utilities') -----
+ fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
+ "Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
+ "Note: May be called by translated primitive code."
+
+ | intOrFloat floatVal frac trunc |
+ <inline: false>
+ <var: #floatVal type: 'double '>
+ <var: #frac type: 'double '>
+ <var: #trunc type: 'double '>
+
+ intOrFloat := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
+ (objectMemory isIntegerObject: intOrFloat) ifTrue: [^ objectMemory integerValueOf: intOrFloat].
+ self assertClassOf: intOrFloat is: (objectMemory splObj: ClassFloat).
+ self successful ifTrue: [
+ self cCode: '' inSmalltalk: [floatVal := Float new: 2].
+ self fetchFloatAt: intOrFloat + objectMemory baseHeaderSize into: floatVal.
+ self cCode: 'frac = modf(floatVal, &trunc)'.
+ "the following range check is for C ints, with range -2^31..2^31-1"
+ self flag: #Dan. "The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
+ self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.].
+ self successful
+ ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]]
+ ifFalse: [^ 0].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>fetchNextBytecode (in category 'interpreter shell') -----
+ fetchNextBytecode
+ "This method fetches the next instruction (bytecode). Each bytecode method is responsible for fetching the next bytecode, preferably as early as possible to allow the memory system time to process the request before the next dispatch."
+
+ currentBytecode := self fetchByte.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>fetchStackPointerOf: (in category 'contexts') -----
+ fetchStackPointerOf: aContext
+ "Return the stackPointer of a Context or BlockContext."
+ | sp |
+ <inline: true>
+ sp := objectMemory fetchPointer: StackPointerIndex ofObject: aContext.
+ (objectMemory isIntegerObject: sp) ifFalse: [^0].
+ ^objectMemory integerValueOf: sp!
Item was added:
+ ----- Method: ContextInterpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
+ findClassOfMethod: meth forReceiver: rcvr
+
+ | currClass classDict classDictSize methodArray i done |
+ currClass := objectMemory fetchClassOf: rcvr.
+ done := false.
+ [done] whileFalse: [
+ classDict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currClass.
+ classDictSize := objectMemory fetchWordLengthOf: classDict.
+ methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
+ i := 0.
+ [i < (classDictSize - SelectorStart)] whileTrue: [
+ meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
+ i := i + 1.
+ ].
+ currClass := objectMemory fetchPointer: SuperclassIndex ofObject: currClass.
+ done := currClass = objectMemory getNilObj.
+ ].
+ ^objectMemory fetchClassOf: rcvr "method not found in superclass chain"!
Item was added:
+ ----- Method: ContextInterpreter>>findNewMethodInClass: (in category 'message sending') -----
+ findNewMethodInClass: class
+ "Find the compiled method to be run when the current
+ messageSelector is sent to the given class, setting the values
+ of 'newMethod' and 'primitiveIndex'."
+ | ok |
+ <inline: false>
+ ok := self lookupInMethodCacheSel: messageSelector class: class.
+ ok
+ ifFalse: ["entry was not found in the cache; look it up the hard way "
+ self lookupMethodInClass: class.
+ lkupClass := class.
+ self addNewMethodToCache]!
Item was added:
+ ----- Method: ContextInterpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') -----
+ findSelectorOfMethod: meth forReceiver: rcvr
+
+ | currClass done classDict classDictSize methodArray i |
+ currClass := objectMemory fetchClassOf: rcvr.
+ done := false.
+ [done] whileFalse: [
+ classDict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currClass.
+ classDictSize := objectMemory fetchWordLengthOf: classDict.
+ methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
+ i := 0.
+ [i <= (classDictSize - SelectorStart)] whileTrue: [
+ meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [
+ ^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
+ ].
+ i := i + 1.
+ ].
+ currClass := objectMemory fetchPointer: SuperclassIndex ofObject: currClass.
+ done := currClass = objectMemory getNilObj.
+ ].
+ ^ objectMemory getNilObj "method not found in superclass chain"!
Item was added:
+ ----- Method: ContextInterpreter>>floatObjectOf: (in category 'object format') -----
+ floatObjectOf: aFloat
+ | newFloatObj |
+ <var: #aFloat type: 'double '>
+ self flag: #Dan.
+ newFloatObj := objectMemory instantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + objectMemory baseHeaderSize.
+ self storeFloatAt: newFloatObj + objectMemory baseHeaderSize from: aFloat.
+ ^ newFloatObj.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>floatValueOf: (in category 'utilities') -----
+ floatValueOf: oop
+ "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
+ "Note: May be called by translated primitive code."
+
+ | result |
+ <returnTypeC: 'double'>
+ <var: #result type: 'double '>
+ self flag: #Dan. "None of the float stuff has been converted for 64 bits"
+ self assertClassOf: oop is: (objectMemory splObj: ClassFloat).
+ self successful
+ ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: oop + objectMemory baseHeaderSize into: result]
+ ifFalse: [result := 0.0].
+ ^ result!
Item was added:
+ ----- Method: ContextInterpreter>>flushAtCache (in category 'method lookup cache') -----
+ flushAtCache
+ "Flush the at cache. The method cache is flushed on every programming change and garbage collect."
+
+ 1 to: AtCacheTotalSize do: [ :i | atCache at: i put: 0 ]
+ !
Item was added:
+ ----- Method: ContextInterpreter>>flushExternalPrimitiveOf: (in category 'plugin primitive support') -----
+ flushExternalPrimitiveOf: methodPtr
+ "methodPtr is a CompiledMethod containing an external primitive. Flush the function address and session ID of the CM"
+ | lit |
+ (self literalCountOf: methodPtr) > 0 ifFalse:[^nil]. "Something's broken"
+ lit := self literal: 0 ofMethod: methodPtr.
+ ((objectMemory isArray: lit) and:[(objectMemory lengthOf: lit) = 4])
+ ifFalse:[^nil]. "Something's broken"
+ "ConstZero is a known SmallInt so no root check needed"
+ objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
+ objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>flushExternalPrimitiveTable (in category 'plugin primitive support') -----
+ flushExternalPrimitiveTable
+ "Flush the external primitive table"
+ 0 to: MaxExternalPrimitiveTableSize-1 do:[:i|
+ externalPrimitiveTable at: i put: 0].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>flushExternalPrimitives (in category 'plugin primitive support') -----
+ flushExternalPrimitives
+ "Flush the references to external functions from plugin
+ primitives. This will force a reload of those primitives when
+ accessed next.
+ Note: We must flush the method cache here so that any
+ failed primitives are looked up again."
+ | oop primIdx |
+ oop := objectMemory firstObject.
+ [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory]
+ whileTrue: [(objectMemory isFreeObject: oop)
+ ifFalse: [(objectMemory isCompiledMethod: oop)
+ ifTrue: ["This is a compiled method"
+ primIdx := self primitiveIndexOf: oop.
+ primIdx = PrimitiveExternalCallIndex
+ ifTrue: ["It's primitiveExternalCall"
+ self flushExternalPrimitiveOf: oop]]].
+ oop := objectMemory objectAfter: oop].
+ self flushMethodCache.
+ self flushExternalPrimitiveTable!
Item was added:
+ ----- Method: ContextInterpreter>>flushMethodCache (in category 'method lookup cache') -----
+ flushMethodCache
+ "Flush the method cache. The method cache is flushed on every programming change and garbage collect."
+
+ 1 to: MethodCacheSize do: [ :i | methodCache at: i put: 0 ].
+ self flushAtCache!
Item was added:
+ ----- Method: ContextInterpreter>>flushMethodCacheFrom:to: (in category 'method lookup cache') -----
+ flushMethodCacheFrom: memStart to: memEnd
+ "Flush entries in the method cache only if the oop address is within the given memory range.
+ This reduces overagressive cache clearing. Note the AtCache is fully flushed, 70% of the time
+ cache entries live in newspace, new objects die young"
+ | probe |
+ probe := 0.
+ 1 to: MethodCacheEntries do: [:i |
+ (methodCache at: probe + MethodCacheSelector) = 0
+ ifFalse: [(((((objectMemory oop: (methodCache at: probe + MethodCacheSelector) isGreaterThanOrEqualTo: memStart)
+ and: [objectMemory oop: (methodCache at: probe + MethodCacheSelector) isLessThan: memEnd])
+ or: [(objectMemory oop: (methodCache at: probe + MethodCacheClass) isGreaterThanOrEqualTo: memStart)
+ and: [objectMemory oop: (methodCache at: probe + MethodCacheClass) isLessThan: memEnd]])
+ or: [(objectMemory oop: (methodCache at: probe + MethodCacheMethod) isGreaterThanOrEqualTo: memStart)
+ and: [objectMemory oop: (methodCache at: probe + MethodCacheMethod) isLessThan: memEnd]])
+ or: [(objectMemory oop: (methodCache at: probe + MethodCacheNative) isGreaterThanOrEqualTo: memStart)
+ and: [objectMemory oop: (methodCache at: probe + MethodCacheNative) isLessThan: memEnd]])
+ ifTrue: [methodCache at: probe + MethodCacheSelector put: 0]].
+ probe := probe + MethodCacheEntrySize].
+ 1 to: AtCacheTotalSize do: [:i | atCache at: i put: 0]!
Item was added:
+ ----- Method: ContextInterpreter>>forceInterruptCheck (in category 'process primitive support') -----
+ forceInterruptCheck
+ "force an interrupt check ASAP - setting interruptCheckCounter to a large -ve number is used as a flag to skip messing with the feedback mechanism and nextPollTick resetting makes sure that ioProcess gets called as near immediately as we can manage"
+ interruptCheckCounter := -1000.
+ nextPollTick := 0!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>functionPointerFor:inClass: (in category 'method lookup cache') -----
+ functionPointerFor: primIdx inClass: theClass
+ "Find an actual function pointer for this primitiveIndex. This is an
+ opportunity to specialise the prim for the relevant class (format for
+ example). Default for now is simply the entry in the base primitiveTable."
+
+ <returnTypeC: 'void *'>
+ ^primitiveTable at: primIdx!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>getFullScreenFlag (in category 'plugin primitive support') -----
+ getFullScreenFlag
+ ^fullScreenFlag!
Item was added:
+ ----- Method: ContextInterpreter>>getInterruptCheckCounter (in category 'plugin primitive support') -----
+ getInterruptCheckCounter
+ ^interruptCheckCounter!
Item was added:
+ ----- Method: ContextInterpreter>>getInterruptKeycode (in category 'plugin primitive support') -----
+ getInterruptKeycode
+ ^interruptKeycode!
Item was added:
+ ----- Method: ContextInterpreter>>getInterruptPending (in category 'plugin primitive support') -----
+ getInterruptPending
+ ^interruptPending!
Item was added:
+ ----- Method: ContextInterpreter>>getLongFromFile:swap: (in category 'image save/restore') -----
+ getLongFromFile: aFile swap: swapFlag
+ "Answer the next word read from aFile, byte-swapped according to the swapFlag."
+
+ | w |
+ <var: #aFile type: 'sqImageFile '>
+ w := 0.
+ self cCode: 'sqImageFileRead(&w, sizeof(w), 1, aFile)'
+ inSmalltalk: [w := self nextLongFrom: aFile].
+ swapFlag
+ ifTrue: [^ objectMemory byteSwapped: w]
+ ifFalse: [^ w].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>getNextWakeupTick (in category 'plugin primitive support') -----
+ getNextWakeupTick
+ ^nextWakeupTick!
Item was added:
+ ----- Method: ContextInterpreter>>getSavedWindowSize (in category 'plugin primitive support') -----
+ getSavedWindowSize
+ ^savedWindowSize!
Item was added:
+ ----- Method: ContextInterpreter>>getStackPointer (in category 'contexts') -----
+ getStackPointer
+ "For Newsqueak FFI"
+ <export: true>
+ ^stackPointer!
Item was added:
+ ----- Method: ContextInterpreter>>getThisSessionID (in category 'plugin support') -----
+ getThisSessionID
+ "return the global session ID value"
+ <inline: false>
+ ^globalSessionID!
Item was added:
+ ----- Method: ContextInterpreter>>headerOf: (in category 'compiled methods') -----
+ headerOf: methodPointer
+ ^objectMemory fetchPointer: HeaderIndex ofObject: methodPointer!
Item was added:
+ ----- Method: ContextInterpreter>>imageFormatBackwardCompatibilityVersion (in category 'image save/restore') -----
+ imageFormatBackwardCompatibilityVersion
+ "This VM is backwards-compatible with the immediately preceeding pre-closure version, and will allow loading images (or image segments) of that version."
+
+ objectMemory bytesPerWord == 4
+ ifTrue: [^6502]
+ ifFalse: [^68000]!
Item was added:
+ ----- Method: ContextInterpreter>>imageFormatVersion (in category 'image save/restore') -----
+ imageFormatVersion
+ "Return a magic constant that changes when the image format changes. Since the image reading code uses
+ this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."
+
+ "See Interpreter class>>declareCVarsIn: and Interpreter>>pushClosureCopyCopiedValuesBytecode
+ for the initialization of imageFormatVersionNumber"
+ ^imageFormatVersionNumber!
Item was added:
+ ----- Method: ContextInterpreter>>includesBehavior:ThatOf: (in category 'plugin primitive support') -----
+ includesBehavior: aClass ThatOf: aSuperclass
+ "Return the equivalent of
+ aClass includesBehavior: aSuperclass.
+ Note: written for efficiency and better inlining (only 1 temp)"
+ | theClass |
+ <inline: true>
+ aSuperclass = objectMemory getNilObj ifTrue:
+ [^false].
+ theClass := aClass.
+ [theClass = aSuperclass ifTrue:
+ [^true].
+ theClass ~= objectMemory getNilObj] whileTrue:
+ [theClass := self superclassOf: theClass].
+ ^false!
Item was added:
+ ----- Method: ContextInterpreter>>initCompilerHooks (in category 'compiler support') -----
+ initCompilerHooks
+ "Initialize hooks for the 'null compiler'"
+
+ self cCode: 'compilerHooks[1]= nullCompilerHook'.
+ self cCode: 'compilerHooks[2]= nullCompilerHook'.
+ self cCode: 'compilerHooks[3]= nullCompilerHook'.
+ self cCode: 'compilerHooks[4]= nullCompilerHook'.
+ self cCode: 'compilerHooks[5]= nullCompilerHook'.
+ self cCode: 'compilerHooks[6]= nullCompilerHook'.
+ self cCode: 'compilerHooks[7]= nullCompilerHook'.
+ self cCode: 'compilerHooks[8]= nullCompilerHook'.
+ self cCode: 'compilerHooks[9]= nullCompilerHook'.
+ self cCode: 'compilerHooks[10]= nullCompilerHook'.
+ self cCode: 'compilerHooks[11]= nullCompilerHook'.
+ self cCode: 'compilerHooks[12]= nullCompilerHook'.
+ self cCode: 'compilerHooks[13]= nullCompilerHook'.
+ self cCode: 'compilerHooks[14]= nullCompilerHook'.
+
+ compilerInitialized := false!
Item was added:
+ ----- Method: ContextInterpreter>>initialCleanup (in category 'initialization') -----
+ initialCleanup
+ "Images written by VMs earlier than 3.6/3.7 will wrongly have the root bit set on the active context. Besides clearing the root bit, we treat this as a marker that these images also lack a cleanup of external primitives (which has been introduced at the same time when the root bit problem was fixed). In this case, we merely flush them from here."
+
+ ((objectMemory longAt: activeContext) bitAnd: objectMemory rootBit) = 0 ifTrue:[^nil]. "root bit is clean"
+ "Clean root bit of activeContext"
+ objectMemory longAt: activeContext put: ((objectMemory longAt: activeContext) bitAnd: objectMemory allButRootBit).
+ "Clean external primitives"
+ self flushExternalPrimitives.!
Item was added:
+ ----- Method: ContextInterpreter>>initialImageFormatVersion (in category 'image save/restore') -----
+ initialImageFormatVersion
+ "This is the image format version that was saved to in the previous image snapshot.
+ The interpreter checks this value at image load time to determine if it is able to load
+ and run the image file. When the image is next saved, it will be saved using the current
+ imageFormatVersion, which may be different from imageFormatInitialVersion.
+ Selector name chosen to avoid conflict with variable declaration in generated code."
+ ^imageFormatInitialVersion!
Item was added:
+ ----- Method: ContextInterpreter>>initializeImageFormatVersionIfNeeded (in category 'image save/restore') -----
+ initializeImageFormatVersionIfNeeded
+ "Set the imageFormatVersionNumber to a default value for this word
+ size. Normally this will have been set at image load time, but set it to
+ a reasonable default if this has not been done."
+
+ <inline: false>
+ imageFormatVersionNumber = 0
+ ifTrue: [objectMemory bytesPerWord == 8
+ ifFalse: [imageFormatVersionNumber := 6502]
+ ifTrue: [imageFormatVersionNumber := 68000]]
+ !
Item was added:
+ ----- Method: ContextInterpreter>>initializeInterpreter: (in category 'initialization') -----
+ initializeInterpreter: bytesToShift
+ "Initialize Interpreter state before starting execution of a new image."
+ interpreterProxy := self sqGetInterpreterProxy.
+ self dummyReferToProxy.
+ objectMemory initializeObjectMemory: bytesToShift.
+ self initCompilerHooks.
+ activeContext := objectMemory getNilObj.
+ theHomeContext := objectMemory getNilObj.
+ method := objectMemory getNilObj.
+ receiver := objectMemory getNilObj.
+ messageSelector := objectMemory getNilObj.
+ newMethod := objectMemory getNilObj.
+ methodClass := objectMemory getNilObj.
+ lkupClass := objectMemory getNilObj.
+ receiverClass := objectMemory getNilObj.
+ newNativeMethod := objectMemory getNilObj.
+ self flushMethodCache.
+ self loadInitialContext.
+ self initialCleanup.
+ interruptCheckCounter := 0.
+ interruptCheckCounterFeedBackReset := 1000.
+ interruptChecksEveryNms := 1.
+ nextPollTick := 0.
+ nextWakeupTick := 0.
+ lastTick := 0.
+ interruptKeycode := 2094. "cmd-. as used for Mac but no other OS"
+ interruptPending := false.
+ semaphoresUseBufferA := true.
+ semaphoresToSignalCountA := 0.
+ semaphoresToSignalCountB := 0.
+ deferDisplayUpdates := false.
+ pendingFinalizationSignals := 0.
+ globalSessionID := 0.
+ [globalSessionID = 0]
+ whileTrue: [globalSessionID := self
+ cCode: 'time(NULL) + ioMSecs()'
+ inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]].
+ jmpDepth := 0.
+ jmpMax := MaxJumpBuf. "xxxx: Must match the definition of jmpBuf and suspendedCallbacks"
+ !
Item was added:
+ ----- Method: ContextInterpreter>>install:inAtCache:at:string: (in category 'indexing primitives') -----
+ install: rcvr inAtCache: cache at: atIx string: stringy
+ "Install the oop of this object in the given cache (at or atPut), along with
+ its size, format and fixedSize"
+ | hdr fmt totalLength fixedFields |
+ <var: #cache type: 'sqInt *'>
+
+ hdr := objectMemory baseHeader: rcvr.
+ fmt := (hdr >> 8) bitAnd: 16rF.
+ (fmt = 3 and: [self isContextHeader: hdr]) ifTrue:
+ ["Contexts must not be put in the atCache, since their size is not constant"
+ ^ self primitiveFail].
+ totalLength := objectMemory lengthOf: rcvr baseHeader: hdr format: fmt.
+ fixedFields := objectMemory fixedFieldsOf: rcvr format: fmt length: totalLength.
+
+ cache at: atIx+AtCacheOop put: rcvr.
+ stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16] "special flag for strings"
+ ifFalse: [cache at: atIx+AtCacheFmt put: fmt].
+ cache at: atIx+AtCacheFixedFields put: fixedFields.
+ cache at: atIx+AtCacheSize put: totalLength - fixedFields.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>internalAboutToReturn:through: (in category 'return bytecodes') -----
+ internalAboutToReturn: resultObj through: aContext
+ <inline: true>
+ self internalPush: activeContext.
+ self internalPush: resultObj.
+ self internalPush: aContext.
+ messageSelector := objectMemory splObj: SelectorAboutToReturn.
+ argumentCount := 2.
+ ^self normalSend!
Item was added:
+ ----- Method: ContextInterpreter>>internalActivateNewMethod (in category 'message sending') -----
+ internalActivateNewMethod
+ | methodHeader newContext tempCount argCount2 needsLarge where |
+ <inline: true>
+
+ methodHeader := self headerOf: newMethod.
+ needsLarge := methodHeader bitAnd: LargeContextBit.
+ (needsLarge = 0 and: [objectMemory getFreeContexts ~= objectMemory nilContext])
+ ifTrue: [newContext := objectMemory getFreeContexts.
+ objectMemory setFreeContextsAfter: newContext]
+ ifFalse: ["Slower call for large contexts or empty free list"
+ self externalizeIPandSP.
+ newContext := objectMemory allocateOrRecycleContext: needsLarge.
+ self internalizeIPandSP].
+ tempCount := (methodHeader >> 19) bitAnd: 16r3F.
+
+ "Assume: newContext will be recorded as a root if necessary by the
+ call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + objectMemory baseHeaderSize.
+ objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
+ objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord)
+ put: (objectMemory integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1)).
+ objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
+ objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
+ objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory getNilObj.
+
+ "Copy the receiver and arguments..."
+ argCount2 := argumentCount.
+ 0 to: argCount2 do:
+ [:i | objectMemory longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord) put: (self internalStackValue: argCount2-i)].
+
+ "clear remaining temps to nil in case it has been recycled"
+ methodHeader := objectMemory getNilObj. "methodHeader here used just as faster (register?) temp"
+ argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: methodHeader].
+
+ self internalPop: argCount2 + 1.
+ reclaimableContextCount := reclaimableContextCount + 1.
+ self internalNewActiveContext: newContext.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>internalCannotReturn: (in category 'return bytecodes') -----
+ internalCannotReturn: resultObj
+ <inline: true>
+ reclaimableContextCount := 0.
+ self internalPush: activeContext.
+ self internalPush: resultObj.
+ messageSelector := objectMemory splObj: SelectorCannotReturn.
+ argumentCount := 1.
+ ^ self normalSend!
Item was added:
+ ----- Method: ContextInterpreter>>internalExecuteNewMethod (in category 'message sending') -----
+ internalExecuteNewMethod
+ | localPrimIndex delta nArgs |
+ <inline: true>
+ localPrimIndex := primitiveIndex.
+ localPrimIndex > 0
+ ifTrue: [(localPrimIndex > 255
+ and: [localPrimIndex < 520])
+ ifTrue: ["Internal return instvars"
+ localPrimIndex >= 264
+ ifTrue: [^ self internalPop: 1 thenPush: (objectMemory fetchPointer: localPrimIndex - 264 ofObject: self internalStackTop)]
+ ifFalse: ["Internal return constants"
+ localPrimIndex = 256 ifTrue: [^ nil].
+ localPrimIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getTrueObj].
+ localPrimIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getFalseObj].
+ localPrimIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getNilObj].
+ ^ self internalPop: 1 thenPush: (objectMemory integerObjectOf: localPrimIndex - 261)]]
+ ifFalse: [self externalizeIPandSP.
+ "self primitiveResponse. <-replaced with manually inlined code"
+ DoBalanceChecks
+ ifTrue: ["check stack balance"
+ nArgs := argumentCount.
+ delta := stackPointer - activeContext].
+ self initPrimCall.
+ self dispatchFunctionPointer: primitiveFunctionPointer. "branch direct to prim function from address stored in mcache"
+ DoBalanceChecks
+ ifTrue: [(self balancedStack: delta afterPrimitive: localPrimIndex withArgs: nArgs)
+ ifFalse: [self printUnbalancedStack: localPrimIndex]].
+ self internalizeIPandSP.
+ self successful
+ ifTrue: [self browserPluginReturnIfNeeded.
+ ^ nil]]].
+ "if not primitive, or primitive failed, activate the method"
+ self internalActivateNewMethod.
+ "check for possible interrupts at each real send"
+ self internalQuickCheckForInterrupts!
Item was added:
+ ----- Method: ContextInterpreter>>internalFetchContextRegisters: (in category 'contexts') -----
+ internalFetchContextRegisters: activeCntx
+ "Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."
+
+ | tmp |
+ <inline: true>
+ tmp := objectMemory fetchPointer: MethodIndex ofObject: activeCntx.
+ (objectMemory isIntegerObject: tmp) ifTrue: [
+ "if the MethodIndex field is an integer, activeCntx is a block context"
+ tmp := objectMemory fetchPointer: HomeIndex ofObject: activeCntx.
+ (objectMemory oop: tmp isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: tmp ].
+ ] ifFalse: [
+ "otherwise, it is a method context and is its own home context"
+ tmp := activeCntx.
+ ].
+ localHomeContext := tmp.
+ receiver := objectMemory fetchPointer: ReceiverIndex ofObject: tmp.
+ method := objectMemory fetchPointer: MethodIndex ofObject: tmp.
+
+ "the instruction pointer is a pointer variable equal to
+ method oop + ip + objectMemory baseHeaderSize
+ -1 for 0-based addressing of fetchByte
+ -1 because it gets incremented BEFORE fetching currentByte"
+ tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ localIP := objectMemory pointerForOop: method + tmp + objectMemory baseHeaderSize - 2.
+
+ "the stack pointer is a pointer variable also..."
+ tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ localSP := objectMemory pointerForOop: activeCntx + objectMemory baseHeaderSize + ((TempFrameStart + tmp - 1) * objectMemory bytesPerWord)!
Item was added:
+ ----- Method: ContextInterpreter>>internalFindNewMethod (in category 'message sending') -----
+ internalFindNewMethod
+ "Find the compiled method to be run when the current messageSelector is sent to the class 'lkupClass', setting the values of 'newMethod' and 'primitiveIndex'."
+ | ok |
+ <inline: true>
+ ok := self lookupInMethodCacheSel: messageSelector class: lkupClass.
+ ok ifFalse: [
+ "entry was not found in the cache; look it up the hard way"
+ self externalizeIPandSP.
+ self lookupMethodInClass: lkupClass.
+ self internalizeIPandSP.
+ self addNewMethodToCache].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>internalIsImmutable: (in category 'object format') -----
+ internalIsImmutable: oop
+ <inline: true>
+ <export: true>
+ ^false.
+ "^((self baseHeader: oop) bitAnd: ImmutabilityBit) ~= 0"!
Item was added:
+ ----- Method: ContextInterpreter>>internalIsMutable: (in category 'object format') -----
+ internalIsMutable: oop
+ <inline: true>
+ <export: true>
+ ^true
+ "^((self baseHeader: oop) bitAnd: ImmutabilityBit) = 0"!
Item was added:
+ ----- Method: ContextInterpreter>>internalJustActivateNewMethod (in category 'message sending') -----
+ internalJustActivateNewMethod
+ "Activate the new method but *do not* copy receiver or arguments from activeContext."
+ | methodHeader initialIP newContext tempCount needsLarge where |
+ <inline: true>
+
+ methodHeader := self headerOf: newMethod.
+ needsLarge := methodHeader bitAnd: LargeContextBit.
+ (needsLarge = 0 and: [objectMemory getFreeContexts ~= objectMemory nilContext])
+ ifTrue: [newContext := objectMemory getFreeContexts.
+ objectMemory setFreeContextsAfter: newContext]
+ ifFalse: ["Slower call for large contexts or empty free list"
+ newContext := objectMemory allocateOrRecycleContext: needsLarge].
+ initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1.
+ tempCount := (methodHeader >> 19) bitAnd: 16r3F.
+
+ "Assume: newContext will be recorded as a root if necessary by the
+ call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + objectMemory baseHeaderSize.
+ objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
+ objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: initialIP).
+ objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
+ objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
+
+ "Set the receiver..."
+ objectMemory longAt: where + (ReceiverIndex << objectMemory shiftForWord) put: receiver.
+
+ "clear all args and temps to nil in case it has been recycled"
+ needsLarge := objectMemory getNilObj. "needsLarge here used just as faster (register?) temp"
+ ReceiverIndex + 1 to: tempCount + ReceiverIndex do:
+ [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: needsLarge].
+ reclaimableContextCount := reclaimableContextCount + 1.
+
+ activeContext := newContext.!
Item was added:
+ ----- Method: ContextInterpreter>>internalNewActiveContext: (in category 'contexts') -----
+ internalNewActiveContext: aContext
+ "The only difference between this method and newActiveContext: is that this method uses internal context registers."
+ <inline: true>
+
+ self internalStoreContextRegisters: activeContext.
+ (objectMemory oop: aContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
+ activeContext := aContext.
+ self internalFetchContextRegisters: aContext.!
Item was added:
+ ----- Method: ContextInterpreter>>internalPop: (in category 'contexts') -----
+ internalPop: nItems
+
+ localSP := localSP - (nItems * objectMemory bytesPerWord).!
Item was added:
+ ----- Method: ContextInterpreter>>internalPop:thenPush: (in category 'contexts') -----
+ internalPop: nItems thenPush: oop
+
+ objectMemory longAtPointer: (localSP := localSP - ((nItems - 1) * objectMemory bytesPerWord)) put: oop.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>internalPrimitiveValue (in category 'control primitives') -----
+ internalPrimitiveValue
+ | newContext blockArgumentCount initialIP |
+ <inline: true>
+ self sharedCodeNamed: 'commonPrimitiveValue' inCase: 201.
+ self initPrimCall.
+ newContext := self internalStackValue: argumentCount.
+ self assertClassOf: newContext is: (objectMemory splObj: ClassBlockContext).
+ blockArgumentCount := self argumentCountOfBlock: newContext.
+
+ self success: (argumentCount = blockArgumentCount and: [(objectMemory fetchPointer: CallerIndex ofObject: newContext) = objectMemory getNilObj]).
+
+ self successful
+ ifTrue: ["This code assumes argCount can only = 0 or 1"
+ argumentCount = 1
+ ifTrue: [objectMemory storePointer: TempFrameStart ofObject: newContext withValue: self internalStackTop].
+ self internalPop: argumentCount + 1.
+ "copy the initialIP value to the ip slot"
+ initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: newContext.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
+ self storeStackPointerValue: argumentCount inContext: newContext.
+ objectMemory storePointerUnchecked: CallerIndex ofObject: newContext withValue: activeContext.
+ self internalNewActiveContext: newContext]
+ ifFalse: [messageSelector := self specialSelector: 25 + argumentCount.
+ self normalSend]!
Item was added:
+ ----- Method: ContextInterpreter>>internalPush: (in category 'contexts') -----
+ internalPush: object
+
+ objectMemory longAtPointer: (localSP := localSP + objectMemory bytesPerWord) put: object.!
Item was added:
+ ----- Method: ContextInterpreter>>internalQuickCheckForInterrupts (in category 'process primitive support') -----
+ internalQuickCheckForInterrupts
+ "Internal version of quickCheckForInterrupts for use within jumps."
+
+ <inline: true>
+ ((interruptCheckCounter := interruptCheckCounter - 1) <= 0) ifTrue: [
+ self externalizeIPandSP.
+ self checkForInterrupts.
+
+ self browserPluginReturnIfNeeded.
+
+ self internalizeIPandSP].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>internalStackTop (in category 'contexts') -----
+ internalStackTop
+
+ ^ objectMemory longAtPointer: localSP!
Item was added:
+ ----- Method: ContextInterpreter>>internalStackValue: (in category 'contexts') -----
+ internalStackValue: offset
+
+ ^ objectMemory longAtPointer: localSP - (offset * objectMemory bytesPerWord)!
Item was added:
+ ----- Method: ContextInterpreter>>internalStoreContextRegisters: (in category 'contexts') -----
+ internalStoreContextRegisters: activeCntx
+ "The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."
+
+ "InstructionPointer is a pointer variable equal to
+ method oop + ip + objectMemory baseHeaderSize
+ -1 for 0-based addressing of fetchByte
+ -1 because it gets incremented BEFORE fetching currentByte"
+
+ <inline: true>
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
+ withValue: (objectMemory integerObjectOf:
+ ((objectMemory oopForPointer: localIP) + 2 - (method + objectMemory baseHeaderSize))).
+ objectMemory storePointerUnchecked: StackPointerIndex ofObject: activeCntx
+ withValue: (objectMemory integerObjectOf:
+ ((((objectMemory oopForPointer: localSP) - (activeCntx + objectMemory baseHeaderSize)) >> objectMemory shiftForWord) - TempFrameStart + 1)).
+ !
Item was added:
+ ----- Method: ContextInterpreter>>internalizeIPandSP (in category 'utilities') -----
+ internalizeIPandSP
+ "Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop."
+
+ localIP := objectMemory pointerForOop: instructionPointer.
+ localSP := objectMemory pointerForOop: stackPointer.
+ localHomeContext := theHomeContext.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>interpret (in category 'interpreter shell') -----
+ interpret
+ "This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently."
+
+ <inline: false> "should not be inlined into any senders"
+ "record entry time when running as a browser plug-in"
+ self browserPluginInitialiseIfNeeded.
+ self initializeImageFormatVersionIfNeeded.
+ self internalizeIPandSP.
+ self fetchNextBytecode.
+ [true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable].
+ localIP := localIP - 1. "undo the pre-increment of IP before returning"
+ self externalizeIPandSP.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>interpreterAllocationReserveBytes (in category 'stack interpreter support') -----
+ interpreterAllocationReserveBytes
+ "Extra allocation space in the object memory required by StackInterpreter"
+ ^ 0
+ !
Item was added:
+ ----- Method: ContextInterpreter>>interruptCheckForced (in category 'process primitive support') -----
+ interruptCheckForced
+ "was this interrupt check forced by outside code?"
+ ^interruptCheckCounter < -100!
Item was added:
+ ----- Method: ContextInterpreter>>ioFilename:fromString:ofLength:resolveAliases: (in category 'plugin support') -----
+ ioFilename: aCharBuffer fromString: aFilenameString ofLength: filenameLength resolveAliases: aBoolean
+ "the vm has to convert aFilenameString via any canonicalization and char-mapping and put the result in aCharBuffer.
+ Note the resolveAliases flag - this is an awful artefact of OSX and Apples demented alias handling. When opening a file, the flag must be true, when closing or renaming it must be false. Sigh."
+ <var: #aCharBuffer type: 'char *'>
+ <var: #aFilenameString type: 'char *'>
+ self cCode:'sqGetFilenameFromString(aCharBuffer, aFilenameString, filenameLength, aBoolean)'
+ inSmalltalk:["this doesn't translate well in Smalltalk since we know how long strings are rather than considering them terminated by a 0 char. Do the best we can"
+ aCharBuffer replaceFrom:1 to: filenameLength with: aFilenameString]!
Item was added:
+ ----- Method: ContextInterpreter>>is:KindOf: (in category 'plugin primitive support') -----
+ is: oop KindOf: className
+ "Support for external primitives."
+ | oopClass |
+ <var: #className type: 'char *'>
+ oopClass := objectMemory fetchClassOf: oop.
+ [oopClass == objectMemory getNilObj] whileFalse:[
+ (self classNameOf: oopClass Is: className) ifTrue:[^true].
+ oopClass := self superclassOf: oopClass].
+ ^false!
Item was added:
+ ----- Method: ContextInterpreter>>is:KindOfClass: (in category 'plugin primitive support') -----
+ is: oop KindOfClass: aClass
+ "Support for external primitives."
+ <api>
+ | oopClass |
+ oopClass := self fetchClassOf: oop.
+ [oopClass = objectMemory getNilObj] whileFalse:
+ [oopClass = aClass ifTrue: [^true].
+ oopClass := self superclassOf: oopClass].
+ ^false!
Item was added:
+ ----- Method: ContextInterpreter>>is:MemberOf: (in category 'plugin primitive support') -----
+ is: oop MemberOf: className
+ "Support for external primitives"
+ | oopClass |
+ <var: #className type: 'char *'>
+ oopClass := objectMemory fetchClassOf: oop.
+ ^(self classNameOf: oopClass Is: className)!
Item was added:
+ ----- Method: ContextInterpreter>>isContext: (in category 'contexts') -----
+ isContext: oop
+ <inline: true>
+ ^(objectMemory isNonIntegerObject: oop) and: [self isContextHeader: (objectMemory baseHeader: oop)]!
Item was added:
+ ----- Method: ContextInterpreter>>isContextHeader: (in category 'contexts') -----
+ isContextHeader: aHeader
+ <inline: true>
+ ^ ((aHeader >> 12) bitAnd: 16r1F) = 13 "MethodContext"
+ or: [((aHeader >> 12) bitAnd: 16r1F) = 14 "BlockContext"
+ or: [((aHeader >> 12) bitAnd: 16r1F) = 4]] "PseudoContext"!
Item was added:
+ ----- Method: ContextInterpreter>>isEmptyList: (in category 'process primitive support') -----
+ isEmptyList: aLinkedList
+
+ ^ (objectMemory fetchPointer: FirstLinkIndex ofObject: aLinkedList) = objectMemory getNilObj!
Item was added:
+ ----- Method: ContextInterpreter>>isFloatObject: (in category 'plugin primitive support') -----
+ isFloatObject: oop
+ ^(objectMemory fetchClassOf: oop) == objectMemory classFloat!
Item was added:
+ ----- Method: ContextInterpreter>>isHandlerMarked: (in category 'compiled methods') -----
+ isHandlerMarked: aContext
+ "Is this a MethodContext whose meth has a primitive number of 199?"
+ | header meth pIndex |
+ "NB: the use of a primitive number for marking the method is pretty grungy, but it is simple to use for a test sytem, not too expensive and we don't actually have the two spare method header bits we need. We can probably obtain them when the method format is changed.
+ NB 2: actually, the jitter will probably implement the prim to actually mark the volatile frame by changing the return function pointer."
+ <inline: true>
+ header := objectMemory baseHeader: aContext.
+ (self isMethodContextHeader: header) ifFalse: [^false].
+ meth := objectMemory fetchPointer: MethodIndex ofObject: aContext.
+ pIndex := self primitiveIndexOf: meth.
+ ^pIndex == 199
+ !
Item was added:
+ ----- Method: ContextInterpreter>>isIndexable: (in category 'object format') -----
+ isIndexable: oop
+ ^(objectMemory formatOf: oop) >= 2!
Item was added:
+ ----- Method: ContextInterpreter>>isMarriedOrWidowedContext: (in category 'stack interpreter support') -----
+ isMarriedOrWidowedContext: aContext
+ ^false!
Item was added:
+ ----- Method: ContextInterpreter>>isMethodContextHeader: (in category 'contexts') -----
+ isMethodContextHeader: aHeader
+ <inline: true>
+ ^ ((aHeader >> 12) bitAnd: 16r1F) = 14!
Item was added:
+ ----- Method: ContextInterpreter>>isUnwindMarked: (in category 'compiled methods') -----
+ isUnwindMarked: aContext
+ "Is this a MethodContext whose meth has a primitive number of 198?"
+ | header meth pIndex |
+ "NB: the use of a primitive number for marking the method is pretty grungy, but it is simple to use for a test sytem, not too expensive and we don't actually have the two spare method header bits we need. We can probably obtain them when the method format is changed
+ NB 2: actually, the jitter will probably implement the prim to actually mark the volatile frame by changing the return function pointer."
+ <inline: true>
+ header := objectMemory baseHeader: aContext.
+ (self isMethodContextHeader: header) ifFalse: [^false].
+ meth := objectMemory fetchPointer: MethodIndex ofObject: aContext.
+ pIndex := self primitiveIndexOf: meth.
+ ^pIndex == 198
+ !
Item was added:
+ ----- Method: ContextInterpreter>>jump: (in category 'jump bytecodes') -----
+ jump: offset
+
+ localIP := localIP + offset + 1.
+ currentBytecode := objectMemory byteAtPointer: localIP.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>jumplfFalseBy: (in category 'jump bytecodes') -----
+ jumplfFalseBy: offset
+ | boolean |
+ boolean := self internalStackTop.
+ boolean = objectMemory getFalseObj
+ ifTrue: [self jump: offset]
+ ifFalse: [boolean = objectMemory getTrueObj
+ ifFalse: [messageSelector := objectMemory splObj: SelectorMustBeBoolean.
+ argumentCount := 0.
+ ^ self normalSend].
+ self fetchNextBytecode].
+ self internalPop: 1!
Item was added:
+ ----- Method: ContextInterpreter>>jumplfTrueBy: (in category 'jump bytecodes') -----
+ jumplfTrueBy: offset
+ | boolean |
+ boolean := self internalStackTop.
+ boolean = objectMemory getTrueObj
+ ifTrue: [self jump: offset]
+ ifFalse: [boolean = objectMemory getFalseObj
+ ifFalse: [messageSelector := objectMemory splObj: SelectorMustBeBoolean.
+ argumentCount := 0.
+ ^ self normalSend].
+ self fetchNextBytecode].
+ self internalPop: 1!
Item was added:
+ ----- Method: ContextInterpreter>>literal: (in category 'compiled methods') -----
+ literal: offset
+ ^self literal: offset ofMethod: method!
Item was added:
+ ----- Method: ContextInterpreter>>literal:ofMethod: (in category 'compiled methods') -----
+ literal: offset ofMethod: methodPointer
+
+ ^ objectMemory fetchPointer: offset + LiteralStart ofObject: methodPointer
+ !
Item was added:
+ ----- Method: ContextInterpreter>>literalCountOf: (in category 'compiled methods') -----
+ literalCountOf: methodPointer
+ ^self literalCountOfHeader: (self headerOf: methodPointer)!
Item was added:
+ ----- Method: ContextInterpreter>>literalCountOfHeader: (in category 'compiled methods') -----
+ literalCountOfHeader: headerPointer
+ ^ (headerPointer >> 10) bitAnd: 16rFF!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
+ loadFloatOrIntFrom: floatOrInt
+ "If floatOrInt is an integer, then convert it to a C double float and return it.
+ If it is a Float, then load its value and return it.
+ Otherwise fail -- ie return with primFailCode set."
+
+ <inline: true>
+ <returnTypeC: 'double'>
+
+ (objectMemory isIntegerObject: floatOrInt) ifTrue:
+ [^ (objectMemory integerValueOf: floatOrInt) asFloat].
+ (objectMemory fetchClassOfNonInt: floatOrInt) = (objectMemory splObj: ClassFloat)
+ ifTrue: [^ self floatValueOf: floatOrInt].
+ self primitiveFail!
Item was added:
+ ----- Method: ContextInterpreter>>loadInitialContext (in category 'initialization') -----
+ loadInitialContext
+
+ | sched proc |
+ sched := objectMemory fetchPointer: ValueIndex ofObject: (objectMemory splObj: SchedulerAssociation).
+ proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
+ activeContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
+ (objectMemory oop: activeContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: activeContext ].
+ self fetchContextRegisters: activeContext.
+ reclaimableContextCount := 0.!
Item was added:
+ ----- Method: ContextInterpreter>>longJumpIfFalse (in category 'jump bytecodes') -----
+ longJumpIfFalse
+
+ self jumplfFalseBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.!
Item was added:
+ ----- Method: ContextInterpreter>>longJumpIfTrue (in category 'jump bytecodes') -----
+ longJumpIfTrue
+
+ self jumplfTrueBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.!
Item was added:
+ ----- Method: ContextInterpreter>>longUnconditionalJump (in category 'jump bytecodes') -----
+ longUnconditionalJump
+
+ | offset |
+ offset := (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte.
+ localIP := localIP + offset.
+ offset < 0 ifTrue: [
+ "backward jump means we're in a loop; check for possible interrupts"
+ self internalQuickCheckForInterrupts.
+ ].
+ self fetchNextBytecode
+ !
Item was added:
+ ----- Method: ContextInterpreter>>lookupInMethodCacheSel:class: (in category 'method lookup cache') -----
+ lookupInMethodCacheSel: selector class: class
+ "This method implements a simple method lookup cache. If an entry for the given selector and class is found in the cache, set the values of 'newMethod' and 'primitiveIndex' and return true. Otherwise, return false."
+ "About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe, introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up."
+ "WARNING: Since the hash computation is based on the object addresses of the class and selector, we must rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating the addresses of the objects in the cache."
+
+ | hash probe |
+ <inline: true>
+ hash := selector bitXor: class. "shift drops two low-order zeros from addresses"
+
+ probe := hash bitAnd: MethodCacheMask. "first probe"
+ (((methodCache at: probe + MethodCacheSelector) = selector) and:
+ [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
+ [newMethod := methodCache at: probe + MethodCacheMethod.
+ primitiveIndex := methodCache at: probe + MethodCachePrim.
+ newNativeMethod := methodCache at: probe + MethodCacheNative.
+ primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void (*)(void)'.
+ ^ true "found entry in cache; done"].
+
+ probe := (hash >> 1) bitAnd: MethodCacheMask. "second probe"
+ (((methodCache at: probe + MethodCacheSelector) = selector) and:
+ [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
+ [newMethod := methodCache at: probe + MethodCacheMethod.
+ primitiveIndex := methodCache at: probe + MethodCachePrim.
+ newNativeMethod := methodCache at: probe + MethodCacheNative.
+ primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void (*)(void)'.
+ ^ true "found entry in cache; done"].
+
+ probe := (hash >> 2) bitAnd: MethodCacheMask.
+ (((methodCache at: probe + MethodCacheSelector) = selector) and:
+ [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
+ [newMethod := methodCache at: probe + MethodCacheMethod.
+ primitiveIndex := methodCache at: probe + MethodCachePrim.
+ newNativeMethod := methodCache at: probe + MethodCacheNative.
+ primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void (*)(void)'.
+ ^ true "found entry in cache; done"].
+
+ ^ false
+ !
Item was added:
+ ----- Method: ContextInterpreter>>lookupMethodInClass: (in category 'message sending') -----
+ lookupMethodInClass: class
+ | currentClass dictionary found rclass |
+ <inline: false>
+
+ currentClass := class.
+ [currentClass ~= objectMemory getNilObj]
+ whileTrue:
+ [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
+ dictionary = objectMemory getNilObj ifTrue:
+ ["MethodDict pointer is nil (hopefully due a swapped out stub)
+ -- raise exception #cannotInterpret:."
+ objectMemory pushRemappableOop: currentClass. "may cause GC!!"
+ self createActualMessageTo: class.
+ currentClass := objectMemory popRemappableOop.
+ messageSelector := objectMemory 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 = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue:
+ [self error: 'Recursive not understood error encountered'].
+
+ "Cound not find a normal message -- raise exception #doesNotUnderstand:"
+ objectMemory pushRemappableOop: class. "may cause GC!!"
+ self createActualMessageTo: class.
+ rclass := objectMemory popRemappableOop.
+ messageSelector := objectMemory splObj: SelectorDoesNotUnderstand.
+ ^ self lookupMethodInClass: rclass!
Item was added:
+ ----- Method: ContextInterpreter>>lookupMethodInDictionary: (in category 'message sending') -----
+ lookupMethodInDictionary: dictionary
+ "This method lookup tolerates integers as Dictionary keys to
+ support execution of images in which Symbols have been
+ compacted out"
+ | length index mask wrapAround nextSelector methodArray |
+ <inline: true>
+ length := objectMemory fetchWordLengthOf: dictionary.
+ mask := length - SelectorStart - 1.
+ (objectMemory isIntegerObject: messageSelector)
+ ifTrue: [index := (mask bitAnd: (objectMemory integerValueOf: messageSelector)) + SelectorStart]
+ ifFalse: [index := (mask bitAnd: (objectMemory hashBitsOf: messageSelector)) + SelectorStart].
+
+ "It is assumed that there are some nils in this dictionary, and search will
+ stop when one is encountered. However, if there are no nils, then wrapAround
+ will be detected the second time the loop gets to the end of the table."
+ wrapAround := false.
+ [true]
+ whileTrue: [nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
+ nextSelector = objectMemory getNilObj ifTrue: [^ false].
+ nextSelector = messageSelector
+ ifTrue: [methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
+ newMethod := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray.
+ "Check if newMethod is a CompiledMethod."
+ (objectMemory isCompiledMethod: newMethod)
+ ifTrue: [primitiveIndex := self primitiveIndexOf: newMethod.
+ primitiveIndex > MaxPrimitiveIndex
+ ifTrue: ["If primitiveIndex is out of range, set to zero before putting in
+ cache. This is equiv to primFail, and avoids the need to check on
+ every send."
+ primitiveIndex := 0]]
+ ifFalse: ["indicate that this is no compiled method - use primitiveInvokeObjectAsMethod"
+ primitiveIndex := 248].
+ ^ true].
+ index := index + 1.
+ index = length
+ ifTrue: [wrapAround
+ ifTrue: [^ false].
+ wrapAround := true.
+ index := SelectorStart]]!
Item was added:
+ ----- Method: ContextInterpreter>>lookupMethodNoMNUEtcInClass: (in category 'alien support') -----
+ lookupMethodNoMNUEtcInClass: class
+ "Lookup. Answer false on failure father than performing MNU processing etc."
+ | currentClass dictionary |
+ <inline: true>
+
+ currentClass := class.
+ [currentClass ~= objectMemory getNilObj] whileTrue:
+ [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
+ (dictionary ~= objectMemory getNilObj
+ and: [self lookupMethodInDictionary: dictionary]) ifTrue:
+ [methodClass := currentClass.
+ ^true].
+ currentClass := self superclassOf: currentClass].
+
+ ^false!
Item was added:
+ ----- Method: ContextInterpreter>>mapInterpreterOops (in category 'object memory support') -----
+ mapInterpreterOops
+ "Map all oops in the interpreter's state to their new values
+ during garbage collection or a become: operation."
+ "Assume: All traced variables contain valid oops."
+ | oop |
+ objectMemory mapRootObjects.
+ compilerInitialized
+ ifFalse: [stackPointer := stackPointer - activeContext. "*rel to active"
+ activeContext := objectMemory remap: activeContext.
+ stackPointer := stackPointer + activeContext. "*rel to active"
+ theHomeContext := objectMemory remap: theHomeContext].
+ instructionPointer := instructionPointer - method. "*rel to method"
+ method := objectMemory remap: method.
+ instructionPointer := instructionPointer + method. "*rel to method"
+ receiver := objectMemory remap: receiver.
+ messageSelector := objectMemory remap: messageSelector.
+ newMethod := objectMemory remap: newMethod.
+ methodClass := objectMemory remap: methodClass.
+ lkupClass := objectMemory remap: lkupClass.
+ receiverClass := objectMemory remap: receiverClass.
+ 1 to: objectMemory getRemapBufferCount do: [:i |
+ oop := objectMemory remapBufferAt: i.
+ (objectMemory isIntegerObject: oop)
+ ifFalse: [objectMemory remapBufferAt: i put: (objectMemory remap: oop)]].
+
+ "Callback support - trace suspended callback list"
+ 1 to: jmpDepth do:[:i|
+ oop := suspendedCallbacks at: i.
+ (objectMemory isIntegerObject: oop)
+ ifFalse:[suspendedCallbacks at: i put: (objectMemory remap: oop)].
+ oop := suspendedMethods at: i.
+ (objectMemory isIntegerObject: oop)
+ ifFalse:[suspendedMethods at: i put: (objectMemory remap: oop)].
+ ].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>markAndTraceAndMaybeFreeStackPages: (in category 'stack interpreter support') -----
+ markAndTraceAndMaybeFreeStackPages: fullGCFlag
+ "This is a no-op in Interpreter"
+ !
Item was added:
+ ----- Method: ContextInterpreter>>markAndTraceInterpreterOops: (in category 'object memory support') -----
+ markAndTraceInterpreterOops: fullGCFlag
+ "Mark and trace all oops in the interpreter's state."
+ "Assume: All traced variables contain valid oops."
+ | oop |
+ self compilerMarkHook.
+ objectMemory markAndTrace: objectMemory getSpecialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
+ compilerInitialized
+ ifTrue: [objectMemory markAndTrace: receiver.
+ objectMemory markAndTrace: method]
+ ifFalse: [objectMemory markAndTrace: activeContext].
+ objectMemory markAndTrace: messageSelector.
+ objectMemory markAndTrace: newMethod.
+ objectMemory markAndTrace: methodClass.
+ objectMemory markAndTrace: lkupClass.
+ objectMemory markAndTrace: receiverClass.
+ 1 to: objectMemory getRemapBufferCount do: [:i |
+ oop := objectMemory remapBufferAt: i.
+ (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]].
+
+ "Callback support - trace suspended callback list"
+ 1 to: jmpDepth do:[:i|
+ oop := suspendedCallbacks at: i.
+ (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
+ oop := suspendedMethods at: i.
+ (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
+ ].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>markAndTraceOrFreeMachineCode: (in category 'stack interpreter support') -----
+ markAndTraceOrFreeMachineCode: fullGCFlag
+ "This is a no-op in Interpreter"
+ !
Item was added:
+ ----- Method: ContextInterpreter>>methodArgumentCount (in category 'plugin primitive support') -----
+ methodArgumentCount
+ ^argumentCount!
Item was added:
+ ----- Method: ContextInterpreter>>methodClassOf: (in category 'compiled methods') -----
+ methodClassOf: methodPointer
+
+ ^ objectMemory fetchPointer: ValueIndex ofObject: (self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer)!
Item was added:
+ ----- Method: ContextInterpreter>>methodPrimitiveIndex (in category 'plugin primitive support') -----
+ methodPrimitiveIndex
+ ^primitiveIndex!
Item was added:
+ ----- Method: ContextInterpreter>>moduleUnloaded: (in category 'initialization') -----
+ moduleUnloaded: aModuleName
+ "The module with the given name was just unloaded.
+ Make sure we have no dangling references."
+ <export: true>
+ <var: #aModuleName type: 'char *'>
+ (aModuleName strcmp: 'SurfacePlugin') = 0
+ ifTrue: ["Surface plugin went away. Should never happen. But then, who knows"
+ showSurfaceFn := 0]!
Item was added:
+ ----- Method: ContextInterpreter>>newActiveContext: (in category 'contexts') -----
+ newActiveContext: aContext
+ "Note: internalNewActiveContext: should track changes to this method."
+
+ self storeContextRegisters: activeContext.
+ (objectMemory oop: aContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
+ activeContext := aContext.
+ self fetchContextRegisters: aContext.!
Item was added:
+ ----- Method: ContextInterpreter>>normalSend (in category 'message sending') -----
+ normalSend
+ "Send a message, starting lookup with the receiver's class."
+ "Assume: messageSelector and argumentCount have been set, and that
+ the receiver and arguments have been pushed onto the stack,"
+ "Note: This method is inlined into the interpreter dispatch loop."
+ | rcvr |
+ <inline: true>
+ self sharedCodeNamed: 'normalSend' inCase: 131.
+ rcvr := self internalStackValue: argumentCount.
+ lkupClass := objectMemory fetchClassOf: rcvr.
+ receiverClass := lkupClass.
+ self commonSend.!
Item was added:
+ ----- Method: ContextInterpreter>>normalizeFloatOrderingInImage (in category 'image save/restore') -----
+ normalizeFloatOrderingInImage
+ "Float objects were saved in platform word ordering. Reorder them into the
+ traditional object format."
+
+ <inline: false>
+ <var: #floatData type: 'unsigned int *'>
+ <var: #val type: 'unsigned int'>
+ self isBigEnder
+ ifFalse: [ | oop | "Swap words within Float objects, taking them out of native platform ordering"
+ oop := objectMemory firstAccessibleObject.
+ [oop = nil] whileFalse: [ | val |
+ (objectMemory isFreeObject: oop) ifFalse: [
+ (objectMemory fetchClassOf: oop) = objectMemory classFloat
+ ifTrue: [ | floatData |
+ floatData := self cCoerce: (objectMemory firstIndexableField: oop) to: 'unsigned int *'.
+ val := floatData at: 0.
+ floatData at: 0 put: (floatData at: 1).
+ floatData at: 1 put: val].
+ oop := objectMemory accessibleObjectAfter: oop]]]
+ !
Item was added:
+ ----- Method: ContextInterpreter>>nullCompilerHook (in category 'compiler support') -----
+ nullCompilerHook
+ "This should never be called: either the compiler is uninitialised (in which case the hooks should never be reached) or the compiler initialisation should have replaced all the hook with their external implementations."
+
+ self error: 'uninitialised compiler hook called'.
+ ^false!
Item was added:
+ ----- Method: ContextInterpreter>>okayActiveProcessStack (in category 'debug support') -----
+ okayActiveProcessStack
+
+ | cntxt |
+ cntxt := activeContext.
+ [cntxt = objectMemory getNilObj] whileFalse: [
+ self okayFields: cntxt.
+ cntxt := (objectMemory fetchPointer: SenderIndex ofObject: cntxt).
+ ].!
Item was added:
+ ----- Method: ContextInterpreter>>okayFields: (in category 'debug support') -----
+ okayFields: oop
+ "If this is a pointers object, check that its fields are all okay oops."
+
+ | i fieldOop c |
+ (oop = nil or: [oop = 0]) ifTrue: [ ^true ].
+ (objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
+ objectMemory okayOop: oop.
+ self oopHasOkayClass: oop.
+ (objectMemory isPointers: oop) ifFalse: [ ^true ].
+ c := objectMemory fetchClassOf: oop.
+ (c = (objectMemory splObj: ClassMethodContext)
+ or: [c = (objectMemory splObj: ClassBlockContext)])
+ ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
+ ifFalse: [i := (objectMemory lengthOf: oop) - 1].
+ [i >= 0] whileTrue: [
+ fieldOop := objectMemory fetchPointer: i ofObject: oop.
+ (objectMemory isIntegerObject: fieldOop) ifFalse: [
+ objectMemory okayOop: fieldOop.
+ self oopHasOkayClass: fieldOop.
+ ].
+ i := i - 1.
+ ].!
Item was added:
+ ----- Method: ContextInterpreter>>okayInterpreterObjects (in category 'debug support') -----
+ okayInterpreterObjects
+
+ | oopOrZero oop |
+ self okayFields: objectMemory getNilObj.
+ self okayFields: objectMemory getFalseObj.
+ self okayFields: objectMemory getTrueObj.
+ self okayFields: objectMemory getSpecialObjectsOop.
+ self okayFields: activeContext.
+ self okayFields: method.
+ self okayFields: receiver.
+ self okayFields: theHomeContext.
+ self okayFields: messageSelector.
+ self okayFields: newMethod.
+ self okayFields: lkupClass.
+ 0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i |
+ oopOrZero := methodCache at: i + MethodCacheSelector.
+ oopOrZero = 0 ifFalse: [
+ self okayFields: (methodCache at: i + MethodCacheSelector).
+ self okayFields: (methodCache at: i + MethodCacheClass).
+ self okayFields: (methodCache at: i + MethodCacheMethod).
+ ].
+ ].
+ 1 to: objectMemory getRemapBufferCount do: [ :i |
+ oop := objectMemory remapBufferAt: i.
+ (objectMemory isIntegerObject: oop) ifFalse: [
+ self okayFields: oop.
+ ].
+ ].
+ self okayActiveProcessStack.!
Item was added:
+ ----- Method: ContextInterpreter>>oldFormatFullScreenFlag: (in category 'image save/restore') -----
+ oldFormatFullScreenFlag: flagsWord
+ "The full screen flags word in the image header file was originally defined as
+ a boolean (low order bit of the word set for true). In more recent usage with
+ StackInterpreter, the remaining bits are allocated for other purposes. This
+ interpreter does not use the new bit definitions, and should clear the bits
+ before saving the image."
+
+ ^ flagsWord bitAnd: 1!
Item was added:
+ ----- Method: ContextInterpreter>>oopHasOkayClass: (in category 'debug support') -----
+ oopHasOkayClass: signedOop
+ "Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."
+
+ | oop oopClass formatMask behaviorFormatBits oopFormatBits |
+ <var: #oop type: 'usqInt'>
+ <var: #oopClass type: 'usqInt'>
+
+ oop := self cCoerce: signedOop to: 'usqInt'.
+ objectMemory okayOop: oop.
+ oopClass := self cCoerce: (objectMemory fetchClassOf: oop) to: 'usqInt'.
+
+ (objectMemory isIntegerObject: oopClass)
+ ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ].
+ objectMemory okayOop: oopClass.
+ ((objectMemory isPointers: oopClass) and: [(objectMemory lengthOf: oopClass) >= 3])
+ ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ].
+ (objectMemory isBytes: oop)
+ ifTrue: [ formatMask := 16rC00 ] "ignore extra bytes size bits"
+ ifFalse: [ formatMask := 16rF00 ].
+
+ behaviorFormatBits := (objectMemory formatOfClass: oopClass) bitAnd: formatMask.
+ oopFormatBits := (objectMemory baseHeader: oop) bitAnd: formatMask.
+ behaviorFormatBits = oopFormatBits
+ ifFalse: [ self error: 'object and its class (behavior) formats differ' ].
+ ^true!
Item was added:
+ ----- Method: ContextInterpreter>>pop2AndPushIntegerIfOK: (in category 'contexts') -----
+ pop2AndPushIntegerIfOK: integerResult
+
+ self successful ifTrue:
+ [(objectMemory isIntegerValue: integerResult)
+ ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: integerResult)]
+ ifFalse: [self primitiveFail]]!
Item was added:
+ ----- Method: ContextInterpreter>>pop: (in category 'contexts') -----
+ pop: nItems
+ "Note: May be called by translated primitive code."
+
+ stackPointer := stackPointer - (nItems * objectMemory bytesPerWord).!
Item was added:
+ ----- Method: ContextInterpreter>>pop:thenPush: (in category 'contexts') -----
+ pop: nItems thenPush: oop
+
+ | sp |
+ objectMemory longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord)) put: oop.
+ stackPointer := sp.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pop:thenPushBool: (in category 'contexts') -----
+ pop: nItems thenPushBool: trueOrFalse
+ "A few places pop a few items off the stack and then push a boolean. Make it convenient"
+ | sp |
+ objectMemory longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord))
+ put:(trueOrFalse ifTrue: [objectMemory getTrueObj] ifFalse: [objectMemory getFalseObj]).
+ stackPointer := sp!
Item was added:
+ ----- Method: ContextInterpreter>>pop:thenPushInteger: (in category 'contexts') -----
+ pop: nItems thenPushInteger: integerVal
+ "lots of places pop a few items off the stack and then push an integer. MAke it convenient"
+ | sp |
+ objectMemory longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord)) put:(objectMemory integerObjectOf: integerVal).
+ stackPointer := sp.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>popFloat (in category 'stack bytecodes') -----
+ popFloat
+ "Note: May be called by translated primitive code."
+
+ | top result |
+ <returnTypeC: 'double'>
+ <var: #result type: 'double '>
+ top := self popStack.
+ self assertClassOf: top is: (objectMemory splObj: ClassFloat).
+ self successful ifTrue:
+ [self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: top + objectMemory baseHeaderSize into: result].
+ ^ result!
Item was added:
+ ----- Method: ContextInterpreter>>popInteger (in category 'contexts') -----
+ popInteger
+ "returns 0 if the stackTop was not an integer value, plus sets primFailCode"
+ | integerPointer |
+ integerPointer := self popStack.
+ ^self checkedIntegerValueOf: integerPointer!
Item was added:
+ ----- Method: ContextInterpreter>>popPos32BitInteger (in category 'contexts') -----
+ popPos32BitInteger
+ "May set primFailCode, and return false if not valid"
+
+ | top |
+ top := self popStack.
+ ^ self positive32BitValueOf: top!
Item was added:
+ ----- Method: ContextInterpreter>>popStack (in category 'contexts') -----
+ popStack
+
+ | top |
+ top := objectMemory longAt: stackPointer.
+ stackPointer := stackPointer - objectMemory bytesPerWord.
+ ^ top!
Item was added:
+ ----- Method: ContextInterpreter>>popStackBytecode (in category 'stack bytecodes') -----
+ popStackBytecode
+
+ self fetchNextBytecode.
+ self internalPop: 1.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>positive32BitIntegerFor: (in category 'primitive support') -----
+ positive32BitIntegerFor: integerValue
+
+ | newLargeInteger |
+ "Note - integerValue is interpreted as POSITIVE, eg, as the result of
+ Bitmap>at:, or integer>bitAnd:."
+ integerValue >= 0
+ ifTrue: [(objectMemory isIntegerValue: integerValue)
+ ifTrue: [^ objectMemory integerObjectOf: integerValue]].
+
+ objectMemory bytesPerWord = 4
+ ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size."
+ newLargeInteger := objectMemory instantiateSmallClass: (objectMemory splObj: ClassLargePositiveInteger)
+ sizeInBytes: objectMemory baseHeaderSize + 4]
+ ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement."
+ newLargeInteger := objectMemory instantiateClass: (objectMemory splObj: ClassLargePositiveInteger)
+ indexableSize: 4].
+ objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
+ objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
+ objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
+ objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
+ ^ newLargeInteger!
Item was added:
+ ----- Method: ContextInterpreter>>positive64BitIntegerFor: (in category 'primitive support') -----
+ positive64BitIntegerFor: integerValue
+
+ | newLargeInteger value highWord sz |
+ "Note - integerValue is interpreted as POSITIVE, eg, as the result of
+ Bitmap>at:, or integer>bitAnd:."
+ <var: 'integerValue' type: 'sqLong'>
+
+ (self sizeof: integerValue) = 4 ifTrue: [^self positive32BitIntegerFor: integerValue].
+
+
+ highWord := self cCode: 'integerValue >> 32'. "shift is coerced to usqInt otherwise"
+ highWord = 0 ifTrue:[^self positive32BitIntegerFor: integerValue].
+ 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 := objectMemory instantiateClass: (objectMemory splObj: ClassLargePositiveInteger) indexableSize: sz.
+ 0 to: sz-1 do: [:i |
+ value := self cCode: '(integerValue >> (i * 8)) & 255'.
+ objectMemory storeByte: i ofObject: newLargeInteger withValue: value].
+ ^ newLargeInteger
+ !
Item was added:
+ ----- Method: ContextInterpreter>>postGCAction (in category 'object memory support') -----
+ postGCAction
+ "Mark the active and home contexts as roots if old. This
+ allows the interpreter to use storePointerUnchecked to
+ store into them."
+
+ compilerInitialized
+ ifTrue: [self compilerPostGC]
+ ifFalse: [(objectMemory oop: activeContext isLessThan: objectMemory getYoungStart)
+ ifTrue: [objectMemory beRootIfOld: activeContext].
+ (objectMemory oop: theHomeContext isLessThan: objectMemory getYoungStart)
+ ifTrue: [objectMemory beRootIfOld: theHomeContext]].
+ (objectMemory oop: (objectMemory sizeOfFree: objectMemory getFreeBlock) isGreaterThan: objectMemory getShrinkThreshold)
+ ifTrue: ["Attempt to shrink memory after successfully
+ reclaiming lots of memory"
+ objectMemory shrinkObjectMemory: (objectMemory sizeOfFree: objectMemory getFreeBlock) - objectMemory getGrowHeadroom].
+
+ self signalSemaphoreWithIndex: objectMemory getGcSemaphoreIndex.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>preGCAction: (in category 'object memory support') -----
+ preGCAction: fullGCFlag
+
+ compilerInitialized
+ ifTrue: [self compilerPreGC: fullGCFlag]
+ ifFalse: [self storeContextRegisters: activeContext].!
Item was added:
+ ----- Method: ContextInterpreter>>primIndex (in category 'primitive support') -----
+ primIndex
+ ^ primitiveIndex!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveAsOop (in category 'object access primitives') -----
+ primitiveAsOop
+ | thisReceiver |
+ thisReceiver := self stackTop.
+ self success: (objectMemory isIntegerObject: thisReceiver) not.
+ self successful
+ ifTrue: [self pop:1 thenPushInteger: (objectMemory hashBitsOf: thisReceiver)]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveAtEnd (in category 'deprecated - array and stream primitives') -----
+ primitiveAtEnd
+ "nb: This primitive was previously installed as primitive 67, but is no
+ longer in use."
+ | stream index limit |
+ stream := self popStack.
+ ((objectMemory isPointers: stream)
+ and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex+1)])
+ ifTrue: [index := self fetchInteger: StreamIndexIndex ofObject: stream.
+ limit := self fetchInteger: StreamReadLimitIndex ofObject: stream]
+ ifFalse: [self primitiveFail].
+ self successful
+ ifTrue: [self pushBool: (index >= limit)]
+ ifFalse: [self unPop: 1].!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveBlockCopy (in category 'control primitives') -----
+ primitiveBlockCopy
+
+ | context methodContext contextSize newContext initialIP |
+ context := self stackValue: 1.
+ (objectMemory isIntegerObject: (objectMemory fetchPointer: MethodIndex ofObject: context))
+ ifTrue: ["context is a block; get the context of its enclosing method"
+ methodContext := objectMemory fetchPointer: HomeIndex ofObject: context]
+ ifFalse: [methodContext := context].
+ contextSize := objectMemory sizeBitsOf: methodContext. "in bytes, including header"
+ context := nil. "context is no longer needed and is not preserved across allocation"
+
+ "remap methodContext in case GC happens during allocation"
+ objectMemory pushRemappableOop: methodContext.
+ newContext := objectMemory instantiateContext: (objectMemory splObj: ClassBlockContext) sizeInBytes: contextSize.
+ methodContext := objectMemory popRemappableOop.
+
+ initialIP := objectMemory integerObjectOf: (instructionPointer+1+3) - (method + objectMemory baseHeaderSize).
+ "Was instructionPointer + 3, but now it's greater by 1 due to preIncrement"
+
+ "Assume: have just allocated a new context; it must be young.
+ Thus, can use uncheck stores. See the comment in fetchContextRegisters."
+
+ objectMemory storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
+ self storeStackPointerValue: 0 inContext: newContext.
+ objectMemory storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
+ objectMemory storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
+ objectMemory storePointerUnchecked: SenderIndex ofObject: newContext withValue: objectMemory getNilObj.
+
+ self pop: 2 thenPush: newContext.!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveChangeClassWithClass (in category 'object access primitives') -----
+ primitiveChangeClassWithClass
+ "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
+ | rcvr argClass |
+ <export: true>
+ self methodArgumentCount = 1 ifFalse: [self primitiveFail. ^ nil].
+
+ argClass := self stackObjectValue: 0.
+ rcvr := self stackObjectValue: 1.
+
+ self changeClassOf: rcvr to: argClass.
+ self successful ifTrue: [ self flushAtCache. self pop: 1 ].
+ ^ nil.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveClone (in category 'object access primitives') -----
+ primitiveClone
+ "Return a shallow copy of the receiver."
+
+ | newCopy |
+ newCopy := objectMemory clone: (self stackTop).
+ newCopy = 0
+ ifTrue:["not enough memory most likely" ^self primitiveFail].
+ self pop: 1 thenPush: newCopy.!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
+ primitiveClosureCopyWithCopiedValues
+ | newClosure copiedValues numCopiedValues numArgs |
+ numArgs := self stackIntegerValue: 1.
+ copiedValues := self stackTop.
+ self success: (objectMemory fetchClassOf: copiedValues) = (objectMemory splObj: ClassArray).
+ self successful ifFalse:
+ [^self primitiveFail].
+ numCopiedValues := objectMemory fetchWordLengthOf: copiedValues.
+ newClosure := self
+ closureNumArgs: numArgs
+ "greater by 1 due to preIncrement of localIP"
+ instructionPointer: instructionPointer + 2 - (method + objectMemory baseHeaderSize)
+ numCopiedValues: numCopiedValues.
+ "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
+ numCopiedValues > 0 ifTrue:
+ ["Allocation may have done a GC and copiedValues may have moved."
+ copiedValues := self stackTop.
+ 0 to: numCopiedValues - 1 do:
+ [:i|
+ "Assume: have just allocated a new BlockClosure; it must be young.
+ Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
+ ofObject: newClosure
+ withValue: (objectMemory fetchPointer: i ofObject: copiedValues)]].
+ self pop: 3 thenPush: newClosure!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveClosureValue (in category 'control primitives') -----
+ primitiveClosureValue
+ | blockClosure blockArgumentCount closureMethod outerContext |
+ blockClosure := self stackValue: argumentCount.
+ blockArgumentCount := self argumentCountOfClosure: blockClosure.
+ argumentCount = blockArgumentCount ifFalse:
+ [^self primitiveFail].
+
+ "Somewhat paranoiac checks we need while debugging that we may be able to discard
+ in a robust system."
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
+ (self isContext: outerContext) ifFalse:
+ [^self primitiveFail].
+ closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
+ "Check if the closure's method is actually a CompiledMethod."
+ (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
+ [^self primitiveFail].
+
+ self activateNewClosureMethod: blockClosure.
+ self quickCheckForInterrupts!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveClosureValueNoContextSwitch (in category 'control primitives') -----
+ primitiveClosureValueNoContextSwitch
+ "An exact clone of primitiveClosureValue except that this version will not
+ check for interrupts on stack overflow."
+ | blockClosure blockArgumentCount closureMethod outerContext |
+ blockClosure := self stackValue: argumentCount.
+ blockArgumentCount := self argumentCountOfClosure: blockClosure.
+ argumentCount = blockArgumentCount ifFalse:
+ [^self primitiveFail].
+
+ "Somewhat paranoiac checks we need while debugging that we may be able to discard
+ in a robust system."
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
+ (self isContext: outerContext) ifFalse:
+ [^self primitiveFail].
+ closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
+ "Check if the closure's method is actually a CompiledMethod."
+ (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
+ [^self primitiveFail].
+
+ self activateNewClosureMethod: blockClosure!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveClosureValueWithArgs (in category 'control primitives') -----
+ primitiveClosureValueWithArgs
+ | argumentArray arraySize cntxSize blockClosure blockArgumentCount closureMethod index outerContext |
+ argumentArray := self stackTop.
+ (objectMemory isArray: argumentArray) ifFalse:
+ [^self primitiveFail].
+
+ "Check for enough space in thisContext to push all args"
+ arraySize := objectMemory fetchWordLengthOf: argumentArray.
+ cntxSize := objectMemory fetchWordLengthOf: activeContext.
+ (self stackPointerIndex + arraySize) < cntxSize ifFalse:
+ [^self primitiveFail].
+
+ blockClosure := self stackValue: argumentCount.
+ blockArgumentCount := self argumentCountOfClosure: blockClosure.
+ arraySize = blockArgumentCount ifFalse:
+ [^self primitiveFail].
+
+ "Somewhat paranoiac checks we need while debugging that we may be able to discard
+ in a robust system."
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
+ (self isContext: outerContext) ifFalse:
+ [^self primitiveFail].
+ closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
+ "Check if the closure's method is actually a CompiledMethod."
+ (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
+ [^self primitiveFail].
+
+ self popStack.
+
+ "Copy the arguments to the stack, and activate"
+ index := 1.
+ [index <= arraySize]
+ whileTrue:
+ [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
+ index := index + 1].
+
+ argumentCount := arraySize.
+ self activateNewClosureMethod: blockClosure.
+ self quickCheckForInterrupts!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveCopyObject (in category 'object access primitives') -----
+ primitiveCopyObject
+ "Primitive. Copy the state of the receiver from the argument.
+ Fail if receiver and argument are of a different class.
+ Fail if the receiver or argument are non-pointer objects.
+ Fail if receiver and argument have different lengths (for indexable objects).
+ "
+ | rcvr arg length |
+ self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
+ arg := self stackObjectValue: 0.
+ rcvr := self stackObjectValue: 1.
+
+ self failed ifTrue:[^nil].
+ (objectMemory isPointers: rcvr) ifFalse:[^self primitiveFail].
+ (objectMemory fetchClassOf: rcvr) = (objectMemory fetchClassOf: arg) ifFalse:[^self primitiveFail].
+ length := objectMemory lengthOf: rcvr.
+ length = (objectMemory lengthOf: arg) ifFalse:[^self primitiveFail].
+
+ "Now copy the elements"
+ 0 to: length-1 do:[:i|
+ objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)].
+
+ "Note: The above could be faster for young receivers but I don't think it'll matter"
+ self pop: 1. "pop arg; answer receiver"
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveDeferDisplayUpdates (in category 'I/O primitives') -----
+ primitiveDeferDisplayUpdates
+ "Set or clear the flag that controls whether modifications of
+ the Display object are propagated to the underlying
+ platform's screen."
+ | flag |
+ flag := self stackTop.
+ flag = objectMemory getTrueObj
+ ifTrue: [deferDisplayUpdates := true]
+ ifFalse: [flag = objectMemory getFalseObj
+ ifTrue: [deferDisplayUpdates := false]
+ ifFalse: [self primitiveFail]].
+ self successful
+ ifTrue: [self pop: 1]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveDoPrimitiveWithArgs (in category 'control primitives') -----
+ primitiveDoPrimitiveWithArgs
+ | argumentArray arraySize index cntxSize primIdx |
+ argumentArray := self stackTop.
+ arraySize := objectMemory fetchWordLengthOf: argumentArray.
+ cntxSize := objectMemory fetchWordLengthOf: activeContext.
+ self success: self stackPointerIndex + arraySize < cntxSize.
+ (objectMemory isArray: argumentArray) ifFalse: [^ self primitiveFail].
+
+ primIdx := self stackIntegerValue: 1.
+ self successful ifFalse: [^ self primitiveFail]. "invalid args"
+
+ "Pop primIndex and argArray, then push args in place..."
+ self pop: 2.
+ primitiveIndex := primIdx.
+ argumentCount := arraySize.
+ index := 1.
+ [index <= argumentCount]
+ whileTrue: [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
+ index := index + 1].
+
+ "Run the primitive (sets primFailCode)"
+ objectMemory pushRemappableOop: argumentArray. "prim might alloc/gc"
+ lkupClass := objectMemory getNilObj.
+ self primitiveResponse.
+ argumentArray := objectMemory popRemappableOop.
+ self successful
+ ifFalse: ["If primitive failed, then restore state for failure code"
+ self pop: arraySize.
+ self pushInteger: primIdx.
+ self push: argumentArray.
+ argumentCount := 2]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveExecuteMethod (in category 'control primitives') -----
+ primitiveExecuteMethod
+ "receiver, args, then method are on top of stack. Execute method against receiver and args"
+ newMethod := self popStack.
+ primitiveIndex := self primitiveIndexOf: newMethod.
+ self success: argumentCount - 1 = (self argumentCountOf: newMethod).
+ self successful
+ ifTrue: [argumentCount := argumentCount - 1.
+ self executeNewMethod]
+ ifFalse: [self unPop: 1]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') -----
+ primitiveExecuteMethodArgsArray
+ "receiver, argsArray, then method are on top of stack. Execute method against
+ receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives).
+ Set primitiveFunctionPointer because no cache lookup has been done for the
+ method, and hence primitiveFunctionPointer is stale."
+ | methodArgument argCnt argumentArray |
+ methodArgument := self stackTop.
+ argumentArray := self stackValue: 1.
+ ((objectMemory isOopCompiledMethod: methodArgument)
+ and: [objectMemory isArray: argumentArray]) ifFalse:
+ [^self primitiveFail].
+ argCnt := self argumentCountOf: methodArgument.
+ argCnt = (objectMemory fetchWordLengthOf: argumentArray) ifFalse:
+ [^self primitiveFail].
+ argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod:
+ SqueakObjectPrimitives class >> receiver:withArguments:apply:
+ VMMirror>>ifFail:object:with:executeMethod: et al"
+ [argumentCount > 4 ifTrue:
+ [^self primitiveFail].
+ self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver"
+ "and push the actual arguments"
+ self pop: argumentCount.
+ 0 to: argCnt - 1 do:
+ [:i|
+ self push: (objectMemory fetchPointer: i ofObject: argumentArray)].
+ newMethod := methodArgument.
+ primitiveIndex := self primitiveIndexOf: newMethod.
+ primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil.
+ argumentCount := argCnt.
+ "We set the messageSelector for executeMethod below since things
+ like the at cache read messageSelector and so it cannot be left stale."
+ messageSelector := objectMemory nilObject.
+ self executeNewMethod.
+ "Recursive xeq affects primFailCode"
+ self initPrimCall!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveExternalCall (in category 'plugin primitives') -----
+ 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 extFnAddr moduleName functionName moduleLength functionLength index |
+ <var: #extFnAddr declareC: 'void (*extFnAddr)(void)'>
+
+ "Fetch the first literal of the method"
+ self success: (self literalCountOf: newMethod) > 0. "@@: Could this be omitted for speed?!!"
+ self successful ifFalse: [^ nil].
+
+ lit := self literal: 0 ofMethod: newMethod.
+ "Check if it's an array of length 4"
+ self success: ((objectMemory isArray: lit) and: [(objectMemory lengthOf: lit) = 4]).
+ self successful ifFalse: [^ nil].
+
+ "Look at the function index in case it has been loaded before"
+ index := objectMemory fetchPointer: 3 ofObject: lit.
+ index := self checkedIntegerValueOf: index.
+ self successful 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: [extFnAddr := externalPrimitiveTable at: index - 1.
+ extFnAddr ~= 0
+ ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: extFnAddr.
+ self callExternalPrimitive: extFnAddr.
+ ^ 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"
+ objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
+ objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
+
+ "The function has not been loaded yet. Fetch module and function name."
+ moduleName := objectMemory fetchPointer: 0 ofObject: lit.
+ moduleName = objectMemory getNilObj
+ ifTrue: [moduleLength := 0]
+ ifFalse: [self success: (objectMemory isBytes: moduleName).
+ moduleLength := objectMemory lengthOf: moduleName.
+ self cCode: '' inSmalltalk:
+ [ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName))
+ ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
+ functionName := objectMemory fetchPointer: 1 ofObject: lit.
+ self success: (objectMemory isBytes: functionName).
+ functionLength := objectMemory lengthOf: functionName.
+ self successful ifFalse: [^ nil].
+
+ extFnAddr := self cCoerce: (self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
+ OfLength: functionLength
+ FromModule: moduleName + objectMemory baseHeaderSize
+ OfLength: moduleLength) to: 'void (*)(void)'.
+ extFnAddr = 0
+ ifTrue: [index := -1]
+ ifFalse: ["add the function to the external primitive table"
+ index := self addToExternalPrimitiveTable: extFnAddr].
+ self success: index >= 0.
+ "Store the index (or -1 if failure) back in the literal"
+ objectMemory storePointerUnchecked: 3 ofObject: lit withValue: (objectMemory integerObjectOf: index).
+
+ "If the function has been successfully loaded process it"
+ (self successful and: [extFnAddr ~= 0])
+ ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: extFnAddr.
+ self callExternalPrimitive: extFnAddr]
+ ifFalse: ["Otherwise rewrite the primitive index"
+ self
+ rewriteMethodCacheSel: messageSelector
+ class: lkupClass
+ primIndex: 0]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatAdd:toArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatAdd: rcvrOop toArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [
+ self pop: 2.
+ self pushFloat: rcvr + arg].!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatAt (in category 'indexing primitives') -----
+ primitiveFloatAt
+ "Provide platform-independent access to 32-bit words comprising
+ a Float. Map index 1 onto the most significant word and index 2
+ onto the least significant word."
+ | rcvr index result |
+ <var: #result type: #usqInt>
+ self initPrimCall.
+ rcvr := self stackValue: 1.
+ index := self stackTop.
+ index = ConstOne ifTrue:
+ [result := self positive32BitIntegerFor:
+ (objectMemory fetchLong32: 0
+ ofObject: rcvr).
+ ^self pop: 2 thenPush: result].
+ index = ConstTwo ifTrue:
+ [result := self positive32BitIntegerFor:
+ (objectMemory fetchLong32: 1
+ ofObject: rcvr).
+ ^self pop: 2 thenPush: result].
+ self primitiveFailFor: ((objectMemory isIntegerObject: index)
+ ifTrue: [PrimErrBadIndex]
+ ifFalse: [PrimErrBadArgument])!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatAtPut (in category 'indexing primitives') -----
+ primitiveFloatAtPut
+ "Provide platform-independent access to 32-bit words comprising
+ a Float. Map index 1 onto the most significant word and index 2
+ onto the least significant word."
+ | rcvr index oopToStore valueToStore |
+ <var: #result type: #usqInt>
+ self initPrimCall.
+ oopToStore := self stackTop.
+ valueToStore := self positive32BitValueOf: oopToStore.
+ self successful ifFalse:
+ [^self primitiveFailFor: PrimErrBadArgument].
+ rcvr := self stackValue: 2.
+ index := self stackValue: 1.
+ index = ConstOne ifTrue:
+ [objectMemory storeLong32: 0
+ ofObject: rcvr
+ withValue: valueToStore.
+ ^self pop: 3 thenPush: oopToStore].
+ index = ConstTwo ifTrue:
+ [objectMemory storeLong32: 1
+ ofObject: rcvr
+ withValue: valueToStore.
+ ^self pop: 3 thenPush: oopToStore].
+ self primitiveFailFor: ((objectMemory isIntegerObject: index)
+ ifTrue: [PrimErrBadIndex]
+ ifFalse: [PrimErrBadArgument])!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatDivide:byArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatDivide: rcvrOop byArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [
+ self success: arg ~= 0.0.
+ self successful ifTrue: [
+ self pop: 2.
+ self pushFloat: (self cCode: 'rcvr / arg' inSmalltalk: [rcvr / arg])]].!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatEqual:toArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatEqual: rcvrOop toArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [^ rcvr = arg]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatGreater:thanArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatGreater: rcvrOop thanArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [^ rcvr > arg].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatGreaterOrEqual:toArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatGreaterOrEqual: rcvrOop toArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [^ rcvr >= arg].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatLess:thanArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatLess: rcvrOop thanArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [^ rcvr < arg].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatLessOrEqual:toArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatLessOrEqual: rcvrOop toArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [^ rcvr <= arg].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatMultiply:byArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatMultiply: rcvrOop byArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [
+ self pop: 2.
+ self pushFloat: rcvr * arg].!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFloatSubtract:fromArg: (in category 'arithmetic float primitives') -----
+ primitiveFloatSubtract: rcvrOop fromArg: argOop
+ | rcvr arg |
+ <var: #rcvr type: 'double '>
+ <var: #arg type: 'double '>
+
+ rcvr := self loadFloatOrIntFrom: rcvrOop.
+ arg := self loadFloatOrIntFrom: argOop.
+ self successful ifTrue: [
+ self pop: 2.
+ self pushFloat: rcvr - arg].!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFlushCacheByMethod (in category 'system control primitives') -----
+ primitiveFlushCacheByMethod
+ "The receiver is a compiledMethod. Clear all entries in the method lookup cache that refer to this method, presumably because it has been redefined, overridden or removed."
+ | probe oldMethod |
+ oldMethod := self stackTop.
+ probe := 0.
+ 1 to: MethodCacheEntries do:
+ [:i | (methodCache at: probe + MethodCacheMethod) = oldMethod ifTrue:
+ [methodCache at: probe + MethodCacheSelector put: 0].
+ probe := probe + MethodCacheEntrySize].
+ self flushAtCache.
+ self compilerFlushCacheHook: oldMethod. "Flush the dynamic compiler's inline caches."!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFlushCacheBySelector (in category 'system control primitives') -----
+ primitiveFlushCacheBySelector
+ "The receiver is a message selector. Clear all entries in the method lookup cache with this selector, presumably because an associated method has been redefined."
+ | selector probe |
+ selector := self stackTop.
+ probe := 0.
+ 1 to: MethodCacheEntries do:
+ [:i | (methodCache at: probe + MethodCacheSelector) = selector ifTrue:
+ [methodCache at: probe + MethodCacheSelector put: 0].
+ probe := probe + MethodCacheEntrySize].
+ (selector = (self specialSelector: 16) "at:"
+ or: [selector = (self specialSelector: 17) "at:put:"]) ifTrue:
+ [self flushAtCache]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveIndexOf: (in category 'compiled methods') -----
+ primitiveIndexOf: methodPointer
+ "Note: We now have 10 bits of primitive index, but they are in two places
+ for temporary backward compatibility. The time to unpack is negligible,
+ since the reconstituted full index is stored in the method cache."
+ | primBits |
+ primBits := ((self headerOf: methodPointer) >> 1) bitAnd: 16r100001FF.
+
+ ^ (primBits bitAnd: 16r1FF) + (primBits >> 19)
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveIndexOfMethodHeader: (in category 'compiled methods') -----
+ primitiveIndexOfMethodHeader: methodHeader
+ "Note: We now have 10 bits of primitive index, but they are in two places
+ for temporary backward compatibility. The time to unpack is negligible,
+ since the derived primitive function pointer is stored in the method cache."
+ | primBits |
+ primBits := (methodHeader >> 1).
+ ^(primBits bitAnd: 16r1FF) + ((primBits >> 19) bitAnd: 16r200)!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveInvokeObjectAsMethod (in category 'control primitives') -----
+ primitiveInvokeObjectAsMethod
+ "Primitive. 'Invoke' an object like a function, sending the special message
+ run: originalSelector with: arguments in: aReceiver.
+ "
+ | runSelector runReceiver runArgs newReceiver lookupClass |
+ runArgs := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount.
+ objectMemory beRootIfOld: runArgs. "do we really need this?"
+ self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * objectMemory bytesPerWord) to: runArgs + objectMemory baseHeaderSize.
+
+ runSelector := messageSelector.
+ runReceiver := self stackValue: argumentCount.
+ self pop: argumentCount+1.
+
+ "stack is clean here"
+
+ newReceiver := newMethod.
+ messageSelector := objectMemory splObj: SelectorRunWithIn.
+ argumentCount := 3.
+
+ self push: newReceiver.
+ self push: runSelector.
+ self push: runArgs.
+ self push: runReceiver.
+
+ lookupClass := objectMemory fetchClassOf: newReceiver.
+ self findNewMethodInClass: lookupClass.
+ self executeNewMethodFromCache. "Recursive xeq affects primFailCode"
+ self initPrimCall.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveLoadInstVar (in category 'quick primitives') -----
+ primitiveLoadInstVar
+ | thisReceiver |
+ thisReceiver := self popStack.
+ self push: (objectMemory fetchPointer: primitiveIndex-264 ofObject: thisReceiver)!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveNext (in category 'deprecated - array and stream primitives') -----
+ primitiveNext
+ "PrimitiveNext will succeed only if the stream's array is in the atCache.
+ Otherwise failure will lead to proper message lookup of at: and
+ subsequent installation in the cache if appropriate.
+ nb: This primitive was previously installed as primitive 65, but is no
+ longer in use."
+ | stream array index limit result atIx |
+ stream := self stackTop.
+ ((objectMemory isPointers: stream)
+ and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex + 1)])
+ ifFalse: [^ self primitiveFail].
+
+ array := objectMemory fetchPointer: StreamArrayIndex ofObject: stream.
+ index := self fetchInteger: StreamIndexIndex ofObject: stream.
+ limit := self fetchInteger: StreamReadLimitIndex ofObject: stream.
+ atIx := array bitAnd: AtCacheMask.
+ (index < limit and: [(atCache at: atIx+AtCacheOop) = array])
+ ifFalse: [^ self primitiveFail].
+
+ "OK -- its not at end, and the array is in the cache"
+ index := index + 1.
+ result := self commonVariable: array at: index cacheIndex: atIx.
+ "Above may cause GC, so can't use stream, array etc. below it"
+ self successful ifTrue:
+ [stream := self stackTop.
+ self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
+ ^ self pop: 1 thenPush: result].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveNextPut (in category 'deprecated - array and stream primitives') -----
+ primitiveNextPut
+ "PrimitiveNextPut will succeed only if the stream's array is in the atPutCache.
+ Otherwise failure will lead to proper message lookup of at:put: and
+ subsequent installation in the cache if appropriate.
+ nb: This primitive was previously installed as primitive 66, but is no
+ longer in use."
+ | value stream index limit array atIx |
+ value := self stackTop.
+ stream := self stackValue: 1.
+ ((objectMemory isPointers: stream)
+ and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex + 1)])
+ ifFalse: [^ self primitiveFail].
+
+ array := objectMemory fetchPointer: StreamArrayIndex ofObject: stream.
+ index := self fetchInteger: StreamIndexIndex ofObject: stream.
+ limit := self fetchInteger: StreamWriteLimitIndex ofObject: stream.
+ atIx := (array bitAnd: AtCacheMask) + AtPutBase.
+ (index < limit and: [(atCache at: atIx+AtCacheOop) = array])
+ ifFalse: [^ self primitiveFail].
+
+ "OK -- its not at end, and the array is in the cache"
+ index := index + 1.
+ self commonVariable: array at: index put: value cacheIndex: atIx.
+ self successful ifTrue:
+ [self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
+ ^ self pop: 2 thenPush: value].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitivePerform (in category 'control primitives') -----
+ primitivePerform
+ | performSelector newReceiver selectorIndex lookupClass performMethod |
+ performSelector := messageSelector.
+ performMethod := newMethod.
+ messageSelector := self stackValue: argumentCount - 1.
+ newReceiver := self stackValue: argumentCount.
+
+ "NOTE: the following lookup may fail and be converted to #doesNotUnderstand:, so we must adjust argumentCount and slide args now, so that would work."
+
+ "Slide arguments down over selector"
+ argumentCount := argumentCount - 1.
+ selectorIndex := self stackPointerIndex - argumentCount.
+ self
+ transfer: argumentCount
+ fromIndex: selectorIndex + 1
+ ofObject: activeContext
+ toIndex: selectorIndex
+ ofObject: activeContext.
+ self pop: 1.
+ lookupClass := objectMemory fetchClassOf: newReceiver.
+ self findNewMethodInClass: lookupClass.
+
+ "Only test CompiledMethods for argument count - other objects will have to take their chances"
+ (objectMemory isOopCompiledMethod: newMethod)
+ ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
+
+ self successful
+ ifTrue: [self executeNewMethodFromCache.
+ "Recursive xeq affects primFailCode"
+ self initPrimCall]
+ ifFalse: ["Slide the args back up (sigh) and re-insert the
+ selector. "
+ 1 to: argumentCount do: [:i | objectMemory
+ storePointer: argumentCount - i + 1 + selectorIndex
+ ofObject: activeContext
+ withValue: (objectMemory fetchPointer: argumentCount - i + selectorIndex ofObject: activeContext)].
+ self unPop: 1.
+ objectMemory storePointer: selectorIndex
+ ofObject: activeContext
+ withValue: messageSelector.
+ argumentCount := argumentCount + 1.
+ newMethod := performMethod.
+ messageSelector := performSelector]!
Item was added:
+ ----- Method: ContextInterpreter>>primitivePerformAt: (in category 'control primitives') -----
+ primitivePerformAt: lookupClass
+ "Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"
+
+ "NOTE: The case of doesNotUnderstand: is not a failure to perform.
+ The only failures are arg types and consistency of argumentCount."
+
+ | performSelector argumentArray arraySize index cntxSize performMethod performArgCount |
+ argumentArray := self stackTop.
+ (objectMemory isArray: argumentArray) ifFalse:[^self primitiveFail].
+
+ self successful ifTrue:
+ ["Check for enough space in thisContext to push all args"
+ arraySize := objectMemory fetchWordLengthOf: argumentArray.
+ cntxSize := objectMemory fetchWordLengthOf: activeContext.
+ self success: (self stackPointerIndex + arraySize) < cntxSize].
+ self successful ifFalse: [^nil].
+
+ performSelector := messageSelector.
+ performMethod := newMethod.
+ performArgCount := argumentCount.
+ "pop the arg array and the selector, then push the args out of the array, as if they were on the stack"
+ self popStack.
+ messageSelector := self popStack.
+
+ "Copy the arguments to the stack, and execute"
+ index := 1.
+ [index <= arraySize]
+ whileTrue:
+ [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
+ index := index + 1].
+ argumentCount := arraySize.
+
+ self findNewMethodInClass: lookupClass.
+
+ "Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
+ (objectMemory isOopCompiledMethod: newMethod)
+ ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
+
+ self successful
+ ifTrue: [self executeNewMethodFromCache. "Recursive xeq affects primFailCode"
+ self initPrimCall]
+ ifFalse: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
+ self pop: argumentCount.
+ self push: messageSelector.
+ self push: argumentArray.
+ messageSelector := performSelector.
+ newMethod := performMethod.
+ argumentCount := performArgCount]
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitivePerformInSuperclass (in category 'control primitives') -----
+ primitivePerformInSuperclass
+ | lookupClass rcvr currentClass |
+ lookupClass := self stackTop.
+ rcvr := self stackValue: 3.
+ currentClass := objectMemory fetchClassOf: rcvr.
+ [currentClass ~= lookupClass]
+ whileTrue:
+ [currentClass := self superclassOf: currentClass.
+ currentClass = objectMemory getNilObj ifTrue: [^self primitiveFailFor: PrimErrBadArgument]].
+
+ argumentCount = 3
+ ifTrue: ["normal primitive call with 3 arguments expected on the stack"
+ self popStack.
+ self primitivePerformAt: lookupClass.
+ self successful ifFalse:
+ [self push: lookupClass]]
+ ifFalse: [argumentCount = 4
+ ifTrue: ["mirror primitive call with extra argument specifying object to serve as receiver"
+ | s1 s2 s3 s4 s5 |
+ "save stack contents"
+ s1 := self popStack. "lookupClass"
+ s2 := self popStack. "args"
+ s3 := self popStack. "selector"
+ s4 := self popStack. "mirror receiver"
+ s5 := self popStack. "actual receiver"
+ "slide stack up one, omitting the actual receiver parameter"
+ self push: s4. "mirror receiver"
+ self push: s3. "selector"
+ self push: s2. "args"
+ "perform as if mirror receiver had been the actual receiver"
+ self primitivePerformAt: lookupClass.
+ self successful ifFalse:
+ ["restore original stack"
+ self pop: 3. "args, selector, mirror receiver"
+ self push: s5. "actual receiver"
+ self push: s4. "mirror receiver"
+ self push: s3. "selector"
+ self push: s2. "args"
+ self push: s1. "lookup class" ]]
+ ifFalse: ["wrong number of arguments"
+ ^self primitiveFailFor: PrimErrBadNumArgs]]
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitivePerformWithArgs (in category 'control primitives') -----
+ primitivePerformWithArgs
+
+ | lookupClass rcvr |
+ rcvr := self stackValue: argumentCount.
+ lookupClass := objectMemory fetchClassOf: rcvr.
+ self primitivePerformAt: lookupClass.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitivePushFalse (in category 'quick primitives') -----
+ primitivePushFalse
+ self popStack.
+ self push: objectMemory getFalseObj!
Item was added:
+ ----- Method: ContextInterpreter>>primitivePushMinusOne (in category 'quick primitives') -----
+ primitivePushMinusOne
+ self popStack.
+ self push: ConstMinusOne!
Item was added:
+ ----- Method: ContextInterpreter>>primitivePushNil (in category 'quick primitives') -----
+ primitivePushNil
+ self popStack.
+ self push: objectMemory getNilObj!
Item was added:
+ ----- Method: ContextInterpreter>>primitivePushOne (in category 'quick primitives') -----
+ primitivePushOne
+ self popStack.
+ self push: ConstOne!
Item was added:
+ ----- Method: ContextInterpreter>>primitivePushSelf (in category 'quick primitives') -----
+ primitivePushSelf
+ " no-op, really...
+ thisReceiver := self popStack.
+ self push: thisReceiver
+ "!
Item was added:
+ ----- Method: ContextInterpreter>>primitivePushTrue (in category 'quick primitives') -----
+ primitivePushTrue
+ self popStack.
+ self push: objectMemory getTrueObj!
Item was added:
+ ----- Method: ContextInterpreter>>primitivePushTwo (in category 'quick primitives') -----
+ primitivePushTwo
+ self popStack.
+ self push: ConstTwo!
Item was added:
+ ----- Method: ContextInterpreter>>primitivePushZero (in category 'quick primitives') -----
+ primitivePushZero
+ self popStack.
+ self push: ConstZero!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveResponse (in category 'primitive support') -----
+ primitiveResponse
+
+ | delta primIdx nArgs |
+ DoBalanceChecks ifTrue:["check stack balance"
+ nArgs := argumentCount.
+ delta := stackPointer - activeContext.
+ ].
+ primIdx := primitiveIndex.
+ self initPrimCall.
+ "self dispatchOn: primitiveIndex in: primitiveTable."
+ self dispatchFunctionPointerOn: primIdx in: primitiveTable.
+ "replace with fetch entry primitiveIndex from table and branch there"
+ DoBalanceChecks ifTrue:[
+ (self balancedStack: delta afterPrimitive: primIdx withArgs: nArgs)
+ ifFalse:[self printUnbalancedStack: primIdx].
+ ].
+ self checkForInterrupts.
+ primitiveIndex := 0. "clear out primIndex so VM knows we're no longer in primitive"
+ ^ primFailCode
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveResume (in category 'process primitives') -----
+ primitiveResume
+ "Put this process on the scheduler's lists thus allowing it to proceed next
+ time there is a chance for processes of its priority level"
+
+ | proc |
+ proc := self stackTop. "rcvr"
+ "self success: ((self fetchClassOf: proc) = (self splObj: ClassProcess))."
+ (self isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)) ifFalse:
+ [^self primitiveFail].
+ self successful ifTrue: [ self resume: proc ].!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>primitiveSignalAtMilliseconds (in category 'system control primitives') -----
+ primitiveSignalAtMilliseconds
+ "Cause the time semaphore, if one has been registered, to
+ be signalled when the millisecond clock is greater than or
+ equal to the given tick value. A tick value of zero turns off
+ timer interrupts."
+ | tick sema |
+ tick := self popInteger.
+ sema := self popStack.
+ self successful
+ ifTrue: [(objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
+ ifTrue: [objectMemory
+ storePointer: TheTimerSemaphore
+ ofObject: objectMemory getSpecialObjectsOop
+ withValue: sema.
+ nextWakeupTick := tick]
+ ifFalse: [objectMemory
+ storePointer: TheTimerSemaphore
+ ofObject: objectMemory getSpecialObjectsOop
+ withValue: objectMemory getNilObj.
+ nextWakeupTick := 0]]
+ ifFalse: [self unPop: 2]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveSignalAtUTCMicroseconds (in category 'system control primitives') -----
+ primitiveSignalAtUTCMicroseconds
+ "Cause the time semaphore, if one has been registered, to be
+ signalled when the microsecond clock is greater than or equal to
+ the given tick value. A tick value of zero turns off timer interrupts."
+
+ "Provided for compatibility with StackInterpreter microsecond implementation.
+ This is a required primitive in some newer images, and is implemented here
+ with millisecond precision only."
+
+ | tick sema usecsObj now usecs |
+ <var: #usecs type: #usqLong>
+ <var: #now type: #usqLong>
+ usecsObj := self popStack.
+ sema := self popStack.
+ usecs := self positive64BitValueOf: usecsObj.
+ now := self ioUTCMicroseconds.
+ tick := lastTick + (self cCoerce: usecs - now + 500 / 1000 to: #sqInt). "add 500 for rounding"
+ self successful
+ ifTrue: [(objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
+ ifTrue: [objectMemory
+ storePointer: TheTimerSemaphore
+ ofObject: objectMemory getSpecialObjectsOop
+ withValue: sema.
+ nextWakeupTick := tick]
+ ifFalse: [objectMemory
+ storePointer: TheTimerSemaphore
+ ofObject: objectMemory getSpecialObjectsOop
+ withValue: objectMemory getNilObj.
+ nextWakeupTick := 0]]
+ ifFalse: [self unPop: 2]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveStoreStackp (in category 'object access primitives') -----
+ primitiveStoreStackp
+ "Atomic store into context stackPointer.
+ Also ensures that any newly accessible cells are initialized to nil "
+ | ctxt newStackp stackp |
+ ctxt := self stackValue: 1.
+ newStackp := self stackIntegerValue: 0.
+ self success: (objectMemory oop: newStackp isGreaterThanOrEqualTo: 0).
+ self success: (objectMemory oop: newStackp isLessThanOrEqualTo: (objectMemory largeContextSize - objectMemory baseHeaderSize // objectMemory bytesPerWord - CtxtTempFrameStart)).
+ self successful ifFalse: [^ self primitiveFail].
+ stackp := self fetchStackPointerOf: ctxt.
+ (objectMemory oop: newStackp isGreaterThan: stackp) ifTrue: ["Nil any newly accessible cells"
+ stackp + 1 to: newStackp do: [:i | objectMemory storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: objectMemory getNilObj]].
+ self storeStackPointerValue: newStackp inContext: ctxt.
+ self pop: 1!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveTerminateTo (in category 'process primitives') -----
+ primitiveTerminateTo
+ "Primitive. Terminate up the context stack from the receiver up to but not including the argument, if previousContext is on my Context stack. Make previousContext my sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct"
+ | thisCntx currentCntx aContext nextCntx nilOop |
+ aContext := self popStack.
+ thisCntx := self popStack.
+
+ "make sure that aContext is in my chain"
+ (self context: thisCntx hasSender: aContext) ifTrue:[
+ nilOop := objectMemory getNilObj.
+ currentCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
+ [currentCntx = aContext] whileFalse: [
+ nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCntx.
+ objectMemory storePointer: SenderIndex ofObject: currentCntx withValue: nilOop.
+ objectMemory storePointer: InstructionPointerIndex ofObject: currentCntx withValue: nilOop.
+ currentCntx := nextCntx]].
+
+ objectMemory storePointer: SenderIndex ofObject: thisCntx withValue: aContext.
+ ^self push: thisCntx!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveVMParameter (in category 'system control primitives') -----
+ primitiveVMParameter
+ "Behaviour depends on argument count:
+ 0 args: return an Array of VM parameter values;
+ 1 arg: return the indicated VM parameter;
+ 2 args: set the VM indicated parameter.
+ VM parameters are numbered as follows:
+ 1 end of old-space (0-based, read-only)
+ 2 end of young-space (read-only)
+ 3 end of memory (read-only)
+ 4 allocationCount (read-only)
+ 5 allocations between GCs (read-write)
+ 6 survivor count tenuring threshold (read-write)
+ 7 full GCs since startup (read-only)
+ 8 total milliseconds in full GCs since startup (read-only)
+ 9 incremental GCs since startup (read-only)
+ 10 total milliseconds in incremental GCs since startup (read-only)
+ 11 tenures of surving objects since startup (read-only)
+ 12-20 specific to the translating VM
+ 21 root table size (read-only)
+ 22 root table overflows since startup (read-only)
+ 23 bytes of extra memory to reserve for VM buffers, plugins, etc.
+ 24 memory threshold above which shrinking object memory (rw)
+ 25 memory headroom when growing object memory (rw)
+ 26 interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image is not calling getNextEvent often (rw)
+ 27 number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking
+ 28 number of times sweep loop iterated for current IGC/FGC (read-only)
+ 29 number of times make forward loop iterated for current IGC/FGC (read-only)
+ 30 number of times compact move loop iterated for current IGC/FGC (read-only)
+ 31 number of grow memory requests (read-only)
+ 32 number of shrink memory requests (read-only)
+ 33 number of root table entries used for current IGC/FGC (read-only)
+ 34 number of allocations done before current IGC/FGC (read-only)
+ 35 number of survivor objects after current IGC/FGC (read-only)
+ 36 millisecond clock when current IGC/FGC completed (read-only)
+ 37 number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only)
+ 38 milliseconds taken by current IGC (read-only)
+ 39 Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only)
+ 40 BytesPerWord for this image
+
+ Note: Thanks to Ian Piumarta for this primitive."
+
+ | mem paramsArraySize result arg index statIGCDeltaTimeObj statGCTimeObj statIncrGCMSecsObj statFullGCMSecsObj resultLargePositiveInteger |
+ <var: #resultLargePositiveInteger type: 'sqLong'>
+ mem := objectMemory startOfMemory.
+ paramsArraySize := 40.
+ argumentCount = 0 ifTrue: [
+ result := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: paramsArraySize.
+ objectMemory pushRemappableOop: result.
+ objectMemory pushRemappableOop: (self positive64BitIntegerFor: objectMemory getStatFullGCMSecs).
+ objectMemory pushRemappableOop: (self positive64BitIntegerFor: objectMemory getStatIncrGCMSecs).
+ objectMemory pushRemappableOop: (self positive64BitIntegerFor: objectMemory getStatGCTime).
+ objectMemory pushRemappableOop: (self positive64BitIntegerFor: objectMemory getStatIGCDeltaTime).
+ statIGCDeltaTimeObj := objectMemory popRemappableOop.
+ statGCTimeObj := objectMemory popRemappableOop.
+ statIncrGCMSecsObj := objectMemory popRemappableOop.
+ statFullGCMSecsObj := objectMemory popRemappableOop.
+ result := objectMemory popRemappableOop.
+ 0 to: paramsArraySize - 1 do:
+ [:i | objectMemory storePointer: i ofObject: result withValue: ConstZero].
+
+ objectMemory storePointer: 0 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getYoungStart - mem).
+ objectMemory storePointer: 1 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getFreeBlock - mem).
+ objectMemory storePointer: 2 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getEndOfMemory - mem).
+ objectMemory storePointer: 3 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory allocationCount).
+ objectMemory storePointer: 4 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getAllocationsBetweenGCs).
+ objectMemory storePointer: 5 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getTenuringThreshold).
+ objectMemory storePointer: 6 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatFullGCs).
+ objectMemory storePointer: 7 ofObject: result withValue: statFullGCMSecsObj.
+ objectMemory storePointer: 8 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatIncrGCs).
+ objectMemory storePointer: 9 ofObject: result withValue: statIncrGCMSecsObj.
+ objectMemory storePointer: 10 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatTenures).
+ objectMemory storePointer: 20 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getRootTableCount).
+ objectMemory storePointer: 21 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatRootTableOverflows).
+ objectMemory storePointer: 22 ofObject: result withValue: (self positive64BitIntegerFor: extraVMMemory).
+ objectMemory storePointer: 23 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getShrinkThreshold).
+ objectMemory storePointer: 24 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getGrowHeadroom).
+ objectMemory storePointer: 25 ofObject: result withValue: (objectMemory integerObjectOf: interruptChecksEveryNms).
+ objectMemory storePointer: 26 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatMarkCount).
+ objectMemory storePointer: 27 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatSweepCount).
+ objectMemory storePointer: 28 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatMkFwdCount).
+ objectMemory storePointer: 29 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatCompMoveCount).
+ objectMemory storePointer: 30 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatGrowMemory).
+ objectMemory storePointer: 31 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatShrinkMemory).
+ objectMemory storePointer: 32 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatRootTableCount).
+ objectMemory storePointer: 33 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatAllocationCount).
+ objectMemory storePointer: 34 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatSurvivorCount).
+ objectMemory storePointer: 35 ofObject: result withValue: statGCTimeObj.
+ objectMemory storePointer: 36 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatSpecialMarkCount).
+ objectMemory storePointer: 37 ofObject: result withValue: statIGCDeltaTimeObj.
+ objectMemory storePointer: 38 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatpendingFinalizationSignals).
+ objectMemory storePointer: 39 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory bytesPerWord).
+ objectMemory pop: 1 thenPush: result.
+ ^nil].
+
+ arg := self stackTop.
+ (objectMemory isIntegerObject: arg) ifFalse: [^self primitiveFail].
+ arg := objectMemory integerValueOf: arg.
+ resultLargePositiveInteger := -1.
+ argumentCount = 1 ifTrue: [ "read VM parameter"
+ (arg < 1 or: [arg > paramsArraySize]) ifTrue: [^self primitiveFail].
+ arg = 1 ifTrue: [resultLargePositiveInteger := objectMemory getYoungStart - mem].
+ arg = 2 ifTrue: [resultLargePositiveInteger := objectMemory getFreeBlock - mem].
+ arg = 3 ifTrue: [resultLargePositiveInteger := objectMemory getEndOfMemory - mem].
+ arg = 4 ifTrue: [result := objectMemory allocationCount].
+ arg = 5 ifTrue: [result := objectMemory getAllocationsBetweenGCs].
+ arg = 6 ifTrue: [result := objectMemory getTenuringThreshold].
+ arg = 7 ifTrue: [result := objectMemory getStatFullGCs].
+ arg = 8 ifTrue: [resultLargePositiveInteger := objectMemory getStatFullGCMSecs].
+ arg = 9 ifTrue: [result := objectMemory getStatIncrGCs].
+ arg = 10 ifTrue: [resultLargePositiveInteger := objectMemory getStatIncrGCMSecs].
+ arg = 11 ifTrue: [result := objectMemory getStatTenures].
+ ((arg >= 12) and: [arg <= 20]) ifTrue: [result := 0].
+ arg = 21 ifTrue: [result := objectMemory getRootTableCount].
+ arg = 22 ifTrue: [result := objectMemory getStatRootTableOverflows].
+ arg = 23 ifTrue: [resultLargePositiveInteger := extraVMMemory].
+ arg = 24 ifTrue: [resultLargePositiveInteger := objectMemory getShrinkThreshold].
+ arg = 25 ifTrue: [resultLargePositiveInteger := objectMemory getGrowHeadroom].
+ arg = 26 ifTrue: [result := interruptChecksEveryNms].
+ arg = 27 ifTrue: [result := objectMemory getStatMarkCount].
+ arg = 28 ifTrue: [result := objectMemory getStatSweepCount].
+ arg = 29 ifTrue: [result := objectMemory getStatMkFwdCount].
+ arg = 30 ifTrue: [result := objectMemory getStatCompMoveCount].
+ arg = 31 ifTrue: [result := objectMemory getStatGrowMemory].
+ arg = 32 ifTrue: [result := objectMemory getStatShrinkMemory].
+ arg = 33 ifTrue: [result := objectMemory getStatRootTableCount].
+ arg = 34 ifTrue: [result := objectMemory getStatAllocationCount].
+ arg = 35 ifTrue: [result := objectMemory getStatSurvivorCount].
+ arg = 36 ifTrue: [resultLargePositiveInteger := objectMemory getStatGCTime].
+ arg = 37 ifTrue: [result := objectMemory getStatSpecialMarkCount].
+ arg = 38 ifTrue: [resultLargePositiveInteger := objectMemory getStatIGCDeltaTime].
+ arg = 39 ifTrue: [result := objectMemory getStatpendingFinalizationSignals].
+ arg = 40 ifTrue: [result := objectMemory bytesPerWord].
+ resultLargePositiveInteger = -1
+ ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: result)]
+ ifFalse: [self pop: 2 thenPush: (self positive64BitIntegerFor: resultLargePositiveInteger)].
+ ^nil].
+
+ "write a VM parameter"
+ argumentCount = 2 ifFalse: [^self primitiveFail].
+ index := self stackValue: 1.
+ (objectMemory isIntegerObject: index) ifFalse: [^self primitiveFail].
+ index := objectMemory integerValueOf: index.
+ index <= 0 ifTrue: [^self primitiveFail].
+ self primitiveFail.
+ index = 5 ifTrue: [
+ result := objectMemory getAllocationsBetweenGCs.
+ objectMemory setAllocationsBetweenGCs: arg.
+ self initPrimCall].
+ index = 6 ifTrue: [
+ result := objectMemory getTenuringThreshold.
+ objectMemory setTenuringThreshold: arg.
+ self initPrimCall].
+ index = 23 ifTrue: [
+ result := extraVMMemory.
+ extraVMMemory := arg.
+ self initPrimCall].
+ index = 24 ifTrue: [
+ result := objectMemory getShrinkThreshold.
+ arg > 0 ifTrue:[
+ objectMemory setShrinkThreshold: arg.
+ self initPrimCall]].
+ index = 25 ifTrue: [
+ result := objectMemory getGrowHeadroom.
+ arg > 0 ifTrue:[
+ objectMemory setGrowHeadroom: arg.
+ self initPrimCall]].
+ index = 26 ifTrue: [
+ arg > 1 ifTrue:[
+ result := interruptChecksEveryNms.
+ interruptChecksEveryNms := arg.
+ self initPrimCall]].
+
+ self successful ifTrue: [
+ self pop: 3 thenPush: (objectMemory integerObjectOf: result). "return old value"
+ ^ nil].
+
+ self primitiveFail. "attempting to write a read-only parameter"
+
+
+
+ !
Item was added:
+ ----- Method: ContextInterpreter>>primitiveValue (in category 'control primitives') -----
+ primitiveValue
+ | blockContext blockArgumentCount initialIP |
+ blockContext := self stackValue: argumentCount.
+ blockArgumentCount := self argumentCountOfBlock: blockContext.
+ self success: (argumentCount = blockArgumentCount
+ and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory getNilObj]).
+ self successful
+ ifTrue: [self transfer: argumentCount
+ fromIndex: self stackPointerIndex - argumentCount + 1
+ ofObject: activeContext
+ toIndex: TempFrameStart
+ ofObject: blockContext.
+
+ "Assume: The call to transfer:... makes blockContext a root if necessary,
+ allowing use to use unchecked stored in the following code."
+ self pop: argumentCount + 1.
+ initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: blockContext.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP.
+ self storeStackPointerValue: argumentCount inContext: blockContext.
+ objectMemory storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext.
+ self newActiveContext: blockContext]!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveValueUninterruptably (in category 'control primitives') -----
+ primitiveValueUninterruptably
+ "The only purpose of this primitive is to indicate that the new EH mechanisms are supported."
+ <inline: false>
+ ^self primitiveValue!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveValueWithArgs (in category 'control primitives') -----
+ primitiveValueWithArgs
+ | argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |
+ argumentArray := self popStack.
+ blockContext := self popStack.
+ blockArgumentCount := self argumentCountOfBlock: blockContext.
+ "If the argArray isnt actually an Array we ahve to unpop the above two"
+ (objectMemory isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
+
+ self successful ifTrue: [arrayArgumentCount := objectMemory fetchWordLengthOf: argumentArray.
+ self success: (arrayArgumentCount = blockArgumentCount
+ and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory getNilObj])].
+ self successful
+ ifTrue: [self
+ transfer: arrayArgumentCount
+ fromIndex: 0
+ ofObject: argumentArray
+ toIndex: TempFrameStart
+ ofObject: blockContext.
+ "Assume: The call to transfer:... makes blockContext a root if necessary,
+ allowing use to use unchecked stored in the following code. "
+ initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: blockContext.
+ objectMemory
+ storePointerUnchecked: InstructionPointerIndex
+ ofObject: blockContext
+ withValue: initialIP.
+ self storeStackPointerValue: arrayArgumentCount inContext: blockContext.
+ objectMemory
+ storePointerUnchecked: CallerIndex
+ ofObject: blockContext
+ withValue: activeContext.
+ self newActiveContext: blockContext]
+ ifFalse: [self unPop: 2]!
Item was added:
+ ----- Method: ContextInterpreter>>print: (in category 'debug printing') -----
+ print: s
+ "For testing in Smalltalk, this method should be overridden in a subclass."
+
+ <var: #s type: 'char *'>
+ self cCode: 'printf("%s", s)'.!
Item was added:
+ ----- Method: ContextInterpreter>>printAllStacks (in category 'debug printing') -----
+ printAllStacks
+ "Print all the stacks of all running processes, including those that are currently suspended."
+ | oop proc ctx |
+ <export: true> "exported to permit access from plugins"
+ proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
+ self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5.
+ self cr.
+ self printCallStackOf: activeContext. "first the active context"
+ oop := objectMemory firstObject.
+ [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory] whileTrue:[
+ (objectMemory fetchClassOf: oop) == objectMemory classSemaphore ifTrue:[
+ self cr.
+ proc := objectMemory fetchPointer: FirstLinkIndex ofObject: oop.
+ [proc == objectMemory nilObject] whileFalse:[
+ self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5.
+ self cr.
+ ctx := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
+ ctx == objectMemory nilObject ifFalse:[self printCallStackOf: ctx].
+ proc := objectMemory fetchPointer: NextLinkIndex ofObject: proc].
+ ].
+ oop := objectMemory objectAfter: oop.
+ ].!
Item was added:
+ ----- Method: ContextInterpreter>>printCallStack (in category 'debug printing') -----
+ printCallStack
+ ^self printCallStackOf: activeContext!
Item was added:
+ ----- Method: ContextInterpreter>>printCallStackOf: (in category 'debug printing') -----
+ printCallStackOf: aContext
+
+ | ctxt home methClass methodSel message |
+ <inline: false>
+ ctxt := aContext.
+ [ctxt = objectMemory getNilObj] whileFalse: [
+ (objectMemory fetchClassOf: ctxt) = (objectMemory splObj: ClassBlockContext)
+ ifTrue: [ home := objectMemory fetchPointer: HomeIndex ofObject: ctxt ]
+ ifFalse: [ home := ctxt ].
+ methClass :=
+ self findClassOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
+ forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
+ methodSel :=
+ self findSelectorOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
+ forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
+ self printNum: ctxt.
+ self print: ' '.
+ ctxt = home ifFalse: [ self print: '[] in ' ].
+ self printNameOfClass: methClass count: 5.
+ self print: '>'.
+ methodSel = objectMemory getNilObj
+ ifTrue: [self print: '?']
+ ifFalse: [self printStringOf: methodSel].
+ methodSel = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue: [
+ "print arg message selector"
+ message := objectMemory fetchPointer: 0 + TempFrameStart ofObject: home.
+ methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: message.
+ self print: ' '.
+ self printStringOf: methodSel.
+ ].
+ self cr.
+
+ ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt).
+ ].!
Item was added:
+ ----- Method: ContextInterpreter>>printChar: (in category 'debug printing') -----
+ printChar: aByte
+ "For testing in Smalltalk, this method should be overridden in a subclass."
+
+ self putchar: aByte.!
Item was added:
+ ----- Method: ContextInterpreter>>printNameOfClass:count: (in category 'debug printing') -----
+ printNameOfClass: classOop count: cnt
+ "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
+
+ cnt <= 0 ifTrue: [ ^ self print: 'bad class' ].
+ (objectMemory sizeBitsOf: classOop) = (7 * objectMemory bytesPerWord) "(Metaclass instSize+1 * 4)"
+ ifTrue: [self printNameOfClass: (objectMemory fetchPointer: 5 "thisClass" ofObject: classOop)
+ count: cnt - 1.
+ self print: ' class']
+ ifFalse: [self printStringOf: (objectMemory fetchPointer: 6 "name" ofObject: classOop)]!
Item was added:
+ ----- Method: ContextInterpreter>>printNum: (in category 'debug printing') -----
+ printNum: n
+ "For testing in Smalltalk, this method should be overridden in a subclass."
+
+ self cCode: 'printf("%ld", (long) n)'.!
Item was added:
+ ----- Method: ContextInterpreter>>printStringOf: (in category 'debug printing') -----
+ printStringOf: oop
+
+ | fmt cnt i |
+ (objectMemory isIntegerObject: oop) ifTrue:[^nil].
+ fmt := objectMemory formatOf: oop.
+ fmt < 8 ifTrue: [ ^nil ].
+
+ cnt := 100 min: (objectMemory lengthOf: oop).
+ i := 0.
+ [i < cnt] whileTrue: [
+ self printChar: (objectMemory fetchByte: i ofObject: oop).
+ i := i + 1.
+ ].!
Item was added:
+ ----- Method: ContextInterpreter>>printUnbalancedStack: (in category 'debug printing') -----
+ printUnbalancedStack: primIdx
+ <inline: false>
+ self print: 'Stack unbalanced after '.
+ self successful
+ ifTrue:[self print:'successful primitive ']
+ ifFalse:[self print: 'failed primitive '].
+ self printNum: primIdx.
+ self cr.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>printUnbalancedStackFromNamedPrimitive (in category 'debug printing') -----
+ printUnbalancedStackFromNamedPrimitive
+ | lit |
+ <inline: false>
+ self print: 'Stack unbalanced after '.
+ self successful
+ ifTrue:[self print:'successful ']
+ ifFalse:[self print: 'failed '].
+ lit := self literal: 0 ofMethod: newMethod.
+ self printStringOf: (objectMemory fetchPointer: 1 ofObject: lit).
+ self print:' in '.
+ self printStringOf: (objectMemory fetchPointer: 0 ofObject: lit).
+ self cr.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>push: (in category 'contexts') -----
+ push: object
+
+ | sp |
+ objectMemory longAt: (sp := stackPointer + objectMemory bytesPerWord) put: object.
+ stackPointer := sp.!
Item was added:
+ ----- Method: ContextInterpreter>>pushActiveContextBytecode (in category 'stack bytecodes') -----
+ pushActiveContextBytecode
+ "Puts reclaimability of this context in question."
+
+ self fetchNextBytecode.
+ reclaimableContextCount := 0.
+ self internalPush: activeContext.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushBool: (in category 'contexts') -----
+ pushBool: trueOrFalse
+
+ trueOrFalse
+ ifTrue: [ self push: objectMemory getTrueObj ]
+ ifFalse: [ self push: objectMemory getFalseObj ].!
Item was added:
+ ----- Method: ContextInterpreter>>pushClosureCopyCopiedValuesBytecode (in category 'stack bytecodes') -----
+ pushClosureCopyCopiedValuesBytecode
+ "The compiler has pushed the values to be copied, if any. Find numArgs and numCopied in the byte following.
+ Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure.
+ Set numArgs as specified, and set startpc to the pc following the block size and jump over that code."
+ | newClosure numArgsNumCopied numArgs numCopied blockSize |
+ objectMemory bytesPerWord == 4
+ ifTrue: [imageFormatVersionNumber := 6504]
+ ifFalse: [imageFormatVersionNumber := 68002].
+ numArgsNumCopied := self fetchByte.
+ numArgs := numArgsNumCopied bitAnd: 16rF.
+ numCopied := numArgsNumCopied bitShift: -4.
+ "Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
+ blockSize := self fetchByte << 8.
+ blockSize := blockSize + self fetchByte.
+ self externalizeIPandSP. "This is a pain."
+ newClosure := self
+ closureNumArgs: numArgs
+ instructionPointer: ((objectMemory oopForPointer: localIP) + 2 - (method + objectMemory baseHeaderSize))
+ numCopiedValues: numCopied.
+ self internalizeIPandSP.
+ "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext.
+ reclaimableContextCount := 0. "The closure refers to thisContext so it can't be reclaimed."
+ numCopied > 0 ifTrue:
+ [0 to: numCopied - 1 do:
+ [:i|
+ "Assume: have just allocated a new BlockClosure; it must be young.
+ Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
+ ofObject: newClosure
+ withValue: (self internalStackValue: numCopied - i - 1)].
+ self internalPop: numCopied].
+ localIP := localIP + blockSize.
+ self fetchNextBytecode.
+ self internalPush: newClosure!
Item was added:
+ ----- Method: ContextInterpreter>>pushConstantFalseBytecode (in category 'stack bytecodes') -----
+ pushConstantFalseBytecode
+
+ self fetchNextBytecode.
+ self internalPush: objectMemory getFalseObj.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushConstantMinusOneBytecode (in category 'stack bytecodes') -----
+ pushConstantMinusOneBytecode
+
+ self fetchNextBytecode.
+ self internalPush: ConstMinusOne.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushConstantNilBytecode (in category 'stack bytecodes') -----
+ pushConstantNilBytecode
+
+ self fetchNextBytecode.
+ self internalPush: objectMemory getNilObj.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushConstantOneBytecode (in category 'stack bytecodes') -----
+ pushConstantOneBytecode
+
+ self fetchNextBytecode.
+ self internalPush: ConstOne.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushConstantTrueBytecode (in category 'stack bytecodes') -----
+ pushConstantTrueBytecode
+
+ self fetchNextBytecode.
+ self internalPush: objectMemory getTrueObj.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushConstantTwoBytecode (in category 'stack bytecodes') -----
+ pushConstantTwoBytecode
+
+ self fetchNextBytecode.
+ self internalPush: ConstTwo.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushConstantZeroBytecode (in category 'stack bytecodes') -----
+ pushConstantZeroBytecode
+
+ self fetchNextBytecode.
+ self internalPush: ConstZero.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushFloat: (in category 'stack bytecodes') -----
+ pushFloat: f
+
+ <var: #f type: 'double '>
+ self push: (self floatObjectOf: f).!
Item was added:
+ ----- Method: ContextInterpreter>>pushInteger: (in category 'contexts') -----
+ pushInteger: integerValue
+ self push: (objectMemory integerObjectOf: integerValue).!
Item was added:
+ ----- Method: ContextInterpreter>>pushLiteralConstant: (in category 'stack bytecodes') -----
+ pushLiteralConstant: literalIndex
+
+ self internalPush: (self literal: literalIndex).!
Item was added:
+ ----- Method: ContextInterpreter>>pushLiteralConstantBytecode (in category 'stack bytecodes') -----
+ pushLiteralConstantBytecode
+
+ self flag: #'requires currentBytecode to be expanded to a constant'.
+ self fetchNextBytecode.
+ "this bytecode will be expanded so that refs to currentBytecode below will be constant"
+ self pushLiteralConstant: (currentBytecode bitAnd: 16r1F).
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushLiteralVariable: (in category 'stack bytecodes') -----
+ pushLiteralVariable: literalIndex
+
+ self internalPush:
+ (objectMemory fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).!
Item was added:
+ ----- Method: ContextInterpreter>>pushLiteralVariableBytecode (in category 'stack bytecodes') -----
+ pushLiteralVariableBytecode
+
+ self flag: #'requires currentBytecode to be expanded to a constant'.
+ self fetchNextBytecode.
+ "this bytecode will be expanded so that refs to currentBytecode below will be constant"
+ self pushLiteralVariable: (currentBytecode bitAnd: 16r1F).
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushNewArrayBytecode (in category 'stack bytecodes') -----
+ pushNewArrayBytecode
+ | size popValues array |
+ size := self fetchByte.
+ popValues := size > 127.
+ size := size bitAnd: 127.
+ self fetchNextBytecode.
+ self externalizeIPandSP.
+ array := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: size.
+ self internalizeIPandSP.
+ popValues ifTrue:
+ [0 to: size - 1 do:
+ [:i|
+ "Assume: have just allocated a new Array; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: i ofObject: array withValue: (self internalStackValue: size - i - 1)].
+ self internalPop: size].
+ self internalPush: array!
Item was added:
+ ----- Method: ContextInterpreter>>pushReceiverBytecode (in category 'stack bytecodes') -----
+ pushReceiverBytecode
+
+ self fetchNextBytecode.
+ self internalPush: receiver.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushReceiverVariable: (in category 'stack bytecodes') -----
+ pushReceiverVariable: fieldIndex
+
+ self internalPush:
+ (objectMemory fetchPointer: fieldIndex ofObject: receiver).!
Item was added:
+ ----- Method: ContextInterpreter>>pushReceiverVariableBytecode (in category 'stack bytecodes') -----
+ pushReceiverVariableBytecode
+
+ self flag: #'requires currentBytecode to be expanded to a constant'.
+ self fetchNextBytecode.
+ "this bytecode will be expanded so that refs to currentBytecode below will be constant"
+ self pushReceiverVariable: (currentBytecode bitAnd: 16rF).
+ !
Item was added:
+ ----- Method: ContextInterpreter>>pushRemoteTemp:inVectorAt: (in category 'stack bytecodes') -----
+ pushRemoteTemp: index inVectorAt: tempVectorIndex
+ | tempVector |
+ tempVector := self temporary: tempVectorIndex.
+ self internalPush: (objectMemory fetchPointer: index ofObject: tempVector)!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>pushTemporaryVariable: (in category 'stack bytecodes') -----
+ pushTemporaryVariable: temporaryIndex
+
+ self internalPush: (self temporary: temporaryIndex).!
Item was added:
+ ----- Method: ContextInterpreter>>pushTemporaryVariableBytecode (in category 'stack bytecodes') -----
+ pushTemporaryVariableBytecode
+
+ self flag: #'requires currentBytecode to be expanded to a constant'.
+ self fetchNextBytecode.
+ "this bytecode will be expanded so that refs to currentBytecode below will be constant"
+ self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).
+ !
Item was added:
+ ----- Method: ContextInterpreter>>putLong:toFile: (in category 'image save/restore') -----
+ putLong: aWord toFile: aFile
+ "Append aWord to aFile in this platforms 'natural' byte order. (Bytes will be swapped, if
+ necessary, when the image is read on a different platform.) Set primFailCode if the
+ write fails."
+
+ | objectsWritten |
+ <var: #aFile type: 'sqImageFile '>
+
+ objectsWritten := self cCode: 'sqImageFileWrite(&aWord, sizeof(aWord), 1, aFile)'.
+ self success: objectsWritten = 1.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>putToSleep: (in category 'process primitive support') -----
+ putToSleep: aProcess
+ "Save the given process on the scheduler process list for its priority."
+
+ | priority processLists processList |
+ priority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
+ processLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ processList := objectMemory fetchPointer: priority - 1 ofObject: processLists.
+ self addLastLink: aProcess toList: processList.!
Item was added:
+ ----- Method: ContextInterpreter>>putToSleep:yieldingIf: (in category 'process primitive support') -----
+ putToSleep: aProcess yieldingIf: yieldImplicitly
+ "Save the given process on the scheduler process list for its priority,
+ adding to the back if yieldImplicitly or to the front if not yieldImplicitly."
+
+ | priority processLists processList |
+ priority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
+ processLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ processList := objectMemory fetchPointer: priority - 1 ofObject: processLists.
+ yieldImplicitly
+ ifTrue: [self addLastLink: aProcess toList: processList]
+ ifFalse: [self addFirstLink: aProcess toList: processList]!
Item was added:
+ ----- Method: ContextInterpreter>>quickCheckForInterrupts (in category 'process primitive support') -----
+ quickCheckForInterrupts
+ "Quick check for possible user or timer interrupts. Decrement a counter and only do a real check when counter reaches zero or when a low space or user interrupt is pending."
+ "Note: Clients that trigger interrupts should set use forceInterruptCheck to set interruptCheckCounter to zero and get immediate results."
+ "Note: Requires that instructionPointer and stackPointer be external."
+
+ ((interruptCheckCounter := interruptCheckCounter - 1) <= 0)
+ ifTrue: [self checkForInterrupts].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>quickFetchInteger:ofObject: (in category 'utilities') -----
+ quickFetchInteger: fieldIndex ofObject: objectPointer
+ "Return the integer value of the field without verifying that it is an integer value!! For use in time-critical places where the integer-ness of the field can be guaranteed."
+
+ ^ objectMemory integerValueOf: (objectMemory fetchPointer: fieldIndex ofObject: objectPointer).!
Item was added:
+ ----- Method: ContextInterpreter>>readImageFormatFromFile:StartingAt: (in category 'image save/restore') -----
+ readImageFormatFromFile: f StartingAt: imageOffset
+ "Read an image header from the given file stream, and answer the image format
+ version number for the saved image. Exported to allow platform support code to
+ query image files for image format number."
+
+ <export: true>
+ <var: #f type: 'sqImageFile '>
+ <var: #imageOffset type: 'squeakFileOffsetType '>
+
+ self checkImageVersionFrom: f startingAt: imageOffset.
+ ^ imageFormatInitialVersion
+ !
Item was added:
+ ----- Method: ContextInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
+ readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
+ "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
+ "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
+ "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
+
+ | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
+ <var: #f type: 'sqImageFile '>
+ <var: #desiredHeapSize type: 'usqInt'>
+ <var: #headerStart type: 'squeakFileOffsetType '>
+ <var: #dataSize type: 'size_t '>
+ <var: #imageOffset type: 'squeakFileOffsetType '>
+
+ swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - objectMemory bytesPerWord. "record header start position"
+
+ headerSize := self getLongFromFile: f swap: swapBytes.
+ dataSize := self getLongFromFile: f swap: swapBytes.
+ oldBaseAddr := self getLongFromFile: f swap: swapBytes.
+ objectMemory setSpecialObjectsOop: (self getLongFromFile: f swap: swapBytes).
+ objectMemory setLastHash: (self getLongFromFile: f swap: swapBytes).
+ savedWindowSize := self getLongFromFile: f swap: swapBytes.
+ fullScreenFlag := self oldFormatFullScreenFlag: (self getLongFromFile: f swap: swapBytes).
+ extraVMMemory := self getLongFromFile: f swap: swapBytes.
+
+ objectMemory getLastHash = 0 ifTrue: [
+ "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
+ objectMemory setLastHash: 999].
+
+ "decrease Squeak object heap to leave extra memory for the VM"
+ heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
+
+ "compare memory requirements with availability".
+ minimumMemory := dataSize + 100000. "need at least 100K of breathing room"
+ heapSize < minimumMemory ifTrue: [
+ self insufficientMemorySpecifiedError].
+
+ "allocate a contiguous block of memory for the Squeak heap"
+ (objectMemory allocateMemory: heapSize
+ minimum: minimumMemory
+ imageFile: f
+ headerSize: headerSize) = nil ifTrue: [self insufficientMemoryAvailableError].
+
+ memStart := objectMemory startOfMemory.
+ objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
+ objectMemory setEndOfMemory: memStart + dataSize.
+
+ "position file after the header"
+ self sqImageFile: f Seek: headerStart + headerSize.
+
+ "read in the image in bulk, then swap the bytes if necessary"
+ bytesRead := self
+ sqImage: (objectMemory pointerForOop: objectMemory getMemory)
+ read: f
+ size: (self cCode: 'sizeof(unsigned char)')
+ length: dataSize.
+ bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
+
+ objectMemory headerTypeBytesAt: 0 put: objectMemory bytesPerWord * 2. "3-word header (type 0)"
+ objectMemory headerTypeBytesAt: 1 put: objectMemory bytesPerWord. "2-word header (type 1)"
+ objectMemory headerTypeBytesAt: 2 put: 0. "free chunk (type 2)"
+ objectMemory headerTypeBytesAt: 3 put: 0. "1-word header (type 3)"
+
+ swapBytes ifTrue: [self reverseBytesInImage].
+
+ "compute difference between old and new memory base addresses"
+ bytesToShift := memStart - oldBaseAddr.
+ self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
+ self isBigEnder. "work out the machine endianness and cache the answer"
+
+ (self initialImageFormatVersion bitAnd: 1) = 1
+ ifTrue: ["Low order bit set, indicating that the image was saved from
+ a StackInterpreter (Cog) VM. Storage of all Float objects must be
+ returned to older object memory format."
+ self normalizeFloatOrderingInImage].
+
+ ^ dataSize
+ !
Item was added:
+ ----- Method: ContextInterpreter>>readableFormat: (in category 'image save/restore') -----
+ readableFormat: imageVersion
+ "Anwer true if images of the given format are readable by this interpreter. Allows
+ a virtual machine to accept selected older image formats. In our case we can
+ select a newer (closure) image format as well as the existing format. Images with
+ platform-ordered floats (StackInterpreter and Cog format) are readable but will be
+ converted to traditional word ordering."
+
+ objectMemory bytesPerWord = 4
+ ifTrue: [^ (imageVersion = 6502 "Original 32-bit Squeak image format"
+ or: [imageVersion = 6504]) "32-bit with closures"
+ or: [imageVersion = 6505]] "32-bit with closures and platform-ordered floats"
+ ifFalse: [^ (imageVersion = 68000 "Original 64-bit Squeak image format"
+ or: [imageVersion = 68002]) "64-bit with closures"
+ or: [imageVersion = 68003]] "64-bit with closures and platform-ordered floats"
+ !
Item was added:
+ ----- Method: ContextInterpreter>>reestablishContextPriorToCallback: (in category 'contexts') -----
+ reestablishContextPriorToCallback: callbackContext
+ "callbackContext is an activation of invokeCallback:stack:registers:jmpbuf:. Its sender
+ is the interpreter's state prior to the callback. Reestablish that state."
+ | calloutContext |
+ <export: true>
+ (objectMemory fetchClassOf: callbackContext) ~~ (objectMemory splObj: ClassMethodContext) ifTrue:
+ [^false].
+ calloutContext := objectMemory fetchPointer: SenderIndex ofObject: callbackContext.
+ self newActiveContext: calloutContext.
+ ^true!
Item was added:
+ ----- Method: ContextInterpreter>>removeFirstLinkOfList: (in category 'process primitive support') -----
+ removeFirstLinkOfList: aList
+ "Remove the first process from the given linked list."
+ | first last next |
+ first := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
+ last := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
+ first = last
+ ifTrue: [objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: objectMemory getNilObj.
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory getNilObj]
+ ifFalse: [next := objectMemory fetchPointer: NextLinkIndex ofObject: first.
+ objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: next].
+ objectMemory storePointer: NextLinkIndex ofObject: first withValue: objectMemory getNilObj.
+ ^ first!
Item was added:
+ ----- Method: ContextInterpreter>>removeProcess:fromList: (in category 'process primitive support') -----
+ removeProcess: aProcess fromList: aList
+ "Remove a given process from a linked list. May fail if aProcess is not on the list."
+ | firstLink lastLink nextLink tempLink |
+ firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
+ lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
+ aProcess == firstLink ifTrue:[
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess .
+ objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: nextLink.
+ aProcess == lastLink ifTrue:[
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory nilObject.
+ ].
+ ] ifFalse:[
+ tempLink := firstLink.
+ [tempLink == objectMemory nilObject ifTrue:[^self success: false]. "fail"
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
+ nextLink == aProcess] whileFalse:[
+ tempLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
+ ].
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess.
+ objectMemory storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink.
+ aProcess == lastLink ifTrue:[
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: tempLink.
+ ].
+ ].
+ objectMemory storePointer: NextLinkIndex ofObject: aProcess withValue: objectMemory nilObject.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>resume: (in category 'process primitive support') -----
+ resume: aProcess
+ | activeProc activePriority newPriority |
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
+ activePriority := self quickFetchInteger: PriorityIndex ofObject: activeProc.
+ newPriority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
+ newPriority > activePriority
+ ifTrue: [self putToSleep: activeProc.
+ self transferTo: aProcess]
+ ifFalse: [self putToSleep: aProcess]!
Item was added:
+ ----- Method: ContextInterpreter>>returnFalse (in category 'return bytecodes') -----
+ returnFalse
+ localReturnContext := self sender.
+ localReturnValue := objectMemory getFalseObj.
+ self commonReturn.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>returnNil (in category 'return bytecodes') -----
+ returnNil
+ localReturnContext := self sender.
+ localReturnValue := objectMemory getNilObj.
+ self commonReturn.!
Item was added:
+ ----- Method: ContextInterpreter>>returnReceiver (in category 'return bytecodes') -----
+ returnReceiver
+ localReturnContext := self sender.
+ localReturnValue := receiver.
+ self commonReturn.!
Item was added:
+ ----- Method: ContextInterpreter>>returnTopFromBlock (in category 'return bytecodes') -----
+ returnTopFromBlock
+ "Return to the caller of the method containing the block."
+ localReturnContext := self caller. "Note: caller, not sender!!"
+ localReturnValue := self internalStackTop.
+ self commonReturn.!
Item was added:
+ ----- Method: ContextInterpreter>>returnTopFromMethod (in category 'return bytecodes') -----
+ returnTopFromMethod
+ localReturnContext := self sender.
+ localReturnValue := self internalStackTop.
+ self commonReturn.!
Item was added:
+ ----- Method: ContextInterpreter>>returnTrue (in category 'return bytecodes') -----
+ returnTrue
+ localReturnContext := self sender.
+ localReturnValue := objectMemory getTrueObj.
+ self commonReturn.!
Item was added:
+ ----- Method: ContextInterpreter>>reverseBytesInImage (in category 'image save/restore') -----
+ reverseBytesInImage
+ "Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."
+
+ "First, byte-swap every word in the image. This fixes objects headers."
+ objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory getEndOfMemory.
+
+ "Second, return the bytes of bytes-type objects to their orginal order."
+ self byteSwapByteObjects.!
Item was added:
+ ----- Method: ContextInterpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
+ reverseDisplayFrom: startIndex to: endIndex
+ "Reverse the given range of Display words (at different bit
+ depths, this will reverse different numbers of pixels). Used to
+ give feedback during VM activities such as garbage
+ collection when debugging. It is assumed that the given
+ word range falls entirely within the first line of the Display."
+ | displayObj dispBitsPtr w reversed |
+ displayObj := objectMemory splObj: TheDisplay.
+ ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
+ w := self fetchInteger: 1 ofObject: displayObj.
+ dispBitsPtr := objectMemory fetchPointer: 0 ofObject: displayObj.
+ (objectMemory isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
+ dispBitsPtr := dispBitsPtr + objectMemory baseHeaderSize.
+ dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
+ do: [:ptr |
+ reversed := (objectMemory long32At: ptr) bitXor: 4294967295.
+ objectMemory longAt: ptr put: reversed].
+ self initPrimCall.
+ self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
+ self ioForceDisplayUpdate!
Item was added:
+ ----- Method: ContextInterpreter>>rewriteMethodCacheSel:class:primIndex: (in category 'method lookup cache') -----
+ rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex
+
+ "Rewrite the cache entry with the given primitive index and matching function pointer"
+ | primPtr |
+ <var: #primPtr declareC: 'void (*primPtr)(void)'>
+ <inline: false>
+ localPrimIndex = 0
+ ifTrue: [primPtr := 0]
+ ifFalse: [primPtr := primitiveTable at: localPrimIndex].
+ self
+ rewriteMethodCacheSel: selector class: class
+ primIndex: localPrimIndex primFunction: primPtr!
Item was added:
+ ----- Method: ContextInterpreter>>rewriteMethodCacheSel:class:primIndex:primFunction: (in category 'method lookup cache') -----
+ rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex primFunction: localPrimAddress
+ "Rewrite an existing entry in the method cache with a new primitive
+ index & function address. Used by primExternalCall to make direct jumps to found external prims"
+ | probe hash |
+ <inline: false>
+ <var: #localPrimAddress declareC: 'void (*localPrimAddress)(void)'>
+ hash := selector bitXor: class.
+ 0 to: CacheProbeMax - 1 do: [:p |
+ probe := hash >> p bitAnd: MethodCacheMask.
+ ((methodCache at: probe + MethodCacheSelector) = selector
+ and: [(methodCache at: probe + MethodCacheClass) = class])
+ ifTrue: [methodCache at: probe + MethodCachePrim put: localPrimIndex.
+ methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: localPrimAddress to: 'long').
+ ^ nil]]!
Item was added:
+ ----- Method: ContextInterpreter>>roomToPushNArgs: (in category 'primitive support') -----
+ roomToPushNArgs: n
+ "Answer if there is room to push n arguments onto the current stack.
+ There may be room in this stackPage but there may not be room if
+ the frame were converted into a context."
+ | cntxSize |
+ ((self headerOf: method) bitAnd: LargeContextBit) ~= 0
+ ifTrue: [cntxSize := objectMemory largeContextSize / objectMemory bytesPerWord - ReceiverIndex]
+ ifFalse: [cntxSize := objectMemory smallContextSize / objectMemory bytesPerWord - ReceiverIndex].
+ ^self stackPointerIndex + n <= cntxSize!
Item was added:
+ ----- Method: ContextInterpreter>>saveProcessSignalingLowSpace (in category 'process primitive support') -----
+ saveProcessSignalingLowSpace
+ "The low space semaphore is about to be signaled. Save the currently active
+ process in the special objects array so that the low space handler will be able
+ to determine the process that first triggered a low space condition. The low
+ space handler (in the image) is expected to nil out the special objects array
+ slot when it handles the low space condition."
+
+ | lastSavedProcess sched currentProc |
+ lastSavedProcess := objectMemory splObj: ProcessSignalingLowSpace.
+ (lastSavedProcess == objectMemory nilObject) ifTrue:
+ [sched := self schedulerPointer.
+ currentProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
+ objectMemory storePointer: ProcessSignalingLowSpace ofObject: objectMemory getSpecialObjectsOop withValue: currentProc]!
Item was added:
+ ----- Method: ContextInterpreter>>secondExtendedSendBytecode (in category 'send bytecodes') -----
+ secondExtendedSendBytecode
+ "This replaces the Blue Book double-extended super-send [134],
+ which is subsumed by the new double-extended do-anything [132].
+ It offers a 2-byte send of 0-3 args for up to 63 literals, for which
+ the Blue Book opcode set requires a 3-byte instruction."
+
+ | descriptor |
+ descriptor := self fetchByte.
+ messageSelector := self literal: (descriptor bitAnd: 16r3F).
+ argumentCount := descriptor >> 6.
+ self normalSend.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'alien support') -----
+ sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
+ "Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
+ to Alien class with the supplied args. The arguments are raw C addresses
+ and are converted to integer objects on the way."
+ | where |
+ <export: true>
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
+ receiver := objectMemory splObj: ClassAlien.
+ lkupClass := objectMemory fetchClassOfNonInt: receiver.
+ messageSelector := objectMemory splObj: objectMemory invokeCallbackSelector.
+ (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
+ [(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
+ [^false]].
+ primitiveIndex ~= 0 ifTrue:
+ [^false].
+ self storeContextRegisters: activeContext.
+ self internalJustActivateNewMethod.
+ where := activeContext + objectMemory baseHeaderSize + (ReceiverIndex << objectMemory shiftForWord).
+ objectMemory longAt: where + (1 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
+ objectMemory longAt: where + (2 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
+ objectMemory longAt: where + (3 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
+ objectMemory longAt: where + (4 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
+ self fetchContextRegisters: activeContext.
+ self callInterpreter.
+ "not reached"
+ ^true!
Item was added:
+ ----- Method: ContextInterpreter>>sendLiteralSelectorBytecode (in category 'send bytecodes') -----
+ sendLiteralSelectorBytecode
+ "Can use any of the first 16 literals for the selector and pass up to 2 arguments."
+
+ messageSelector := self literal: (currentBytecode bitAnd: 16rF).
+ argumentCount := ((currentBytecode >> 4) bitAnd: 3) - 1.
+ self normalSend!
Item was added:
+ ----- Method: ContextInterpreter>>sender (in category 'contexts') -----
+ sender
+
+ | context closureOrNil |
+ context := localHomeContext.
+ [(closureOrNil := objectMemory fetchPointer: ClosureIndex ofObject: context) ~~ objectMemory getNilObj] whileTrue:
+ [context := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closureOrNil].
+ ^objectMemory fetchPointer: SenderIndex ofObject: context!
Item was added:
+ ----- Method: ContextInterpreter>>setCompilerInitialized: (in category 'compiler support') -----
+ setCompilerInitialized: newFlag
+ | oldFlag |
+ oldFlag := compilerInitialized.
+ compilerInitialized := newFlag.
+ ^oldFlag!
Item was added:
+ ----- Method: ContextInterpreter>>setFullScreenFlag: (in category 'plugin primitive support') -----
+ setFullScreenFlag: value
+ fullScreenFlag := value!
Item was added:
+ ----- Method: ContextInterpreter>>setInterruptCheckCounter: (in category 'plugin primitive support') -----
+ setInterruptCheckCounter: value
+ interruptCheckCounter := value!
Item was added:
+ ----- Method: ContextInterpreter>>setInterruptKeycode: (in category 'plugin primitive support') -----
+ setInterruptKeycode: value
+ interruptKeycode := value!
Item was added:
+ ----- Method: ContextInterpreter>>setInterruptPending: (in category 'plugin primitive support') -----
+ setInterruptPending: value
+ interruptPending := value!
Item was added:
+ ----- Method: ContextInterpreter>>setMicroSeconds:andOffset: (in category 'utilities') -----
+ setMicroSeconds: microSeconds andOffset: utcOffset
+ "A default substitute for unimplemented ioUtcWithOffset external function."
+ <var: #microSeconds type: 'sqLong *'>
+ <var: #utcOffset type: 'int *'>
+
+ self flag: #toRemove. "after implementing ioUtcWithOffset in support code for all platforms"
+
+ ^ -1
+
+ "The corresponding platform support function for a GNU unix system is:
+ sqInt ioUtcWithOffset(sqLong *microSeconds, int *offset)
+ {
+ struct timeval timeval;
+ if (gettimeofday(&timeval, NULL) == -1) return -1;
+ long long seconds = timeval.tv_sec;
+ suseconds_t usec = timeval.tv_usec;
+ *microSeconds = seconds * 1000000 + usec;
+ *offset = localtime(&seconds)->tm_gmtoff;
+ return 0;
+ }"
+ !
Item was added:
+ ----- Method: ContextInterpreter>>setNextWakeupTick: (in category 'plugin primitive support') -----
+ setNextWakeupTick: value
+ nextWakeupTick := value!
Item was added:
+ ----- Method: ContextInterpreter>>setSavedWindowSize: (in category 'plugin primitive support') -----
+ setSavedWindowSize: value
+ savedWindowSize := value!
Item was added:
+ ----- Method: ContextInterpreter>>shortConditionalJump (in category 'jump bytecodes') -----
+ shortConditionalJump
+
+ self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.!
Item was added:
+ ----- Method: ContextInterpreter>>shortUnconditionalJump (in category 'jump bytecodes') -----
+ shortUnconditionalJump
+
+ self jump: (currentBytecode bitAnd: 7) + 1.!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>signalExternalSemaphores (in category 'process primitive support') -----
+ signalExternalSemaphores
+ "Signal all requested semaphores"
+ | xArray xSize index sema |
+ semaphoresUseBufferA := semaphoresUseBufferA not.
+ xArray := objectMemory splObj: ExternalObjectsArray.
+ xSize := self stSizeOf: xArray.
+ semaphoresUseBufferA
+ ifTrue: ["use opposite buffer during read"
+ 1 to: semaphoresToSignalCountB do: [:i |
+ index := semaphoresToSignalB at: i.
+ index <= xSize
+ ifTrue: [sema := objectMemory fetchPointer: index - 1 ofObject: xArray.
+ "Note: semaphore indices are 1-based"
+ (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
+ ifTrue: [self synchronousSignal: sema]]].
+ semaphoresToSignalCountB := 0]
+ ifFalse: [1 to: semaphoresToSignalCountA do: [:i |
+ index := semaphoresToSignalA at: i.
+ index <= xSize
+ ifTrue: [sema := objectMemory fetchPointer: index - 1 ofObject: xArray.
+ "Note: semaphore indices are 1-based"
+ (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
+ ifTrue: [self synchronousSignal: sema]]].
+ semaphoresToSignalCountA := 0]!
Item was added:
+ ----- Method: ContextInterpreter>>signalFinalization: (in category 'process primitive support') -----
+ signalFinalization: weakReferenceOop
+ "If it is not there already, record the given semaphore index in the list of semaphores to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."
+
+ self forceInterruptCheck.
+ pendingFinalizationSignals := pendingFinalizationSignals + 1.!
Item was added:
+ ----- Method: ContextInterpreter>>signalSemaphoreWithIndex: (in category 'process primitive support') -----
+ signalSemaphoreWithIndex: index
+ "Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."
+
+ index <= 0 ifTrue: [^ nil]. "bad index; ignore it"
+
+ semaphoresUseBufferA
+ ifTrue: [semaphoresToSignalCountA < SemaphoresToSignalSize
+ ifTrue: [ semaphoresToSignalCountA := semaphoresToSignalCountA + 1.
+ semaphoresToSignalA at: semaphoresToSignalCountA put: index]]
+ ifFalse: [semaphoresToSignalCountB < SemaphoresToSignalSize
+ ifTrue: [ semaphoresToSignalCountB := semaphoresToSignalCountB + 1.
+ semaphoresToSignalB at: semaphoresToSignalCountB put: index]].
+ self forceInterruptCheck
+ !
Item was added:
+ ----- Method: ContextInterpreter>>signed32BitIntegerFor: (in category 'primitive support') -----
+ signed32BitIntegerFor: integerValue
+ "Return a full 32 bit integer object for the given integer value"
+ | newLargeInteger value largeClass |
+ <inline: false>
+ <var: #integerValue type: 'int'>
+ (objectMemory isIntegerValue: integerValue)
+ ifTrue: [^ objectMemory integerObjectOf: integerValue].
+ integerValue < 0
+ ifTrue:[ largeClass := objectMemory classLargeNegativeInteger.
+ value := 0 - integerValue]
+ ifFalse:[ largeClass := objectMemory classLargePositiveInteger.
+ value := integerValue].
+ newLargeInteger := objectMemory instantiateClass: largeClass indexableSize: 4.
+ objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((value >> 24) bitAnd: 16rFF).
+ objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((value >> 16) bitAnd: 16rFF).
+ objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((value >> 8) bitAnd: 16rFF).
+ objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (value bitAnd: 16rFF).
+ ^ newLargeInteger!
Item was added:
+ ----- Method: ContextInterpreter>>signed64BitIntegerFor: (in category 'primitive support') -----
+ 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 := objectMemory classLargeNegativeInteger.
+ magnitude := 0 - integerValue]
+ ifFalse:[ largeClass := objectMemory classLargePositiveInteger.
+ magnitude := integerValue].
+
+ magnitude <= 16r7FFFFFFF ifTrue:[^self signed32BitIntegerFor: integerValue].
+
+ highWord := self
+ cCode: 'magnitude >> 32' "shift is coerced to usqInt otherwise"
+ inSmalltalk: [magnitude bitShift: -32].
+ 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 := objectMemory instantiateClass: largeClass indexableSize: sz.
+ 0 to: sz-1 do: [:i |
+ intValue := self
+ cCode: '(magnitude >> (i * 8)) & 255'
+ inSmalltalk: [(magnitude bitShift: (i * 8) negated) bitAnd: 16rFF].
+ objectMemory storeByte: i ofObject: newLargeInteger withValue: intValue].
+ ^ newLargeInteger!
Item was added:
+ ----- Method: ContextInterpreter>>singleExtendedSendBytecode (in category 'send bytecodes') -----
+ singleExtendedSendBytecode
+ "Can use any of the first 32 literals for the selector and pass up to 7 arguments."
+
+ | descriptor |
+ descriptor := self fetchByte.
+ messageSelector := self literal: (descriptor bitAnd: 16r1F).
+ argumentCount := descriptor >> 5.
+ self normalSend.!
Item was added:
+ ----- Method: ContextInterpreter>>singleExtendedSuperBytecode (in category 'send bytecodes') -----
+ singleExtendedSuperBytecode
+ "Can use any of the first 32 literals for the selector and pass up to 7 arguments."
+
+ | descriptor |
+ descriptor := self fetchByte.
+ messageSelector := self literal: (descriptor bitAnd: 16r1F).
+ argumentCount := descriptor >> 5.
+ self superclassSend.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') -----
+ sizeOfSTArrayFromCPrimitive: cPtr
+ "Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
+ "Note: Only called by translated primitive code."
+
+ | oop |
+ <var: #cPtr type: 'void *'>
+ oop := (objectMemory oopForPointer: (self cCoerce: cPtr to: 'char *')) - objectMemory baseHeaderSize.
+ (objectMemory isWordsOrBytes: oop) ifFalse: [
+ self primitiveFail.
+ ^0].
+ ^objectMemory lengthOf: oop
+ !
Item was added:
+ ----- Method: ContextInterpreter>>snapshot: (in category 'image save/restore') -----
+ snapshot: embedded
+ "update state of active context"
+ | activeProc dataSize rcvr setMacType |
+ <var: #setMacType type: 'void *'>
+ compilerInitialized
+ ifTrue: [self compilerPreSnapshot]
+ ifFalse: [self storeContextRegisters: activeContext].
+
+ "update state of active process"
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
+ objectMemory
+ storePointer: SuspendedContextIndex
+ ofObject: activeProc
+ withValue: activeContext.
+
+ "compact memory and compute the size of the memory actually in use"
+ objectMemory incrementalGC.
+
+ "maximimize space for forwarding table"
+ objectMemory fullGC.
+ self snapshotCleanUp.
+
+ dataSize := objectMemory getFreeBlock - objectMemory startOfMemory. "Assume all objects are below the start of the free block"
+ self successful
+ ifTrue: [rcvr := self popStack.
+ "pop rcvr"
+ self push: objectMemory getTrueObj.
+ self writeImageFile: dataSize.
+ embedded
+ ifFalse: ["set Mac file type and creator; this is a noop on other platforms"
+ setMacType := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
+ setMacType = 0
+ ifFalse: [self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
+ self pop: 1].
+
+ "activeContext was unmarked in #snapshotCleanUp, mark it old "
+ objectMemory beRootIfOld: activeContext.
+ self successful
+ ifTrue: [self push: objectMemory getFalseObj]
+ ifFalse: [self push: rcvr].
+ compilerInitialized
+ ifTrue: [self compilerPostSnapshot]!
Item was added:
+ ----- Method: ContextInterpreter>>snapshotCleanUp (in category 'image save/restore') -----
+ snapshotCleanUp
+ "Clean up right before saving an image, sweeping memory and:
+ * nilling out all fields of contexts above the stack pointer.
+ * flushing external primitives
+ * clearing the root bit of any object in the root table "
+ | oop header fmt sz |
+ oop := objectMemory firstObject.
+ [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory]
+ whileTrue: [(objectMemory isFreeObject: oop)
+ ifFalse: [header := objectMemory longAt: oop.
+ fmt := header >> 8 bitAnd: 15.
+ "Clean out context"
+ (fmt = 3 and: [self isContextHeader: header])
+ ifTrue: [sz := objectMemory sizeBitsOf: oop.
+ (objectMemory lastPointerOf: oop) + objectMemory bytesPerWord
+ to: sz - objectMemory baseHeaderSize by: objectMemory bytesPerWord
+ do: [:i | objectMemory longAt: oop + i put: objectMemory getNilObj]].
+ "Clean out external functions"
+ fmt >= 12
+ ifTrue: ["This is a compiled method"
+ (self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
+ ifTrue: ["It's primitiveExternalCall"
+ self flushExternalPrimitiveOf: oop]]].
+ oop := objectMemory objectAfter: oop].
+ objectMemory clearRootsTable!
Item was added:
+ ----- Method: ContextInterpreter>>specialSelector: (in category 'message sending') -----
+ specialSelector: index
+
+ ^ objectMemory fetchPointer: (index * 2) ofObject: (objectMemory splObj: SpecialSelectors)!
Item was added:
+ ----- Method: ContextInterpreter>>sqImage:read:size:length: (in category 'image save/restore') -----
+ sqImage: memoryAddress read: fileStream size: elementSize length: length
+ "Normally implemented in support code as fread().
+ See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation."
+
+ <inline: true>
+ <returnTypeC: 'size_t'>
+ <var: #memoryAddress type: 'char *'>
+ <var: #elementSize type: 'size_t'>
+ <var: #length type: 'size_t'>
+ <var: #fileStream type: 'sqImageFile'>
+ ^ self sqImage: memoryAddress File: elementSize ReadEntire: length Image: fileStream
+
+ !
Item was added:
+ ----- Method: ContextInterpreter>>sqImage:write:size:length: (in category 'image save/restore') -----
+ sqImage: memoryAddress write: fileStream size: elementSize length: length
+ "Normally implemented in support code as fwrite()"
+
+ <inline: true>
+ <returnTypeC: 'size_t'>
+ <var: #memoryAddress type: 'char *'>
+ <var: #elementSize type: 'size_t'>
+ <var: #length type: 'size_t'>
+ <var: #fileStream type: 'sqImageFile'>
+ ^ self sq: memoryAddress Image: elementSize File: length Write: fileStream "sqImageFileWrite()"
+ !
Item was added:
+ ----- Method: ContextInterpreter>>stObject:at: (in category 'array primitive support') -----
+ stObject: array at: index
+ "Return what ST would return for <obj> at: index."
+
+ | hdr fmt totalLength fixedFields stSize |
+ <inline: false>
+ hdr := objectMemory baseHeader: array.
+ fmt := (hdr >> 8) bitAnd: 16rF.
+ totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
+ fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
+ (fmt = 3 and: [self isContextHeader: hdr])
+ ifTrue: [stSize := self fetchStackPointerOf: array]
+ ifFalse: [stSize := totalLength - fixedFields].
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
+ ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt]
+ ifFalse: [self primitiveFail. ^ 0].!
Item was added:
+ ----- Method: ContextInterpreter>>stObject:at:put: (in category 'array primitive support') -----
+ stObject: array at: index put: value
+ "Do what ST would return for <obj> at: index put: value."
+ | hdr fmt totalLength fixedFields stSize |
+ <inline: false>
+ hdr := objectMemory baseHeader: array.
+ fmt := (hdr >> 8) bitAnd: 16rF.
+ totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
+ fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
+ (fmt = 3 and: [self isContextHeader: hdr])
+ ifTrue: [stSize := self fetchStackPointerOf: array]
+ ifFalse: [stSize := totalLength - fixedFields].
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
+ ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
+ ifFalse: [self primitiveFail]!
Item was added:
+ ----- Method: ContextInterpreter>>stSizeOf: (in category 'array primitive support') -----
+ stSizeOf: oop
+ "Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for <obj> size)."
+ "Note: Assume oop is not a SmallInteger!!"
+
+ | hdr fmt totalLength fixedFields |
+ <inline: false>
+ hdr := objectMemory baseHeader: oop.
+ fmt := (hdr >> 8) bitAnd: 16rF.
+ totalLength := objectMemory lengthOf: oop baseHeader: hdr format: fmt.
+ fixedFields := objectMemory fixedFieldsOf: oop format: fmt length: totalLength.
+ (fmt = 3 and: [self isContextHeader: hdr])
+ ifTrue: [^ self fetchStackPointerOf: oop]
+ ifFalse: [^ totalLength - fixedFields]!
Item was added:
+ ----- Method: ContextInterpreter>>stackFloatValue: (in category 'contexts') -----
+ stackFloatValue: offset
+ "Note: May be called by translated primitive code."
+ | result floatPointer |
+ <returnTypeC: 'double'>
+ <var: #result type: 'double '>
+ floatPointer := objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord).
+ (objectMemory fetchClassOf: floatPointer) = (objectMemory splObj: ClassFloat)
+ ifFalse:[self primitiveFail. ^0.0].
+ self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: floatPointer + objectMemory baseHeaderSize into: result.
+ ^ result!
Item was added:
+ ----- Method: ContextInterpreter>>stackIntegerValue: (in category 'contexts') -----
+ stackIntegerValue: offset
+ | integerPointer |
+ integerPointer := objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord).
+ ^self checkedIntegerValueOf: integerPointer!
Item was added:
+ ----- Method: ContextInterpreter>>stackObjectValue: (in category 'contexts') -----
+ stackObjectValue: offset
+ "Ensures that the given object is a real object, not a SmallInteger."
+
+ | oop |
+ oop := objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord).
+ (objectMemory isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
+ ^ oop
+ !
Item was added:
+ ----- Method: ContextInterpreter>>stackPointerIndex (in category 'contexts') -----
+ stackPointerIndex
+ "Return the 0-based index rel to the current context.
+ (This is what stackPointer used to be before conversion to pointer"
+ ^ (stackPointer - activeContext - objectMemory baseHeaderSize) >> objectMemory shiftForWord!
Item was added:
+ ----- Method: ContextInterpreter>>stackTop (in category 'contexts') -----
+ stackTop
+ ^objectMemory longAt: stackPointer!
Item was added:
+ ----- Method: ContextInterpreter>>stackValue: (in category 'contexts') -----
+ stackValue: offset
+ ^ objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord)!
Item was added:
+ ----- Method: ContextInterpreter>>stackValue:put: (in category 'contexts') -----
+ stackValue: offset put: oop
+ ^objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord)
+ put: oop!
Item was added:
+ ----- Method: ContextInterpreter>>storeAndPopReceiverVariableBytecode (in category 'stack bytecodes') -----
+ storeAndPopReceiverVariableBytecode
+ "Note: This code uses
+ storePointerUnchecked:ofObject:withValue: and does the
+ store check explicitely in order to help the translator
+ produce better code."
+ | rcvr top |
+ self flag: #'requires currentBytecode to be expanded to a constant'.
+ self fetchNextBytecode.
+ "this bytecode will be expanded so that refs to currentBytecode below will be constant"
+ rcvr := receiver.
+ top := self internalStackTop.
+ (objectMemory oop: rcvr isLessThan: objectMemory getYoungStart)
+ ifTrue: [objectMemory possibleRootStoreInto: rcvr value: top].
+ objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top.
+ self internalPop: 1!
Item was added:
+ ----- Method: ContextInterpreter>>storeAndPopRemoteTempLongBytecode (in category 'stack bytecodes') -----
+ storeAndPopRemoteTempLongBytecode
+ self storeRemoteTempLongBytecode.
+ self internalPop: 1!
Item was added:
+ ----- Method: ContextInterpreter>>storeAndPopTemporaryVariableBytecode (in category 'stack bytecodes') -----
+ storeAndPopTemporaryVariableBytecode
+
+ self flag: #'requires currentBytecode to be expanded to a constant'.
+ self fetchNextBytecode.
+ "this bytecode will be expanded so that refs to currentBytecode below will be constant"
+ objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
+ ofObject: localHomeContext
+ withValue: self internalStackTop.
+ self internalPop: 1.
+ !
Item was added:
+ ----- Method: ContextInterpreter>>storeContextRegisters: (in category 'contexts') -----
+ storeContextRegisters: activeCntx
+ "Note: internalStoreContextRegisters: should track changes to this method."
+
+ "InstructionPointer is a pointer variable equal to
+ method oop + ip + objectMemory baseHeaderSize
+ -1 for 0-based addressing of fetchByte
+ -1 because it gets incremented BEFORE fetching currentByte"
+
+ <inline: true>
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
+ withValue: (objectMemory integerObjectOf: (instructionPointer - method - (objectMemory baseHeaderSize - 2))).
+ objectMemory storePointerUnchecked: StackPointerIndex ofObject: activeCntx
+ withValue: (objectMemory integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
+ !
Item was added:
+ ----- Method: ContextInterpreter>>storeInstructionPointerValue:inContext: (in category 'contexts') -----
+ storeInstructionPointerValue: value inContext: contextPointer
+ "Assume: value is an integerValue"
+
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: contextPointer withValue: (objectMemory integerObjectOf: value).!
Item was added:
+ ----- Method: ContextInterpreter>>storeRemoteTemp:inVectorAt: (in category 'stack bytecodes') -----
+ storeRemoteTemp: index inVectorAt: tempVectorIndex
+ | tempVector |
+ tempVector := self temporary: tempVectorIndex.
+ objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop.!
Item was added:
+ ----- 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 added:
+ ----- Method: ContextInterpreter>>storeStackPointerValue:inContext: (in category 'contexts') -----
+ storeStackPointerValue: value inContext: contextPointer
+ "Assume: value is an integerValue"
+
+ objectMemory storePointerUnchecked: StackPointerIndex ofObject: contextPointer
+ withValue: (objectMemory integerObjectOf: value).!
Item was added:
+ ----- Method: ContextInterpreter>>subscript:with:format: (in category 'array primitive support') -----
+ subscript: array with: index format: fmt
+ "Note: This method assumes that the index is within bounds!!"
+
+ <inline: true>
+ fmt <= 4 ifTrue: [ "pointer type objects"
+ ^ objectMemory fetchPointer: index - 1 ofObject: array].
+ fmt < 8 ifTrue: [ "long-word type objects"
+ ^ self positive32BitIntegerFor:
+ (objectMemory fetchLong32: index - 1 ofObject: array)
+ ] ifFalse: [ "byte-type objects"
+ ^ objectMemory integerObjectOf:
+ (objectMemory fetchByte: index - 1 ofObject: array)
+ ].!
Item was added:
+ ----- Method: ContextInterpreter>>subscript:with:storing:format: (in category 'array primitive support') -----
+ subscript: array with: index storing: oopToStore format: fmt
+ "Note: This method assumes that the index is within bounds!!"
+ | valueToStore |
+ <inline: true>
+ fmt <= 4
+ ifTrue: ["pointer type objects"
+ objectMemory storePointer: index - 1 ofObject: array
+ withValue: oopToStore]
+ ifFalse: [fmt < 8
+ ifTrue: ["long-word type objects"
+ valueToStore := self positive32BitValueOf: oopToStore.
+ self successful
+ ifTrue: [objectMemory storeLong32: index - 1 ofObject: array
+ withValue: valueToStore]]
+ ifFalse: ["byte-type objects"
+ (objectMemory isIntegerObject: oopToStore)
+ ifFalse: [self primitiveFail].
+ valueToStore := objectMemory integerValueOf: oopToStore.
+ (valueToStore >= 0
+ and: [valueToStore <= 255])
+ ifFalse: [self primitiveFail].
+ self successful
+ ifTrue: [objectMemory
+ storeByte: index - 1
+ ofObject: array
+ withValue: valueToStore]]]!
Item was added:
+ ----- Method: ContextInterpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
+ sufficientSpaceToInstantiate: classOop indexableSize: size
+ "Return true if there is enough space to allocate an instance of the given class with the given number of indexable fields."
+ "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
+ | format |
+ <inline: true>
+ <var: #size type: 'usqInt'>
+ <var: #bytesNeeded type: 'usqInt'>
+ format := (objectMemory formatOfClass: classOop) >> 8 bitAnd: 16rF.
+
+ "Fail if attempting to call new: on non-indexable class"
+ (size > 0 and: [format < 2])
+ ifTrue: [^ false].
+
+ format < 8
+ ifTrue: ["indexable fields are words or pointers"
+ (objectMemory isExcessiveAllocationRequest: size shift: objectMemory shiftForWord) ifTrue: [^ false].
+ ^ objectMemory sufficientSpaceToAllocate: 2500 + (size * objectMemory bytesPerWord)]
+ ifFalse: ["indexable fields are bytes"
+ (objectMemory isExcessiveAllocationRequest: size shift: 0) ifTrue: [^ false].
+ ^ objectMemory sufficientSpaceToAllocate: 2500 + size]
+ !
Item was added:
+ ----- Method: ContextInterpreter>>superclassOf: (in category 'message sending') -----
+ superclassOf: classPointer
+
+ ^ objectMemory fetchPointer: SuperclassIndex ofObject: classPointer!
Item was added:
+ ----- Method: ContextInterpreter>>superclassSend (in category 'message sending') -----
+ superclassSend
+ "Send a message to self, starting lookup with the superclass of the class containing the currently executing method."
+ "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack,"
+ "Note: This method is inlined into the interpreter dispatch loop."
+ | rcvr |
+ <inline: true>
+ self sharedCodeNamed: 'commonSupersend' inCase: 133.
+ lkupClass := self superclassOf: (self methodClassOf: method).
+ rcvr := self internalStackValue: argumentCount.
+ receiverClass := objectMemory fetchClassOf: rcvr.
+ self commonSend.!
Item was added:
+ ----- Method: ContextInterpreter>>synchronousSignal: (in category 'process primitive support') -----
+ synchronousSignal: aSemaphore
+ "Signal the given semaphore from within the interpreter."
+ | excessSignals |
+ <inline: false>
+ (self isEmptyList: aSemaphore)
+ ifTrue: ["no process is waiting on this semaphore"
+ excessSignals := self fetchInteger: ExcessSignalsIndex ofObject: aSemaphore.
+ self storeInteger: ExcessSignalsIndex ofObject: aSemaphore withValue: excessSignals + 1]
+ ifFalse: [self resume: (self removeFirstLinkOfList: aSemaphore)]!
Item was added:
+ ----- Method: ContextInterpreter>>tempCountOf: (in category 'compiled methods') -----
+ tempCountOf: methodPointer
+ ^ ((self headerOf: methodPointer) >> 19) bitAnd: 16r3F!
Item was added:
+ ----- Method: ContextInterpreter>>temporary: (in category 'contexts') -----
+ temporary: offset
+
+ ^ objectMemory fetchPointer: offset + TempFrameStart ofObject: localHomeContext!
Item was added:
+ ----- Method: ContextInterpreter>>transfer:fromIndex:ofObject:toIndex:ofObject: (in category 'utilities') -----
+ transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop
+ "Transfer the specified fullword fields, as from calling context to called context"
+
+ "Assume: beRootIfOld: will be called on toOop."
+ | fromIndex toIndex lastFrom |
+ <inline: true>
+ self flag: #Dan. "Need to check all senders before converting this for 64 bits"
+ fromIndex := fromOop + (firstFrom * objectMemory bytesPerWord).
+ toIndex := toOop + (firstTo * objectMemory bytesPerWord).
+ lastFrom := fromIndex + (count * objectMemory bytesPerWord).
+ [objectMemory oop: fromIndex isLessThan: lastFrom]
+ whileTrue: [fromIndex := fromIndex + objectMemory bytesPerWord.
+ toIndex := toIndex + objectMemory bytesPerWord.
+ objectMemory
+ longAt: toIndex
+ put: (objectMemory longAt: fromIndex)]!
Item was added:
+ ----- Method: ContextInterpreter>>transferTo: (in category 'process primitive support') -----
+ transferTo: aProc
+ "Record a process to be awoken on the next interpreter cycle.
+ ikp 11/24/1999 06:07 -- added hook for external runtime
+ compiler "
+ | sched oldProc newProc |
+ newProc := aProc.
+ sched := self schedulerPointer.
+ oldProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
+ objectMemory storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
+ compilerInitialized
+ ifTrue: [self compilerProcessChange: oldProc to: newProc]
+ ifFalse: [objectMemory storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
+ self newActiveContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: newProc).
+ objectMemory storePointer: SuspendedContextIndex ofObject: newProc withValue: objectMemory getNilObj].
+ reclaimableContextCount := 0!
Item was added:
+ ----- Method: ContextInterpreter>>unPop: (in category 'contexts') -----
+ unPop: nItems
+ stackPointer := stackPointer + (nItems * objectMemory bytesPerWord)!
Item was added:
+ ----- Method: ContextInterpreter>>unknownBytecode (in category 'interpreter shell') -----
+ unknownBytecode
+ "This should never get called; it means that an unimplemented bytecode appears in a CompiledMethod."
+
+ self error: 'Unknown bytecode'.!
Item was added:
+ ----- Method: ContextInterpreter>>vmEndianness (in category 'plugin support') -----
+ vmEndianness
+ "return 0 for little endian, 1 for big endian"
+
+ self isBigEnder ifTrue: [^ 1] ifFalse: [^ 0]
+ !
Item was added:
+ ----- Method: ContextInterpreter>>wakeHighestPriority (in category 'process primitive support') -----
+ wakeHighestPriority
+ "Return the highest priority process that is ready to run."
+ "Note: It is a fatal VM error if there is no runnable process."
+ | schedLists p processList |
+ schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ p := objectMemory fetchWordLengthOf: schedLists.
+ p := p - 1.
+ "index of last indexable field"
+ processList := objectMemory fetchPointer: p ofObject: schedLists.
+ [self isEmptyList: processList]
+ whileTrue: [p := p - 1.
+ p < 0 ifTrue: [self error: 'scheduler could not find a runnable process'].
+ processList := objectMemory fetchPointer: p ofObject: schedLists].
+ ^ self removeFirstLinkOfList: processList!
Item was added:
+ ----- Method: ContextInterpreter>>writeImageFile: (in category 'image save/restore') -----
+ writeImageFile: imageBytes
+
+ | fn |
+ <var: #fn type: 'void *'>
+ self writeImageFileIO: imageBytes.
+ "set Mac file type and creator; this is a noop on other platforms"
+ fn := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
+ fn = 0 ifFalse:[
+ self cCode:'((sqInt (*)(char*, char*, char*))fn)(imageName, "STim", "FAST")'.
+ ].
+ !
Item was added:
+ ----- Method: ContextInterpreter>>writeImageFileIO: (in category 'image save/restore') -----
+ writeImageFileIO: imageBytes
+
+ | headerStart headerSize f bytesWritten sCWIfn okToWrite |
+ <var: #f type: 'sqImageFile'>
+ <var: #headerStart type: 'squeakFileOffsetType '>
+ <var: #sCWIfn type: 'void *'>
+
+ "If the security plugin can be loaded, use it to check for write permission.
+ If not, assume it's ok"
+ sCWIfn := self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
+ sCWIfn ~= 0 ifTrue:[okToWrite := self cCode: '((sqInt (*)(void))sCWIfn)()'.
+ okToWrite ifFalse:[^self primitiveFail]].
+
+ "local constants"
+ headerStart := 0.
+ headerSize := 16 * objectMemory bytesPerWord. "header size in bytes; do not change!!"
+
+ f := self cCode: 'sqImageFileOpen(imageName, "wb")'.
+ f = nil ifTrue: [
+ "could not open the image file for writing"
+ self success: false.
+ ^ nil].
+
+ headerStart := self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
+ self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
+ "position file to start of header"
+ self sqImageFile: f Seek: headerStart.
+
+ self putLong: (self imageFormatVersion) toFile: f.
+ self putLong: headerSize toFile: f.
+ self putLong: imageBytes toFile: f.
+ self putLong: (objectMemory startOfMemory) toFile: f.
+ self putLong: objectMemory getSpecialObjectsOop toFile: f.
+ self putLong: objectMemory getLastHash toFile: f.
+ self putLong: (self ioScreenSize) toFile: f.
+ self putLong: fullScreenFlag toFile: f.
+ self putLong: extraVMMemory toFile: f.
+ 1 to: 7 do: [:i | self putLong: 0 toFile: f]. "fill remaining header words with zeros"
+ self successful ifFalse: [
+ "file write or seek failure"
+ self cCode: 'sqImageFileClose(f)'.
+ ^ nil].
+
+ "position file after the header"
+ self sqImageFile: f Seek: headerStart + headerSize.
+
+ "write the image data"
+ bytesWritten := self
+ sqImage: (objectMemory pointerForOop: objectMemory getMemory)
+ write: f
+ size: (self cCode: 'sizeof(unsigned char)')
+ length: imageBytes.
+ self success: bytesWritten = imageBytes.
+ self cCode: 'sqImageFileClose(f)'.
+
+ !
Item was changed:
InterpreterPrimitives subclass: #Interpreter
+ instanceVariableNames: ''
+ classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase MaxExternalPrimitiveTableSize MaxPrimitiveIndex'
+ poolDictionaries: ''
- instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector currentBytecode primitiveIndex primitiveFunctionPointer methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptPending semaphoresToSignalA semaphoresUseBufferA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks extraVMMemory newNativeMethod methodClass receiverClass interpreterVersion imageFormatVersionNumber interpreterProxy showSurfaceFn interruptCheckCounter interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTable globalSessionID jmpBuf jmpDepth jmpMax suspendedCallbacks suspendedMethods imageFormatInitialVersion'
- classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockArgumentCountIndex BytecodeTable CacheProbeMax CallerIndex CompilerHooksSize DirBadPath DirEntryFound DirNoMoreEntries DoBalanceChecks HomeIndex InitialIPIndex MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MessageDictionaryIndex MethodCacheNative PrimitiveExternalCallIndex PrimitiveTable SemaphoresToSignalSize TempFrameStart'
- poolDictionaries: 'VMMethodCacheConstants VMSqueakV3BytecodeConstants'
category: 'VMMaker-Interpreter'!
+ !Interpreter commentStamp: 'dtl 4/22/2016 22:14' prior: 0!
- !Interpreter 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.
+ ContextInterpreter is the Squeak interpreter VM as originally implemented by Dan Ingalls.
- 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.
+ StackInterpreter is the stack mapped interpreter by Eliot Miranda, which provides the basis for later Cog and Spur VMs.!
- 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 removed:
- ----- Method: Interpreter class>>additionalHeadersDo: (in category 'translation') -----
- additionalHeadersDo: aBinaryBlock
- "Evaluate aBinaryBlock with the names and contents of
- any additional header files that need to be generated."!
Item was removed:
- ----- Method: Interpreter class>>bytecodeTable (in category 'constants') -----
- bytecodeTable
-
- ^ BytecodeTable!
Item was removed:
- ----- Method: Interpreter class>>constMinusOne (in category 'constants') -----
- constMinusOne
- ^ConstMinusOne!
Item was changed:
----- Method: Interpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
- aCCodeGenerator addHeaderFile: '<setjmp.h>'.
- aCCodeGenerator var: #interpreterProxy type: #'struct VirtualMachine*'.
aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[' , (MaxPrimitiveIndex + 2) printString , '] )(void)= ' , self primitiveTableString.
- "declare primitiveTable as an array of pointers to a function returning void, taking no arguments"
- aCCodeGenerator var: #primitiveFunctionPointer declareC: 'void (*primitiveFunctionPointer)(void)'.
- "keep this matching the declaration for primitiveTable"
- self primitiveTable do:
- [:symbolOrNot|
- (symbolOrNot isSymbol
- and: [symbolOrNot ~~ #primitiveFail]) ifTrue:
- [(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil:
- [:tMethod| tMethod returnType: #void]]].
- "make sure al the primitves are declared returning 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: 'semaphoresToSignalA' declareC: 'sqInt semaphoresToSignalA[' , (SemaphoresToSignalSize + 1) printString , ']'.
- aCCodeGenerator var: 'semaphoresToSignalB' declareC: 'sqInt semaphoresToSignalB[' , (SemaphoresToSignalSize + 1) printString , ']'.
- aCCodeGenerator var: #compilerHooks declareC: 'sqInt (*compilerHooks[' , (CompilerHooksSize + 1) printString , '])()'.
- aCCodeGenerator var: #interpreterVersion declareC: 'const char *interpreterVersion = "' , SmalltalkImage current datedVersion , ' [' , SmalltalkImage current lastUpdateString , ']"'.
aCCodeGenerator var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[' , (MaxExternalPrimitiveTableSize + 1) printString , '])(void)'.
+
+ !
- 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'!
Item was changed:
----- Method: Interpreter 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.
-
- 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"
+ self initializeCaches.
-
- 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: Interpreter class>>initializeAssociationIndex (in category 'initialization') -----
- initializeAssociationIndex
- ValueIndex := 1!
Item was removed:
- ----- Method: Interpreter class>>initializeBytecodeTable (in category 'initialization') -----
- initializeBytecodeTable
- "Interpreter initializeBytecodeTable"
- "Note: This table will be used to generate a C switch statement."
-
- BytecodeTable := Array new: 256.
- self table: BytecodeTable from:
- #(
- ( 0 15 pushReceiverVariableBytecode)
- ( 16 31 pushTemporaryVariableBytecode)
- ( 32 63 pushLiteralConstantBytecode)
- ( 64 95 pushLiteralVariableBytecode)
- ( 96 103 storeAndPopReceiverVariableBytecode)
- (104 111 storeAndPopTemporaryVariableBytecode)
- (112 pushReceiverBytecode)
- (113 pushConstantTrueBytecode)
- (114 pushConstantFalseBytecode)
- (115 pushConstantNilBytecode)
- (116 pushConstantMinusOneBytecode)
- (117 pushConstantZeroBytecode)
- (118 pushConstantOneBytecode)
- (119 pushConstantTwoBytecode)
- (120 returnReceiver)
- (121 returnTrue)
- (122 returnFalse)
- (123 returnNil)
- (124 returnTopFromMethod)
- (125 returnTopFromBlock)
-
- (126 127 unknownBytecode)
-
- (128 extendedPushBytecode)
- (129 extendedStoreBytecode)
- (130 extendedStoreAndPopBytecode)
- (131 singleExtendedSendBytecode)
- (132 doubleExtendedDoAnythingBytecode)
- (133 singleExtendedSuperBytecode)
- (134 secondExtendedSendBytecode)
- (135 popStackBytecode)
- (136 duplicateTopBytecode)
-
- (137 pushActiveContextBytecode)
- (138 pushNewArrayBytecode)
- (139 unknownBytecode)
- (140 pushRemoteTempLongBytecode)
- (141 storeRemoteTempLongBytecode)
- (142 storeAndPopRemoteTempLongBytecode)
- (143 pushClosureCopyCopiedValuesBytecode)
-
- (144 151 shortUnconditionalJump)
- (152 159 shortConditionalJump)
- (160 167 longUnconditionalJump)
- (168 171 longJumpIfTrue)
- (172 175 longJumpIfFalse)
-
- "176-191 were sendArithmeticSelectorBytecode"
- (176 bytecodePrimAdd)
- (177 bytecodePrimSubtract)
- (178 bytecodePrimLessThan)
- (179 bytecodePrimGreaterThan)
- (180 bytecodePrimLessOrEqual)
- (181 bytecodePrimGreaterOrEqual)
- (182 bytecodePrimEqual)
- (183 bytecodePrimNotEqual)
- (184 bytecodePrimMultiply)
- (185 bytecodePrimDivide)
- (186 bytecodePrimMod)
- (187 bytecodePrimMakePoint)
- (188 bytecodePrimBitShift)
- (189 bytecodePrimDiv)
- (190 bytecodePrimBitAnd)
- (191 bytecodePrimBitOr)
-
- "192-207 were sendCommonSelectorBytecode"
- (192 bytecodePrimAt)
- (193 bytecodePrimAtPut)
- (194 bytecodePrimSize)
- (195 bytecodePrimNext)
- (196 bytecodePrimNextPut)
- (197 bytecodePrimAtEnd)
- (198 bytecodePrimEquivalent)
- (199 bytecodePrimClass)
- (200 bytecodePrimBlockCopy)
- (201 bytecodePrimValue)
- (202 bytecodePrimValueWithArg)
- (203 bytecodePrimDo)
- (204 bytecodePrimNew)
- (205 bytecodePrimNewWithArg)
- (206 bytecodePrimPointX)
- (207 bytecodePrimPointY)
-
- (208 255 sendLiteralSelectorBytecode)
- ).!
Item was changed:
----- Method: Interpreter class>>initializeCaches (in category 'initialization') -----
initializeCaches
| atCacheEntrySize |
- MethodCacheEntries := 512.
- MethodCacheSelector := 1.
- MethodCacheClass := 2.
- MethodCacheMethod := 3.
- MethodCachePrim := 4.
- MethodCacheNative := 5.
- MethodCachePrimFunction := 6.
- MethodCacheEntrySize := 8. "Must be power of two for masking scheme."
- MethodCacheMask := (MethodCacheEntries - 1) * MethodCacheEntrySize.
- MethodCacheSize := MethodCacheEntries * MethodCacheEntrySize.
- CacheProbeMax := 3.
-
AtCacheEntries := 8. "Must be a power of two"
AtCacheOop := 1.
AtCacheSize := 2.
AtCacheFmt := 3.
AtCacheFixedFields := 4.
+
atCacheEntrySize := 4. "Must be power of two for masking scheme."
AtCacheMask := (AtCacheEntries-1) * atCacheEntrySize.
AtPutBase := AtCacheEntries * atCacheEntrySize.
AtCacheTotalSize := AtCacheEntries * atCacheEntrySize * 2.
!
Item was removed:
- ----- Method: Interpreter class>>initializeCharacterIndex (in category 'initialization') -----
- initializeCharacterIndex
- CharacterValueIndex := 0!
Item was removed:
- ----- Method: Interpreter class>>initializeCharacterScannerIndices (in category 'initialization') -----
- initializeCharacterScannerIndices
- CrossedX := 258.
- EndOfRun := 257
- !
Item was removed:
- ----- Method: Interpreter class>>initializeClassIndices (in category 'initialization') -----
- initializeClassIndices
- "Class Class"
- SuperclassIndex := 0.
- MessageDictionaryIndex := 1.
- InstanceSpecificationIndex := 2.
- "Fields of a message dictionary"
- MethodArrayIndex := 1.
- SelectorStart := 2!
Item was removed:
- ----- Method: Interpreter class>>initializeCodeGenerator: (in category 'translation') -----
- initializeCodeGenerator: cg
- "Load a code generator with classes in a manner suitable for generating
- code for this class."
-
- super initializeCodeGenerator: cg.
- self initializeClassicObjectMemoryInCodeGenerator: cg.
- VMMaker addMemoryAccessTo: cg.
- ^cg
- "^ self initializeNewObjectMemoryInCodeGenerator: cg"
- !
Item was removed:
- ----- Method: Interpreter class>>initializeCompilerHooks (in category 'initialization') -----
- initializeCompilerHooks
- "Interpreter initializeCompilerHooks"
-
- "compilerHooks[] indices:
- 1 void compilerTranslateMethodHook(void)
- 2 void compilerFlushCacheHook(CompiledMethod *oldMethod)
- 3 void compilerPreGCHook(int fullGCFlag)
- 4 void compilerMapHook(int memStart, int memEnd)
- 5 void compilerPostGCHook(void)
- 6 void compilerProcessChangeHook(void)
- 7 void compilerPreSnapshotHook(void)
- 8 void compilerPostSnapshotHook(void)
- 9 void compilerMarkHook(void)
- 10 void compilerActivateMethodHook(void)
- 11 void compilerNewActiveContextHook(int sendFlag)
- 12 void compilerGetInstructionPointerHook(void)
- 13 void compilerSetInstructionPointerHook(void)
- 14 void compilerCreateActualMessageHook(void)"
-
- CompilerHooksSize := 15.!
Item was removed:
- ----- Method: Interpreter class>>initializeContextIndices (in category 'initialization') -----
- initializeContextIndices
- "Class MethodContext"
- SenderIndex := 0.
- InstructionPointerIndex := 1.
- StackPointerIndex := 2.
- MethodIndex := 3.
- ClosureIndex := 4. "N.B. Called receiverMap in the image."
- ReceiverIndex := 5.
- TempFrameStart := 6. "Note this is in two places!!"
-
- "Class BlockContext"
- CallerIndex := 0.
- BlockArgumentCountIndex := 3.
- InitialIPIndex := 4.
- HomeIndex := 5.
-
- "Class BlockClosure"
- ClosureOuterContextIndex := 0.
- ClosureStartPCIndex := 1.
- ClosureNumArgsIndex := 2.
- ClosureFirstCopiedValueIndex := 3.
-
- CtxtTempFrameStart := 6. "Copy of TempFrameStart in Interp"
-
- "n.b. The constants SmallContextSize and LargeContextSize are not required.
- See ObjectMemory>>smallContextSize and ObjectMemory>>largeContextSize
- for implementations that work for both 32 and 64 bit object memory."
- !
Item was removed:
- ----- Method: Interpreter class>>initializeDirectoryLookupResultCodes (in category 'initialization') -----
- initializeDirectoryLookupResultCodes
-
- DirEntryFound := 0.
- DirNoMoreEntries := 1.
- DirBadPath := 2.!
Item was removed:
- ----- Method: Interpreter class>>initializeInterpreterSourceVersion (in category 'initialization') -----
- initializeInterpreterSourceVersion
- "Identify the VMMaker source version that generated the C code for an
- interpreter. Provides a runtime version identification test."
-
- Smalltalk at: #VMMaker
- ifPresent: [:vmm | ^ InterpreterSourceVersion := vmm versionString].
- ^ InterpreterSourceVersion := ''!
Item was removed:
- ----- Method: Interpreter class>>initializeMessageIndices (in category 'initialization') -----
- initializeMessageIndices
- MessageSelectorIndex := 0.
- MessageArgumentsIndex := 1.
- MessageLookupClassIndex := 2.!
Item was removed:
- ----- Method: Interpreter class>>initializeMethodIndices (in category 'initialization') -----
- initializeMethodIndices
- "Class CompiledMethod"
- HeaderIndex := 0.
- LiteralStart := 1!
Item was removed:
- ----- Method: Interpreter class>>initializePointIndices (in category 'initialization') -----
- initializePointIndices
- XIndex := 0.
- YIndex := 1!
Item was removed:
- ----- Method: Interpreter class>>initializePrimitiveTable (in category 'initialization') -----
- initializePrimitiveTable
- "This table generates a C function address table use in primitiveResponse along with dispatchFunctionPointerOn:in:"
-
- "NOTE: The real limit here is 2047 because of the method header layout but there is no point in going over the needed size"
- MaxPrimitiveIndex := 575.
- PrimitiveTable := Array new: MaxPrimitiveIndex + 1.
- self table: PrimitiveTable from:
- #( "Integer Primitives (0-19)"
- (0 primitiveFail)
- (1 primitiveAdd)
- (2 primitiveSubtract)
- (3 primitiveLessThan)
- (4 primitiveGreaterThan)
- (5 primitiveLessOrEqual)
- (6 primitiveGreaterOrEqual)
- (7 primitiveEqual)
- (8 primitiveNotEqual)
- (9 primitiveMultiply)
- (10 primitiveDivide)
- (11 primitiveMod)
- (12 primitiveDiv)
- (13 primitiveQuo)
- (14 primitiveBitAnd)
- (15 primitiveBitOr)
- (16 primitiveBitXor)
- (17 primitiveBitShift)
- (18 primitiveMakePoint)
- (19 primitiveFail) "Guard primitive for simulation -- *must* fail"
-
- "LargeInteger Primitives (20-39)"
- (20 primitiveRemLargeIntegers)
- (21 primitiveAddLargeIntegers)
- (22 primitiveSubtractLargeIntegers)
- (23 primitiveLessThanLargeIntegers)
- (24 primitiveGreaterThanLargeIntegers)
- (25 primitiveLessOrEqualLargeIntegers)
- (26 primitiveGreaterOrEqualLargeIntegers)
- (27 primitiveEqualLargeIntegers)
- (28 primitiveNotEqualLargeIntegers)
- (29 primitiveMultiplyLargeIntegers)
- (30 primitiveDivideLargeIntegers)
- (31 primitiveModLargeIntegers)
- (32 primitiveDivLargeIntegers)
- (33 primitiveQuoLargeIntegers)
- (34 primitiveBitAndLargeIntegers)
- (35 primitiveBitOrLargeIntegers)
- (36 primitiveBitXorLargeIntegers)
- (37 primitiveBitShiftLargeIntegers)
-
- "Float Primitives (38-59)"
- (38 primitiveFloatAt)
- (39 primitiveFloatAtPut)
- (40 primitiveAsFloat)
- (41 primitiveFloatAdd)
- (42 primitiveFloatSubtract)
- (43 primitiveFloatLessThan)
- (44 primitiveFloatGreaterThan)
- (45 primitiveFloatLessOrEqual)
- (46 primitiveFloatGreaterOrEqual)
- (47 primitiveFloatEqual)
- (48 primitiveFloatNotEqual)
- (49 primitiveFloatMultiply)
- (50 primitiveFloatDivide)
- (51 primitiveTruncated)
- (52 primitiveFractionalPart)
- (53 primitiveExponent)
- (54 primitiveTimesTwoPower)
- (55 primitiveSquareRoot)
- (56 primitiveSine)
- (57 primitiveArctan)
- (58 primitiveLogN)
- (59 primitiveExp)
-
- "Subscript and Stream Primitives (60-67)"
- (60 primitiveAt)
- (61 primitiveAtPut)
- (62 primitiveSize)
- (63 primitiveStringAt)
- (64 primitiveStringAtPut)
- (65 primitiveFail) "was primitiveNext which no longer pays its way (normal Smalltalk code is faster)"
- (66 primitiveFail) "was primitiveNextPut which no longer pays its way (normal Smalltalk code is faster)"
- (67 primitiveFail) "was primitiveAtEnd which no longer pays its way (normal Smalltalk code is faster)"
-
- "StorageManagement Primitives (68-79)"
- (68 primitiveObjectAt)
- (69 primitiveObjectAtPut)
- (70 primitiveNew)
- (71 primitiveNewWithArg)
- (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome"
- (73 primitiveInstVarAt)
- (74 primitiveInstVarAtPut)
- (75 primitiveAsOop)
- (76 primitiveStoreStackp) "Blue Book: primitiveAsObject"
- (77 primitiveSomeInstance)
- (78 primitiveNextInstance)
- (79 primitiveNewMethod)
-
- "Control Primitives (80-89)"
- (80 primitiveBlockCopy)
- (81 primitiveValue)
- (82 primitiveValueWithArgs)
- (83 primitivePerform)
- (84 primitivePerformWithArgs)
- (85 primitiveSignal)
- (86 primitiveWait)
- (87 primitiveResume)
- (88 primitiveSuspend)
- (89 primitiveFlushCache)
-
- "Input/Output Primitives (90-109)"
- (90 primitiveMousePoint)
- (91 primitiveTestDisplayDepth) "Blue Book: primitiveCursorLocPut"
- (92 primitiveSetDisplayMode) "Blue Book: primitiveCursorLink"
- (93 primitiveInputSemaphore)
- (94 primitiveGetNextEvent) "Blue Book: primitiveSampleInterval"
- (95 primitiveInputWord)
- (96 primitiveFail) "primitiveCopyBits"
- (97 primitiveSnapshot)
- (98 primitiveStoreImageSegment)
- (99 primitiveLoadImageSegment)
- (100 primitivePerformInSuperclass) "Blue Book: primitiveSignalAtTick"
- (101 primitiveBeCursor)
- (102 primitiveBeDisplay)
- (103 primitiveScanCharacters)
- (104 primitiveFail) "primitiveDrawLoop"
- (105 primitiveStringReplace)
- (106 primitiveScreenSize)
- (107 primitiveMouseButtons)
- (108 primitiveKbdNext)
- (109 primitiveKbdPeek)
-
- "System Primitives (110-119)"
- (110 primitiveIdentical)
- (111 primitiveClass)
- (112 primitiveBytesLeft)
- (113 primitiveQuit)
- (114 primitiveExitToDebugger)
- (115 primitiveChangeClass) "Blue Book: primitiveOopsLeft"
- (116 primitiveFlushCacheByMethod)
- (117 primitiveExternalCall)
- (118 primitiveDoPrimitiveWithArgs)
- (119 primitiveFlushCacheBySelector)
- "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116.
- Both are supported for backward compatibility."
-
- "Miscellaneous Primitives (120-127)"
- (120 primitiveCalloutToFFI)
- (121 primitiveImageName)
- (122 primitiveNoop) "Blue Book: primitiveImageVolume"
- (123 primitiveValueUninterruptably) "@@@: Remove this when all VMs have support"
- (124 primitiveLowSpaceSemaphore)
- (125 primitiveSignalAtBytesLeft)
-
- "Squeak Primitives Start Here"
-
- "Squeak Miscellaneous Primitives (128-149)"
- (126 primitiveDeferDisplayUpdates)
- (127 primitiveShowDisplayRect)
- (128 primitiveArrayBecome)
- (129 primitiveSpecialObjectsOop)
- (130 primitiveFullGC)
- (131 primitiveIncrementalGC)
- (132 primitiveObjectPointsTo)
- (133 primitiveSetInterruptKey)
- (134 primitiveInterruptSemaphore)
- (135 primitiveMillisecondClock)
- (136 primitiveSignalAtMilliseconds)
- (137 primitiveSecondsClock)
- (138 primitiveSomeObject)
- (139 primitiveNextObject)
- (140 primitiveBeep)
- (141 primitiveClipboardText)
- (142 primitiveVMPath)
- (143 primitiveShortAt)
- (144 primitiveShortAtPut)
- (145 primitiveConstantFill)
- "NOTE: When removing the obsolete indexed primitives,
- the following two should go become #primitiveIntegerAt / atPut"
- (146 primitiveFail) "primitiveReadJoystick"
- (147 primitiveFail) "primitiveWarpBits"
- (148 primitiveClone)
- (149 primitiveGetAttribute)
-
- "File Primitives (150-169) - NO LONGER INDEXED"
- (150 159 primitiveFail)
- (160 primitiveAdoptInstance)
- (161 primitiveSetIdentityHash) "CogMemoryManager primitives"
- (162 164 primitiveFail)
- (165 primitiveIntegerAt) "hacked in here for now"
- (166 primitiveIntegerAtPut)
- (167 primitiveYield)
- (168 primitiveCopyObject)
- (169 primitiveNotIdentical)
-
- "Sound Primitives (170-199) - NO LONGER INDEXED"
- (170 174 primitiveFail)
-
- "CogMemoryManager primitives"
- (175 primitiveBehaviorHash)
- (176 primitiveMaxIdentityHash)
- (177 184 primitiveFail)
-
- "CriticalSection primitives"
- (185 primitiveExitCriticalSection) "similar to signal hence index = signal + 100"
- (186 primitiveEnterCriticalSection) "similar to wait hence index = wait + 100. was primitiveClosureValue"
- (187 primitiveTestAndSetOwnershipOfCriticalSection) "was primitiveClosureValueWithArgs"
-
- "Perform method directly"
- (188 primitiveExecuteMethodArgsArray)
- (189 primitiveExecuteMethod)
-
- "Sound Primitives (continued) - NO LONGER INDEXED"
- (190 194 primitiveFail)
-
- "Unwind primitives"
- (195 primitiveFindNextUnwindContext)
- (196 primitiveTerminateTo)
- (197 primitiveFindHandlerContext)
- (198 primitiveMarkUnwindMethod)
- (199 primitiveMarkHandlerMethod)
-
- "new closure primitives (were Networking primitives)"
- (200 primitiveClosureCopyWithCopiedValues)
- (201 primitiveClosureValue) "value"
- (202 primitiveClosureValue) "value:"
- (203 primitiveClosureValue) "value:value:"
- (204 primitiveClosureValue) "value:value:value:"
- (205 primitiveClosureValue) "value:value:value:value:"
- (206 primitiveClosureValueWithArgs) "valueWithArguments:"
-
- (207 209 primitiveFail) "reserved for Cog primitives"
-
- (210 primitiveAt) "Compatibility with Cog StackInterpreter Context primitives"
- (211 primitiveAtPut) "Compatibility with Cog StackInterpreter Context primitives"
- (212 primitiveSize) "Compatibility with Cog StackInterpreter Context primitives"
- (213 219 primitiveFail) "reserved for Cog primitives"
-
- (220 primitiveFail) "reserved for Cog primitives"
-
- (221 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch"
- (222 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch:"
-
- (223 229 primitiveFail) "reserved for Cog primitives"
-
- (230 primitiveRelinquishProcessor)
- (231 primitiveForceDisplayUpdate)
- (232 primitiveFormPrint)
- (233 primitiveSetFullScreen)
- (234 primitiveFail) "primBitmapdecompressfromByteArrayat"
- (235 primitiveFail) "primStringcomparewithcollated"
- (236 primitiveFail) "primSampledSoundconvert8bitSignedFromto16Bit"
- (237 primitiveFail) "primBitmapcompresstoByteArray"
- (238 239 primitiveFail) "serial port primitives"
- (240 primitiveUTCMicrosecondClock) "was serial port primitive"
- (241 primitiveLocalMicrosecondClock) "was serial port primitive"
- (242 primitiveSignalAtUTCMicroseconds)
- (243 primitiveFail) "primStringtranslatefromtotable"
- (244 primitiveFail) "primStringfindFirstInStringinSetstartingAt"
- (245 primitiveFail) "primStringindexOfAsciiinStringstartingAt"
- (246 primitiveFail) "primStringfindSubstringinstartingAtmatchTable"
- (247 primitiveSnapshotEmbedded)
- (248 primitiveInvokeObjectAsMethod)
- (249 primitiveArrayBecomeOneWayCopyHash)
-
- "VM Implementor Primitives (250-255)"
- (250 clearProfile)
- (251 dumpProfile)
- (252 startProfiling)
- (253 stopProfiling)
- (254 primitiveVMParameter)
- (255 primitiveFail) "primitiveInstVarsPutFromStack. Never used except in Disney tests. Remove after 2.3 release."
-
- "Quick Push Const Methods"
- (256 primitivePushSelf)
- (257 primitivePushTrue)
- (258 primitivePushFalse)
- (259 primitivePushNil)
- (260 primitivePushMinusOne)
- (261 primitivePushZero)
- (262 primitivePushOne)
- (263 primitivePushTwo)
-
- "Quick Push Const Methods"
- (264 519 primitiveLoadInstVar)
-
- "These ranges used to be used by obsiolete indexed primitives."
- (520 529 primitiveFail)
- (530 539 primitiveFail)
- (540 549 primitiveFail)
- (550 559 primitiveFail)
- (560 569 primitiveFail)
-
- "External primitive support primitives"
- (570 primitiveFlushExternalPrimitives)
- (571 primitiveUnloadModule)
- (572 primitiveListBuiltinModule)
- (573 primitiveListExternalModule)
- (574 primitiveFail) "reserved for addl. external support prims"
-
- "Unassigned Primitives"
- (575 primitiveFail)).
- !
Item was removed:
- ----- Method: Interpreter class>>initializeSchedulerIndices (in category 'initialization') -----
- initializeSchedulerIndices
- "Class ProcessorScheduler"
- ProcessListsIndex := 0.
- ActiveProcessIndex := 1.
- "Class LinkedList"
- FirstLinkIndex := 0.
- LastLinkIndex := 1.
- "Class Semaphore"
- ExcessSignalsIndex := 2.
- "Class Link"
- NextLinkIndex := 0.
- "Class Process"
- SuspendedContextIndex := 1.
- PriorityIndex := 2.
- MyListIndex := 3!
Item was removed:
- ----- Method: Interpreter class>>initializeStreamIndices (in category 'initialization') -----
- initializeStreamIndices
- StreamArrayIndex := 0.
- StreamIndexIndex := 1.
- StreamReadLimitIndex := 2.
- StreamWriteLimitIndex := 3.!
Item was removed:
- ----- Method: Interpreter class>>isInterpreterClass (in category 'translation') -----
- isInterpreterClass
- ^true!
Item was removed:
- ----- Method: Interpreter class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
- isNonArgumentImplicitReceiverVariableName: aString
- aString = 'interpreterProxy' ifTrue: [self halt].
- ^'self' = aString!
Item was removed:
- ----- Method: Interpreter class>>patchInterp: (in category 'translation') -----
- patchInterp: fileName
- "Interpreter patchInterp: 'Squeak VM PPC'"
- "This will patch out the unneccesary range check (a compare
- and branch) in the inner interpreter dispatch loop."
- "NOTE: You must edit in the Interpeter file name, and the
- number of instructions (delta) to count back to find the compare
- and branch that we want to get rid of."
-
- | delta f code len remnant i |
- delta := 6.
- f := FileStream fileNamed: fileName.
- f binary.
- code := Bitmap new: (len := f size) // 4.
- f nextInto: code.
- remnant := f next: len - (code size * 4).
- i := 0.
- ["Look for a BCTR instruction"
- (i := code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue:
- ["Look for a CMPLWI FF, 6 instrs back"
- ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r280000FF ifTrue:
- ["Copy dispatch instrs back over the compare"
- self inform: 'Patching at ', i hex.
- 0 to: delta - 2 do: [ :j |
- code at: (i - delta) + j put: (code at: (i - delta) + j + 2)]]].
- f position: 0; nextPutAll: code; nextPutAll: remnant.
- f close.
- !
Item was removed:
- ----- Method: Interpreter class>>patchInterpGCCPPC: (in category 'translation') -----
- patchInterpGCCPPC: fileName
- "Interpreter patchInterpGCCPPC: 'Squeak copy 1'"
- "This will patch out the unneccesary range check (a compare
- and branch) in the inner interpreter dispatch loop. for the PPC version of the GCC compiled
- version of Squeak under MPW"
- "NOTE: You must edit in the Interpeter file name"
-
- | delta f code len remnant i |
- delta := 7.
- f := FileStream fileNamed: fileName.
- f binary.
- code := Bitmap new: (len := f size) // 4.
- f nextInto: code.
- remnant := f next: len - (code size * 4).
- i := 0.
- ["Look for a BCTR instruction"
- (i := code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue:
- ["Look for a CMPLWI cr1,rxx,FF, 7 instrs back"
- ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r288000FF ifTrue:
- ["Copy dispatch instrs back over the compare"
- self inform: 'Patching at ', i hex.
- 0 to: delta - 2 do: [ :j |
- code at: (i - delta) + j put: (code at: (i - delta) + j + 2)]]].
- f position: 0; nextPutAll: code; nextPutAll: remnant.
- f close!
Item was removed:
- ----- Method: Interpreter class>>primitiveTable (in category 'constants') -----
- primitiveTable
-
- ^ PrimitiveTable!
Item was removed:
- ----- Method: Interpreter class>>primitiveTableString (in category 'initialization') -----
- primitiveTableString
- "Interpreter initializePrimitiveTable primitiveTableString"
- | table |
- table := self primitiveTable.
- ^ String
- streamContents: [:s |
- s nextPut: ${.
- table
- withIndexDo: [:primSpec :index | s cr; tab;
- nextPutAll: '/* ';
- nextPutAll: (index - 1) printString;
- nextPutAll: '*/ ';
- nextPutAll: '(void (*)(void))'; "keep this matching the declaration of primitiveTable in Interpreter class>declareCVarsIn:"
- nextPutAll: primSpec;
- nextPut: $,].
- s cr; nextPutAll: ' 0 }']!
Item was removed:
- ----- Method: Interpreter class>>requiredMethodNames (in category 'translation') -----
- requiredMethodNames
- "return the list of method names that should be retained for export or other support reasons"
- | requiredList |
- requiredList := Set new:400.
- "A number of methods required by VM support code, jitter, specific platforms etc"
- requiredList addAll: #(fullDisplayUpdate interpret printCallStack printAllStacks readImageFromFile:HeapSize:StartingAt: success: readableFormat: getCurrentBytecode characterForAscii: findClassOfMethod:forReceiver: findSelectorOfMethod:forReceiver: loadInitialContext nullCompilerHook setCompilerInitialized: getFullScreenFlag getInterruptCheckCounter getInterruptKeycode getInterruptPending getNextWakeupTick getSavedWindowSize setFullScreenFlag: setInterruptCheckCounter: setInterruptKeycode: setInterruptPending: setNextWakeupTick: setSavedWindowSize: forceInterruptCheck getThisSessionID setMicroSeconds:andOffset:).
-
- "Nice to actually have all the primitives available"
- requiredList addAll: self primitiveTable.
-
- "InterpreterProxy is the internal analogue of sqVirtualMachine.c, so make sure to keep all those"
- InterpreterProxy organization categories do: [:cat |
- ((cat ~= 'initialize') and: [cat ~= 'private']) ifTrue: [
- requiredList addAll: (InterpreterProxy organization listAtCategoryNamed: cat)]].
-
- ^requiredList!
Item was removed:
- ----- Method: Interpreter class>>table:from: (in category 'initialization') -----
- table: anArray from: specArray
- "SpecArray is an array of either (index selector) or (index1
- index2 selector)."
- | contiguous |
- contiguous := 0.
- specArray do: [:spec |
- (spec at: 1) = contiguous
- ifFalse: [self error: 'Non-contiguous table entry'].
- spec size = 2
- ifTrue: [anArray at: (spec at: 1) + 1
- put: (spec at: 2).
- contiguous := contiguous + 1]
- ifFalse: [(spec at: 1) to: (spec at: 2) do: [:i | anArray at: i + 1 put: (spec at: 3)].
- contiguous := contiguous + ((spec at: 2) - (spec at: 1)) + 1]]!
Item was removed:
- ----- Method: Interpreter class>>wantsLabels (in category 'translation') -----
- wantsLabels
- "Only label the VM, not plugins (internal or external). This to cut down the scope
- of problems with labels being duplicated by C compiler optimizer inlining and
- loop unrolling. We use the asmLabel: directive to control labelling in the
- interpreter proper. But it is too much work doing that for plugins too."
- ^true!
Item was removed:
- ----- Method: Interpreter>>activateNewClosureMethod: (in category 'control primitives') -----
- activateNewClosureMethod: blockClosure
- "Similar to activateNewMethod but for Closure and newMethod."
- | theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
-
- DoAssertionChecks ifTrue:
- [objectMemory okayOop: blockClosure].
- outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
- DoAssertionChecks ifTrue:
- [objectMemory okayOop: outerContext].
- closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
- methodHeader := self headerOf: closureMethod.
- objectMemory pushRemappableOop: blockClosure.
- newContext := objectMemory allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
-
- "allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
- theBlockClosure := objectMemory popRemappableOop.
- outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
- numCopied := (objectMemory fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
-
- "Assume: newContext will be recorded as a root if necessary by the
- call to newActiveContext: below, so we can use unchecked stores."
- where := newContext + objectMemory baseHeaderSize.
- objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord)
- put: activeContext.
- objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord)
- put: (objectMemory fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
- objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord)
- put: (objectMemory integerObjectOf: argumentCount + numCopied).
- objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord)
- put: (objectMemory fetchPointer: MethodIndex ofObject: outerContext).
- objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord)
- put: theBlockClosure.
- objectMemory longAt: where + (ReceiverIndex << objectMemory shiftForWord)
- put: (objectMemory fetchPointer: ReceiverIndex ofObject: outerContext).
-
- "Copy the arguments..."
- 1 to: argumentCount do:
- [:i | objectMemory longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord)
- put: (self stackValue: argumentCount-i)].
-
- "Copy the copied values..."
- where := newContext + objectMemory baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << objectMemory shiftForWord).
- 0 to: numCopied - 1 do:
- [:i| objectMemory longAt: where + (i << objectMemory shiftForWord)
- put: (objectMemory fetchPointer: i + ClosureFirstCopiedValueIndex
- ofObject: theBlockClosure)].
-
- "The initial instructions in the block nil-out remaining temps."
-
- self pop: argumentCount + 1.
- self newActiveContext: newContext!
Item was removed:
- ----- Method: Interpreter>>activateNewMethod (in category 'message sending') -----
- activateNewMethod
- | newContext methodHeader initialIP tempCount nilOop where |
-
- methodHeader := self headerOf: newMethod.
- newContext := objectMemory allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).
-
- initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1.
- tempCount := (methodHeader >> 19) bitAnd: 16r3F.
-
- "Assume: newContext will be recorded as a root if necessary by the
- call to newActiveContext: below, so we can use unchecked stores."
-
- where := newContext + objectMemory baseHeaderSize.
- objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
- objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: initialIP).
- objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
- objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
- objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory getNilObj.
-
- "Copy the receiver and arguments..."
- 0 to: argumentCount do:
- [:i | objectMemory longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord) put: (self stackValue: argumentCount-i)].
-
- "clear remaining temps to nil in case it has been recycled"
- nilOop := objectMemory getNilObj.
- argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do:
- [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: nilOop].
-
- self pop: argumentCount + 1.
- reclaimableContextCount := reclaimableContextCount + 1.
- self newActiveContext: newContext.!
Item was removed:
- ----- Method: Interpreter>>addNewMethodToCache (in category 'method lookup cache') -----
- addNewMethodToCache
- "Add the given entry to the method cache.
- The policy is as follows:
- Look for an empty entry anywhere in the reprobe chain.
- If found, install the new entry there.
- If not found, then install the new entry at the first probe position
- and delete the entries in the rest of the reprobe chain.
- This has two useful purposes:
- If there is active contention over the first slot, the second
- or third will likely be free for reentry after ejection.
- Also, flushing is good when reprobe chains are getting full."
- | probe hash |
- <inline: false>
- self compilerTranslateMethodHook. "newMethod x lkupClass -> newNativeMethod (may cause GC !!)"
- hash := messageSelector bitXor: lkupClass. "drop low-order zeros from addresses"
-
- primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: lkupClass.
-
- 0 to: CacheProbeMax-1 do:
- [:p | probe := (hash >> p) bitAnd: MethodCacheMask.
- (methodCache at: probe + MethodCacheSelector) = 0 ifTrue:
- ["Found an empty entry -- use it"
- methodCache at: probe + MethodCacheSelector put: messageSelector.
- methodCache at: probe + MethodCacheClass put: lkupClass.
- methodCache at: probe + MethodCacheMethod put: newMethod.
- methodCache at: probe + MethodCachePrim put: primitiveIndex.
- methodCache at: probe + MethodCacheNative put: newNativeMethod.
- methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').
- ^ nil]].
-
- "OK, we failed to find an entry -- install at the first slot..."
- probe := hash bitAnd: MethodCacheMask. "first probe"
- methodCache at: probe + MethodCacheSelector put: messageSelector.
- methodCache at: probe + MethodCacheClass put: lkupClass.
- methodCache at: probe + MethodCacheMethod put: newMethod.
- methodCache at: probe + MethodCachePrim put: primitiveIndex.
- methodCache at: probe + MethodCacheNative put: newNativeMethod.
- methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').
-
- "...and zap the following entries"
- 1 to: CacheProbeMax-1 do:
- [:p | probe := (hash >> p) bitAnd: MethodCacheMask.
- methodCache at: probe + MethodCacheSelector put: 0].
- !
Item was removed:
- ----- Method: Interpreter>>addToExternalPrimitiveTable: (in category 'plugin support') -----
- addToExternalPrimitiveTable: functionAddress
- "Add the given function address to the external primitive table and return the index where it's stored. This function doesn't need to be fast since it is only called when an external primitive has been looked up (which takes quite a bit of time itself). So there's nothing specifically complicated here.
- Note: Return index will be one-based (ST convention)"
-
- <var: #functionAddress declareC: 'void (*functionAddress)(void)'>
-
- 0 to: MaxExternalPrimitiveTableSize-1 do: [ :i |
- (externalPrimitiveTable at: i) = 0 ifTrue: [
- externalPrimitiveTable at: i put: functionAddress.
- ^i+1]].
- "if no space left, return zero so it'll looked up again"
- ^0!
Item was removed:
- ----- Method: Interpreter>>allAccessibleObjectsOkay (in category 'debug support') -----
- allAccessibleObjectsOkay
- "Ensure that all accessible objects in the heap are okay."
-
- | oop |
- oop := objectMemory firstAccessibleObject.
- [oop = nil] whileFalse: [
- self okayFields: oop.
- oop := objectMemory accessibleObjectAfter: oop.
- ].!
Item was removed:
- ----- Method: Interpreter>>argCount (in category 'message sending') -----
- argCount
- ^ argumentCount!
Item was removed:
- ----- Method: Interpreter>>argumentCountOf: (in category 'compiled methods') -----
- argumentCountOf: methodPointer
- ^ ((self headerOf: methodPointer) >> 25) bitAnd: 16r0F!
Item was removed:
- ----- Method: Interpreter>>argumentCountOfBlock: (in category 'contexts') -----
- argumentCountOfBlock: blockPointer
-
- | localArgCount |
- localArgCount := objectMemory fetchPointer: BlockArgumentCountIndex ofObject: blockPointer.
- ^self checkedIntegerValueOf: localArgCount!
Item was removed:
- ----- Method: Interpreter>>argumentCountOfClosure: (in category 'contexts') -----
- argumentCountOfClosure: closurePointer
-
- ^self quickFetchInteger: ClosureNumArgsIndex ofObject: closurePointer!
Item was removed:
- ----- Method: Interpreter>>argumentCountOfMethodHeader: (in category 'compiled methods') -----
- argumentCountOfMethodHeader: header
- ^ (header >> 25) bitAnd: 16r0F!
Item was removed:
- ----- Method: Interpreter>>arrayValueOf: (in category 'utilities') -----
- arrayValueOf: arrayOop
- "Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
- "Note: May be called by translated primitive code."
-
- <returnTypeC: 'void *'>
- ((objectMemory isIntegerObject: arrayOop) not and:
- [objectMemory isWordsOrBytes: arrayOop])
- ifTrue: [^ objectMemory pointerForOop: (arrayOop + objectMemory baseHeaderSize)].
- self primitiveFail.
- !
Item was removed:
- ----- Method: Interpreter>>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: Interpreter>>assertClassOf:is: (in category 'utilities') -----
- assertClassOf: oop is: classOop
- "Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."
-
- | ccIndex cl |
- <inline: true>
- (objectMemory isIntegerObject: oop)
- ifTrue: [ self primitiveFail. ^ nil ].
-
- ccIndex := ((objectMemory baseHeader: oop) >> 12) bitAnd: 16r1F.
- ccIndex = 0
- ifTrue: [ cl := ((objectMemory classHeader: oop) bitAnd: objectMemory allButTypeMask) ]
- ifFalse: [
- "look up compact class"
- cl := (objectMemory fetchPointer: (ccIndex - 1)
- ofObject: (objectMemory fetchPointer: CompactClasses ofObject: objectMemory getSpecialObjectsOop))].
-
- self success: cl = classOop.
- !
Item was removed:
- ----- Method: Interpreter>>balancedStack:afterPrimitive:withArgs: (in category 'debug support') -----
- balancedStack: delta afterPrimitive: primIdx withArgs: nArgs
- "Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)"
- (primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true].
- "81-88 are control primitives after which the stack may look unbalanced"
- self successful ifTrue:[
- "Successful prim, stack must have exactly nArgs arguments popped off"
- ^(stackPointer - activeContext + (nArgs * objectMemory bytesPerWord)) = delta
- ].
- "Failed prim must leave stack intact"
- ^(stackPointer - activeContext) = delta
- !
Item was removed:
- ----- Method: Interpreter>>booleanCheat: (in category 'utilities') -----
- booleanCheat: cond
- "cheat the interpreter out of the pleasure of handling the next bytecode IFF it is a jump-on-boolean. Which it is, often enough when the current bytecode is something like bytecodePrimEqual"
- | bytecode offset |
- <inline: true>
-
- bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)"
- self internalPop: 2.
- (bytecode < 160 and: [bytecode > 151]) ifTrue: [ "short jumpIfFalse"
- cond
- ifTrue: [^ self fetchNextBytecode]
- ifFalse: [^ self jump: bytecode - 151]].
-
- bytecode = 172 ifTrue: [ "long jumpIfFalse"
- offset := self fetchByte.
- cond
- ifTrue: [^ self fetchNextBytecode]
- ifFalse: [^ self jump: offset]].
-
- "not followed by a jumpIfFalse; undo instruction fetch and push boolean result"
- localIP := localIP - 1.
- self fetchNextBytecode.
- cond
- ifTrue: [self internalPush: objectMemory getTrueObj]
- ifFalse: [self internalPush: objectMemory getFalseObj].
- !
Item was removed:
- ----- Method: Interpreter>>booleanValueOf: (in category 'utilities') -----
- booleanValueOf: obj
- "convert true and false (Smalltalk) to true or false(C)"
- obj = objectMemory getTrueObj ifTrue: [ ^ true ].
- obj = objectMemory getFalseObj ifTrue: [ ^ false ].
- self primitiveFail.
- ^ nil!
Item was removed:
- ----- Method: Interpreter>>byteLengthOf: (in category 'array primitive support') -----
- byteLengthOf: oop
- "Return the number of indexable bytes in the given object. This is basically a special copy of lengthOf: for BitBlt."
- | header sz fmt |
- header := objectMemory baseHeader: oop.
- (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
- ifTrue: [ sz := (objectMemory sizeHeader: oop) bitAnd: objectMemory allButTypeMask ]
- ifFalse: [ sz := header bitAnd: objectMemory sizeMask ].
- fmt := (header >> 8) bitAnd: 16rF.
- fmt < 8
- ifTrue: [ ^ (sz - objectMemory baseHeaderSize)] "words"
- ifFalse: [ ^ (sz - objectMemory baseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was removed:
- ----- Method: Interpreter>>byteSwapByteObjects (in category 'image save/restore') -----
- byteSwapByteObjects
- "Byte-swap the words of all bytes objects in the image. This returns these objects to their original byte ordering after blindly byte-swapping the entire image."
-
- self byteSwapByteObjectsFrom: objectMemory firstObject to: objectMemory getEndOfMemory!
Item was removed:
- ----- Method: Interpreter>>byteSwapByteObjectsFrom:to: (in category 'image save/restore') -----
- byteSwapByteObjectsFrom: startOop to: stopAddr
- "Byte-swap the words of all bytes objects in a range of the
- image, including Strings, ByteArrays, and CompiledMethods.
- This returns these objects to their original byte ordering
- after blindly byte-swapping the entire image. For compiled
- methods, byte-swap only their bytecodes part."
- | oop fmt wordAddr methodHeader |
- oop := startOop.
- [objectMemory oop: oop isLessThan: stopAddr]
- whileTrue: [(objectMemory isFreeObject: oop)
- ifFalse: [fmt := objectMemory formatOf: oop.
- fmt >= 8
- ifTrue: ["oop contains bytes"
- wordAddr := oop + objectMemory baseHeaderSize.
- fmt >= 12
- ifTrue: ["compiled method; start after methodHeader and literals"
- methodHeader := objectMemory longAt: oop + objectMemory baseHeaderSize.
- wordAddr := wordAddr + objectMemory bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * objectMemory bytesPerWord)].
- objectMemory reverseBytesFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)].
- (fmt = 6 and: [objectMemory bytesPerWord = 8])
- ifTrue: ["Object contains 32-bit half-words packed into 64-bit machine words."
- wordAddr := oop + objectMemory baseHeaderSize.
- objectMemory reverseWordsFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)]].
- oop := objectMemory objectAfter: oop]!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>bytecodePrimAt (in category 'common selector sends') -----
- bytecodePrimAt
- "BytecodePrimAt will only succeed if the receiver is in the atCache.
- Otherwise it will fail so that the more general primitiveAt will put it in the
- cache after validating that message lookup results in a primitive response."
- | index rcvr result atIx |
- index := self internalStackTop.
- rcvr := self internalStackValue: 1.
- ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isIntegerObject: index])
- ifTrue: [atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
- (atCache at: atIx+AtCacheOop) = rcvr
- ifTrue: [result := self
- commonVariableInternal: rcvr
- at: (objectMemory integerValueOf: index)
- cacheIndex: atIx.
- self successful ifTrue:
- [self fetchNextBytecode.
- ^self internalPop: 2 thenPush: result]]]
- ifFalse: [self primitiveFail].
- messageSelector := self specialSelector: 16.
- argumentCount := 1.
- self normalSend.
- !
Item was removed:
- ----- Method: Interpreter>>bytecodePrimAtEnd (in category 'common selector sends') -----
- bytecodePrimAtEnd
- messageSelector := self specialSelector: 21.
- argumentCount := 0.
- self normalSend.!
Item was removed:
- ----- Method: Interpreter>>bytecodePrimAtPut (in category 'common selector sends') -----
- bytecodePrimAtPut
- "BytecodePrimAtPut will only succeed if the receiver is in the atCache.
- Otherwise it will fail so that the more general primitiveAtPut will put it in the
- cache after validating that message lookup results in a primitive response."
- | index rcvr atIx value |
- value := self internalStackTop.
- index := self internalStackValue: 1.
- rcvr := self internalStackValue: 2.
- ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isIntegerObject: index])
- ifTrue: [atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
- (atCache at: atIx+AtCacheOop) = rcvr
- ifTrue: [self
- commonVariable: rcvr
- at: (objectMemory integerValueOf: index)
- put: value cacheIndex: atIx.
- self successful ifTrue: [self fetchNextBytecode.
- ^self internalPop: 3 thenPush: value]]]
- ifFalse: [self primitiveFail].
- messageSelector := self specialSelector: 17.
- argumentCount := 2.
- self normalSend!
Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: Interpreter>>bytecodePrimBlockCopy (in category 'common selector sends') -----
- bytecodePrimBlockCopy
-
- | rcvr hdr |
- rcvr := self internalStackValue: 1.
- self initPrimCall.
- hdr := objectMemory baseHeader: rcvr.
- self success: (self isContextHeader: hdr).
- self successful ifTrue: [self externalizeIPandSP.
- self primitiveBlockCopy.
- self internalizeIPandSP].
- self successful ifFalse: [messageSelector := self specialSelector: 24.
- argumentCount := 1.
- ^ self normalSend].
- self fetchNextBytecode.
- !
Item was removed:
- ----- Method: Interpreter>>bytecodePrimClass (in category 'common selector sends') -----
- bytecodePrimClass
- | rcvr |
- rcvr := self internalStackTop.
- self internalPop: 1 thenPush: (objectMemory fetchClassOf: rcvr).
- self fetchNextBytecode.
- !
Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: Interpreter>>bytecodePrimDo (in category 'common selector sends') -----
- bytecodePrimDo
-
- messageSelector := self specialSelector: 27.
- argumentCount := 1.
- self normalSend.
- !
Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: Interpreter>>bytecodePrimGreaterOrEqual (in category 'common selector sends') -----
- bytecodePrimGreaterOrEqual
- | rcvr arg aBool |
- rcvr := self internalStackValue: 1.
- arg := self internalStackValue: 0.
- (self areIntegers: rcvr and: arg) ifTrue:
- [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) >= (objectMemory integerValueOf: arg)].
- ^self booleanCheat: rcvr >= arg].
-
- self initPrimCall.
- aBool := self primitiveFloatGreaterOrEqual: rcvr toArg: arg.
- self successful ifTrue: [^self booleanCheat: aBool].
-
- messageSelector := self specialSelector: 5.
- argumentCount := 1.
- self normalSend!
Item was removed:
- ----- Method: Interpreter>>bytecodePrimGreaterThan (in category 'common selector sends') -----
- bytecodePrimGreaterThan
- | rcvr arg aBool |
- rcvr := self internalStackValue: 1.
- arg := self internalStackValue: 0.
- (self areIntegers: rcvr and: arg) ifTrue:
- [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) > (objectMemory integerValueOf: arg)].
- ^self booleanCheat: rcvr > arg].
-
- self initPrimCall.
- aBool := self primitiveFloatGreater: rcvr thanArg: arg.
- self successful ifTrue: [^self booleanCheat: aBool].
-
- messageSelector := self specialSelector: 3.
- argumentCount := 1.
- self normalSend
- !
Item was removed:
- ----- Method: Interpreter>>bytecodePrimLessOrEqual (in category 'common selector sends') -----
- bytecodePrimLessOrEqual
- | rcvr arg aBool |
- rcvr := self internalStackValue: 1.
- arg := self internalStackValue: 0.
- (self areIntegers: rcvr and: arg) ifTrue:
- [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) <= (objectMemory integerValueOf: arg)].
- ^ self booleanCheat: rcvr <= arg].
-
- self initPrimCall.
- aBool := self primitiveFloatLessOrEqual: rcvr toArg: arg.
- self successful ifTrue: [^self booleanCheat: aBool].
-
- messageSelector := self specialSelector: 4.
- argumentCount := 1.
- self normalSend!
Item was removed:
- ----- Method: Interpreter>>bytecodePrimLessThan (in category 'common selector sends') -----
- bytecodePrimLessThan
- | rcvr arg aBool |
- rcvr := self internalStackValue: 1.
- arg := self internalStackValue: 0.
- (self areIntegers: rcvr and: arg) ifTrue:
- [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) < (objectMemory integerValueOf: arg)].
- ^ self booleanCheat: rcvr < arg].
-
- self initPrimCall.
- aBool := self primitiveFloatLess: rcvr thanArg: arg.
- self successful ifTrue: [^ self booleanCheat: aBool].
-
- messageSelector := self specialSelector: 2.
- argumentCount := 1.
- self normalSend
- !
Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: Interpreter>>bytecodePrimMultiply (in category 'common selector sends') -----
- bytecodePrimMultiply
- | 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.
- result := rcvr * arg.
- (arg = 0 or: [(result // arg) = rcvr and: [objectMemory isIntegerValue: result]])
- ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
- ^ self fetchNextBytecode "success"]]
- ifFalse: [self initPrimCall.
- self externalizeIPandSP.
- self primitiveFloatMultiply: rcvr byArg: arg.
- self internalizeIPandSP.
- self successful ifTrue: [^ self fetchNextBytecode "success"]].
-
- messageSelector := self specialSelector: 8.
- argumentCount := 1.
- self normalSend.
- !
Item was removed:
- ----- Method: Interpreter>>bytecodePrimNew (in category 'common selector sends') -----
- bytecodePrimNew
-
- messageSelector := self specialSelector: 28.
- argumentCount := 0.
- self normalSend.
- !
Item was removed:
- ----- Method: Interpreter>>bytecodePrimNewWithArg (in category 'common selector sends') -----
- bytecodePrimNewWithArg
-
- messageSelector := self specialSelector: 29.
- argumentCount := 1.
- self normalSend.
- !
Item was removed:
- ----- Method: Interpreter>>bytecodePrimNext (in category 'common selector sends') -----
- bytecodePrimNext
- messageSelector := self specialSelector: 19.
- argumentCount := 0.
- self normalSend.!
Item was removed:
- ----- Method: Interpreter>>bytecodePrimNextPut (in category 'common selector sends') -----
- bytecodePrimNextPut
- messageSelector := self specialSelector: 20.
- argumentCount := 1.
- self normalSend.!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>bytecodePrimPointX (in category 'common selector sends') -----
- bytecodePrimPointX
-
- | rcvr |
- self initPrimCall.
- rcvr := self internalStackTop.
- self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
- self successful
- ifTrue: [self internalPop: 1 thenPush: (objectMemory fetchPointer: XIndex ofObject: rcvr).
- ^ self fetchNextBytecode "success"].
-
- messageSelector := self specialSelector: 30.
- argumentCount := 0.
- self normalSend!
Item was removed:
- ----- Method: Interpreter>>bytecodePrimPointY (in category 'common selector sends') -----
- bytecodePrimPointY
-
- | rcvr |
- self initPrimCall.
- rcvr := self internalStackTop.
- self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
- self successful
- ifTrue: [self internalPop: 1 thenPush: (objectMemory fetchPointer: YIndex ofObject: rcvr).
- ^ self fetchNextBytecode "success"].
-
- messageSelector := self specialSelector: 31.
- argumentCount := 0.
- self normalSend!
Item was removed:
- ----- Method: Interpreter>>bytecodePrimSize (in category 'common selector sends') -----
- bytecodePrimSize
- messageSelector := self specialSelector: 18.
- argumentCount := 0.
- self normalSend!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>bytecodePrimValue (in category 'common selector sends') -----
- bytecodePrimValue
- "In-line value for BlockClosure and BlockContext"
- | maybeBlock rcvrClass |
- maybeBlock := self internalStackTop.
- argumentCount := 0.
- self initPrimCall.
- (objectMemory isNonIntegerObject: maybeBlock) ifTrue:
- [rcvrClass := objectMemory fetchClassOfNonInt: maybeBlock.
- rcvrClass = (objectMemory splObj: ClassBlockClosure)
- ifTrue:
- [self externalizeIPandSP.
- self primitiveClosureValue.
- self internalizeIPandSP]
- ifFalse:
- [rcvrClass = (objectMemory splObj: ClassBlockContext)
- ifTrue:
- [self externalizeIPandSP.
- self primitiveValue.
- self internalizeIPandSP]
- ifFalse:
- [self primitiveFail]]].
- self successful ifFalse:
- [messageSelector := self specialSelector: 25.
- ^self normalSend].
- self fetchNextBytecode!
Item was removed:
- ----- Method: Interpreter>>bytecodePrimValueWithArg (in category 'common selector sends') -----
- bytecodePrimValueWithArg
- "In-line value: for BlockClosure and BlockContext"
- | maybeBlock rcvrClass |
- maybeBlock := self internalStackValue: 1.
- argumentCount := 1.
- self initPrimCall.
- (objectMemory isNonIntegerObject: maybeBlock) ifTrue:
- [rcvrClass := objectMemory fetchClassOfNonInt: maybeBlock.
- rcvrClass = (objectMemory splObj: ClassBlockClosure)
- ifTrue:
- [self externalizeIPandSP.
- self primitiveClosureValue.
- self internalizeIPandSP]
- ifFalse:
- [rcvrClass = (objectMemory splObj: ClassBlockContext)
- ifTrue:
- [self externalizeIPandSP.
- self primitiveValue.
- self internalizeIPandSP]
- ifFalse:
- [self primitiveFail]]].
- self successful ifFalse:
- [messageSelector := self specialSelector: 26.
- ^self normalSend].
- self fetchNextBytecode!
Item was removed:
- ----- Method: Interpreter>>callExternalPrimitive: (in category 'plugin primitive support') -----
- callExternalPrimitive: functionID
- "Call the external plugin function identified. In the VM this is an address, see InterpreterSimulator for it's version. "
-
- <var: #functionID declareC: 'void (*functionID)(void)'>
- self dispatchFunctionPointer: functionID!
Item was removed:
- ----- Method: Interpreter>>callInterpreter (in category 'interpreter shell') -----
- callInterpreter
- "External call into the interpreter"
-
- <inline: false>
- <export: true>
- self interpret.!
Item was removed:
- ----- Method: Interpreter>>callbackEnter: (in category 'callback support') -----
- callbackEnter: callbackID
- "Re-enter the interpreter for executing a callback"
- | result activeProc |
- <export: true>
- <var: #callbackID declareC: 'sqInt *callbackID'>
-
- "For now, do not allow a callback unless we're in a primitiveResponse"
- primitiveIndex = 0 ifTrue:[^false].
-
- "Check if we've exceeded the callback depth"
- jmpDepth >= jmpMax ifTrue:[^false].
- jmpDepth := jmpDepth + 1.
-
- "Suspend the currently active process"
- activeProc := objectMemory fetchPointer: ActiveProcessIndex
- ofObject: self schedulerPointer.
- suspendedCallbacks at: jmpDepth put: activeProc.
- "We need to preserve newMethod explicitly since it is not activated yet
- and therefore no context has been created for it. If the caller primitive
- for any reason decides to fail we need to make sure we execute the correct
- method and not the one 'last used' in the call back"
- suspendedMethods at: jmpDepth put: newMethod.
- self transferTo: self wakeHighestPriority.
-
- "Typically, invoking the callback means that some semaphore has been
- signaled to indicate the callback. Force an interrupt check right away."
- self forceInterruptCheck.
-
- result := self setjmp: (jmpBuf at: jmpDepth).
- result == 0 ifTrue:["Fill in callbackID"
- callbackID at: 0 put: jmpDepth.
- "This is ugly but the inliner treats interpret() in very special and strange ways and calling any kind of 'self interpret' either directly or even via cCode:inSmalltalk: will cause this entire method to vanish."
- self cCode: 'interpret()'.
- ].
-
- "Transfer back to the previous process so that caller can push result"
- activeProc := objectMemory fetchPointer: ActiveProcessIndex
- ofObject: self schedulerPointer.
- self putToSleep: activeProc.
- activeProc := suspendedCallbacks at: jmpDepth.
- newMethod := suspendedMethods at: jmpDepth. "see comment above"
- self transferTo: activeProc.
- jmpDepth := jmpDepth-1.
- ^true!
Item was removed:
- ----- Method: Interpreter>>callbackLeave: (in category 'callback support') -----
- callbackLeave: cbID
- "Leave from a previous callback"
- <export: true>
-
- "For now, do not allow a callback unless we're in a primitiveResponse"
- primitiveIndex = 0 ifTrue:[^false].
-
- "Check if this is the top-level callback"
- cbID = jmpDepth ifFalse:[^false].
- cbID < 1 ifTrue:[^false].
- "This is ugly but necessary, or otherwise the Mac will not build"
- self long: (jmpBuf at: jmpDepth) jmp: 1.
- !
Item was removed:
- ----- Method: Interpreter>>caller (in category 'contexts') -----
- caller
- ^objectMemory fetchPointer: CallerIndex ofObject: activeContext!
Item was removed:
- ----- Method: Interpreter>>capturePendingFinalizationSignals (in category 'debug support') -----
- capturePendingFinalizationSignals
- objectMemory setStatpendingFinalizationSignals: pendingFinalizationSignals.
- !
Item was removed:
- ----- Method: Interpreter>>changeClassOf:to: (in category 'object access primitives') -----
- changeClassOf: rcvr to: argClass
- "Change the class of the receiver into the class specified by the argument given that the format of the receiver matches the format of the argument. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
- | classHdr sizeHiBits byteSize argFormat rcvrFormat ccIndex |
- "Check what the format of the class says"
- classHdr := objectMemory formatOfClass: argClass. "Low 2 bits are 0"
-
- "Compute the size of instances of the class (used for fixed field classes only)"
- sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
- classHdr := classHdr bitAnd: 16r1FFFF.
- byteSize := (classHdr bitAnd: objectMemory sizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
-
- "Check the receiver's format against that of the class"
- argFormat := (classHdr >> 8) bitAnd: 16rF.
- rcvrFormat := objectMemory formatOf: rcvr.
- argFormat = rcvrFormat ifFalse:[^self primitiveFail]. "no way"
-
- "For fixed field classes, the sizes must match.
- Note: byteSize-4 because base header is included in class size."
- argFormat < 2 ifTrue:[(byteSize - 4) = (objectMemory byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].
-
- (objectMemory headerType: rcvr) = HeaderTypeShort
- ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex"
- ccIndex := classHdr bitAnd: CompactClassMask.
- ccIndex = 0 ifTrue:[^self primitiveFail]. "class is not compact"
- objectMemory longAt: rcvr put:
- (((objectMemory longAt: rcvr) bitAnd: CompactClassMask bitInvert32)
- bitOr: ccIndex)]
- ifFalse:["Exchange the class pointer, which could make rcvr a root for argClass"
- objectMemory longAt: rcvr - objectMemory baseHeaderSize put: (argClass bitOr: (objectMemory headerType: rcvr)).
- (objectMemory oop: rcvr isLessThan: objectMemory getYoungStart)
- ifTrue: [objectMemory possibleRootStoreInto: rcvr value: argClass]]!
Item was removed:
- ----- Method: Interpreter>>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: Interpreter>>characterTable (in category 'plugin support') -----
- characterTable
- ^objectMemory splObj: CharacterTable!
Item was removed:
- ----- Method: Interpreter>>checkBooleanResult: (in category 'arithmetic primitive support') -----
- checkBooleanResult: result
- self successful
- ifTrue: [self pushBool: result]
- ifFalse: [self unPop: 2]!
Item was removed:
- ----- Method: Interpreter>>checkCodeIntegrity: (in category 'stack interpreter support') -----
- checkCodeIntegrity: fullGCFlag
- "This is a no-op in the Interpreter and the StackVM"
- ^true!
Item was removed:
- ----- Method: Interpreter>>checkForInterrupts (in category 'process primitive support') -----
- checkForInterrupts
- "Check for possible interrupts and handle one if necessary."
- | sema now |
- <inline: false>
-
- "Mask so same wrapping as primitiveMillisecondClock"
- now := self ioMSecs bitAnd: MillisecondClockMask.
-
- self interruptCheckForced ifFalse: [
- "don't play with the feedback if we forced a check. It only makes life difficult"
- now - lastTick < interruptChecksEveryNms
- ifTrue: ["wrapping is not a concern, it'll get caught quickly
- enough. This clause is trying to keep a reasonable
- guess of how many times per interruptChecksEveryNms we are calling
- quickCheckForInterrupts. Not sure how effective it really is."
- interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset + 10]
- ifFalse: [interruptCheckCounterFeedBackReset <= 1000
- ifTrue: [interruptCheckCounterFeedBackReset := 1000]
- ifFalse: [interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset - 12]]].
-
- "reset the interrupt check counter"
- interruptCheckCounter := interruptCheckCounterFeedBackReset.
-
- objectMemory getSignalLowSpace
- ifTrue: [objectMemory setSignalLowSpace: false. "reset flag"
- sema := objectMemory splObj: TheLowSpaceSemaphore.
- sema = objectMemory getNilObj ifFalse: [self synchronousSignal: sema]].
-
- now < lastTick
- ifTrue: ["millisecond clock wrapped so correct the nextPollTick"
- nextPollTick := nextPollTick - MillisecondClockMask - 1].
- now >= nextPollTick
- ifTrue: [self ioProcessEvents.
- "sets interruptPending if interrupt key pressed"
- nextPollTick := now + 200
- "msecs to wait before next call to ioProcessEvents.
- Note that strictly speaking we might need to update
- 'now' at this point since ioProcessEvents could take a
- very long time on some platforms"].
- interruptPending
- ifTrue: [interruptPending := false.
- "reset interrupt flag"
- sema := objectMemory splObj: TheInterruptSemaphore.
- sema = objectMemory getNilObj
- ifFalse: [self synchronousSignal: sema]].
-
- nextWakeupTick ~= 0
- ifTrue: [now < lastTick
- ifTrue: ["the clock has wrapped. Subtract the wrap
- interval from nextWakeupTick - this might just
- possibly result in 0. Since this is used as a flag
- value for 'no timer' we do the 0 check above"
- nextWakeupTick := nextWakeupTick - MillisecondClockMask - 1].
- now >= nextWakeupTick
- ifTrue: [nextWakeupTick := 0.
- "set timer interrupt to 0 for 'no timer'"
- sema := objectMemory splObj: TheTimerSemaphore.
- sema = objectMemory getNilObj ifFalse: [self synchronousSignal: sema]]].
-
- "signal any pending finalizations"
- pendingFinalizationSignals > 0
- ifTrue: [sema := objectMemory splObj: TheFinalizationSemaphore.
- (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
- ifTrue: [self synchronousSignal: sema].
- pendingFinalizationSignals := 0].
-
- "signal all semaphores in semaphoresToSignal"
- (semaphoresToSignalCountA > 0 or: [semaphoresToSignalCountB > 0])
- ifTrue: [self signalExternalSemaphores].
-
- "update the tracking value"
- lastTick := now!
Item was removed:
- ----- Method: Interpreter>>checkImageVersionFrom:startingAt: (in category 'image save/restore') -----
- checkImageVersionFrom: f startingAt: imageOffset
- "Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number."
- "This code is based on C code by Ian Piumarta."
-
- | firstVersion |
- <var: #f type: 'sqImageFile '>
- <var: #imageOffset type: 'squeakFileOffsetType '>
-
- "check the version number"
- self sqImageFile: f Seek: imageOffset.
- imageFormatInitialVersion := firstVersion := self getLongFromFile: f swap: false.
- (self readableFormat: imageFormatInitialVersion) ifTrue: [^ false].
-
- "try with bytes reversed"
- self sqImageFile: f Seek: imageOffset.
- imageFormatInitialVersion := self getLongFromFile: f swap: true.
- (self readableFormat: imageFormatInitialVersion) ifTrue: [^ true].
-
- "Note: The following is only meaningful if not reading an embedded image"
- imageOffset = 0 ifTrue:[
- "try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)"
- self sqImageFile: f Seek: 512.
- imageFormatInitialVersion := self getLongFromFile: f swap: false.
- (self readableFormat: imageFormatInitialVersion) ifTrue: [^ false].
-
- "try skipping the first 512 bytes with bytes reversed"
- self sqImageFile: f Seek: 512.
- imageFormatInitialVersion := self getLongFromFile: f swap: true.
- (self readableFormat: imageFormatInitialVersion) ifTrue: [^ true]].
-
- "hard failure; abort"
- self print: 'This interpreter (vers. '.
- self printNum: self imageFormatVersion.
- self print: ') cannot read image file (vers. '.
- self printNum: firstVersion.
- self print: ').'.
- self cr.
- self print: 'Press CR to quit...'.
- self getchar.
- self ioExit.
- !
Item was removed:
- ----- Method: Interpreter>>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: Interpreter>>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: Interpreter>>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 changed:
----- Method: Interpreter>>checkedIntegerValueOf: (in category 'utilities') -----
checkedIntegerValueOf: intOop
"Note: May be called by translated primitive code."
(objectMemory isIntegerObject: intOop)
ifTrue: [ ^ objectMemory integerValueOf: intOop ]
ifFalse: [ self primitiveFail. ^ 0 ]!
Item was removed:
- ----- Method: Interpreter>>classNameOf:Is: (in category 'plugin primitive support') -----
- classNameOf: aClass Is: className
- "Check if aClass's name is className"
- | srcName name length |
- <var: #className type: 'char *'>
- <var: #srcName type: 'char *'>
- (objectMemory lengthOf: aClass) <= 6 ifTrue: [^ false].
-
- "Not a class but might be behavior"
- name := objectMemory fetchPointer: 6 ofObject: aClass.
- (objectMemory isBytes: name) ifFalse: [^ false].
- length := self stSizeOf: name.
- srcName := self cCoerce: (self arrayValueOf: name) to: 'char *'.
- 0 to: length - 1 do: [:i | (srcName at: i) = (className at: i) ifFalse: [^ false]].
- "Check if className really ends at this point"
- ^ (className at: length) = 0!
Item was removed:
- ----- Method: Interpreter>>closureNumArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
- closureNumArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
- | newClosure |
- <inline: true>
- newClosure := objectMemory
- instantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
- sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize.
- "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
- objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
- objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
- "It is up to the caller to store the outer context and copiedValues."
- ^newClosure!
Item was removed:
- ----- Method: Interpreter>>commonAt: (in category 'array primitive support') -----
- commonAt: stringy
- "This code is called if the receiver responds primitively to at:.
- If this is so, it will be installed in the atCache so that subsequent calls of at:
- or next may be handled immediately in bytecode primitive routines."
- | index rcvr atIx result |
- index := self positive32BitValueOf: (self stackTop). "Sets primFailCode"
- rcvr := self stackValue: 1.
- self successful & (objectMemory isIntegerObject: rcvr) not
- ifFalse: [^ self primitiveFail].
-
- "NOTE: The at-cache, since it is specific to the non-super response to #at:.
- Therefore we must determine that the message is #at: (not, eg, #basicAt:),
- and that the send is not a super-send, before using the at-cache."
- (messageSelector = (self specialSelector: 16)
- and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)])
- ifTrue:
- ["OK -- look in the at-cache"
- atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
- (atCache at: atIx+AtCacheOop) = rcvr ifFalse:
- ["Rcvr not in cache. Install it..."
- self install: rcvr inAtCache: atCache at: atIx string: stringy].
- self successful ifTrue:
- [result := self commonVariable: rcvr at: index cacheIndex: atIx].
- self successful ifTrue:
- [^ self pop: argumentCount+1 thenPush: result]].
-
- "The slow but sure way..."
- self initPrimCall.
- result := self stObject: rcvr at: index.
- self successful ifTrue:
- [stringy ifTrue: [result := self characterForAscii: (objectMemory integerValueOf: result)].
- ^ self pop: argumentCount+1 thenPush: result]!
Item was removed:
- ----- Method: Interpreter>>commonAtPut: (in category 'array primitive support') -----
- commonAtPut: stringy
- "This code is called if the receiver responds primitively to at:Put:.
- If this is so, it will be installed in the atPutCache so that subsequent calls of at:
- or next may be handled immediately in bytecode primitive routines."
- | value index rcvr atIx |
- value := self stackTop.
- index := self positive32BitValueOf: (self stackValue: 1). "Sets primFailCode"
- rcvr := self stackValue: 2.
- self successful & (objectMemory isIntegerObject: rcvr) not
- ifFalse: [^ self primitiveFail].
-
- "NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:.
- Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:),
- and that the send is not a super-send, before using the at-cache."
- (messageSelector = (self specialSelector: 17)
- and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)])
- ifTrue:
- ["OK -- look in the at-cache"
- atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
- (atCache at: atIx+AtCacheOop) = rcvr ifFalse:
- ["Rcvr not in cache. Install it..."
- self install: rcvr inAtCache: atCache at: atIx string: stringy].
- self successful ifTrue:
- [self commonVariable: rcvr at: index put: value cacheIndex: atIx].
- self successful ifTrue:
- [^ self pop: argumentCount+1 thenPush: value]].
-
- "The slow but sure way..."
- self initPrimCall.
- stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
- ifFalse: [self stObject: rcvr at: index put: value].
- self successful ifTrue: [^ self pop: argumentCount+1 thenPush: value].
- !
Item was removed:
- ----- Method: Interpreter>>commonReturn (in category 'return bytecodes') -----
- commonReturn
- "Note: Assumed to be inlined into the dispatch loop."
-
- | nilOop thisCntx contextOfCaller localCntx localVal unwindMarked |
- <inline: true>
- self sharedCodeNamed: 'commonReturn' inCase: 120.
-
- nilOop := objectMemory getNilObj. "keep in a register"
- thisCntx := activeContext.
- localCntx := localReturnContext.
- localVal := localReturnValue.
-
- "make sure we can return to the given context"
- ((localCntx = nilOop) or:
- [(objectMemory fetchPointer: InstructionPointerIndex ofObject: localCntx) = nilOop]) ifTrue: [
- "error: sender's instruction pointer or context is nil; cannot return"
- ^self internalCannotReturn: localVal].
-
- "If this return is not to our immediate predecessor (i.e. from a method to its sender, or from a block to its caller), scan the stack for the first unwind marked context and inform this context and let it deal with it. This provides a chance for ensure unwinding to occur."
- thisCntx := objectMemory fetchPointer: SenderIndex ofObject: activeContext.
-
- "Just possibly a faster test would be to compare the homeContext and activeContext - they are of course different for blocks. Thus we might be able to optimise a touch by having a different returnTo for the blockreteurn (since we know that must return to caller) and then if active ~= home we must be doing a non-local return. I think. Maybe."
- [thisCntx = localCntx] whileFalse: [
- thisCntx = nilOop ifTrue:[
- "error: sender's instruction pointer or context is nil; cannot return"
- ^self internalCannotReturn: localVal].
- "Climb up stack towards localCntx. Break out to a send of #aboutToReturn:through: if an unwind marked context is found"
- unwindMarked := self isUnwindMarked: thisCntx.
- unwindMarked ifTrue:[
- "context is marked; break out"
- ^self internalAboutToReturn: localVal through: thisCntx].
- thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- ].
-
- "If we get here there is no unwind to worry about. Simply terminate the stack up to the localCntx - often just the sender of the method"
- thisCntx := activeContext.
- [thisCntx = localCntx]
- whileFalse:
- ["climb up stack to localCntx"
- contextOfCaller := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
-
- "zap exited contexts so any future attempted use will be caught"
- objectMemory storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.
- objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.
- reclaimableContextCount > 0 ifTrue:
- ["try to recycle this context"
- reclaimableContextCount := reclaimableContextCount - 1.
- objectMemory recycleContextIfPossible: thisCntx].
- thisCntx := contextOfCaller].
-
- activeContext := thisCntx.
- (objectMemory oop: thisCntx isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: thisCntx ].
-
- self internalFetchContextRegisters: thisCntx. "updates local IP and SP"
- self fetchNextBytecode.
- self internalPush: localVal.
- !
Item was removed:
- ----- Method: Interpreter>>commonSend (in category 'message sending') -----
- commonSend
- "Send a message, starting lookup with the receiver's class."
- "Assume: messageSelector and argumentCount have been set, and that
- the receiver and arguments have been pushed onto the stack,"
- "Note: This method is inlined into the interpreter dispatch loop."
- self sharedCodeNamed: 'commonSend' inCase: 131.
- self internalFindNewMethod.
- self internalExecuteNewMethod.
- self fetchNextBytecode!
Item was removed:
- ----- Method: Interpreter>>commonVariable:at:cacheIndex: (in category 'array primitive support') -----
- commonVariable: rcvr at: index cacheIndex: atIx
- "This code assumes the receiver has been identified at location atIx in the atCache."
- | stSize fmt fixedFields result |
-
- stSize := atCache at: atIx+AtCacheSize.
- ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
- and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ifTrue:
- [fmt := atCache at: atIx+AtCacheFmt.
- fmt <= 4 ifTrue:
- [fixedFields := atCache at: atIx+AtCacheFixedFields.
- ^ objectMemory fetchPointer: index + fixedFields - 1 ofObject: rcvr].
- fmt < 8 ifTrue: "Bitmap"
- [result := objectMemory fetchLong32: index - 1 ofObject: rcvr.
- result := objectMemory positive32BitIntegerFor: result.
- ^ result].
- fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
- ifTrue: "String"
- [^ self characterForAscii: (objectMemory fetchByte: index - 1 ofObject: rcvr)]
- ifFalse: "ByteArray"
- [^ objectMemory integerObjectOf: (objectMemory fetchByte: index - 1 ofObject: rcvr)]].
-
- self primitiveFail!
Item was removed:
- ----- Method: Interpreter>>commonVariable:at:put:cacheIndex: (in category 'array primitive support') -----
- commonVariable: rcvr at: index put: value cacheIndex: atIx
- "This code assumes the receiver has been identified at location atIx in the atCache."
- | stSize fmt fixedFields valToPut |
- <inline: true>
-
- stSize := atCache at: atIx+AtCacheSize.
- ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
- and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ifTrue:
- [fmt := atCache at: atIx+AtCacheFmt.
- fmt <= 4 ifTrue:
- [fixedFields := atCache at: atIx+AtCacheFixedFields.
- ^ objectMemory storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value].
- fmt < 8 ifTrue: "Bitmap"
- [valToPut := self positive32BitValueOf: value.
- self successful ifTrue: [objectMemory storeLong32: index - 1 ofObject: rcvr withValue: valToPut].
- ^ nil].
- fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
- ifTrue: [valToPut := self asciiOfCharacter: value.
- self successful ifFalse: [^ nil]]
- ifFalse: [valToPut := value].
- (objectMemory isIntegerObject: valToPut) ifTrue:
- [valToPut := objectMemory integerValueOf: valToPut.
- ((valToPut >= 0) and: [valToPut <= 255]) ifFalse: [^ self primitiveFail].
- ^ objectMemory storeByte: index - 1 ofObject: rcvr withValue: valToPut]].
-
- self primitiveFail!
Item was removed:
- ----- Method: Interpreter>>commonVariableInternal:at:cacheIndex: (in category 'array primitive support') -----
- commonVariableInternal: rcvr at: index cacheIndex: atIx
- "This code assumes the receiver has been identified at location atIx in the atCache."
- | stSize fmt fixedFields result |
- <inline: true>
-
- stSize := atCache at: atIx+AtCacheSize.
- ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
- and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ifTrue:
- [fmt := atCache at: atIx+AtCacheFmt.
- fmt <= 4 ifTrue:
- [fixedFields := atCache at: atIx+AtCacheFixedFields.
- ^ objectMemory fetchPointer: index + fixedFields - 1 ofObject: rcvr].
- fmt < 8 ifTrue: "Bitmap"
- [result := objectMemory fetchLong32: index - 1 ofObject: rcvr.
- self externalizeIPandSP.
- result := objectMemory positive32BitIntegerFor: result.
- self internalizeIPandSP.
- ^ result].
- fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
- ifTrue: "String"
- [^ self characterForAscii: (objectMemory fetchByte: index - 1 ofObject: rcvr)]
- ifFalse: "ByteArray"
- [^ objectMemory integerObjectOf: (objectMemory fetchByte: index - 1 ofObject: rcvr)]].
-
- self primitiveFail!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>compilerCreateActualMessage:storingArgs: (in category 'compiler support') -----
- compilerCreateActualMessage: aMessage storingArgs: argArray
- ^self cCode: 'compilerHooks[14](aMessage, argArray)'!
Item was removed:
- ----- Method: Interpreter>>compilerFlushCache: (in category 'compiler support') -----
- compilerFlushCache: aCompiledMethod
- ^self cCode: 'compilerHooks[2](aCompiledMethod)'!
Item was removed:
- ----- Method: Interpreter>>compilerFlushCacheHook: (in category 'compiler support') -----
- compilerFlushCacheHook: aCompiledMethod
- <inline: true>
- compilerInitialized ifTrue: [self compilerFlushCache: aCompiledMethod]!
Item was removed:
- ----- Method: Interpreter>>compilerMapFrom:to: (in category 'compiler support') -----
- compilerMapFrom: memStart to: memEnd
- ^self cCode: 'compilerHooks[4](memStart, memEnd)'!
Item was removed:
- ----- Method: Interpreter>>compilerMapHookFrom:to: (in category 'compiler support') -----
- compilerMapHookFrom: memStart to: memEnd
- <inline: true>
- compilerInitialized ifTrue: [self compilerMapFrom: memStart to: memEnd]!
Item was removed:
- ----- Method: Interpreter>>compilerMark (in category 'compiler support') -----
- compilerMark
- ^self cCode: 'compilerHooks[9]()'!
Item was removed:
- ----- Method: Interpreter>>compilerMarkHook (in category 'compiler support') -----
- compilerMarkHook
- <inline: true>
- compilerInitialized ifTrue: [self compilerMark]!
Item was removed:
- ----- Method: Interpreter>>compilerPostGC (in category 'compiler support') -----
- compilerPostGC
- ^self cCode: 'compilerHooks[5]()'!
Item was removed:
- ----- Method: Interpreter>>compilerPostGCHook (in category 'compiler support') -----
- compilerPostGCHook
- <inline: true>
- compilerInitialized ifTrue: [self compilerPostGC]!
Item was removed:
- ----- Method: Interpreter>>compilerPostSnapshot (in category 'compiler support') -----
- compilerPostSnapshot
- ^self cCode: 'compilerHooks[8]()'!
Item was removed:
- ----- Method: Interpreter>>compilerPostSnapshotHook (in category 'compiler support') -----
- compilerPostSnapshotHook
- <inline: true>
- compilerInitialized ifTrue: [self compilerPostSnapshot]!
Item was removed:
- ----- Method: Interpreter>>compilerPreGC: (in category 'compiler support') -----
- compilerPreGC: fullGCFlag
- ^self cCode: 'compilerHooks[3](fullGCFlag)'!
Item was removed:
- ----- Method: Interpreter>>compilerPreGCHook: (in category 'compiler support') -----
- compilerPreGCHook: fullGCFlag
- <inline: true>
- compilerInitialized ifTrue: [self compilerPreGC: fullGCFlag]!
Item was removed:
- ----- Method: Interpreter>>compilerPreSnapshot (in category 'compiler support') -----
- compilerPreSnapshot
- ^self cCode: 'compilerHooks[7]()'!
Item was removed:
- ----- Method: Interpreter>>compilerPreSnapshotHook (in category 'compiler support') -----
- compilerPreSnapshotHook
- <inline: true>
- compilerInitialized ifTrue: [self compilerPreSnapshot]!
Item was removed:
- ----- Method: Interpreter>>compilerProcessChange (in category 'compiler support') -----
- compilerProcessChange
- ^self cCode: 'compilerHooks[6]()'!
Item was removed:
- ----- Method: Interpreter>>compilerProcessChange:to: (in category 'compiler support') -----
- compilerProcessChange: oldProc to: newProc
- ^self cCode: 'compilerHooks[6](oldProc, newProc)'!
Item was removed:
- ----- Method: Interpreter>>compilerProcessChangeHook (in category 'compiler support') -----
- compilerProcessChangeHook
- <inline: true>
- compilerInitialized ifTrue: [self compilerProcessChange]!
Item was removed:
- ----- Method: Interpreter>>compilerTranslateMethod (in category 'compiler support') -----
- compilerTranslateMethod
- ^self cCode: 'compilerHooks[1]()'!
Item was removed:
- ----- Method: Interpreter>>compilerTranslateMethodHook (in category 'compiler support') -----
- compilerTranslateMethodHook
- <inline: true>
- ^compilerInitialized and: [self compilerTranslateMethod]!
Item was removed:
- ----- Method: Interpreter>>constMinusOne (in category 'constants') -----
- constMinusOne
- ^ConstMinusOne!
Item was removed:
- ----- Method: Interpreter>>context:hasSender: (in category 'contexts') -----
- context: thisCntx hasSender: aContext
- "Does thisCntx have aContext in its sender chain?"
- | s nilOop |
- <inline: true>
- thisCntx == aContext ifTrue: [^false].
- nilOop := objectMemory getNilObj.
- s := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- [s == nilOop]
- whileFalse: [s == aContext ifTrue: [^true].
- s := objectMemory fetchPointer: SenderIndex ofObject: s].
- ^false!
Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: Interpreter>>cr (in category 'debug printing') -----
- cr
- "For testing in Smalltalk, this method should be overridden in a subclass."
-
- self printf: '\n'.!
Item was removed:
- ----- Method: Interpreter>>createActualMessageTo: (in category 'message sending') -----
- createActualMessageTo: aClass
- "Bundle up the selector, arguments and lookupClass into a Message object.
- In the process it pops the arguments off the stack, and pushes the message object.
- This can then be presented as the argument of e.g. #doesNotUnderstand:.
- ikp 11/20/1999 03:59 -- added hook for external runtime compilers."
- "remap lookupClass in case GC happens during allocation"
- | argumentArray message lookupClass |
- objectMemory pushRemappableOop: aClass.
- argumentArray := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount.
- "remap argumentArray in case GC happens during allocation"
- objectMemory pushRemappableOop: argumentArray.
- message := objectMemory instantiateClass: (objectMemory splObj: ClassMessage) indexableSize: 0.
- argumentArray := objectMemory popRemappableOop.
- lookupClass := objectMemory popRemappableOop.
- objectMemory beRootIfOld: argumentArray.
-
- compilerInitialized
- ifTrue: [self compilerCreateActualMessage: message storingArgs: argumentArray]
- ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * objectMemory bytesPerWord) to: argumentArray + objectMemory baseHeaderSize.
- self pop: argumentCount thenPush: message].
-
- argumentCount := 1.
- objectMemory storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector.
- objectMemory storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray.
- (objectMemory lastPointerOf: message) >= (MessageLookupClassIndex * objectMemory bytesPerWord + objectMemory baseHeaderSize)
- ifTrue: ["Only store lookupClass if message has 3 fields (old images don't)"
- objectMemory storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]!
Item was removed:
- ----- Method: Interpreter>>disableCompiler (in category 'compiler support') -----
- disableCompiler
- compilerInitialized := false!
Item was removed:
- ----- Method: Interpreter>>dispatchFunctionPointer: (in category 'message sending') -----
- dispatchFunctionPointer: aFunctionPointer
- <var: #aFunctionPointer declareC: 'void (*aFunctionPointer)(void)'>
- self
- cCode: '(aFunctionPointer)()'
- inSmalltalk: [self error: 'my simulator should simulate me']!
Item was removed:
- ----- Method: Interpreter>>dispatchFunctionPointerOn:in: (in category 'message sending') -----
- dispatchFunctionPointerOn: primIdx in: primTable
- "Call the primitive at index primIdx in the primitiveTable."
-
- <var: #primTable declareC: 'void (*primTable[])(void)'>
- ^self dispatchFunctionPointer: (primTable at: primIdx)!
Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: Interpreter>>doubleExtendedDoAnythingBytecode (in category 'send bytecodes') -----
- doubleExtendedDoAnythingBytecode
- "Replaces the Blue Book double-extended send [132], in which the first byte was wasted on 8 bits of argument count.
- Here we use 3 bits for the operation sub-type (opType), and the remaining 5 bits for argument count where needed.
- The last byte give access to 256 instVars or literals.
- See also secondExtendedSendBytecode"
- | byte2 byte3 opType top |
- byte2 := self fetchByte.
- byte3 := self fetchByte.
- opType := byte2 >> 5.
- opType = 0 ifTrue: [messageSelector := self literal: byte3.
- argumentCount := byte2 bitAnd: 31.
- ^ self normalSend].
- opType = 1 ifTrue: [messageSelector := self literal: byte3.
- argumentCount := byte2 bitAnd: 31.
- ^ self superclassSend].
- self fetchNextBytecode.
- opType = 2 ifTrue: [^ self pushReceiverVariable: byte3].
- opType = 3 ifTrue: [^ self pushLiteralConstant: byte3].
- opType = 4 ifTrue: [^ self pushLiteralVariable: byte3].
- opType = 5 ifTrue: [top := self internalStackTop.
- ^ objectMemory storePointer: byte3 ofObject: receiver withValue: top].
- opType = 6
- ifTrue: [top := self internalStackTop.
- self internalPop: 1.
- ^ objectMemory storePointer: byte3 ofObject: receiver withValue: top].
- opType = 7
- ifTrue: [top := self internalStackTop.
- ^ objectMemory storePointer: ValueIndex ofObject: (self literal: byte3) withValue: top]!
Item was removed:
- ----- Method: Interpreter>>dummyReferToProxy (in category 'initialization') -----
- dummyReferToProxy
- <inline: false>
- interpreterProxy := interpreterProxy!
Item was removed:
- ----- Method: Interpreter>>dumpImage: (in category 'image save/restore') -----
- dumpImage: fileName
- "Dump the entire image out to the given file. Intended for debugging only."
- | f dataSize result |
- <export: true>
- <var: #fileName type: 'char *'>
- <var: #f type: 'sqImageFile'>
-
- f := self cCode: 'sqImageFileOpen(fileName, "wb")'.
- f = nil ifTrue: [^-1].
- dataSize := objectMemory getEndOfMemory - objectMemory startOfMemory.
- result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
- self cCode: 'sqImageFileClose(f)'.
- ^result
- !
Item was removed:
- ----- Method: Interpreter>>duplicateTopBytecode (in category 'stack bytecodes') -----
- duplicateTopBytecode
-
- self fetchNextBytecode.
- self internalPush: self internalStackTop.
- !
Item was removed:
- ----- Method: Interpreter>>enableCompiler (in category 'compiler support') -----
- enableCompiler
- "Calling this before loading the compiler will provoke a nullCompilerHook error"
-
- compilerInitialized := true!
Item was removed:
- ----- Method: Interpreter>>executeNewMethod (in category 'message sending') -----
- executeNewMethod
- "execute a method not found in the mCache - which means that
- primitiveIndex must be manually set. Used by primitiveClosureValue & primitiveExecuteMethod, where no lookup is previously done"
- primitiveIndex > 0
- ifTrue: [self primitiveResponse.
- self successful ifTrue: [^ nil]].
- "if not primitive, or primitive failed, activate the method"
- self activateNewMethod.
- "check for possible interrupts at each real send"
- self quickCheckForInterrupts!
Item was removed:
- ----- Method: Interpreter>>executeNewMethodFromCache (in category 'message sending') -----
- executeNewMethodFromCache
- "execute a method found in the mCache - which means that
- primitiveIndex & primitiveFunctionPointer are already set. Any sender
- needs to have previously sent findMethodInClass: or equivalent"
- | nArgs delta |
- primitiveIndex > 0
- ifTrue: [DoBalanceChecks ifTrue: ["check stack balance"
- nArgs := argumentCount.
- delta := stackPointer - activeContext].
- self initPrimCall.
- self dispatchFunctionPointer: primitiveFunctionPointer.
- "branch direct to prim function from address stored in mcache"
- DoBalanceChecks
- ifTrue: [(self balancedStack: delta afterPrimitive: primitiveIndex withArgs: nArgs)
- ifFalse: [self printUnbalancedStack: primitiveIndex]].
- self successful ifTrue: [^ nil]].
- "if not primitive, or primitive failed, activate the method"
- self activateNewMethod.
- "check for possible interrupts at each real send"
- self quickCheckForInterrupts!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>extendedStoreAndPopBytecode (in category 'stack bytecodes') -----
- extendedStoreAndPopBytecode
-
- self extendedStoreBytecode.
- self internalPop: 1.
- !
Item was removed:
- ----- Method: Interpreter>>extendedStoreBytecode (in category 'stack bytecodes') -----
- extendedStoreBytecode
- | descriptor variableType variableIndex association |
- <inline: true>
- descriptor := self fetchByte.
- self fetchNextBytecode.
- variableType := descriptor >> 6 bitAnd: 3.
- variableIndex := descriptor bitAnd: 63.
- variableType = 0
- ifTrue: [^ objectMemory storePointer: variableIndex ofObject: receiver withValue: self internalStackTop].
- variableType = 1
- ifTrue: [^ objectMemory storePointerUnchecked: variableIndex + TempFrameStart ofObject: localHomeContext withValue: self internalStackTop].
- variableType = 2
- ifTrue: [self error: 'illegal store'].
- variableType = 3
- ifTrue: [association := self literal: variableIndex.
- ^ objectMemory storePointer: ValueIndex ofObject: association withValue: self internalStackTop]!
Item was removed:
- ----- Method: Interpreter>>externalizeIPandSP (in category 'utilities') -----
- externalizeIPandSP
- "Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop."
-
- instructionPointer := objectMemory oopForPointer: localIP.
- stackPointer := objectMemory oopForPointer: localSP.
- theHomeContext := localHomeContext.
- !
Item was removed:
- ----- Method: Interpreter>>fetchArray:ofObject: (in category 'utilities') -----
- fetchArray: fieldIndex ofObject: objectPointer
- "Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
- "Note: May be called by translated primitive code."
-
- | arrayOop |
- <returnTypeC: 'void *'>
- arrayOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
- ^ self arrayValueOf: arrayOop
- !
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>fetchContextRegisters: (in category 'contexts') -----
- fetchContextRegisters: activeCntx
- "Note: internalFetchContextRegisters: should track changes to this method."
- | tmp |
- <inline: true>
- tmp := objectMemory fetchPointer: MethodIndex ofObject: activeCntx.
- (objectMemory isIntegerObject: tmp)
- ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
- tmp := objectMemory fetchPointer: HomeIndex ofObject: activeCntx.
- (objectMemory oop: tmp isLessThan: objectMemory getYoungStart) ifTrue: [objectMemory beRootIfOld: tmp]]
- ifFalse: ["otherwise, it is a method context and is its own home context "
- tmp := activeCntx].
- theHomeContext := tmp.
- receiver := objectMemory fetchPointer: ReceiverIndex ofObject: tmp.
- method := objectMemory fetchPointer: MethodIndex ofObject: tmp.
-
- "the instruction pointer is a pointer variable equal to
- method oop + ip + objectMemory baseHeaderSize
- -1 for 0-based addressing of fetchByte
- -1 because it gets incremented BEFORE fetching currentByte "
- tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
- instructionPointer := method + tmp + objectMemory baseHeaderSize - 2.
-
- "the stack pointer is a pointer variable also..."
- tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
- stackPointer := activeCntx + objectMemory baseHeaderSize + (TempFrameStart + tmp - 1 * objectMemory bytesPerWord)!
Item was removed:
- ----- Method: Interpreter>>fetchFloat:ofObject: (in category 'utilities') -----
- fetchFloat: fieldIndex ofObject: objectPointer
- "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
- "Note: May be called by translated primitive code."
-
- | floatOop |
- <returnTypeC: 'double'>
- floatOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
- ^ self floatValueOf: floatOop!
Item was removed:
- ----- Method: Interpreter>>fetchInteger:ofObject: (in category 'utilities') -----
- fetchInteger: fieldIndex ofObject: objectPointer
- "Note: May be called by translated primitive code."
-
- | intOop |
- <inline: false>
- intOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
- ^self checkedIntegerValueOf: intOop!
Item was removed:
- ----- Method: Interpreter>>fetchIntegerOrTruncFloat:ofObject: (in category 'utilities') -----
- fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
- "Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
- "Note: May be called by translated primitive code."
-
- | intOrFloat floatVal frac trunc |
- <inline: false>
- <var: #floatVal type: 'double '>
- <var: #frac type: 'double '>
- <var: #trunc type: 'double '>
-
- intOrFloat := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
- (objectMemory isIntegerObject: intOrFloat) ifTrue: [^ objectMemory integerValueOf: intOrFloat].
- self assertClassOf: intOrFloat is: (objectMemory splObj: ClassFloat).
- self successful ifTrue: [
- self cCode: '' inSmalltalk: [floatVal := Float new: 2].
- self fetchFloatAt: intOrFloat + objectMemory baseHeaderSize into: floatVal.
- self cCode: 'frac = modf(floatVal, &trunc)'.
- "the following range check is for C ints, with range -2^31..2^31-1"
- self flag: #Dan. "The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
- self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.].
- self successful
- ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]]
- ifFalse: [^ 0].
- !
Item was removed:
- ----- Method: Interpreter>>fetchNextBytecode (in category 'interpreter shell') -----
- fetchNextBytecode
- "This method fetches the next instruction (bytecode). Each bytecode method is responsible for fetching the next bytecode, preferably as early as possible to allow the memory system time to process the request before the next dispatch."
-
- currentBytecode := self fetchByte.
- !
Item was removed:
- ----- Method: Interpreter>>fetchStackPointerOf: (in category 'contexts') -----
- fetchStackPointerOf: aContext
- "Return the stackPointer of a Context or BlockContext."
- | sp |
- <inline: true>
- sp := objectMemory fetchPointer: StackPointerIndex ofObject: aContext.
- (objectMemory isIntegerObject: sp) ifFalse: [^0].
- ^objectMemory integerValueOf: sp!
Item was removed:
- ----- Method: Interpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
- findClassOfMethod: meth forReceiver: rcvr
-
- | currClass classDict classDictSize methodArray i done |
- currClass := objectMemory fetchClassOf: rcvr.
- done := false.
- [done] whileFalse: [
- classDict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currClass.
- classDictSize := objectMemory fetchWordLengthOf: classDict.
- methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
- i := 0.
- [i < (classDictSize - SelectorStart)] whileTrue: [
- meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
- i := i + 1.
- ].
- currClass := objectMemory fetchPointer: SuperclassIndex ofObject: currClass.
- done := currClass = objectMemory getNilObj.
- ].
- ^objectMemory fetchClassOf: rcvr "method not found in superclass chain"!
Item was removed:
- ----- Method: Interpreter>>findNewMethodInClass: (in category 'message sending') -----
- findNewMethodInClass: class
- "Find the compiled method to be run when the current
- messageSelector is sent to the given class, setting the values
- of 'newMethod' and 'primitiveIndex'."
- | ok |
- <inline: false>
- ok := self lookupInMethodCacheSel: messageSelector class: class.
- ok
- ifFalse: ["entry was not found in the cache; look it up the hard way "
- self lookupMethodInClass: class.
- lkupClass := class.
- self addNewMethodToCache]!
Item was removed:
- ----- Method: Interpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') -----
- findSelectorOfMethod: meth forReceiver: rcvr
-
- | currClass done classDict classDictSize methodArray i |
- currClass := objectMemory fetchClassOf: rcvr.
- done := false.
- [done] whileFalse: [
- classDict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currClass.
- classDictSize := objectMemory fetchWordLengthOf: classDict.
- methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
- i := 0.
- [i <= (classDictSize - SelectorStart)] whileTrue: [
- meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [
- ^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
- ].
- i := i + 1.
- ].
- currClass := objectMemory fetchPointer: SuperclassIndex ofObject: currClass.
- done := currClass = objectMemory getNilObj.
- ].
- ^ objectMemory getNilObj "method not found in superclass chain"!
Item was removed:
- ----- Method: Interpreter>>floatObjectOf: (in category 'object format') -----
- floatObjectOf: aFloat
- | newFloatObj |
- <var: #aFloat type: 'double '>
- self flag: #Dan.
- newFloatObj := objectMemory instantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + objectMemory baseHeaderSize.
- self storeFloatAt: newFloatObj + objectMemory baseHeaderSize from: aFloat.
- ^ newFloatObj.
- !
Item was removed:
- ----- Method: Interpreter>>floatValueOf: (in category 'utilities') -----
- floatValueOf: oop
- "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
- "Note: May be called by translated primitive code."
-
- | result |
- <returnTypeC: 'double'>
- <var: #result type: 'double '>
- self flag: #Dan. "None of the float stuff has been converted for 64 bits"
- self assertClassOf: oop is: (objectMemory splObj: ClassFloat).
- self successful
- ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: oop + objectMemory baseHeaderSize into: result]
- ifFalse: [result := 0.0].
- ^ result!
Item was removed:
- ----- Method: Interpreter>>flushAtCache (in category 'method lookup cache') -----
- flushAtCache
- "Flush the at cache. The method cache is flushed on every programming change and garbage collect."
-
- 1 to: AtCacheTotalSize do: [ :i | atCache at: i put: 0 ]
- !
Item was removed:
- ----- Method: Interpreter>>flushExternalPrimitiveOf: (in category 'plugin primitive support') -----
- flushExternalPrimitiveOf: methodPtr
- "methodPtr is a CompiledMethod containing an external primitive. Flush the function address and session ID of the CM"
- | lit |
- (self literalCountOf: methodPtr) > 0 ifFalse:[^nil]. "Something's broken"
- lit := self literal: 0 ofMethod: methodPtr.
- ((objectMemory isArray: lit) and:[(objectMemory lengthOf: lit) = 4])
- ifFalse:[^nil]. "Something's broken"
- "ConstZero is a known SmallInt so no root check needed"
- objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
- objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
- !
Item was removed:
- ----- Method: Interpreter>>flushExternalPrimitiveTable (in category 'plugin primitive support') -----
- flushExternalPrimitiveTable
- "Flush the external primitive table"
- 0 to: MaxExternalPrimitiveTableSize-1 do:[:i|
- externalPrimitiveTable at: i put: 0].
- !
Item was removed:
- ----- Method: Interpreter>>flushExternalPrimitives (in category 'plugin primitive support') -----
- flushExternalPrimitives
- "Flush the references to external functions from plugin
- primitives. This will force a reload of those primitives when
- accessed next.
- Note: We must flush the method cache here so that any
- failed primitives are looked up again."
- | oop primIdx |
- oop := objectMemory firstObject.
- [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory]
- whileTrue: [(objectMemory isFreeObject: oop)
- ifFalse: [(objectMemory isCompiledMethod: oop)
- ifTrue: ["This is a compiled method"
- primIdx := self primitiveIndexOf: oop.
- primIdx = PrimitiveExternalCallIndex
- ifTrue: ["It's primitiveExternalCall"
- self flushExternalPrimitiveOf: oop]]].
- oop := objectMemory objectAfter: oop].
- self flushMethodCache.
- self flushExternalPrimitiveTable!
Item was removed:
- ----- Method: Interpreter>>flushMethodCache (in category 'method lookup cache') -----
- flushMethodCache
- "Flush the method cache. The method cache is flushed on every programming change and garbage collect."
-
- 1 to: MethodCacheSize do: [ :i | methodCache at: i put: 0 ].
- self flushAtCache!
Item was removed:
- ----- Method: Interpreter>>flushMethodCacheFrom:to: (in category 'method lookup cache') -----
- flushMethodCacheFrom: memStart to: memEnd
- "Flush entries in the method cache only if the oop address is within the given memory range.
- This reduces overagressive cache clearing. Note the AtCache is fully flushed, 70% of the time
- cache entries live in newspace, new objects die young"
- | probe |
- probe := 0.
- 1 to: MethodCacheEntries do: [:i |
- (methodCache at: probe + MethodCacheSelector) = 0
- ifFalse: [(((((objectMemory oop: (methodCache at: probe + MethodCacheSelector) isGreaterThanOrEqualTo: memStart)
- and: [objectMemory oop: (methodCache at: probe + MethodCacheSelector) isLessThan: memEnd])
- or: [(objectMemory oop: (methodCache at: probe + MethodCacheClass) isGreaterThanOrEqualTo: memStart)
- and: [objectMemory oop: (methodCache at: probe + MethodCacheClass) isLessThan: memEnd]])
- or: [(objectMemory oop: (methodCache at: probe + MethodCacheMethod) isGreaterThanOrEqualTo: memStart)
- and: [objectMemory oop: (methodCache at: probe + MethodCacheMethod) isLessThan: memEnd]])
- or: [(objectMemory oop: (methodCache at: probe + MethodCacheNative) isGreaterThanOrEqualTo: memStart)
- and: [objectMemory oop: (methodCache at: probe + MethodCacheNative) isLessThan: memEnd]])
- ifTrue: [methodCache at: probe + MethodCacheSelector put: 0]].
- probe := probe + MethodCacheEntrySize].
- 1 to: AtCacheTotalSize do: [:i | atCache at: i put: 0]!
Item was removed:
- ----- Method: Interpreter>>forceInterruptCheck (in category 'process primitive support') -----
- forceInterruptCheck
- "force an interrupt check ASAP - setting interruptCheckCounter to a large -ve number is used as a flag to skip messing with the feedback mechanism and nextPollTick resetting makes sure that ioProcess gets called as near immediately as we can manage"
- interruptCheckCounter := -1000.
- nextPollTick := 0!
Item was removed:
- ----- 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].
- !
Item was removed:
- ----- Method: Interpreter>>functionPointerFor:inClass: (in category 'method lookup cache') -----
- functionPointerFor: primIdx inClass: theClass
- "Find an actual function pointer for this primitiveIndex. This is an
- opportunity to specialise the prim for the relevant class (format for
- example). Default for now is simply the entry in the base primitiveTable."
-
- <returnTypeC: 'void *'>
- ^primitiveTable at: primIdx!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>getFullScreenFlag (in category 'plugin primitive support') -----
- getFullScreenFlag
- ^fullScreenFlag!
Item was removed:
- ----- Method: Interpreter>>getInterruptCheckCounter (in category 'plugin primitive support') -----
- getInterruptCheckCounter
- ^interruptCheckCounter!
Item was removed:
- ----- Method: Interpreter>>getInterruptKeycode (in category 'plugin primitive support') -----
- getInterruptKeycode
- ^interruptKeycode!
Item was removed:
- ----- Method: Interpreter>>getInterruptPending (in category 'plugin primitive support') -----
- getInterruptPending
- ^interruptPending!
Item was removed:
- ----- Method: Interpreter>>getLongFromFile:swap: (in category 'image save/restore') -----
- getLongFromFile: aFile swap: swapFlag
- "Answer the next word read from aFile, byte-swapped according to the swapFlag."
-
- | w |
- <var: #aFile type: 'sqImageFile '>
- w := 0.
- self cCode: 'sqImageFileRead(&w, sizeof(w), 1, aFile)'
- inSmalltalk: [w := self nextLongFrom: aFile].
- swapFlag
- ifTrue: [^ objectMemory byteSwapped: w]
- ifFalse: [^ w].
- !
Item was removed:
- ----- Method: Interpreter>>getNextWakeupTick (in category 'plugin primitive support') -----
- getNextWakeupTick
- ^nextWakeupTick!
Item was removed:
- ----- Method: Interpreter>>getSavedWindowSize (in category 'plugin primitive support') -----
- getSavedWindowSize
- ^savedWindowSize!
Item was removed:
- ----- Method: Interpreter>>getStackPointer (in category 'contexts') -----
- getStackPointer
- "For Newsqueak FFI"
- <export: true>
- ^stackPointer!
Item was removed:
- ----- Method: Interpreter>>getThisSessionID (in category 'plugin support') -----
- getThisSessionID
- "return the global session ID value"
- <inline: false>
- ^globalSessionID!
Item was removed:
- ----- Method: Interpreter>>headerOf: (in category 'compiled methods') -----
- headerOf: methodPointer
- ^objectMemory fetchPointer: HeaderIndex ofObject: methodPointer!
Item was removed:
- ----- Method: Interpreter>>imageFormatBackwardCompatibilityVersion (in category 'image save/restore') -----
- imageFormatBackwardCompatibilityVersion
- "This VM is backwards-compatible with the immediately preceeding pre-closure version, and will allow loading images (or image segments) of that version."
-
- objectMemory bytesPerWord == 4
- ifTrue: [^6502]
- ifFalse: [^68000]!
Item was removed:
- ----- Method: Interpreter>>imageFormatVersion (in category 'image save/restore') -----
- imageFormatVersion
- "Return a magic constant that changes when the image format changes. Since the image reading code uses
- this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."
-
- "See Interpreter class>>declareCVarsIn: and Interpreter>>pushClosureCopyCopiedValuesBytecode
- for the initialization of imageFormatVersionNumber"
- ^imageFormatVersionNumber!
Item was removed:
- ----- Method: Interpreter>>includesBehavior:ThatOf: (in category 'plugin primitive support') -----
- includesBehavior: aClass ThatOf: aSuperclass
- "Return the equivalent of
- aClass includesBehavior: aSuperclass.
- Note: written for efficiency and better inlining (only 1 temp)"
- | theClass |
- <inline: true>
- aSuperclass = objectMemory getNilObj ifTrue:
- [^false].
- theClass := aClass.
- [theClass = aSuperclass ifTrue:
- [^true].
- theClass ~= objectMemory getNilObj] whileTrue:
- [theClass := self superclassOf: theClass].
- ^false!
Item was removed:
- ----- Method: Interpreter>>initCompilerHooks (in category 'compiler support') -----
- initCompilerHooks
- "Initialize hooks for the 'null compiler'"
-
- self cCode: 'compilerHooks[1]= nullCompilerHook'.
- self cCode: 'compilerHooks[2]= nullCompilerHook'.
- self cCode: 'compilerHooks[3]= nullCompilerHook'.
- self cCode: 'compilerHooks[4]= nullCompilerHook'.
- self cCode: 'compilerHooks[5]= nullCompilerHook'.
- self cCode: 'compilerHooks[6]= nullCompilerHook'.
- self cCode: 'compilerHooks[7]= nullCompilerHook'.
- self cCode: 'compilerHooks[8]= nullCompilerHook'.
- self cCode: 'compilerHooks[9]= nullCompilerHook'.
- self cCode: 'compilerHooks[10]= nullCompilerHook'.
- self cCode: 'compilerHooks[11]= nullCompilerHook'.
- self cCode: 'compilerHooks[12]= nullCompilerHook'.
- self cCode: 'compilerHooks[13]= nullCompilerHook'.
- self cCode: 'compilerHooks[14]= nullCompilerHook'.
-
- compilerInitialized := false!
Item was removed:
- ----- Method: Interpreter>>initialCleanup (in category 'initialization') -----
- initialCleanup
- "Images written by VMs earlier than 3.6/3.7 will wrongly have the root bit set on the active context. Besides clearing the root bit, we treat this as a marker that these images also lack a cleanup of external primitives (which has been introduced at the same time when the root bit problem was fixed). In this case, we merely flush them from here."
-
- ((objectMemory longAt: activeContext) bitAnd: objectMemory rootBit) = 0 ifTrue:[^nil]. "root bit is clean"
- "Clean root bit of activeContext"
- objectMemory longAt: activeContext put: ((objectMemory longAt: activeContext) bitAnd: objectMemory allButRootBit).
- "Clean external primitives"
- self flushExternalPrimitives.!
Item was removed:
- ----- Method: Interpreter>>initialImageFormatVersion (in category 'image save/restore') -----
- initialImageFormatVersion
- "This is the image format version that was saved to in the previous image snapshot.
- The interpreter checks this value at image load time to determine if it is able to load
- and run the image file. When the image is next saved, it will be saved using the current
- imageFormatVersion, which may be different from imageFormatInitialVersion.
- Selector name chosen to avoid conflict with variable declaration in generated code."
- ^imageFormatInitialVersion!
Item was removed:
- ----- Method: Interpreter>>initializeImageFormatVersionIfNeeded (in category 'image save/restore') -----
- initializeImageFormatVersionIfNeeded
- "Set the imageFormatVersionNumber to a default value for this word
- size. Normally this will have been set at image load time, but set it to
- a reasonable default if this has not been done."
-
- <inline: false>
- imageFormatVersionNumber = 0
- ifTrue: [objectMemory bytesPerWord == 8
- ifFalse: [imageFormatVersionNumber := 6502]
- ifTrue: [imageFormatVersionNumber := 68000]]
- !
Item was removed:
- ----- Method: Interpreter>>initializeInterpreter: (in category 'initialization') -----
- initializeInterpreter: bytesToShift
- "Initialize Interpreter state before starting execution of a new image."
- interpreterProxy := self sqGetInterpreterProxy.
- self dummyReferToProxy.
- objectMemory initializeObjectMemory: bytesToShift.
- self initCompilerHooks.
- activeContext := objectMemory getNilObj.
- theHomeContext := objectMemory getNilObj.
- method := objectMemory getNilObj.
- receiver := objectMemory getNilObj.
- messageSelector := objectMemory getNilObj.
- newMethod := objectMemory getNilObj.
- methodClass := objectMemory getNilObj.
- lkupClass := objectMemory getNilObj.
- receiverClass := objectMemory getNilObj.
- newNativeMethod := objectMemory getNilObj.
- self flushMethodCache.
- self loadInitialContext.
- self initialCleanup.
- interruptCheckCounter := 0.
- interruptCheckCounterFeedBackReset := 1000.
- interruptChecksEveryNms := 1.
- nextPollTick := 0.
- nextWakeupTick := 0.
- lastTick := 0.
- interruptKeycode := 2094. "cmd-. as used for Mac but no other OS"
- interruptPending := false.
- semaphoresUseBufferA := true.
- semaphoresToSignalCountA := 0.
- semaphoresToSignalCountB := 0.
- deferDisplayUpdates := false.
- pendingFinalizationSignals := 0.
- globalSessionID := 0.
- [globalSessionID = 0]
- whileTrue: [globalSessionID := self
- cCode: 'time(NULL) + ioMSecs()'
- inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]].
- jmpDepth := 0.
- jmpMax := MaxJumpBuf. "xxxx: Must match the definition of jmpBuf and suspendedCallbacks"
- !
Item was removed:
- ----- Method: Interpreter>>install:inAtCache:at:string: (in category 'indexing primitives') -----
- install: rcvr inAtCache: cache at: atIx string: stringy
- "Install the oop of this object in the given cache (at or atPut), along with
- its size, format and fixedSize"
- | hdr fmt totalLength fixedFields |
- <var: #cache type: 'sqInt *'>
-
- hdr := objectMemory baseHeader: rcvr.
- fmt := (hdr >> 8) bitAnd: 16rF.
- (fmt = 3 and: [self isContextHeader: hdr]) ifTrue:
- ["Contexts must not be put in the atCache, since their size is not constant"
- ^ self primitiveFail].
- totalLength := objectMemory lengthOf: rcvr baseHeader: hdr format: fmt.
- fixedFields := objectMemory fixedFieldsOf: rcvr format: fmt length: totalLength.
-
- cache at: atIx+AtCacheOop put: rcvr.
- stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16] "special flag for strings"
- ifFalse: [cache at: atIx+AtCacheFmt put: fmt].
- cache at: atIx+AtCacheFixedFields put: fixedFields.
- cache at: atIx+AtCacheSize put: totalLength - fixedFields.
- !
Item was removed:
- ----- Method: Interpreter>>internalAboutToReturn:through: (in category 'return bytecodes') -----
- internalAboutToReturn: resultObj through: aContext
- <inline: true>
- self internalPush: activeContext.
- self internalPush: resultObj.
- self internalPush: aContext.
- messageSelector := objectMemory splObj: SelectorAboutToReturn.
- argumentCount := 2.
- ^self normalSend!
Item was removed:
- ----- Method: Interpreter>>internalActivateNewMethod (in category 'message sending') -----
- internalActivateNewMethod
- | methodHeader newContext tempCount argCount2 needsLarge where |
- <inline: true>
-
- methodHeader := self headerOf: newMethod.
- needsLarge := methodHeader bitAnd: LargeContextBit.
- (needsLarge = 0 and: [objectMemory getFreeContexts ~= objectMemory nilContext])
- ifTrue: [newContext := objectMemory getFreeContexts.
- objectMemory setFreeContextsAfter: newContext]
- ifFalse: ["Slower call for large contexts or empty free list"
- self externalizeIPandSP.
- newContext := objectMemory allocateOrRecycleContext: needsLarge.
- self internalizeIPandSP].
- tempCount := (methodHeader >> 19) bitAnd: 16r3F.
-
- "Assume: newContext will be recorded as a root if necessary by the
- call to newActiveContext: below, so we can use unchecked stores."
- where := newContext + objectMemory baseHeaderSize.
- objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
- objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord)
- put: (objectMemory integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1)).
- objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
- objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
- objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory getNilObj.
-
- "Copy the receiver and arguments..."
- argCount2 := argumentCount.
- 0 to: argCount2 do:
- [:i | objectMemory longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord) put: (self internalStackValue: argCount2-i)].
-
- "clear remaining temps to nil in case it has been recycled"
- methodHeader := objectMemory getNilObj. "methodHeader here used just as faster (register?) temp"
- argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
- [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: methodHeader].
-
- self internalPop: argCount2 + 1.
- reclaimableContextCount := reclaimableContextCount + 1.
- self internalNewActiveContext: newContext.
- !
Item was removed:
- ----- Method: Interpreter>>internalCannotReturn: (in category 'return bytecodes') -----
- internalCannotReturn: resultObj
- <inline: true>
- reclaimableContextCount := 0.
- self internalPush: activeContext.
- self internalPush: resultObj.
- messageSelector := objectMemory splObj: SelectorCannotReturn.
- argumentCount := 1.
- ^ self normalSend!
Item was removed:
- ----- Method: Interpreter>>internalExecuteNewMethod (in category 'message sending') -----
- internalExecuteNewMethod
- | localPrimIndex delta nArgs |
- <inline: true>
- localPrimIndex := primitiveIndex.
- localPrimIndex > 0
- ifTrue: [(localPrimIndex > 255
- and: [localPrimIndex < 520])
- ifTrue: ["Internal return instvars"
- localPrimIndex >= 264
- ifTrue: [^ self internalPop: 1 thenPush: (objectMemory fetchPointer: localPrimIndex - 264 ofObject: self internalStackTop)]
- ifFalse: ["Internal return constants"
- localPrimIndex = 256 ifTrue: [^ nil].
- localPrimIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getTrueObj].
- localPrimIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getFalseObj].
- localPrimIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getNilObj].
- ^ self internalPop: 1 thenPush: (objectMemory integerObjectOf: localPrimIndex - 261)]]
- ifFalse: [self externalizeIPandSP.
- "self primitiveResponse. <-replaced with manually inlined code"
- DoBalanceChecks
- ifTrue: ["check stack balance"
- nArgs := argumentCount.
- delta := stackPointer - activeContext].
- self initPrimCall.
- self dispatchFunctionPointer: primitiveFunctionPointer. "branch direct to prim function from address stored in mcache"
- DoBalanceChecks
- ifTrue: [(self balancedStack: delta afterPrimitive: localPrimIndex withArgs: nArgs)
- ifFalse: [self printUnbalancedStack: localPrimIndex]].
- self internalizeIPandSP.
- self successful
- ifTrue: [self browserPluginReturnIfNeeded.
- ^ nil]]].
- "if not primitive, or primitive failed, activate the method"
- self internalActivateNewMethod.
- "check for possible interrupts at each real send"
- self internalQuickCheckForInterrupts!
Item was removed:
- ----- Method: Interpreter>>internalFetchContextRegisters: (in category 'contexts') -----
- internalFetchContextRegisters: activeCntx
- "Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."
-
- | tmp |
- <inline: true>
- tmp := objectMemory fetchPointer: MethodIndex ofObject: activeCntx.
- (objectMemory isIntegerObject: tmp) ifTrue: [
- "if the MethodIndex field is an integer, activeCntx is a block context"
- tmp := objectMemory fetchPointer: HomeIndex ofObject: activeCntx.
- (objectMemory oop: tmp isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: tmp ].
- ] ifFalse: [
- "otherwise, it is a method context and is its own home context"
- tmp := activeCntx.
- ].
- localHomeContext := tmp.
- receiver := objectMemory fetchPointer: ReceiverIndex ofObject: tmp.
- method := objectMemory fetchPointer: MethodIndex ofObject: tmp.
-
- "the instruction pointer is a pointer variable equal to
- method oop + ip + objectMemory baseHeaderSize
- -1 for 0-based addressing of fetchByte
- -1 because it gets incremented BEFORE fetching currentByte"
- tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
- localIP := objectMemory pointerForOop: method + tmp + objectMemory baseHeaderSize - 2.
-
- "the stack pointer is a pointer variable also..."
- tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
- localSP := objectMemory pointerForOop: activeCntx + objectMemory baseHeaderSize + ((TempFrameStart + tmp - 1) * objectMemory bytesPerWord)!
Item was removed:
- ----- Method: Interpreter>>internalFindNewMethod (in category 'message sending') -----
- internalFindNewMethod
- "Find the compiled method to be run when the current messageSelector is sent to the class 'lkupClass', setting the values of 'newMethod' and 'primitiveIndex'."
- | ok |
- <inline: true>
- ok := self lookupInMethodCacheSel: messageSelector class: lkupClass.
- ok ifFalse: [
- "entry was not found in the cache; look it up the hard way"
- self externalizeIPandSP.
- self lookupMethodInClass: lkupClass.
- self internalizeIPandSP.
- self addNewMethodToCache].
- !
Item was removed:
- ----- Method: Interpreter>>internalIsImmutable: (in category 'object format') -----
- internalIsImmutable: oop
- <inline: true>
- <export: true>
- ^false.
- "^((self baseHeader: oop) bitAnd: ImmutabilityBit) ~= 0"!
Item was removed:
- ----- Method: Interpreter>>internalIsMutable: (in category 'object format') -----
- internalIsMutable: oop
- <inline: true>
- <export: true>
- ^true
- "^((self baseHeader: oop) bitAnd: ImmutabilityBit) = 0"!
Item was removed:
- ----- Method: Interpreter>>internalJustActivateNewMethod (in category 'message sending') -----
- internalJustActivateNewMethod
- "Activate the new method but *do not* copy receiver or arguments from activeContext."
- | methodHeader initialIP newContext tempCount needsLarge where |
- <inline: true>
-
- methodHeader := self headerOf: newMethod.
- needsLarge := methodHeader bitAnd: LargeContextBit.
- (needsLarge = 0 and: [objectMemory getFreeContexts ~= objectMemory nilContext])
- ifTrue: [newContext := objectMemory getFreeContexts.
- objectMemory setFreeContextsAfter: newContext]
- ifFalse: ["Slower call for large contexts or empty free list"
- newContext := objectMemory allocateOrRecycleContext: needsLarge].
- initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1.
- tempCount := (methodHeader >> 19) bitAnd: 16r3F.
-
- "Assume: newContext will be recorded as a root if necessary by the
- call to newActiveContext: below, so we can use unchecked stores."
- where := newContext + objectMemory baseHeaderSize.
- objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
- objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: initialIP).
- objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
- objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
-
- "Set the receiver..."
- objectMemory longAt: where + (ReceiverIndex << objectMemory shiftForWord) put: receiver.
-
- "clear all args and temps to nil in case it has been recycled"
- needsLarge := objectMemory getNilObj. "needsLarge here used just as faster (register?) temp"
- ReceiverIndex + 1 to: tempCount + ReceiverIndex do:
- [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: needsLarge].
- reclaimableContextCount := reclaimableContextCount + 1.
-
- activeContext := newContext.!
Item was removed:
- ----- Method: Interpreter>>internalNewActiveContext: (in category 'contexts') -----
- internalNewActiveContext: aContext
- "The only difference between this method and newActiveContext: is that this method uses internal context registers."
- <inline: true>
-
- self internalStoreContextRegisters: activeContext.
- (objectMemory oop: aContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
- activeContext := aContext.
- self internalFetchContextRegisters: aContext.!
Item was removed:
- ----- Method: Interpreter>>internalPop: (in category 'contexts') -----
- internalPop: nItems
-
- localSP := localSP - (nItems * objectMemory bytesPerWord).!
Item was removed:
- ----- Method: Interpreter>>internalPop:thenPush: (in category 'contexts') -----
- internalPop: nItems thenPush: oop
-
- objectMemory longAtPointer: (localSP := localSP - ((nItems - 1) * objectMemory bytesPerWord)) put: oop.
- !
Item was removed:
- ----- Method: Interpreter>>internalPrimitiveValue (in category 'control primitives') -----
- internalPrimitiveValue
- | newContext blockArgumentCount initialIP |
- <inline: true>
- self sharedCodeNamed: 'commonPrimitiveValue' inCase: 201.
- self initPrimCall.
- newContext := self internalStackValue: argumentCount.
- self assertClassOf: newContext is: (objectMemory splObj: ClassBlockContext).
- blockArgumentCount := self argumentCountOfBlock: newContext.
-
- self success: (argumentCount = blockArgumentCount and: [(objectMemory fetchPointer: CallerIndex ofObject: newContext) = objectMemory getNilObj]).
-
- self successful
- ifTrue: ["This code assumes argCount can only = 0 or 1"
- argumentCount = 1
- ifTrue: [objectMemory storePointer: TempFrameStart ofObject: newContext withValue: self internalStackTop].
- self internalPop: argumentCount + 1.
- "copy the initialIP value to the ip slot"
- initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: newContext.
- objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
- self storeStackPointerValue: argumentCount inContext: newContext.
- objectMemory storePointerUnchecked: CallerIndex ofObject: newContext withValue: activeContext.
- self internalNewActiveContext: newContext]
- ifFalse: [messageSelector := self specialSelector: 25 + argumentCount.
- self normalSend]!
Item was removed:
- ----- Method: Interpreter>>internalPush: (in category 'contexts') -----
- internalPush: object
-
- objectMemory longAtPointer: (localSP := localSP + objectMemory bytesPerWord) put: object.!
Item was removed:
- ----- Method: Interpreter>>internalQuickCheckForInterrupts (in category 'process primitive support') -----
- internalQuickCheckForInterrupts
- "Internal version of quickCheckForInterrupts for use within jumps."
-
- <inline: true>
- ((interruptCheckCounter := interruptCheckCounter - 1) <= 0) ifTrue: [
- self externalizeIPandSP.
- self checkForInterrupts.
-
- self browserPluginReturnIfNeeded.
-
- self internalizeIPandSP].
- !
Item was removed:
- ----- Method: Interpreter>>internalStackTop (in category 'contexts') -----
- internalStackTop
-
- ^ objectMemory longAtPointer: localSP!
Item was removed:
- ----- Method: Interpreter>>internalStackValue: (in category 'contexts') -----
- internalStackValue: offset
-
- ^ objectMemory longAtPointer: localSP - (offset * objectMemory bytesPerWord)!
Item was removed:
- ----- Method: Interpreter>>internalStoreContextRegisters: (in category 'contexts') -----
- internalStoreContextRegisters: activeCntx
- "The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."
-
- "InstructionPointer is a pointer variable equal to
- method oop + ip + objectMemory baseHeaderSize
- -1 for 0-based addressing of fetchByte
- -1 because it gets incremented BEFORE fetching currentByte"
-
- <inline: true>
- objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
- withValue: (objectMemory integerObjectOf:
- ((objectMemory oopForPointer: localIP) + 2 - (method + objectMemory baseHeaderSize))).
- objectMemory storePointerUnchecked: StackPointerIndex ofObject: activeCntx
- withValue: (objectMemory integerObjectOf:
- ((((objectMemory oopForPointer: localSP) - (activeCntx + objectMemory baseHeaderSize)) >> objectMemory shiftForWord) - TempFrameStart + 1)).
- !
Item was removed:
- ----- Method: Interpreter>>internalizeIPandSP (in category 'utilities') -----
- internalizeIPandSP
- "Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop."
-
- localIP := objectMemory pointerForOop: instructionPointer.
- localSP := objectMemory pointerForOop: stackPointer.
- localHomeContext := theHomeContext.
- !
Item was removed:
- ----- Method: Interpreter>>interpret (in category 'interpreter shell') -----
- interpret
- "This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently."
-
- <inline: false> "should not be inlined into any senders"
- "record entry time when running as a browser plug-in"
- self browserPluginInitialiseIfNeeded.
- self initializeImageFormatVersionIfNeeded.
- self internalizeIPandSP.
- self fetchNextBytecode.
- [true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable].
- localIP := localIP - 1. "undo the pre-increment of IP before returning"
- self externalizeIPandSP.
- !
Item was removed:
- ----- Method: Interpreter>>interpreterAllocationReserveBytes (in category 'stack interpreter support') -----
- interpreterAllocationReserveBytes
- "Extra allocation space in the object memory required by StackInterpreter"
- ^ 0
- !
Item was removed:
- ----- Method: Interpreter>>interruptCheckForced (in category 'process primitive support') -----
- interruptCheckForced
- "was this interrupt check forced by outside code?"
- ^interruptCheckCounter < -100!
Item was removed:
- ----- Method: Interpreter>>ioFilename:fromString:ofLength:resolveAliases: (in category 'plugin support') -----
- ioFilename: aCharBuffer fromString: aFilenameString ofLength: filenameLength resolveAliases: aBoolean
- "the vm has to convert aFilenameString via any canonicalization and char-mapping and put the result in aCharBuffer.
- Note the resolveAliases flag - this is an awful artefact of OSX and Apples demented alias handling. When opening a file, the flag must be true, when closing or renaming it must be false. Sigh."
- <var: #aCharBuffer type: 'char *'>
- <var: #aFilenameString type: 'char *'>
- self cCode:'sqGetFilenameFromString(aCharBuffer, aFilenameString, filenameLength, aBoolean)'
- inSmalltalk:["this doesn't translate well in Smalltalk since we know how long strings are rather than considering them terminated by a 0 char. Do the best we can"
- aCharBuffer replaceFrom:1 to: filenameLength with: aFilenameString]!
Item was removed:
- ----- Method: Interpreter>>is:KindOf: (in category 'plugin primitive support') -----
- is: oop KindOf: className
- "Support for external primitives."
- | oopClass |
- <var: #className type: 'char *'>
- oopClass := objectMemory fetchClassOf: oop.
- [oopClass == objectMemory getNilObj] whileFalse:[
- (self classNameOf: oopClass Is: className) ifTrue:[^true].
- oopClass := self superclassOf: oopClass].
- ^false!
Item was removed:
- ----- Method: Interpreter>>is:KindOfClass: (in category 'plugin primitive support') -----
- is: oop KindOfClass: aClass
- "Support for external primitives."
- <api>
- | oopClass |
- oopClass := self fetchClassOf: oop.
- [oopClass = objectMemory getNilObj] whileFalse:
- [oopClass = aClass ifTrue: [^true].
- oopClass := self superclassOf: oopClass].
- ^false!
Item was removed:
- ----- Method: Interpreter>>is:MemberOf: (in category 'plugin primitive support') -----
- is: oop MemberOf: className
- "Support for external primitives"
- | oopClass |
- <var: #className type: 'char *'>
- oopClass := objectMemory fetchClassOf: oop.
- ^(self classNameOf: oopClass Is: className)!
Item was removed:
- ----- Method: Interpreter>>isContext: (in category 'contexts') -----
- isContext: oop
- <inline: true>
- ^(objectMemory isNonIntegerObject: oop) and: [self isContextHeader: (objectMemory baseHeader: oop)]!
Item was removed:
- ----- Method: Interpreter>>isContextHeader: (in category 'contexts') -----
- isContextHeader: aHeader
- <inline: true>
- ^ ((aHeader >> 12) bitAnd: 16r1F) = 13 "MethodContext"
- or: [((aHeader >> 12) bitAnd: 16r1F) = 14 "BlockContext"
- or: [((aHeader >> 12) bitAnd: 16r1F) = 4]] "PseudoContext"!
Item was removed:
- ----- Method: Interpreter>>isEmptyList: (in category 'process primitive support') -----
- isEmptyList: aLinkedList
-
- ^ (objectMemory fetchPointer: FirstLinkIndex ofObject: aLinkedList) = objectMemory getNilObj!
Item was removed:
- ----- Method: Interpreter>>isFloatObject: (in category 'plugin primitive support') -----
- isFloatObject: oop
- ^(objectMemory fetchClassOf: oop) == objectMemory classFloat!
Item was removed:
- ----- Method: Interpreter>>isHandlerMarked: (in category 'compiled methods') -----
- isHandlerMarked: aContext
- "Is this a MethodContext whose meth has a primitive number of 199?"
- | header meth pIndex |
- "NB: the use of a primitive number for marking the method is pretty grungy, but it is simple to use for a test sytem, not too expensive and we don't actually have the two spare method header bits we need. We can probably obtain them when the method format is changed.
- NB 2: actually, the jitter will probably implement the prim to actually mark the volatile frame by changing the return function pointer."
- <inline: true>
- header := objectMemory baseHeader: aContext.
- (self isMethodContextHeader: header) ifFalse: [^false].
- meth := objectMemory fetchPointer: MethodIndex ofObject: aContext.
- pIndex := self primitiveIndexOf: meth.
- ^pIndex == 199
- !
Item was removed:
- ----- Method: Interpreter>>isIndexable: (in category 'object format') -----
- isIndexable: oop
- ^(objectMemory formatOf: oop) >= 2!
Item was removed:
- ----- Method: Interpreter>>isMarriedOrWidowedContext: (in category 'stack interpreter support') -----
- isMarriedOrWidowedContext: aContext
- ^false!
Item was removed:
- ----- Method: Interpreter>>isMethodContextHeader: (in category 'contexts') -----
- isMethodContextHeader: aHeader
- <inline: true>
- ^ ((aHeader >> 12) bitAnd: 16r1F) = 14!
Item was removed:
- ----- Method: Interpreter>>isUnwindMarked: (in category 'compiled methods') -----
- isUnwindMarked: aContext
- "Is this a MethodContext whose meth has a primitive number of 198?"
- | header meth pIndex |
- "NB: the use of a primitive number for marking the method is pretty grungy, but it is simple to use for a test sytem, not too expensive and we don't actually have the two spare method header bits we need. We can probably obtain them when the method format is changed
- NB 2: actually, the jitter will probably implement the prim to actually mark the volatile frame by changing the return function pointer."
- <inline: true>
- header := objectMemory baseHeader: aContext.
- (self isMethodContextHeader: header) ifFalse: [^false].
- meth := objectMemory fetchPointer: MethodIndex ofObject: aContext.
- pIndex := self primitiveIndexOf: meth.
- ^pIndex == 198
- !
Item was removed:
- ----- Method: Interpreter>>jump: (in category 'jump bytecodes') -----
- jump: offset
-
- localIP := localIP + offset + 1.
- currentBytecode := objectMemory byteAtPointer: localIP.
- !
Item was removed:
- ----- Method: Interpreter>>jumplfFalseBy: (in category 'jump bytecodes') -----
- jumplfFalseBy: offset
- | boolean |
- boolean := self internalStackTop.
- boolean = objectMemory getFalseObj
- ifTrue: [self jump: offset]
- ifFalse: [boolean = objectMemory getTrueObj
- ifFalse: [messageSelector := objectMemory splObj: SelectorMustBeBoolean.
- argumentCount := 0.
- ^ self normalSend].
- self fetchNextBytecode].
- self internalPop: 1!
Item was removed:
- ----- Method: Interpreter>>jumplfTrueBy: (in category 'jump bytecodes') -----
- jumplfTrueBy: offset
- | boolean |
- boolean := self internalStackTop.
- boolean = objectMemory getTrueObj
- ifTrue: [self jump: offset]
- ifFalse: [boolean = objectMemory getFalseObj
- ifFalse: [messageSelector := objectMemory splObj: SelectorMustBeBoolean.
- argumentCount := 0.
- ^ self normalSend].
- self fetchNextBytecode].
- self internalPop: 1!
Item was removed:
- ----- Method: Interpreter>>literal: (in category 'compiled methods') -----
- literal: offset
- ^self literal: offset ofMethod: method!
Item was removed:
- ----- Method: Interpreter>>literal:ofMethod: (in category 'compiled methods') -----
- literal: offset ofMethod: methodPointer
-
- ^ objectMemory fetchPointer: offset + LiteralStart ofObject: methodPointer
- !
Item was removed:
- ----- Method: Interpreter>>literalCountOf: (in category 'compiled methods') -----
- literalCountOf: methodPointer
- ^self literalCountOfHeader: (self headerOf: methodPointer)!
Item was removed:
- ----- Method: Interpreter>>literalCountOfHeader: (in category 'compiled methods') -----
- literalCountOfHeader: headerPointer
- ^ (headerPointer >> 10) bitAnd: 16rFF!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
- loadFloatOrIntFrom: floatOrInt
- "If floatOrInt is an integer, then convert it to a C double float and return it.
- If it is a Float, then load its value and return it.
- Otherwise fail -- ie return with primFailCode set."
-
- <inline: true>
- <returnTypeC: 'double'>
-
- (objectMemory isIntegerObject: floatOrInt) ifTrue:
- [^ (objectMemory integerValueOf: floatOrInt) asFloat].
- (objectMemory fetchClassOfNonInt: floatOrInt) = (objectMemory splObj: ClassFloat)
- ifTrue: [^ self floatValueOf: floatOrInt].
- self primitiveFail!
Item was removed:
- ----- Method: Interpreter>>loadInitialContext (in category 'initialization') -----
- loadInitialContext
-
- | sched proc |
- sched := objectMemory fetchPointer: ValueIndex ofObject: (objectMemory splObj: SchedulerAssociation).
- proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
- activeContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
- (objectMemory oop: activeContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: activeContext ].
- self fetchContextRegisters: activeContext.
- reclaimableContextCount := 0.!
Item was removed:
- ----- Method: Interpreter>>longJumpIfFalse (in category 'jump bytecodes') -----
- longJumpIfFalse
-
- self jumplfFalseBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.!
Item was removed:
- ----- Method: Interpreter>>longJumpIfTrue (in category 'jump bytecodes') -----
- longJumpIfTrue
-
- self jumplfTrueBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.!
Item was removed:
- ----- Method: Interpreter>>longUnconditionalJump (in category 'jump bytecodes') -----
- longUnconditionalJump
-
- | offset |
- offset := (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte.
- localIP := localIP + offset.
- offset < 0 ifTrue: [
- "backward jump means we're in a loop; check for possible interrupts"
- self internalQuickCheckForInterrupts.
- ].
- self fetchNextBytecode
- !
Item was removed:
- ----- Method: Interpreter>>lookupInMethodCacheSel:class: (in category 'method lookup cache') -----
- lookupInMethodCacheSel: selector class: class
- "This method implements a simple method lookup cache. If an entry for the given selector and class is found in the cache, set the values of 'newMethod' and 'primitiveIndex' and return true. Otherwise, return false."
- "About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe, introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up."
- "WARNING: Since the hash computation is based on the object addresses of the class and selector, we must rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating the addresses of the objects in the cache."
-
- | hash probe |
- <inline: true>
- hash := selector bitXor: class. "shift drops two low-order zeros from addresses"
-
- probe := hash bitAnd: MethodCacheMask. "first probe"
- (((methodCache at: probe + MethodCacheSelector) = selector) and:
- [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
- [newMethod := methodCache at: probe + MethodCacheMethod.
- primitiveIndex := methodCache at: probe + MethodCachePrim.
- newNativeMethod := methodCache at: probe + MethodCacheNative.
- primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void (*)(void)'.
- ^ true "found entry in cache; done"].
-
- probe := (hash >> 1) bitAnd: MethodCacheMask. "second probe"
- (((methodCache at: probe + MethodCacheSelector) = selector) and:
- [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
- [newMethod := methodCache at: probe + MethodCacheMethod.
- primitiveIndex := methodCache at: probe + MethodCachePrim.
- newNativeMethod := methodCache at: probe + MethodCacheNative.
- primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void (*)(void)'.
- ^ true "found entry in cache; done"].
-
- probe := (hash >> 2) bitAnd: MethodCacheMask.
- (((methodCache at: probe + MethodCacheSelector) = selector) and:
- [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
- [newMethod := methodCache at: probe + MethodCacheMethod.
- primitiveIndex := methodCache at: probe + MethodCachePrim.
- newNativeMethod := methodCache at: probe + MethodCacheNative.
- primitiveFunctionPointer := self cCoerce: (methodCache at: probe + MethodCachePrimFunction) to: 'void (*)(void)'.
- ^ true "found entry in cache; done"].
-
- ^ false
- !
Item was removed:
- ----- Method: Interpreter>>lookupMethodInClass: (in category 'message sending') -----
- lookupMethodInClass: class
- | currentClass dictionary found rclass |
- <inline: false>
-
- currentClass := class.
- [currentClass ~= objectMemory getNilObj]
- whileTrue:
- [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
- dictionary = objectMemory getNilObj ifTrue:
- ["MethodDict pointer is nil (hopefully due a swapped out stub)
- -- raise exception #cannotInterpret:."
- objectMemory pushRemappableOop: currentClass. "may cause GC!!"
- self createActualMessageTo: class.
- currentClass := objectMemory popRemappableOop.
- messageSelector := objectMemory 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 = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue:
- [self error: 'Recursive not understood error encountered'].
-
- "Cound not find a normal message -- raise exception #doesNotUnderstand:"
- objectMemory pushRemappableOop: class. "may cause GC!!"
- self createActualMessageTo: class.
- rclass := objectMemory popRemappableOop.
- messageSelector := objectMemory splObj: SelectorDoesNotUnderstand.
- ^ self lookupMethodInClass: rclass!
Item was removed:
- ----- Method: Interpreter>>lookupMethodInDictionary: (in category 'message sending') -----
- lookupMethodInDictionary: dictionary
- "This method lookup tolerates integers as Dictionary keys to
- support execution of images in which Symbols have been
- compacted out"
- | length index mask wrapAround nextSelector methodArray |
- <inline: true>
- length := objectMemory fetchWordLengthOf: dictionary.
- mask := length - SelectorStart - 1.
- (objectMemory isIntegerObject: messageSelector)
- ifTrue: [index := (mask bitAnd: (objectMemory integerValueOf: messageSelector)) + SelectorStart]
- ifFalse: [index := (mask bitAnd: (objectMemory hashBitsOf: messageSelector)) + SelectorStart].
-
- "It is assumed that there are some nils in this dictionary, and search will
- stop when one is encountered. However, if there are no nils, then wrapAround
- will be detected the second time the loop gets to the end of the table."
- wrapAround := false.
- [true]
- whileTrue: [nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
- nextSelector = objectMemory getNilObj ifTrue: [^ false].
- nextSelector = messageSelector
- ifTrue: [methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
- newMethod := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray.
- "Check if newMethod is a CompiledMethod."
- (objectMemory isCompiledMethod: newMethod)
- ifTrue: [primitiveIndex := self primitiveIndexOf: newMethod.
- primitiveIndex > MaxPrimitiveIndex
- ifTrue: ["If primitiveIndex is out of range, set to zero before putting in
- cache. This is equiv to primFail, and avoids the need to check on
- every send."
- primitiveIndex := 0]]
- ifFalse: ["indicate that this is no compiled method - use primitiveInvokeObjectAsMethod"
- primitiveIndex := 248].
- ^ true].
- index := index + 1.
- index = length
- ifTrue: [wrapAround
- ifTrue: [^ false].
- wrapAround := true.
- index := SelectorStart]]!
Item was removed:
- ----- Method: Interpreter>>lookupMethodNoMNUEtcInClass: (in category 'alien support') -----
- lookupMethodNoMNUEtcInClass: class
- "Lookup. Answer false on failure father than performing MNU processing etc."
- | currentClass dictionary |
- <inline: true>
-
- currentClass := class.
- [currentClass ~= objectMemory getNilObj] whileTrue:
- [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
- (dictionary ~= objectMemory getNilObj
- and: [self lookupMethodInDictionary: dictionary]) ifTrue:
- [methodClass := currentClass.
- ^true].
- currentClass := self superclassOf: currentClass].
-
- ^false!
Item was removed:
- ----- Method: Interpreter>>mapInterpreterOops (in category 'object memory support') -----
- mapInterpreterOops
- "Map all oops in the interpreter's state to their new values
- during garbage collection or a become: operation."
- "Assume: All traced variables contain valid oops."
- | oop |
- objectMemory mapRootObjects.
- compilerInitialized
- ifFalse: [stackPointer := stackPointer - activeContext. "*rel to active"
- activeContext := objectMemory remap: activeContext.
- stackPointer := stackPointer + activeContext. "*rel to active"
- theHomeContext := objectMemory remap: theHomeContext].
- instructionPointer := instructionPointer - method. "*rel to method"
- method := objectMemory remap: method.
- instructionPointer := instructionPointer + method. "*rel to method"
- receiver := objectMemory remap: receiver.
- messageSelector := objectMemory remap: messageSelector.
- newMethod := objectMemory remap: newMethod.
- methodClass := objectMemory remap: methodClass.
- lkupClass := objectMemory remap: lkupClass.
- receiverClass := objectMemory remap: receiverClass.
- 1 to: objectMemory getRemapBufferCount do: [:i |
- oop := objectMemory remapBufferAt: i.
- (objectMemory isIntegerObject: oop)
- ifFalse: [objectMemory remapBufferAt: i put: (objectMemory remap: oop)]].
-
- "Callback support - trace suspended callback list"
- 1 to: jmpDepth do:[:i|
- oop := suspendedCallbacks at: i.
- (objectMemory isIntegerObject: oop)
- ifFalse:[suspendedCallbacks at: i put: (objectMemory remap: oop)].
- oop := suspendedMethods at: i.
- (objectMemory isIntegerObject: oop)
- ifFalse:[suspendedMethods at: i put: (objectMemory remap: oop)].
- ].
- !
Item was removed:
- ----- Method: Interpreter>>markAndTraceAndMaybeFreeStackPages: (in category 'stack interpreter support') -----
- markAndTraceAndMaybeFreeStackPages: fullGCFlag
- "This is a no-op in Interpreter"
- !
Item was removed:
- ----- Method: Interpreter>>markAndTraceInterpreterOops: (in category 'object memory support') -----
- markAndTraceInterpreterOops: fullGCFlag
- "Mark and trace all oops in the interpreter's state."
- "Assume: All traced variables contain valid oops."
- | oop |
- self compilerMarkHook.
- objectMemory markAndTrace: objectMemory getSpecialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
- compilerInitialized
- ifTrue: [objectMemory markAndTrace: receiver.
- objectMemory markAndTrace: method]
- ifFalse: [objectMemory markAndTrace: activeContext].
- objectMemory markAndTrace: messageSelector.
- objectMemory markAndTrace: newMethod.
- objectMemory markAndTrace: methodClass.
- objectMemory markAndTrace: lkupClass.
- objectMemory markAndTrace: receiverClass.
- 1 to: objectMemory getRemapBufferCount do: [:i |
- oop := objectMemory remapBufferAt: i.
- (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]].
-
- "Callback support - trace suspended callback list"
- 1 to: jmpDepth do:[:i|
- oop := suspendedCallbacks at: i.
- (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
- oop := suspendedMethods at: i.
- (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
- ].
- !
Item was removed:
- ----- Method: Interpreter>>markAndTraceOrFreeMachineCode: (in category 'stack interpreter support') -----
- markAndTraceOrFreeMachineCode: fullGCFlag
- "This is a no-op in Interpreter"
- !
Item was removed:
- ----- Method: Interpreter>>methodArgumentCount (in category 'plugin primitive support') -----
- methodArgumentCount
- ^argumentCount!
Item was removed:
- ----- Method: Interpreter>>methodClassOf: (in category 'compiled methods') -----
- methodClassOf: methodPointer
-
- ^ objectMemory fetchPointer: ValueIndex ofObject: (self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer)!
Item was removed:
- ----- Method: Interpreter>>methodPrimitiveIndex (in category 'plugin primitive support') -----
- methodPrimitiveIndex
- ^primitiveIndex!
Item was removed:
- ----- Method: Interpreter>>moduleUnloaded: (in category 'initialization') -----
- moduleUnloaded: aModuleName
- "The module with the given name was just unloaded.
- Make sure we have no dangling references."
- <export: true>
- <var: #aModuleName type: 'char *'>
- (aModuleName strcmp: 'SurfacePlugin') = 0
- ifTrue: ["Surface plugin went away. Should never happen. But then, who knows"
- showSurfaceFn := 0]!
Item was removed:
- ----- Method: Interpreter>>newActiveContext: (in category 'contexts') -----
- newActiveContext: aContext
- "Note: internalNewActiveContext: should track changes to this method."
-
- self storeContextRegisters: activeContext.
- (objectMemory oop: aContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
- activeContext := aContext.
- self fetchContextRegisters: aContext.!
Item was removed:
- ----- Method: Interpreter>>normalSend (in category 'message sending') -----
- normalSend
- "Send a message, starting lookup with the receiver's class."
- "Assume: messageSelector and argumentCount have been set, and that
- the receiver and arguments have been pushed onto the stack,"
- "Note: This method is inlined into the interpreter dispatch loop."
- | rcvr |
- <inline: true>
- self sharedCodeNamed: 'normalSend' inCase: 131.
- rcvr := self internalStackValue: argumentCount.
- lkupClass := objectMemory fetchClassOf: rcvr.
- receiverClass := lkupClass.
- self commonSend.!
Item was removed:
- ----- Method: Interpreter>>normalizeFloatOrderingInImage (in category 'image save/restore') -----
- normalizeFloatOrderingInImage
- "Float objects were saved in platform word ordering. Reorder them into the
- traditional object format."
-
- <inline: false>
- <var: #floatData type: 'unsigned int *'>
- <var: #val type: 'unsigned int'>
- self isBigEnder
- ifFalse: [ | oop | "Swap words within Float objects, taking them out of native platform ordering"
- oop := objectMemory firstAccessibleObject.
- [oop = nil] whileFalse: [ | val |
- (objectMemory isFreeObject: oop) ifFalse: [
- (objectMemory fetchClassOf: oop) = objectMemory classFloat
- ifTrue: [ | floatData |
- floatData := self cCoerce: (objectMemory firstIndexableField: oop) to: 'unsigned int *'.
- val := floatData at: 0.
- floatData at: 0 put: (floatData at: 1).
- floatData at: 1 put: val].
- oop := objectMemory accessibleObjectAfter: oop]]]
- !
Item was removed:
- ----- Method: Interpreter>>nullCompilerHook (in category 'compiler support') -----
- nullCompilerHook
- "This should never be called: either the compiler is uninitialised (in which case the hooks should never be reached) or the compiler initialisation should have replaced all the hook with their external implementations."
-
- self error: 'uninitialised compiler hook called'.
- ^false!
Item was removed:
- ----- Method: Interpreter>>okayActiveProcessStack (in category 'debug support') -----
- okayActiveProcessStack
-
- | cntxt |
- cntxt := activeContext.
- [cntxt = objectMemory getNilObj] whileFalse: [
- self okayFields: cntxt.
- cntxt := (objectMemory fetchPointer: SenderIndex ofObject: cntxt).
- ].!
Item was removed:
- ----- Method: Interpreter>>okayFields: (in category 'debug support') -----
- okayFields: oop
- "If this is a pointers object, check that its fields are all okay oops."
-
- | i fieldOop c |
- (oop = nil or: [oop = 0]) ifTrue: [ ^true ].
- (objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
- objectMemory okayOop: oop.
- self oopHasOkayClass: oop.
- (objectMemory isPointers: oop) ifFalse: [ ^true ].
- c := objectMemory fetchClassOf: oop.
- (c = (objectMemory splObj: ClassMethodContext)
- or: [c = (objectMemory splObj: ClassBlockContext)])
- ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
- ifFalse: [i := (objectMemory lengthOf: oop) - 1].
- [i >= 0] whileTrue: [
- fieldOop := objectMemory fetchPointer: i ofObject: oop.
- (objectMemory isIntegerObject: fieldOop) ifFalse: [
- objectMemory okayOop: fieldOop.
- self oopHasOkayClass: fieldOop.
- ].
- i := i - 1.
- ].!
Item was removed:
- ----- Method: Interpreter>>okayInterpreterObjects (in category 'debug support') -----
- okayInterpreterObjects
-
- | oopOrZero oop |
- self okayFields: objectMemory getNilObj.
- self okayFields: objectMemory getFalseObj.
- self okayFields: objectMemory getTrueObj.
- self okayFields: objectMemory getSpecialObjectsOop.
- self okayFields: activeContext.
- self okayFields: method.
- self okayFields: receiver.
- self okayFields: theHomeContext.
- self okayFields: messageSelector.
- self okayFields: newMethod.
- self okayFields: lkupClass.
- 0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i |
- oopOrZero := methodCache at: i + MethodCacheSelector.
- oopOrZero = 0 ifFalse: [
- self okayFields: (methodCache at: i + MethodCacheSelector).
- self okayFields: (methodCache at: i + MethodCacheClass).
- self okayFields: (methodCache at: i + MethodCacheMethod).
- ].
- ].
- 1 to: objectMemory getRemapBufferCount do: [ :i |
- oop := objectMemory remapBufferAt: i.
- (objectMemory isIntegerObject: oop) ifFalse: [
- self okayFields: oop.
- ].
- ].
- self okayActiveProcessStack.!
Item was removed:
- ----- Method: Interpreter>>oldFormatFullScreenFlag: (in category 'image save/restore') -----
- oldFormatFullScreenFlag: flagsWord
- "The full screen flags word in the image header file was originally defined as
- a boolean (low order bit of the word set for true). In more recent usage with
- StackInterpreter, the remaining bits are allocated for other purposes. This
- interpreter does not use the new bit definitions, and should clear the bits
- before saving the image."
-
- ^ flagsWord bitAnd: 1!
Item was removed:
- ----- Method: Interpreter>>oopHasOkayClass: (in category 'debug support') -----
- oopHasOkayClass: signedOop
- "Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."
-
- | oop oopClass formatMask behaviorFormatBits oopFormatBits |
- <var: #oop type: 'usqInt'>
- <var: #oopClass type: 'usqInt'>
-
- oop := self cCoerce: signedOop to: 'usqInt'.
- objectMemory okayOop: oop.
- oopClass := self cCoerce: (objectMemory fetchClassOf: oop) to: 'usqInt'.
-
- (objectMemory isIntegerObject: oopClass)
- ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ].
- objectMemory okayOop: oopClass.
- ((objectMemory isPointers: oopClass) and: [(objectMemory lengthOf: oopClass) >= 3])
- ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ].
- (objectMemory isBytes: oop)
- ifTrue: [ formatMask := 16rC00 ] "ignore extra bytes size bits"
- ifFalse: [ formatMask := 16rF00 ].
-
- behaviorFormatBits := (objectMemory formatOfClass: oopClass) bitAnd: formatMask.
- oopFormatBits := (objectMemory baseHeader: oop) bitAnd: formatMask.
- behaviorFormatBits = oopFormatBits
- ifFalse: [ self error: 'object and its class (behavior) formats differ' ].
- ^true!
Item was removed:
- ----- Method: Interpreter>>pop2AndPushIntegerIfOK: (in category 'contexts') -----
- pop2AndPushIntegerIfOK: integerResult
-
- self successful ifTrue:
- [(objectMemory isIntegerValue: integerResult)
- ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: integerResult)]
- ifFalse: [self primitiveFail]]!
Item was removed:
- ----- Method: Interpreter>>pop: (in category 'contexts') -----
- pop: nItems
- "Note: May be called by translated primitive code."
-
- stackPointer := stackPointer - (nItems * objectMemory bytesPerWord).!
Item was removed:
- ----- Method: Interpreter>>pop:thenPush: (in category 'contexts') -----
- pop: nItems thenPush: oop
-
- | sp |
- objectMemory longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord)) put: oop.
- stackPointer := sp.
- !
Item was removed:
- ----- Method: Interpreter>>pop:thenPushBool: (in category 'contexts') -----
- pop: nItems thenPushBool: trueOrFalse
- "A few places pop a few items off the stack and then push a boolean. Make it convenient"
- | sp |
- objectMemory longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord))
- put:(trueOrFalse ifTrue: [objectMemory getTrueObj] ifFalse: [objectMemory getFalseObj]).
- stackPointer := sp!
Item was removed:
- ----- Method: Interpreter>>pop:thenPushInteger: (in category 'contexts') -----
- pop: nItems thenPushInteger: integerVal
- "lots of places pop a few items off the stack and then push an integer. MAke it convenient"
- | sp |
- objectMemory longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord)) put:(objectMemory integerObjectOf: integerVal).
- stackPointer := sp.
- !
Item was removed:
- ----- Method: Interpreter>>popFloat (in category 'stack bytecodes') -----
- popFloat
- "Note: May be called by translated primitive code."
-
- | top result |
- <returnTypeC: 'double'>
- <var: #result type: 'double '>
- top := self popStack.
- self assertClassOf: top is: (objectMemory splObj: ClassFloat).
- self successful ifTrue:
- [self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: top + objectMemory baseHeaderSize into: result].
- ^ result!
Item was removed:
- ----- Method: Interpreter>>popInteger (in category 'contexts') -----
- popInteger
- "returns 0 if the stackTop was not an integer value, plus sets primFailCode"
- | integerPointer |
- integerPointer := self popStack.
- ^self checkedIntegerValueOf: integerPointer!
Item was removed:
- ----- Method: Interpreter>>popPos32BitInteger (in category 'contexts') -----
- popPos32BitInteger
- "May set primFailCode, and return false if not valid"
-
- | top |
- top := self popStack.
- ^ self positive32BitValueOf: top!
Item was removed:
- ----- Method: Interpreter>>popStack (in category 'contexts') -----
- popStack
-
- | top |
- top := objectMemory longAt: stackPointer.
- stackPointer := stackPointer - objectMemory bytesPerWord.
- ^ top!
Item was removed:
- ----- Method: Interpreter>>popStackBytecode (in category 'stack bytecodes') -----
- popStackBytecode
-
- self fetchNextBytecode.
- self internalPop: 1.
- !
Item was removed:
- ----- Method: Interpreter>>positive32BitIntegerFor: (in category 'primitive support') -----
- positive32BitIntegerFor: integerValue
-
- | newLargeInteger |
- "Note - integerValue is interpreted as POSITIVE, eg, as the result of
- Bitmap>at:, or integer>bitAnd:."
- integerValue >= 0
- ifTrue: [(objectMemory isIntegerValue: integerValue)
- ifTrue: [^ objectMemory integerObjectOf: integerValue]].
-
- objectMemory bytesPerWord = 4
- ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size."
- newLargeInteger := objectMemory instantiateSmallClass: (objectMemory splObj: ClassLargePositiveInteger)
- sizeInBytes: objectMemory baseHeaderSize + 4]
- ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement."
- newLargeInteger := objectMemory instantiateClass: (objectMemory splObj: ClassLargePositiveInteger)
- indexableSize: 4].
- objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
- objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
- objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
- objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
- ^ newLargeInteger!
Item was removed:
- ----- Method: Interpreter>>positive64BitIntegerFor: (in category 'primitive support') -----
- positive64BitIntegerFor: integerValue
-
- | newLargeInteger value highWord sz |
- "Note - integerValue is interpreted as POSITIVE, eg, as the result of
- Bitmap>at:, or integer>bitAnd:."
- <var: 'integerValue' type: 'sqLong'>
-
- (self sizeof: integerValue) = 4 ifTrue: [^self positive32BitIntegerFor: integerValue].
-
-
- highWord := self cCode: 'integerValue >> 32'. "shift is coerced to usqInt otherwise"
- highWord = 0 ifTrue:[^self positive32BitIntegerFor: integerValue].
- 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 := objectMemory instantiateClass: (objectMemory splObj: ClassLargePositiveInteger) indexableSize: sz.
- 0 to: sz-1 do: [:i |
- value := self cCode: '(integerValue >> (i * 8)) & 255'.
- objectMemory storeByte: i ofObject: newLargeInteger withValue: value].
- ^ newLargeInteger
- !
Item was removed:
- ----- Method: Interpreter>>postGCAction (in category 'object memory support') -----
- postGCAction
- "Mark the active and home contexts as roots if old. This
- allows the interpreter to use storePointerUnchecked to
- store into them."
-
- compilerInitialized
- ifTrue: [self compilerPostGC]
- ifFalse: [(objectMemory oop: activeContext isLessThan: objectMemory getYoungStart)
- ifTrue: [objectMemory beRootIfOld: activeContext].
- (objectMemory oop: theHomeContext isLessThan: objectMemory getYoungStart)
- ifTrue: [objectMemory beRootIfOld: theHomeContext]].
- (objectMemory oop: (objectMemory sizeOfFree: objectMemory getFreeBlock) isGreaterThan: objectMemory getShrinkThreshold)
- ifTrue: ["Attempt to shrink memory after successfully
- reclaiming lots of memory"
- objectMemory shrinkObjectMemory: (objectMemory sizeOfFree: objectMemory getFreeBlock) - objectMemory getGrowHeadroom].
-
- self signalSemaphoreWithIndex: objectMemory getGcSemaphoreIndex.
- !
Item was removed:
- ----- Method: Interpreter>>preGCAction: (in category 'object memory support') -----
- preGCAction: fullGCFlag
-
- compilerInitialized
- ifTrue: [self compilerPreGC: fullGCFlag]
- ifFalse: [self storeContextRegisters: activeContext].!
Item was removed:
- ----- Method: Interpreter>>primIndex (in category 'primitive support') -----
- primIndex
- ^ primitiveIndex!
Item was removed:
- ----- Method: Interpreter>>primitiveAsOop (in category 'object access primitives') -----
- primitiveAsOop
- | thisReceiver |
- thisReceiver := self stackTop.
- self success: (objectMemory isIntegerObject: thisReceiver) not.
- self successful
- ifTrue: [self pop:1 thenPushInteger: (objectMemory hashBitsOf: thisReceiver)]!
Item was removed:
- ----- Method: Interpreter>>primitiveAtEnd (in category 'deprecated - array and stream primitives') -----
- primitiveAtEnd
- "nb: This primitive was previously installed as primitive 67, but is no
- longer in use."
- | stream index limit |
- stream := self popStack.
- ((objectMemory isPointers: stream)
- and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex+1)])
- ifTrue: [index := self fetchInteger: StreamIndexIndex ofObject: stream.
- limit := self fetchInteger: StreamReadLimitIndex ofObject: stream]
- ifFalse: [self primitiveFail].
- self successful
- ifTrue: [self pushBool: (index >= limit)]
- ifFalse: [self unPop: 1].!
Item was removed:
- ----- Method: Interpreter>>primitiveBlockCopy (in category 'control primitives') -----
- primitiveBlockCopy
-
- | context methodContext contextSize newContext initialIP |
- context := self stackValue: 1.
- (objectMemory isIntegerObject: (objectMemory fetchPointer: MethodIndex ofObject: context))
- ifTrue: ["context is a block; get the context of its enclosing method"
- methodContext := objectMemory fetchPointer: HomeIndex ofObject: context]
- ifFalse: [methodContext := context].
- contextSize := objectMemory sizeBitsOf: methodContext. "in bytes, including header"
- context := nil. "context is no longer needed and is not preserved across allocation"
-
- "remap methodContext in case GC happens during allocation"
- objectMemory pushRemappableOop: methodContext.
- newContext := objectMemory instantiateContext: (objectMemory splObj: ClassBlockContext) sizeInBytes: contextSize.
- methodContext := objectMemory popRemappableOop.
-
- initialIP := objectMemory integerObjectOf: (instructionPointer+1+3) - (method + objectMemory baseHeaderSize).
- "Was instructionPointer + 3, but now it's greater by 1 due to preIncrement"
-
- "Assume: have just allocated a new context; it must be young.
- Thus, can use uncheck stores. See the comment in fetchContextRegisters."
-
- objectMemory storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
- objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
- self storeStackPointerValue: 0 inContext: newContext.
- objectMemory storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
- objectMemory storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
- objectMemory storePointerUnchecked: SenderIndex ofObject: newContext withValue: objectMemory getNilObj.
-
- self pop: 2 thenPush: newContext.!
Item was removed:
- ----- Method: Interpreter>>primitiveChangeClassWithClass (in category 'object access primitives') -----
- primitiveChangeClassWithClass
- "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
- | rcvr argClass |
- <export: true>
- self methodArgumentCount = 1 ifFalse: [self primitiveFail. ^ nil].
-
- argClass := self stackObjectValue: 0.
- rcvr := self stackObjectValue: 1.
-
- self changeClassOf: rcvr to: argClass.
- self successful ifTrue: [ self flushAtCache. self pop: 1 ].
- ^ nil.
- !
Item was removed:
- ----- Method: Interpreter>>primitiveClone (in category 'object access primitives') -----
- primitiveClone
- "Return a shallow copy of the receiver."
-
- | newCopy |
- newCopy := objectMemory clone: (self stackTop).
- newCopy = 0
- ifTrue:["not enough memory most likely" ^self primitiveFail].
- self pop: 1 thenPush: newCopy.!
Item was removed:
- ----- Method: Interpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
- primitiveClosureCopyWithCopiedValues
- | newClosure copiedValues numCopiedValues numArgs |
- numArgs := self stackIntegerValue: 1.
- copiedValues := self stackTop.
- self success: (objectMemory fetchClassOf: copiedValues) = (objectMemory splObj: ClassArray).
- self successful ifFalse:
- [^self primitiveFail].
- numCopiedValues := objectMemory fetchWordLengthOf: copiedValues.
- newClosure := self
- closureNumArgs: numArgs
- "greater by 1 due to preIncrement of localIP"
- instructionPointer: instructionPointer + 2 - (method + objectMemory baseHeaderSize)
- numCopiedValues: numCopiedValues.
- "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
- objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
- numCopiedValues > 0 ifTrue:
- ["Allocation may have done a GC and copiedValues may have moved."
- copiedValues := self stackTop.
- 0 to: numCopiedValues - 1 do:
- [:i|
- "Assume: have just allocated a new BlockClosure; it must be young.
- Thus, can use unchecked stores."
- objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
- ofObject: newClosure
- withValue: (objectMemory fetchPointer: i ofObject: copiedValues)]].
- self pop: 3 thenPush: newClosure!
Item was removed:
- ----- Method: Interpreter>>primitiveClosureValue (in category 'control primitives') -----
- primitiveClosureValue
- | blockClosure blockArgumentCount closureMethod outerContext |
- blockClosure := self stackValue: argumentCount.
- blockArgumentCount := self argumentCountOfClosure: blockClosure.
- argumentCount = blockArgumentCount ifFalse:
- [^self primitiveFail].
-
- "Somewhat paranoiac checks we need while debugging that we may be able to discard
- in a robust system."
- outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
- (self isContext: outerContext) ifFalse:
- [^self primitiveFail].
- closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
- "Check if the closure's method is actually a CompiledMethod."
- (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
- [^self primitiveFail].
-
- self activateNewClosureMethod: blockClosure.
- self quickCheckForInterrupts!
Item was removed:
- ----- Method: Interpreter>>primitiveClosureValueNoContextSwitch (in category 'control primitives') -----
- primitiveClosureValueNoContextSwitch
- "An exact clone of primitiveClosureValue except that this version will not
- check for interrupts on stack overflow."
- | blockClosure blockArgumentCount closureMethod outerContext |
- blockClosure := self stackValue: argumentCount.
- blockArgumentCount := self argumentCountOfClosure: blockClosure.
- argumentCount = blockArgumentCount ifFalse:
- [^self primitiveFail].
-
- "Somewhat paranoiac checks we need while debugging that we may be able to discard
- in a robust system."
- outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
- (self isContext: outerContext) ifFalse:
- [^self primitiveFail].
- closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
- "Check if the closure's method is actually a CompiledMethod."
- (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
- [^self primitiveFail].
-
- self activateNewClosureMethod: blockClosure!
Item was removed:
- ----- Method: Interpreter>>primitiveClosureValueWithArgs (in category 'control primitives') -----
- primitiveClosureValueWithArgs
- | argumentArray arraySize cntxSize blockClosure blockArgumentCount closureMethod index outerContext |
- argumentArray := self stackTop.
- (objectMemory isArray: argumentArray) ifFalse:
- [^self primitiveFail].
-
- "Check for enough space in thisContext to push all args"
- arraySize := objectMemory fetchWordLengthOf: argumentArray.
- cntxSize := objectMemory fetchWordLengthOf: activeContext.
- (self stackPointerIndex + arraySize) < cntxSize ifFalse:
- [^self primitiveFail].
-
- blockClosure := self stackValue: argumentCount.
- blockArgumentCount := self argumentCountOfClosure: blockClosure.
- arraySize = blockArgumentCount ifFalse:
- [^self primitiveFail].
-
- "Somewhat paranoiac checks we need while debugging that we may be able to discard
- in a robust system."
- outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
- (self isContext: outerContext) ifFalse:
- [^self primitiveFail].
- closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
- "Check if the closure's method is actually a CompiledMethod."
- (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
- [^self primitiveFail].
-
- self popStack.
-
- "Copy the arguments to the stack, and activate"
- index := 1.
- [index <= arraySize]
- whileTrue:
- [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
- index := index + 1].
-
- argumentCount := arraySize.
- self activateNewClosureMethod: blockClosure.
- self quickCheckForInterrupts!
Item was removed:
- ----- Method: Interpreter>>primitiveCopyObject (in category 'object access primitives') -----
- primitiveCopyObject
- "Primitive. Copy the state of the receiver from the argument.
- Fail if receiver and argument are of a different class.
- Fail if the receiver or argument are non-pointer objects.
- Fail if receiver and argument have different lengths (for indexable objects).
- "
- | rcvr arg length |
- self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
- arg := self stackObjectValue: 0.
- rcvr := self stackObjectValue: 1.
-
- self failed ifTrue:[^nil].
- (objectMemory isPointers: rcvr) ifFalse:[^self primitiveFail].
- (objectMemory fetchClassOf: rcvr) = (objectMemory fetchClassOf: arg) ifFalse:[^self primitiveFail].
- length := objectMemory lengthOf: rcvr.
- length = (objectMemory lengthOf: arg) ifFalse:[^self primitiveFail].
-
- "Now copy the elements"
- 0 to: length-1 do:[:i|
- objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)].
-
- "Note: The above could be faster for young receivers but I don't think it'll matter"
- self pop: 1. "pop arg; answer receiver"
- !
Item was removed:
- ----- Method: Interpreter>>primitiveDeferDisplayUpdates (in category 'I/O primitives') -----
- primitiveDeferDisplayUpdates
- "Set or clear the flag that controls whether modifications of
- the Display object are propagated to the underlying
- platform's screen."
- | flag |
- flag := self stackTop.
- flag = objectMemory getTrueObj
- ifTrue: [deferDisplayUpdates := true]
- ifFalse: [flag = objectMemory getFalseObj
- ifTrue: [deferDisplayUpdates := false]
- ifFalse: [self primitiveFail]].
- self successful
- ifTrue: [self pop: 1]!
Item was removed:
- ----- Method: Interpreter>>primitiveDoPrimitiveWithArgs (in category 'control primitives') -----
- primitiveDoPrimitiveWithArgs
- | argumentArray arraySize index cntxSize primIdx |
- argumentArray := self stackTop.
- arraySize := objectMemory fetchWordLengthOf: argumentArray.
- cntxSize := objectMemory fetchWordLengthOf: activeContext.
- self success: self stackPointerIndex + arraySize < cntxSize.
- (objectMemory isArray: argumentArray) ifFalse: [^ self primitiveFail].
-
- primIdx := self stackIntegerValue: 1.
- self successful ifFalse: [^ self primitiveFail]. "invalid args"
-
- "Pop primIndex and argArray, then push args in place..."
- self pop: 2.
- primitiveIndex := primIdx.
- argumentCount := arraySize.
- index := 1.
- [index <= argumentCount]
- whileTrue: [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
- index := index + 1].
-
- "Run the primitive (sets primFailCode)"
- objectMemory pushRemappableOop: argumentArray. "prim might alloc/gc"
- lkupClass := objectMemory getNilObj.
- self primitiveResponse.
- argumentArray := objectMemory popRemappableOop.
- self successful
- ifFalse: ["If primitive failed, then restore state for failure code"
- self pop: arraySize.
- self pushInteger: primIdx.
- self push: argumentArray.
- argumentCount := 2]!
Item was removed:
- ----- Method: Interpreter>>primitiveExecuteMethod (in category 'control primitives') -----
- primitiveExecuteMethod
- "receiver, args, then method are on top of stack. Execute method against receiver and args"
- newMethod := self popStack.
- primitiveIndex := self primitiveIndexOf: newMethod.
- self success: argumentCount - 1 = (self argumentCountOf: newMethod).
- self successful
- ifTrue: [argumentCount := argumentCount - 1.
- self executeNewMethod]
- ifFalse: [self unPop: 1]!
Item was removed:
- ----- Method: Interpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') -----
- primitiveExecuteMethodArgsArray
- "receiver, argsArray, then method are on top of stack. Execute method against
- receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives).
- Set primitiveFunctionPointer because no cache lookup has been done for the
- method, and hence primitiveFunctionPointer is stale."
- | methodArgument argCnt argumentArray |
- methodArgument := self stackTop.
- argumentArray := self stackValue: 1.
- ((objectMemory isOopCompiledMethod: methodArgument)
- and: [objectMemory isArray: argumentArray]) ifFalse:
- [^self primitiveFail].
- argCnt := self argumentCountOf: methodArgument.
- argCnt = (objectMemory fetchWordLengthOf: argumentArray) ifFalse:
- [^self primitiveFail].
- argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod:
- SqueakObjectPrimitives class >> receiver:withArguments:apply:
- VMMirror>>ifFail:object:with:executeMethod: et al"
- [argumentCount > 4 ifTrue:
- [^self primitiveFail].
- self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver"
- "and push the actual arguments"
- self pop: argumentCount.
- 0 to: argCnt - 1 do:
- [:i|
- self push: (objectMemory fetchPointer: i ofObject: argumentArray)].
- newMethod := methodArgument.
- primitiveIndex := self primitiveIndexOf: newMethod.
- primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil.
- argumentCount := argCnt.
- "We set the messageSelector for executeMethod below since things
- like the at cache read messageSelector and so it cannot be left stale."
- messageSelector := objectMemory nilObject.
- self executeNewMethod.
- "Recursive xeq affects primFailCode"
- self initPrimCall!
Item was removed:
- ----- Method: Interpreter>>primitiveExternalCall (in category 'plugin primitives') -----
- 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 extFnAddr moduleName functionName moduleLength functionLength index |
- <var: #extFnAddr declareC: 'void (*extFnAddr)(void)'>
-
- "Fetch the first literal of the method"
- self success: (self literalCountOf: newMethod) > 0. "@@: Could this be omitted for speed?!!"
- self successful ifFalse: [^ nil].
-
- lit := self literal: 0 ofMethod: newMethod.
- "Check if it's an array of length 4"
- self success: ((objectMemory isArray: lit) and: [(objectMemory lengthOf: lit) = 4]).
- self successful ifFalse: [^ nil].
-
- "Look at the function index in case it has been loaded before"
- index := objectMemory fetchPointer: 3 ofObject: lit.
- index := self checkedIntegerValueOf: index.
- self successful 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: [extFnAddr := externalPrimitiveTable at: index - 1.
- extFnAddr ~= 0
- ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: extFnAddr.
- self callExternalPrimitive: extFnAddr.
- ^ 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"
- objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
- objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
-
- "The function has not been loaded yet. Fetch module and function name."
- moduleName := objectMemory fetchPointer: 0 ofObject: lit.
- moduleName = objectMemory getNilObj
- ifTrue: [moduleLength := 0]
- ifFalse: [self success: (objectMemory isBytes: moduleName).
- moduleLength := objectMemory lengthOf: moduleName.
- self cCode: '' inSmalltalk:
- [ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName))
- ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
- functionName := objectMemory fetchPointer: 1 ofObject: lit.
- self success: (objectMemory isBytes: functionName).
- functionLength := objectMemory lengthOf: functionName.
- self successful ifFalse: [^ nil].
-
- extFnAddr := self cCoerce: (self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
- OfLength: functionLength
- FromModule: moduleName + objectMemory baseHeaderSize
- OfLength: moduleLength) to: 'void (*)(void)'.
- extFnAddr = 0
- ifTrue: [index := -1]
- ifFalse: ["add the function to the external primitive table"
- index := self addToExternalPrimitiveTable: extFnAddr].
- self success: index >= 0.
- "Store the index (or -1 if failure) back in the literal"
- objectMemory storePointerUnchecked: 3 ofObject: lit withValue: (objectMemory integerObjectOf: index).
-
- "If the function has been successfully loaded process it"
- (self successful and: [extFnAddr ~= 0])
- ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: extFnAddr.
- self callExternalPrimitive: extFnAddr]
- ifFalse: ["Otherwise rewrite the primitive index"
- self
- rewriteMethodCacheSel: messageSelector
- class: lkupClass
- primIndex: 0]!
Item was removed:
- ----- Method: Interpreter>>primitiveFloatAdd:toArg: (in category 'arithmetic float primitives') -----
- primitiveFloatAdd: rcvrOop toArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [
- self pop: 2.
- self pushFloat: rcvr + arg].!
Item was removed:
- ----- Method: Interpreter>>primitiveFloatAt (in category 'indexing primitives') -----
- primitiveFloatAt
- "Provide platform-independent access to 32-bit words comprising
- a Float. Map index 1 onto the most significant word and index 2
- onto the least significant word."
- | rcvr index result |
- <var: #result type: #usqInt>
- self initPrimCall.
- rcvr := self stackValue: 1.
- index := self stackTop.
- index = ConstOne ifTrue:
- [result := self positive32BitIntegerFor:
- (objectMemory fetchLong32: 0
- ofObject: rcvr).
- ^self pop: 2 thenPush: result].
- index = ConstTwo ifTrue:
- [result := self positive32BitIntegerFor:
- (objectMemory fetchLong32: 1
- ofObject: rcvr).
- ^self pop: 2 thenPush: result].
- self primitiveFailFor: ((objectMemory isIntegerObject: index)
- ifTrue: [PrimErrBadIndex]
- ifFalse: [PrimErrBadArgument])!
Item was removed:
- ----- Method: Interpreter>>primitiveFloatAtPut (in category 'indexing primitives') -----
- primitiveFloatAtPut
- "Provide platform-independent access to 32-bit words comprising
- a Float. Map index 1 onto the most significant word and index 2
- onto the least significant word."
- | rcvr index oopToStore valueToStore |
- <var: #result type: #usqInt>
- self initPrimCall.
- oopToStore := self stackTop.
- valueToStore := self positive32BitValueOf: oopToStore.
- self successful ifFalse:
- [^self primitiveFailFor: PrimErrBadArgument].
- rcvr := self stackValue: 2.
- index := self stackValue: 1.
- index = ConstOne ifTrue:
- [objectMemory storeLong32: 0
- ofObject: rcvr
- withValue: valueToStore.
- ^self pop: 3 thenPush: oopToStore].
- index = ConstTwo ifTrue:
- [objectMemory storeLong32: 1
- ofObject: rcvr
- withValue: valueToStore.
- ^self pop: 3 thenPush: oopToStore].
- self primitiveFailFor: ((objectMemory isIntegerObject: index)
- ifTrue: [PrimErrBadIndex]
- ifFalse: [PrimErrBadArgument])!
Item was removed:
- ----- Method: Interpreter>>primitiveFloatDivide:byArg: (in category 'arithmetic float primitives') -----
- primitiveFloatDivide: rcvrOop byArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [
- self success: arg ~= 0.0.
- self successful ifTrue: [
- self pop: 2.
- self pushFloat: (self cCode: 'rcvr / arg' inSmalltalk: [rcvr / arg])]].!
Item was removed:
- ----- Method: Interpreter>>primitiveFloatEqual:toArg: (in category 'arithmetic float primitives') -----
- primitiveFloatEqual: rcvrOop toArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [^ rcvr = arg]!
Item was removed:
- ----- Method: Interpreter>>primitiveFloatGreater:thanArg: (in category 'arithmetic float primitives') -----
- primitiveFloatGreater: rcvrOop thanArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [^ rcvr > arg].
- !
Item was removed:
- ----- Method: Interpreter>>primitiveFloatGreaterOrEqual:toArg: (in category 'arithmetic float primitives') -----
- primitiveFloatGreaterOrEqual: rcvrOop toArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [^ rcvr >= arg].
- !
Item was removed:
- ----- Method: Interpreter>>primitiveFloatLess:thanArg: (in category 'arithmetic float primitives') -----
- primitiveFloatLess: rcvrOop thanArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [^ rcvr < arg].
- !
Item was removed:
- ----- Method: Interpreter>>primitiveFloatLessOrEqual:toArg: (in category 'arithmetic float primitives') -----
- primitiveFloatLessOrEqual: rcvrOop toArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [^ rcvr <= arg].
- !
Item was removed:
- ----- Method: Interpreter>>primitiveFloatMultiply:byArg: (in category 'arithmetic float primitives') -----
- primitiveFloatMultiply: rcvrOop byArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [
- self pop: 2.
- self pushFloat: rcvr * arg].!
Item was removed:
- ----- Method: Interpreter>>primitiveFloatSubtract:fromArg: (in category 'arithmetic float primitives') -----
- primitiveFloatSubtract: rcvrOop fromArg: argOop
- | rcvr arg |
- <var: #rcvr type: 'double '>
- <var: #arg type: 'double '>
-
- rcvr := self loadFloatOrIntFrom: rcvrOop.
- arg := self loadFloatOrIntFrom: argOop.
- self successful ifTrue: [
- self pop: 2.
- self pushFloat: rcvr - arg].!
Item was removed:
- ----- Method: Interpreter>>primitiveFlushCacheByMethod (in category 'system control primitives') -----
- primitiveFlushCacheByMethod
- "The receiver is a compiledMethod. Clear all entries in the method lookup cache that refer to this method, presumably because it has been redefined, overridden or removed."
- | probe oldMethod |
- oldMethod := self stackTop.
- probe := 0.
- 1 to: MethodCacheEntries do:
- [:i | (methodCache at: probe + MethodCacheMethod) = oldMethod ifTrue:
- [methodCache at: probe + MethodCacheSelector put: 0].
- probe := probe + MethodCacheEntrySize].
- self flushAtCache.
- self compilerFlushCacheHook: oldMethod. "Flush the dynamic compiler's inline caches."!
Item was removed:
- ----- Method: Interpreter>>primitiveFlushCacheBySelector (in category 'system control primitives') -----
- primitiveFlushCacheBySelector
- "The receiver is a message selector. Clear all entries in the method lookup cache with this selector, presumably because an associated method has been redefined."
- | selector probe |
- selector := self stackTop.
- probe := 0.
- 1 to: MethodCacheEntries do:
- [:i | (methodCache at: probe + MethodCacheSelector) = selector ifTrue:
- [methodCache at: probe + MethodCacheSelector put: 0].
- probe := probe + MethodCacheEntrySize].
- (selector = (self specialSelector: 16) "at:"
- or: [selector = (self specialSelector: 17) "at:put:"]) ifTrue:
- [self flushAtCache]!
Item was removed:
- ----- Method: Interpreter>>primitiveIndexOf: (in category 'compiled methods') -----
- primitiveIndexOf: methodPointer
- "Note: We now have 10 bits of primitive index, but they are in two places
- for temporary backward compatibility. The time to unpack is negligible,
- since the reconstituted full index is stored in the method cache."
- | primBits |
- primBits := ((self headerOf: methodPointer) >> 1) bitAnd: 16r100001FF.
-
- ^ (primBits bitAnd: 16r1FF) + (primBits >> 19)
- !
Item was removed:
- ----- Method: Interpreter>>primitiveIndexOfMethodHeader: (in category 'compiled methods') -----
- primitiveIndexOfMethodHeader: methodHeader
- "Note: We now have 10 bits of primitive index, but they are in two places
- for temporary backward compatibility. The time to unpack is negligible,
- since the derived primitive function pointer is stored in the method cache."
- | primBits |
- primBits := (methodHeader >> 1).
- ^(primBits bitAnd: 16r1FF) + ((primBits >> 19) bitAnd: 16r200)!
Item was removed:
- ----- Method: Interpreter>>primitiveInvokeObjectAsMethod (in category 'control primitives') -----
- primitiveInvokeObjectAsMethod
- "Primitive. 'Invoke' an object like a function, sending the special message
- run: originalSelector with: arguments in: aReceiver.
- "
- | runSelector runReceiver runArgs newReceiver lookupClass |
- runArgs := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount.
- objectMemory beRootIfOld: runArgs. "do we really need this?"
- self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * objectMemory bytesPerWord) to: runArgs + objectMemory baseHeaderSize.
-
- runSelector := messageSelector.
- runReceiver := self stackValue: argumentCount.
- self pop: argumentCount+1.
-
- "stack is clean here"
-
- newReceiver := newMethod.
- messageSelector := objectMemory splObj: SelectorRunWithIn.
- argumentCount := 3.
-
- self push: newReceiver.
- self push: runSelector.
- self push: runArgs.
- self push: runReceiver.
-
- lookupClass := objectMemory fetchClassOf: newReceiver.
- self findNewMethodInClass: lookupClass.
- self executeNewMethodFromCache. "Recursive xeq affects primFailCode"
- self initPrimCall.
- !
Item was removed:
- ----- Method: Interpreter>>primitiveLoadInstVar (in category 'quick primitives') -----
- primitiveLoadInstVar
- | thisReceiver |
- thisReceiver := self popStack.
- self push: (objectMemory fetchPointer: primitiveIndex-264 ofObject: thisReceiver)!
Item was added:
+ ----- Method: Interpreter>>primitiveNewMethod (in category 'compiled methods') -----
+ primitiveNewMethod
+ | header bytecodeCount class size theMethod literalCount |
+ header := self popStack.
+ bytecodeCount := self popInteger.
+ self success: (objectMemory isIntegerObject: header).
+ self successful ifFalse:
+ [self unPop: 2. ^nil].
+ class := self popStack.
+ size := (self literalCountOfHeader: header) + 1 * objectMemory bytesPerWord + bytecodeCount.
+ theMethod := objectMemory instantiateClass: class indexableSize: size.
+ objectMemory storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
+ literalCount := self literalCountOfHeader: header.
+ 1 to: literalCount do:
+ [:i | objectMemory storePointer: i ofObject: theMethod withValue: objectMemory getNilObj].
+ self push: theMethod!
Item was removed:
- ----- Method: Interpreter>>primitiveNext (in category 'deprecated - array and stream primitives') -----
- primitiveNext
- "PrimitiveNext will succeed only if the stream's array is in the atCache.
- Otherwise failure will lead to proper message lookup of at: and
- subsequent installation in the cache if appropriate.
- nb: This primitive was previously installed as primitive 65, but is no
- longer in use."
- | stream array index limit result atIx |
- stream := self stackTop.
- ((objectMemory isPointers: stream)
- and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex + 1)])
- ifFalse: [^ self primitiveFail].
-
- array := objectMemory fetchPointer: StreamArrayIndex ofObject: stream.
- index := self fetchInteger: StreamIndexIndex ofObject: stream.
- limit := self fetchInteger: StreamReadLimitIndex ofObject: stream.
- atIx := array bitAnd: AtCacheMask.
- (index < limit and: [(atCache at: atIx+AtCacheOop) = array])
- ifFalse: [^ self primitiveFail].
-
- "OK -- its not at end, and the array is in the cache"
- index := index + 1.
- result := self commonVariable: array at: index cacheIndex: atIx.
- "Above may cause GC, so can't use stream, array etc. below it"
- self successful ifTrue:
- [stream := self stackTop.
- self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
- ^ self pop: 1 thenPush: result].
- !
Item was removed:
- ----- Method: Interpreter>>primitiveNextPut (in category 'deprecated - array and stream primitives') -----
- primitiveNextPut
- "PrimitiveNextPut will succeed only if the stream's array is in the atPutCache.
- Otherwise failure will lead to proper message lookup of at:put: and
- subsequent installation in the cache if appropriate.
- nb: This primitive was previously installed as primitive 66, but is no
- longer in use."
- | value stream index limit array atIx |
- value := self stackTop.
- stream := self stackValue: 1.
- ((objectMemory isPointers: stream)
- and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex + 1)])
- ifFalse: [^ self primitiveFail].
-
- array := objectMemory fetchPointer: StreamArrayIndex ofObject: stream.
- index := self fetchInteger: StreamIndexIndex ofObject: stream.
- limit := self fetchInteger: StreamWriteLimitIndex ofObject: stream.
- atIx := (array bitAnd: AtCacheMask) + AtPutBase.
- (index < limit and: [(atCache at: atIx+AtCacheOop) = array])
- ifFalse: [^ self primitiveFail].
-
- "OK -- its not at end, and the array is in the cache"
- index := index + 1.
- self commonVariable: array at: index put: value cacheIndex: atIx.
- self successful ifTrue:
- [self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
- ^ self pop: 2 thenPush: value].
- !
Item was removed:
- ----- Method: Interpreter>>primitivePerform (in category 'control primitives') -----
- primitivePerform
- | performSelector newReceiver selectorIndex lookupClass performMethod |
- performSelector := messageSelector.
- performMethod := newMethod.
- messageSelector := self stackValue: argumentCount - 1.
- newReceiver := self stackValue: argumentCount.
-
- "NOTE: the following lookup may fail and be converted to #doesNotUnderstand:, so we must adjust argumentCount and slide args now, so that would work."
-
- "Slide arguments down over selector"
- argumentCount := argumentCount - 1.
- selectorIndex := self stackPointerIndex - argumentCount.
- self
- transfer: argumentCount
- fromIndex: selectorIndex + 1
- ofObject: activeContext
- toIndex: selectorIndex
- ofObject: activeContext.
- self pop: 1.
- lookupClass := objectMemory fetchClassOf: newReceiver.
- self findNewMethodInClass: lookupClass.
-
- "Only test CompiledMethods for argument count - other objects will have to take their chances"
- (objectMemory isOopCompiledMethod: newMethod)
- ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
-
- self successful
- ifTrue: [self executeNewMethodFromCache.
- "Recursive xeq affects primFailCode"
- self initPrimCall]
- ifFalse: ["Slide the args back up (sigh) and re-insert the
- selector. "
- 1 to: argumentCount do: [:i | objectMemory
- storePointer: argumentCount - i + 1 + selectorIndex
- ofObject: activeContext
- withValue: (objectMemory fetchPointer: argumentCount - i + selectorIndex ofObject: activeContext)].
- self unPop: 1.
- objectMemory storePointer: selectorIndex
- ofObject: activeContext
- withValue: messageSelector.
- argumentCount := argumentCount + 1.
- newMethod := performMethod.
- messageSelector := performSelector]!
Item was removed:
- ----- Method: Interpreter>>primitivePerformAt: (in category 'control primitives') -----
- primitivePerformAt: lookupClass
- "Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"
-
- "NOTE: The case of doesNotUnderstand: is not a failure to perform.
- The only failures are arg types and consistency of argumentCount."
-
- | performSelector argumentArray arraySize index cntxSize performMethod performArgCount |
- argumentArray := self stackTop.
- (objectMemory isArray: argumentArray) ifFalse:[^self primitiveFail].
-
- self successful ifTrue:
- ["Check for enough space in thisContext to push all args"
- arraySize := objectMemory fetchWordLengthOf: argumentArray.
- cntxSize := objectMemory fetchWordLengthOf: activeContext.
- self success: (self stackPointerIndex + arraySize) < cntxSize].
- self successful ifFalse: [^nil].
-
- performSelector := messageSelector.
- performMethod := newMethod.
- performArgCount := argumentCount.
- "pop the arg array and the selector, then push the args out of the array, as if they were on the stack"
- self popStack.
- messageSelector := self popStack.
-
- "Copy the arguments to the stack, and execute"
- index := 1.
- [index <= arraySize]
- whileTrue:
- [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
- index := index + 1].
- argumentCount := arraySize.
-
- self findNewMethodInClass: lookupClass.
-
- "Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
- (objectMemory isOopCompiledMethod: newMethod)
- ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
-
- self successful
- ifTrue: [self executeNewMethodFromCache. "Recursive xeq affects primFailCode"
- self initPrimCall]
- ifFalse: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
- self pop: argumentCount.
- self push: messageSelector.
- self push: argumentArray.
- messageSelector := performSelector.
- newMethod := performMethod.
- argumentCount := performArgCount]
- !
Item was removed:
- ----- Method: Interpreter>>primitivePerformInSuperclass (in category 'control primitives') -----
- primitivePerformInSuperclass
- | lookupClass rcvr currentClass |
- lookupClass := self stackTop.
- rcvr := self stackValue: 3.
- currentClass := objectMemory fetchClassOf: rcvr.
- [currentClass ~= lookupClass]
- whileTrue:
- [currentClass := self superclassOf: currentClass.
- currentClass = objectMemory getNilObj ifTrue: [^self primitiveFailFor: PrimErrBadArgument]].
-
- argumentCount = 3
- ifTrue: ["normal primitive call with 3 arguments expected on the stack"
- self popStack.
- self primitivePerformAt: lookupClass.
- self successful ifFalse:
- [self push: lookupClass]]
- ifFalse: [argumentCount = 4
- ifTrue: ["mirror primitive call with extra argument specifying object to serve as receiver"
- | s1 s2 s3 s4 s5 |
- "save stack contents"
- s1 := self popStack. "lookupClass"
- s2 := self popStack. "args"
- s3 := self popStack. "selector"
- s4 := self popStack. "mirror receiver"
- s5 := self popStack. "actual receiver"
- "slide stack up one, omitting the actual receiver parameter"
- self push: s4. "mirror receiver"
- self push: s3. "selector"
- self push: s2. "args"
- "perform as if mirror receiver had been the actual receiver"
- self primitivePerformAt: lookupClass.
- self successful ifFalse:
- ["restore original stack"
- self pop: 3. "args, selector, mirror receiver"
- self push: s5. "actual receiver"
- self push: s4. "mirror receiver"
- self push: s3. "selector"
- self push: s2. "args"
- self push: s1. "lookup class" ]]
- ifFalse: ["wrong number of arguments"
- ^self primitiveFailFor: PrimErrBadNumArgs]]
- !
Item was removed:
- ----- Method: Interpreter>>primitivePerformWithArgs (in category 'control primitives') -----
- primitivePerformWithArgs
-
- | lookupClass rcvr |
- rcvr := self stackValue: argumentCount.
- lookupClass := objectMemory fetchClassOf: rcvr.
- self primitivePerformAt: lookupClass.
- !
Item was removed:
- ----- Method: Interpreter>>primitivePushFalse (in category 'quick primitives') -----
- primitivePushFalse
- self popStack.
- self push: objectMemory getFalseObj!
Item was removed:
- ----- Method: Interpreter>>primitivePushMinusOne (in category 'quick primitives') -----
- primitivePushMinusOne
- self popStack.
- self push: ConstMinusOne!
Item was removed:
- ----- Method: Interpreter>>primitivePushNil (in category 'quick primitives') -----
- primitivePushNil
- self popStack.
- self push: objectMemory getNilObj!
Item was removed:
- ----- Method: Interpreter>>primitivePushOne (in category 'quick primitives') -----
- primitivePushOne
- self popStack.
- self push: ConstOne!
Item was removed:
- ----- Method: Interpreter>>primitivePushSelf (in category 'quick primitives') -----
- primitivePushSelf
- " no-op, really...
- thisReceiver := self popStack.
- self push: thisReceiver
- "!
Item was removed:
- ----- Method: Interpreter>>primitivePushTrue (in category 'quick primitives') -----
- primitivePushTrue
- self popStack.
- self push: objectMemory getTrueObj!
Item was removed:
- ----- Method: Interpreter>>primitivePushTwo (in category 'quick primitives') -----
- primitivePushTwo
- self popStack.
- self push: ConstTwo!
Item was removed:
- ----- Method: Interpreter>>primitivePushZero (in category 'quick primitives') -----
- primitivePushZero
- self popStack.
- self push: ConstZero!
Item was removed:
- ----- Method: Interpreter>>primitiveResponse (in category 'primitive support') -----
- primitiveResponse
-
- | delta primIdx nArgs |
- DoBalanceChecks ifTrue:["check stack balance"
- nArgs := argumentCount.
- delta := stackPointer - activeContext.
- ].
- primIdx := primitiveIndex.
- self initPrimCall.
- "self dispatchOn: primitiveIndex in: primitiveTable."
- self dispatchFunctionPointerOn: primIdx in: primitiveTable.
- "replace with fetch entry primitiveIndex from table and branch there"
- DoBalanceChecks ifTrue:[
- (self balancedStack: delta afterPrimitive: primIdx withArgs: nArgs)
- ifFalse:[self printUnbalancedStack: primIdx].
- ].
- self checkForInterrupts.
- primitiveIndex := 0. "clear out primIndex so VM knows we're no longer in primitive"
- ^ primFailCode
- !
Item was removed:
- ----- Method: Interpreter>>primitiveResume (in category 'process primitives') -----
- primitiveResume
- "Put this process on the scheduler's lists thus allowing it to proceed next
- time there is a chance for processes of its priority level"
-
- | proc |
- proc := self stackTop. "rcvr"
- "self success: ((self fetchClassOf: proc) = (self splObj: ClassProcess))."
- (self isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)) ifFalse:
- [^self primitiveFail].
- self successful ifTrue: [ self resume: proc ].!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>primitiveSignalAtMilliseconds (in category 'system control primitives') -----
- primitiveSignalAtMilliseconds
- "Cause the time semaphore, if one has been registered, to
- be signalled when the millisecond clock is greater than or
- equal to the given tick value. A tick value of zero turns off
- timer interrupts."
- | tick sema |
- tick := self popInteger.
- sema := self popStack.
- self successful
- ifTrue: [(objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
- ifTrue: [objectMemory
- storePointer: TheTimerSemaphore
- ofObject: objectMemory getSpecialObjectsOop
- withValue: sema.
- nextWakeupTick := tick]
- ifFalse: [objectMemory
- storePointer: TheTimerSemaphore
- ofObject: objectMemory getSpecialObjectsOop
- withValue: objectMemory getNilObj.
- nextWakeupTick := 0]]
- ifFalse: [self unPop: 2]!
Item was removed:
- ----- Method: Interpreter>>primitiveSignalAtUTCMicroseconds (in category 'system control primitives') -----
- primitiveSignalAtUTCMicroseconds
- "Cause the time semaphore, if one has been registered, to be
- signalled when the microsecond clock is greater than or equal to
- the given tick value. A tick value of zero turns off timer interrupts."
-
- "Provided for compatibility with StackInterpreter microsecond implementation.
- This is a required primitive in some newer images, and is implemented here
- with millisecond precision only."
-
- | tick sema usecsObj now usecs |
- <var: #usecs type: #usqLong>
- <var: #now type: #usqLong>
- usecsObj := self popStack.
- sema := self popStack.
- usecs := self positive64BitValueOf: usecsObj.
- now := self ioUTCMicroseconds.
- tick := lastTick + (self cCoerce: usecs - now + 500 / 1000 to: #sqInt). "add 500 for rounding"
- self successful
- ifTrue: [(objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
- ifTrue: [objectMemory
- storePointer: TheTimerSemaphore
- ofObject: objectMemory getSpecialObjectsOop
- withValue: sema.
- nextWakeupTick := tick]
- ifFalse: [objectMemory
- storePointer: TheTimerSemaphore
- ofObject: objectMemory getSpecialObjectsOop
- withValue: objectMemory getNilObj.
- nextWakeupTick := 0]]
- ifFalse: [self unPop: 2]!
Item was removed:
- ----- Method: Interpreter>>primitiveStoreStackp (in category 'object access primitives') -----
- primitiveStoreStackp
- "Atomic store into context stackPointer.
- Also ensures that any newly accessible cells are initialized to nil "
- | ctxt newStackp stackp |
- ctxt := self stackValue: 1.
- newStackp := self stackIntegerValue: 0.
- self success: (objectMemory oop: newStackp isGreaterThanOrEqualTo: 0).
- self success: (objectMemory oop: newStackp isLessThanOrEqualTo: (objectMemory largeContextSize - objectMemory baseHeaderSize // objectMemory bytesPerWord - CtxtTempFrameStart)).
- self successful ifFalse: [^ self primitiveFail].
- stackp := self fetchStackPointerOf: ctxt.
- (objectMemory oop: newStackp isGreaterThan: stackp) ifTrue: ["Nil any newly accessible cells"
- stackp + 1 to: newStackp do: [:i | objectMemory storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: objectMemory getNilObj]].
- self storeStackPointerValue: newStackp inContext: ctxt.
- self pop: 1!
Item was removed:
- ----- Method: Interpreter>>primitiveTerminateTo (in category 'process primitives') -----
- primitiveTerminateTo
- "Primitive. Terminate up the context stack from the receiver up to but not including the argument, if previousContext is on my Context stack. Make previousContext my sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct"
- | thisCntx currentCntx aContext nextCntx nilOop |
- aContext := self popStack.
- thisCntx := self popStack.
-
- "make sure that aContext is in my chain"
- (self context: thisCntx hasSender: aContext) ifTrue:[
- nilOop := objectMemory getNilObj.
- currentCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- [currentCntx = aContext] whileFalse: [
- nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCntx.
- objectMemory storePointer: SenderIndex ofObject: currentCntx withValue: nilOop.
- objectMemory storePointer: InstructionPointerIndex ofObject: currentCntx withValue: nilOop.
- currentCntx := nextCntx]].
-
- objectMemory storePointer: SenderIndex ofObject: thisCntx withValue: aContext.
- ^self push: thisCntx!
Item was removed:
- ----- Method: Interpreter>>primitiveVMParameter (in category 'system control primitives') -----
- primitiveVMParameter
- "Behaviour depends on argument count:
- 0 args: return an Array of VM parameter values;
- 1 arg: return the indicated VM parameter;
- 2 args: set the VM indicated parameter.
- VM parameters are numbered as follows:
- 1 end of old-space (0-based, read-only)
- 2 end of young-space (read-only)
- 3 end of memory (read-only)
- 4 allocationCount (read-only)
- 5 allocations between GCs (read-write)
- 6 survivor count tenuring threshold (read-write)
- 7 full GCs since startup (read-only)
- 8 total milliseconds in full GCs since startup (read-only)
- 9 incremental GCs since startup (read-only)
- 10 total milliseconds in incremental GCs since startup (read-only)
- 11 tenures of surving objects since startup (read-only)
- 12-20 specific to the translating VM
- 21 root table size (read-only)
- 22 root table overflows since startup (read-only)
- 23 bytes of extra memory to reserve for VM buffers, plugins, etc.
- 24 memory threshold above which shrinking object memory (rw)
- 25 memory headroom when growing object memory (rw)
- 26 interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image is not calling getNextEvent often (rw)
- 27 number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking
- 28 number of times sweep loop iterated for current IGC/FGC (read-only)
- 29 number of times make forward loop iterated for current IGC/FGC (read-only)
- 30 number of times compact move loop iterated for current IGC/FGC (read-only)
- 31 number of grow memory requests (read-only)
- 32 number of shrink memory requests (read-only)
- 33 number of root table entries used for current IGC/FGC (read-only)
- 34 number of allocations done before current IGC/FGC (read-only)
- 35 number of survivor objects after current IGC/FGC (read-only)
- 36 millisecond clock when current IGC/FGC completed (read-only)
- 37 number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only)
- 38 milliseconds taken by current IGC (read-only)
- 39 Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only)
- 40 BytesPerWord for this image
-
- Note: Thanks to Ian Piumarta for this primitive."
-
- | mem paramsArraySize result arg index statIGCDeltaTimeObj statGCTimeObj statIncrGCMSecsObj statFullGCMSecsObj resultLargePositiveInteger |
- <var: #resultLargePositiveInteger type: 'sqLong'>
- mem := objectMemory startOfMemory.
- paramsArraySize := 40.
- argumentCount = 0 ifTrue: [
- result := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: paramsArraySize.
- objectMemory pushRemappableOop: result.
- objectMemory pushRemappableOop: (self positive64BitIntegerFor: objectMemory getStatFullGCMSecs).
- objectMemory pushRemappableOop: (self positive64BitIntegerFor: objectMemory getStatIncrGCMSecs).
- objectMemory pushRemappableOop: (self positive64BitIntegerFor: objectMemory getStatGCTime).
- objectMemory pushRemappableOop: (self positive64BitIntegerFor: objectMemory getStatIGCDeltaTime).
- statIGCDeltaTimeObj := objectMemory popRemappableOop.
- statGCTimeObj := objectMemory popRemappableOop.
- statIncrGCMSecsObj := objectMemory popRemappableOop.
- statFullGCMSecsObj := objectMemory popRemappableOop.
- result := objectMemory popRemappableOop.
- 0 to: paramsArraySize - 1 do:
- [:i | objectMemory storePointer: i ofObject: result withValue: ConstZero].
-
- objectMemory storePointer: 0 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getYoungStart - mem).
- objectMemory storePointer: 1 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getFreeBlock - mem).
- objectMemory storePointer: 2 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getEndOfMemory - mem).
- objectMemory storePointer: 3 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory allocationCount).
- objectMemory storePointer: 4 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getAllocationsBetweenGCs).
- objectMemory storePointer: 5 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getTenuringThreshold).
- objectMemory storePointer: 6 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatFullGCs).
- objectMemory storePointer: 7 ofObject: result withValue: statFullGCMSecsObj.
- objectMemory storePointer: 8 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatIncrGCs).
- objectMemory storePointer: 9 ofObject: result withValue: statIncrGCMSecsObj.
- objectMemory storePointer: 10 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatTenures).
- objectMemory storePointer: 20 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getRootTableCount).
- objectMemory storePointer: 21 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatRootTableOverflows).
- objectMemory storePointer: 22 ofObject: result withValue: (self positive64BitIntegerFor: extraVMMemory).
- objectMemory storePointer: 23 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getShrinkThreshold).
- objectMemory storePointer: 24 ofObject: result withValue: (self positive64BitIntegerFor: objectMemory getGrowHeadroom).
- objectMemory storePointer: 25 ofObject: result withValue: (objectMemory integerObjectOf: interruptChecksEveryNms).
- objectMemory storePointer: 26 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatMarkCount).
- objectMemory storePointer: 27 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatSweepCount).
- objectMemory storePointer: 28 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatMkFwdCount).
- objectMemory storePointer: 29 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatCompMoveCount).
- objectMemory storePointer: 30 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatGrowMemory).
- objectMemory storePointer: 31 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatShrinkMemory).
- objectMemory storePointer: 32 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatRootTableCount).
- objectMemory storePointer: 33 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatAllocationCount).
- objectMemory storePointer: 34 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatSurvivorCount).
- objectMemory storePointer: 35 ofObject: result withValue: statGCTimeObj.
- objectMemory storePointer: 36 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatSpecialMarkCount).
- objectMemory storePointer: 37 ofObject: result withValue: statIGCDeltaTimeObj.
- objectMemory storePointer: 38 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory getStatpendingFinalizationSignals).
- objectMemory storePointer: 39 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory bytesPerWord).
- objectMemory pop: 1 thenPush: result.
- ^nil].
-
- arg := self stackTop.
- (objectMemory isIntegerObject: arg) ifFalse: [^self primitiveFail].
- arg := objectMemory integerValueOf: arg.
- resultLargePositiveInteger := -1.
- argumentCount = 1 ifTrue: [ "read VM parameter"
- (arg < 1 or: [arg > paramsArraySize]) ifTrue: [^self primitiveFail].
- arg = 1 ifTrue: [resultLargePositiveInteger := objectMemory getYoungStart - mem].
- arg = 2 ifTrue: [resultLargePositiveInteger := objectMemory getFreeBlock - mem].
- arg = 3 ifTrue: [resultLargePositiveInteger := objectMemory getEndOfMemory - mem].
- arg = 4 ifTrue: [result := objectMemory allocationCount].
- arg = 5 ifTrue: [result := objectMemory getAllocationsBetweenGCs].
- arg = 6 ifTrue: [result := objectMemory getTenuringThreshold].
- arg = 7 ifTrue: [result := objectMemory getStatFullGCs].
- arg = 8 ifTrue: [resultLargePositiveInteger := objectMemory getStatFullGCMSecs].
- arg = 9 ifTrue: [result := objectMemory getStatIncrGCs].
- arg = 10 ifTrue: [resultLargePositiveInteger := objectMemory getStatIncrGCMSecs].
- arg = 11 ifTrue: [result := objectMemory getStatTenures].
- ((arg >= 12) and: [arg <= 20]) ifTrue: [result := 0].
- arg = 21 ifTrue: [result := objectMemory getRootTableCount].
- arg = 22 ifTrue: [result := objectMemory getStatRootTableOverflows].
- arg = 23 ifTrue: [resultLargePositiveInteger := extraVMMemory].
- arg = 24 ifTrue: [resultLargePositiveInteger := objectMemory getShrinkThreshold].
- arg = 25 ifTrue: [resultLargePositiveInteger := objectMemory getGrowHeadroom].
- arg = 26 ifTrue: [result := interruptChecksEveryNms].
- arg = 27 ifTrue: [result := objectMemory getStatMarkCount].
- arg = 28 ifTrue: [result := objectMemory getStatSweepCount].
- arg = 29 ifTrue: [result := objectMemory getStatMkFwdCount].
- arg = 30 ifTrue: [result := objectMemory getStatCompMoveCount].
- arg = 31 ifTrue: [result := objectMemory getStatGrowMemory].
- arg = 32 ifTrue: [result := objectMemory getStatShrinkMemory].
- arg = 33 ifTrue: [result := objectMemory getStatRootTableCount].
- arg = 34 ifTrue: [result := objectMemory getStatAllocationCount].
- arg = 35 ifTrue: [result := objectMemory getStatSurvivorCount].
- arg = 36 ifTrue: [resultLargePositiveInteger := objectMemory getStatGCTime].
- arg = 37 ifTrue: [result := objectMemory getStatSpecialMarkCount].
- arg = 38 ifTrue: [resultLargePositiveInteger := objectMemory getStatIGCDeltaTime].
- arg = 39 ifTrue: [result := objectMemory getStatpendingFinalizationSignals].
- arg = 40 ifTrue: [result := objectMemory bytesPerWord].
- resultLargePositiveInteger = -1
- ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: result)]
- ifFalse: [self pop: 2 thenPush: (self positive64BitIntegerFor: resultLargePositiveInteger)].
- ^nil].
-
- "write a VM parameter"
- argumentCount = 2 ifFalse: [^self primitiveFail].
- index := self stackValue: 1.
- (objectMemory isIntegerObject: index) ifFalse: [^self primitiveFail].
- index := objectMemory integerValueOf: index.
- index <= 0 ifTrue: [^self primitiveFail].
- self primitiveFail.
- index = 5 ifTrue: [
- result := objectMemory getAllocationsBetweenGCs.
- objectMemory setAllocationsBetweenGCs: arg.
- self initPrimCall].
- index = 6 ifTrue: [
- result := objectMemory getTenuringThreshold.
- objectMemory setTenuringThreshold: arg.
- self initPrimCall].
- index = 23 ifTrue: [
- result := extraVMMemory.
- extraVMMemory := arg.
- self initPrimCall].
- index = 24 ifTrue: [
- result := objectMemory getShrinkThreshold.
- arg > 0 ifTrue:[
- objectMemory setShrinkThreshold: arg.
- self initPrimCall]].
- index = 25 ifTrue: [
- result := objectMemory getGrowHeadroom.
- arg > 0 ifTrue:[
- objectMemory setGrowHeadroom: arg.
- self initPrimCall]].
- index = 26 ifTrue: [
- arg > 1 ifTrue:[
- result := interruptChecksEveryNms.
- interruptChecksEveryNms := arg.
- self initPrimCall]].
-
- self successful ifTrue: [
- self pop: 3 thenPush: (objectMemory integerObjectOf: result). "return old value"
- ^ nil].
-
- self primitiveFail. "attempting to write a read-only parameter"
-
-
-
- !
Item was removed:
- ----- Method: Interpreter>>primitiveValue (in category 'control primitives') -----
- primitiveValue
- | blockContext blockArgumentCount initialIP |
- blockContext := self stackValue: argumentCount.
- blockArgumentCount := self argumentCountOfBlock: blockContext.
- self success: (argumentCount = blockArgumentCount
- and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory getNilObj]).
- self successful
- ifTrue: [self transfer: argumentCount
- fromIndex: self stackPointerIndex - argumentCount + 1
- ofObject: activeContext
- toIndex: TempFrameStart
- ofObject: blockContext.
-
- "Assume: The call to transfer:... makes blockContext a root if necessary,
- allowing use to use unchecked stored in the following code."
- self pop: argumentCount + 1.
- initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: blockContext.
- objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP.
- self storeStackPointerValue: argumentCount inContext: blockContext.
- objectMemory storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext.
- self newActiveContext: blockContext]!
Item was removed:
- ----- Method: Interpreter>>primitiveValueUninterruptably (in category 'control primitives') -----
- primitiveValueUninterruptably
- "The only purpose of this primitive is to indicate that the new EH mechanisms are supported."
- <inline: false>
- ^self primitiveValue!
Item was removed:
- ----- Method: Interpreter>>primitiveValueWithArgs (in category 'control primitives') -----
- primitiveValueWithArgs
- | argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |
- argumentArray := self popStack.
- blockContext := self popStack.
- blockArgumentCount := self argumentCountOfBlock: blockContext.
- "If the argArray isnt actually an Array we ahve to unpop the above two"
- (objectMemory isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
-
- self successful ifTrue: [arrayArgumentCount := objectMemory fetchWordLengthOf: argumentArray.
- self success: (arrayArgumentCount = blockArgumentCount
- and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory getNilObj])].
- self successful
- ifTrue: [self
- transfer: arrayArgumentCount
- fromIndex: 0
- ofObject: argumentArray
- toIndex: TempFrameStart
- ofObject: blockContext.
- "Assume: The call to transfer:... makes blockContext a root if necessary,
- allowing use to use unchecked stored in the following code. "
- initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: blockContext.
- objectMemory
- storePointerUnchecked: InstructionPointerIndex
- ofObject: blockContext
- withValue: initialIP.
- self storeStackPointerValue: arrayArgumentCount inContext: blockContext.
- objectMemory
- storePointerUnchecked: CallerIndex
- ofObject: blockContext
- withValue: activeContext.
- self newActiveContext: blockContext]
- ifFalse: [self unPop: 2]!
Item was removed:
- ----- Method: Interpreter>>print: (in category 'debug printing') -----
- print: s
- "For testing in Smalltalk, this method should be overridden in a subclass."
-
- <var: #s type: 'char *'>
- self cCode: 'printf("%s", s)'.!
Item was removed:
- ----- Method: Interpreter>>printAllStacks (in category 'debug printing') -----
- printAllStacks
- "Print all the stacks of all running processes, including those that are currently suspended."
- | oop proc ctx |
- <export: true> "exported to permit access from plugins"
- proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
- self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5.
- self cr.
- self printCallStackOf: activeContext. "first the active context"
- oop := objectMemory firstObject.
- [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory] whileTrue:[
- (objectMemory fetchClassOf: oop) == objectMemory classSemaphore ifTrue:[
- self cr.
- proc := objectMemory fetchPointer: FirstLinkIndex ofObject: oop.
- [proc == objectMemory nilObject] whileFalse:[
- self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5.
- self cr.
- ctx := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
- ctx == objectMemory nilObject ifFalse:[self printCallStackOf: ctx].
- proc := objectMemory fetchPointer: NextLinkIndex ofObject: proc].
- ].
- oop := objectMemory objectAfter: oop.
- ].!
Item was removed:
- ----- Method: Interpreter>>printCallStack (in category 'debug printing') -----
- printCallStack
- ^self printCallStackOf: activeContext!
Item was removed:
- ----- Method: Interpreter>>printCallStackOf: (in category 'debug printing') -----
- printCallStackOf: aContext
-
- | ctxt home methClass methodSel message |
- <inline: false>
- ctxt := aContext.
- [ctxt = objectMemory getNilObj] whileFalse: [
- (objectMemory fetchClassOf: ctxt) = (objectMemory splObj: ClassBlockContext)
- ifTrue: [ home := objectMemory fetchPointer: HomeIndex ofObject: ctxt ]
- ifFalse: [ home := ctxt ].
- methClass :=
- self findClassOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
- forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
- methodSel :=
- self findSelectorOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
- forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
- self printNum: ctxt.
- self print: ' '.
- ctxt = home ifFalse: [ self print: '[] in ' ].
- self printNameOfClass: methClass count: 5.
- self print: '>'.
- methodSel = objectMemory getNilObj
- ifTrue: [self print: '?']
- ifFalse: [self printStringOf: methodSel].
- methodSel = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue: [
- "print arg message selector"
- message := objectMemory fetchPointer: 0 + TempFrameStart ofObject: home.
- methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: message.
- self print: ' '.
- self printStringOf: methodSel.
- ].
- self cr.
-
- ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt).
- ].!
Item was removed:
- ----- Method: Interpreter>>printChar: (in category 'debug printing') -----
- printChar: aByte
- "For testing in Smalltalk, this method should be overridden in a subclass."
-
- self putchar: aByte.!
Item was removed:
- ----- Method: Interpreter>>printNameOfClass:count: (in category 'debug printing') -----
- printNameOfClass: classOop count: cnt
- "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
-
- cnt <= 0 ifTrue: [ ^ self print: 'bad class' ].
- (objectMemory sizeBitsOf: classOop) = (7 * objectMemory bytesPerWord) "(Metaclass instSize+1 * 4)"
- ifTrue: [self printNameOfClass: (objectMemory fetchPointer: 5 "thisClass" ofObject: classOop)
- count: cnt - 1.
- self print: ' class']
- ifFalse: [self printStringOf: (objectMemory fetchPointer: 6 "name" ofObject: classOop)]!
Item was removed:
- ----- Method: Interpreter>>printNum: (in category 'debug printing') -----
- printNum: n
- "For testing in Smalltalk, this method should be overridden in a subclass."
-
- self cCode: 'printf("%ld", (long) n)'.!
Item was removed:
- ----- Method: Interpreter>>printStringOf: (in category 'debug printing') -----
- printStringOf: oop
-
- | fmt cnt i |
- (objectMemory isIntegerObject: oop) ifTrue:[^nil].
- fmt := objectMemory formatOf: oop.
- fmt < 8 ifTrue: [ ^nil ].
-
- cnt := 100 min: (objectMemory lengthOf: oop).
- i := 0.
- [i < cnt] whileTrue: [
- self printChar: (objectMemory fetchByte: i ofObject: oop).
- i := i + 1.
- ].!
Item was removed:
- ----- Method: Interpreter>>printUnbalancedStack: (in category 'debug printing') -----
- printUnbalancedStack: primIdx
- <inline: false>
- self print: 'Stack unbalanced after '.
- self successful
- ifTrue:[self print:'successful primitive ']
- ifFalse:[self print: 'failed primitive '].
- self printNum: primIdx.
- self cr.
- !
Item was removed:
- ----- Method: Interpreter>>printUnbalancedStackFromNamedPrimitive (in category 'debug printing') -----
- printUnbalancedStackFromNamedPrimitive
- | lit |
- <inline: false>
- self print: 'Stack unbalanced after '.
- self successful
- ifTrue:[self print:'successful ']
- ifFalse:[self print: 'failed '].
- lit := self literal: 0 ofMethod: newMethod.
- self printStringOf: (objectMemory fetchPointer: 1 ofObject: lit).
- self print:' in '.
- self printStringOf: (objectMemory fetchPointer: 0 ofObject: lit).
- self cr.
- !
Item was removed:
- ----- Method: Interpreter>>push: (in category 'contexts') -----
- push: object
-
- | sp |
- objectMemory longAt: (sp := stackPointer + objectMemory bytesPerWord) put: object.
- stackPointer := sp.!
Item was removed:
- ----- Method: Interpreter>>pushActiveContextBytecode (in category 'stack bytecodes') -----
- pushActiveContextBytecode
- "Puts reclaimability of this context in question."
-
- self fetchNextBytecode.
- reclaimableContextCount := 0.
- self internalPush: activeContext.
- !
Item was removed:
- ----- Method: Interpreter>>pushBool: (in category 'contexts') -----
- pushBool: trueOrFalse
-
- trueOrFalse
- ifTrue: [ self push: objectMemory getTrueObj ]
- ifFalse: [ self push: objectMemory getFalseObj ].!
Item was removed:
- ----- Method: Interpreter>>pushClosureCopyCopiedValuesBytecode (in category 'stack bytecodes') -----
- pushClosureCopyCopiedValuesBytecode
- "The compiler has pushed the values to be copied, if any. Find numArgs and numCopied in the byte following.
- Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure.
- Set numArgs as specified, and set startpc to the pc following the block size and jump over that code."
- | newClosure numArgsNumCopied numArgs numCopied blockSize |
- objectMemory bytesPerWord == 4
- ifTrue: [imageFormatVersionNumber := 6504]
- ifFalse: [imageFormatVersionNumber := 68002].
- numArgsNumCopied := self fetchByte.
- numArgs := numArgsNumCopied bitAnd: 16rF.
- numCopied := numArgsNumCopied bitShift: -4.
- "Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
- blockSize := self fetchByte << 8.
- blockSize := blockSize + self fetchByte.
- self externalizeIPandSP. "This is a pain."
- newClosure := self
- closureNumArgs: numArgs
- instructionPointer: ((objectMemory oopForPointer: localIP) + 2 - (method + objectMemory baseHeaderSize))
- numCopiedValues: numCopied.
- self internalizeIPandSP.
- "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
- objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext.
- reclaimableContextCount := 0. "The closure refers to thisContext so it can't be reclaimed."
- numCopied > 0 ifTrue:
- [0 to: numCopied - 1 do:
- [:i|
- "Assume: have just allocated a new BlockClosure; it must be young.
- Thus, can use unchecked stores."
- objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
- ofObject: newClosure
- withValue: (self internalStackValue: numCopied - i - 1)].
- self internalPop: numCopied].
- localIP := localIP + blockSize.
- self fetchNextBytecode.
- self internalPush: newClosure!
Item was removed:
- ----- Method: Interpreter>>pushConstantFalseBytecode (in category 'stack bytecodes') -----
- pushConstantFalseBytecode
-
- self fetchNextBytecode.
- self internalPush: objectMemory getFalseObj.
- !
Item was removed:
- ----- Method: Interpreter>>pushConstantMinusOneBytecode (in category 'stack bytecodes') -----
- pushConstantMinusOneBytecode
-
- self fetchNextBytecode.
- self internalPush: ConstMinusOne.
- !
Item was removed:
- ----- Method: Interpreter>>pushConstantNilBytecode (in category 'stack bytecodes') -----
- pushConstantNilBytecode
-
- self fetchNextBytecode.
- self internalPush: objectMemory getNilObj.
- !
Item was removed:
- ----- Method: Interpreter>>pushConstantOneBytecode (in category 'stack bytecodes') -----
- pushConstantOneBytecode
-
- self fetchNextBytecode.
- self internalPush: ConstOne.
- !
Item was removed:
- ----- Method: Interpreter>>pushConstantTrueBytecode (in category 'stack bytecodes') -----
- pushConstantTrueBytecode
-
- self fetchNextBytecode.
- self internalPush: objectMemory getTrueObj.
- !
Item was removed:
- ----- Method: Interpreter>>pushConstantTwoBytecode (in category 'stack bytecodes') -----
- pushConstantTwoBytecode
-
- self fetchNextBytecode.
- self internalPush: ConstTwo.
- !
Item was removed:
- ----- Method: Interpreter>>pushConstantZeroBytecode (in category 'stack bytecodes') -----
- pushConstantZeroBytecode
-
- self fetchNextBytecode.
- self internalPush: ConstZero.
- !
Item was removed:
- ----- Method: Interpreter>>pushFloat: (in category 'stack bytecodes') -----
- pushFloat: f
-
- <var: #f type: 'double '>
- self push: (self floatObjectOf: f).!
Item was removed:
- ----- Method: Interpreter>>pushInteger: (in category 'contexts') -----
- pushInteger: integerValue
- self push: (objectMemory integerObjectOf: integerValue).!
Item was removed:
- ----- Method: Interpreter>>pushLiteralConstant: (in category 'stack bytecodes') -----
- pushLiteralConstant: literalIndex
-
- self internalPush: (self literal: literalIndex).!
Item was removed:
- ----- Method: Interpreter>>pushLiteralConstantBytecode (in category 'stack bytecodes') -----
- pushLiteralConstantBytecode
-
- self flag: #'requires currentBytecode to be expanded to a constant'.
- self fetchNextBytecode.
- "this bytecode will be expanded so that refs to currentBytecode below will be constant"
- self pushLiteralConstant: (currentBytecode bitAnd: 16r1F).
- !
Item was removed:
- ----- Method: Interpreter>>pushLiteralVariable: (in category 'stack bytecodes') -----
- pushLiteralVariable: literalIndex
-
- self internalPush:
- (objectMemory fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).!
Item was removed:
- ----- Method: Interpreter>>pushLiteralVariableBytecode (in category 'stack bytecodes') -----
- pushLiteralVariableBytecode
-
- self flag: #'requires currentBytecode to be expanded to a constant'.
- self fetchNextBytecode.
- "this bytecode will be expanded so that refs to currentBytecode below will be constant"
- self pushLiteralVariable: (currentBytecode bitAnd: 16r1F).
- !
Item was removed:
- ----- Method: Interpreter>>pushNewArrayBytecode (in category 'stack bytecodes') -----
- pushNewArrayBytecode
- | size popValues array |
- size := self fetchByte.
- popValues := size > 127.
- size := size bitAnd: 127.
- self fetchNextBytecode.
- self externalizeIPandSP.
- array := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: size.
- self internalizeIPandSP.
- popValues ifTrue:
- [0 to: size - 1 do:
- [:i|
- "Assume: have just allocated a new Array; it must be young. Thus, can use unchecked stores."
- objectMemory storePointerUnchecked: i ofObject: array withValue: (self internalStackValue: size - i - 1)].
- self internalPop: size].
- self internalPush: array!
Item was removed:
- ----- Method: Interpreter>>pushReceiverBytecode (in category 'stack bytecodes') -----
- pushReceiverBytecode
-
- self fetchNextBytecode.
- self internalPush: receiver.
- !
Item was removed:
- ----- Method: Interpreter>>pushReceiverVariable: (in category 'stack bytecodes') -----
- pushReceiverVariable: fieldIndex
-
- self internalPush:
- (objectMemory fetchPointer: fieldIndex ofObject: receiver).!
Item was removed:
- ----- Method: Interpreter>>pushReceiverVariableBytecode (in category 'stack bytecodes') -----
- pushReceiverVariableBytecode
-
- self flag: #'requires currentBytecode to be expanded to a constant'.
- self fetchNextBytecode.
- "this bytecode will be expanded so that refs to currentBytecode below will be constant"
- self pushReceiverVariable: (currentBytecode bitAnd: 16rF).
- !
Item was removed:
- ----- Method: Interpreter>>pushRemoteTemp:inVectorAt: (in category 'stack bytecodes') -----
- pushRemoteTemp: index inVectorAt: tempVectorIndex
- | tempVector |
- tempVector := self temporary: tempVectorIndex.
- self internalPush: (objectMemory fetchPointer: index ofObject: tempVector)!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>pushTemporaryVariable: (in category 'stack bytecodes') -----
- pushTemporaryVariable: temporaryIndex
-
- self internalPush: (self temporary: temporaryIndex).!
Item was removed:
- ----- Method: Interpreter>>pushTemporaryVariableBytecode (in category 'stack bytecodes') -----
- pushTemporaryVariableBytecode
-
- self flag: #'requires currentBytecode to be expanded to a constant'.
- self fetchNextBytecode.
- "this bytecode will be expanded so that refs to currentBytecode below will be constant"
- self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).
- !
Item was removed:
- ----- Method: Interpreter>>putLong:toFile: (in category 'image save/restore') -----
- putLong: aWord toFile: aFile
- "Append aWord to aFile in this platforms 'natural' byte order. (Bytes will be swapped, if
- necessary, when the image is read on a different platform.) Set primFailCode if the
- write fails."
-
- | objectsWritten |
- <var: #aFile type: 'sqImageFile '>
-
- objectsWritten := self cCode: 'sqImageFileWrite(&aWord, sizeof(aWord), 1, aFile)'.
- self success: objectsWritten = 1.
- !
Item was removed:
- ----- Method: Interpreter>>putToSleep: (in category 'process primitive support') -----
- putToSleep: aProcess
- "Save the given process on the scheduler process list for its priority."
-
- | priority processLists processList |
- priority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
- processLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
- processList := objectMemory fetchPointer: priority - 1 ofObject: processLists.
- self addLastLink: aProcess toList: processList.!
Item was removed:
- ----- Method: Interpreter>>putToSleep:yieldingIf: (in category 'process primitive support') -----
- putToSleep: aProcess yieldingIf: yieldImplicitly
- "Save the given process on the scheduler process list for its priority,
- adding to the back if yieldImplicitly or to the front if not yieldImplicitly."
-
- | priority processLists processList |
- priority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
- processLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
- processList := objectMemory fetchPointer: priority - 1 ofObject: processLists.
- yieldImplicitly
- ifTrue: [self addLastLink: aProcess toList: processList]
- ifFalse: [self addFirstLink: aProcess toList: processList]!
Item was removed:
- ----- Method: Interpreter>>quickCheckForInterrupts (in category 'process primitive support') -----
- quickCheckForInterrupts
- "Quick check for possible user or timer interrupts. Decrement a counter and only do a real check when counter reaches zero or when a low space or user interrupt is pending."
- "Note: Clients that trigger interrupts should set use forceInterruptCheck to set interruptCheckCounter to zero and get immediate results."
- "Note: Requires that instructionPointer and stackPointer be external."
-
- ((interruptCheckCounter := interruptCheckCounter - 1) <= 0)
- ifTrue: [self checkForInterrupts].
- !
Item was removed:
- ----- Method: Interpreter>>quickFetchInteger:ofObject: (in category 'utilities') -----
- quickFetchInteger: fieldIndex ofObject: objectPointer
- "Return the integer value of the field without verifying that it is an integer value!! For use in time-critical places where the integer-ness of the field can be guaranteed."
-
- ^ objectMemory integerValueOf: (objectMemory fetchPointer: fieldIndex ofObject: objectPointer).!
Item was removed:
- ----- Method: Interpreter>>readImageFormatFromFile:StartingAt: (in category 'image save/restore') -----
- readImageFormatFromFile: f StartingAt: imageOffset
- "Read an image header from the given file stream, and answer the image format
- version number for the saved image. Exported to allow platform support code to
- query image files for image format number."
-
- <export: true>
- <var: #f type: 'sqImageFile '>
- <var: #imageOffset type: 'squeakFileOffsetType '>
-
- self checkImageVersionFrom: f startingAt: imageOffset.
- ^ imageFormatInitialVersion
- !
Item was removed:
- ----- Method: Interpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
- "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
- "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
- "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
-
- | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
- <var: #f type: 'sqImageFile '>
- <var: #desiredHeapSize type: 'usqInt'>
- <var: #headerStart type: 'squeakFileOffsetType '>
- <var: #dataSize type: 'size_t '>
- <var: #imageOffset type: 'squeakFileOffsetType '>
-
- swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
- headerStart := (self sqImageFilePosition: f) - objectMemory bytesPerWord. "record header start position"
-
- headerSize := self getLongFromFile: f swap: swapBytes.
- dataSize := self getLongFromFile: f swap: swapBytes.
- oldBaseAddr := self getLongFromFile: f swap: swapBytes.
- objectMemory setSpecialObjectsOop: (self getLongFromFile: f swap: swapBytes).
- objectMemory setLastHash: (self getLongFromFile: f swap: swapBytes).
- savedWindowSize := self getLongFromFile: f swap: swapBytes.
- fullScreenFlag := self oldFormatFullScreenFlag: (self getLongFromFile: f swap: swapBytes).
- extraVMMemory := self getLongFromFile: f swap: swapBytes.
-
- objectMemory getLastHash = 0 ifTrue: [
- "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
- objectMemory setLastHash: 999].
-
- "decrease Squeak object heap to leave extra memory for the VM"
- heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
-
- "compare memory requirements with availability".
- minimumMemory := dataSize + 100000. "need at least 100K of breathing room"
- heapSize < minimumMemory ifTrue: [
- self insufficientMemorySpecifiedError].
-
- "allocate a contiguous block of memory for the Squeak heap"
- (objectMemory allocateMemory: heapSize
- minimum: minimumMemory
- imageFile: f
- headerSize: headerSize) = nil ifTrue: [self insufficientMemoryAvailableError].
-
- memStart := objectMemory startOfMemory.
- objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
- objectMemory setEndOfMemory: memStart + dataSize.
-
- "position file after the header"
- self sqImageFile: f Seek: headerStart + headerSize.
-
- "read in the image in bulk, then swap the bytes if necessary"
- bytesRead := self
- sqImage: (objectMemory pointerForOop: objectMemory getMemory)
- read: f
- size: (self cCode: 'sizeof(unsigned char)')
- length: dataSize.
- bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
-
- objectMemory headerTypeBytesAt: 0 put: objectMemory bytesPerWord * 2. "3-word header (type 0)"
- objectMemory headerTypeBytesAt: 1 put: objectMemory bytesPerWord. "2-word header (type 1)"
- objectMemory headerTypeBytesAt: 2 put: 0. "free chunk (type 2)"
- objectMemory headerTypeBytesAt: 3 put: 0. "1-word header (type 3)"
-
- swapBytes ifTrue: [self reverseBytesInImage].
-
- "compute difference between old and new memory base addresses"
- bytesToShift := memStart - oldBaseAddr.
- self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
- self isBigEnder. "work out the machine endianness and cache the answer"
-
- (self initialImageFormatVersion bitAnd: 1) = 1
- ifTrue: ["Low order bit set, indicating that the image was saved from
- a StackInterpreter (Cog) VM. Storage of all Float objects must be
- returned to older object memory format."
- self normalizeFloatOrderingInImage].
-
- ^ dataSize
- !
Item was removed:
- ----- Method: Interpreter>>readableFormat: (in category 'image save/restore') -----
- readableFormat: imageVersion
- "Anwer true if images of the given format are readable by this interpreter. Allows
- a virtual machine to accept selected older image formats. In our case we can
- select a newer (closure) image format as well as the existing format. Images with
- platform-ordered floats (StackInterpreter and Cog format) are readable but will be
- converted to traditional word ordering."
-
- objectMemory bytesPerWord = 4
- ifTrue: [^ (imageVersion = 6502 "Original 32-bit Squeak image format"
- or: [imageVersion = 6504]) "32-bit with closures"
- or: [imageVersion = 6505]] "32-bit with closures and platform-ordered floats"
- ifFalse: [^ (imageVersion = 68000 "Original 64-bit Squeak image format"
- or: [imageVersion = 68002]) "64-bit with closures"
- or: [imageVersion = 68003]] "64-bit with closures and platform-ordered floats"
- !
Item was removed:
- ----- Method: Interpreter>>reestablishContextPriorToCallback: (in category 'contexts') -----
- reestablishContextPriorToCallback: callbackContext
- "callbackContext is an activation of invokeCallback:stack:registers:jmpbuf:. Its sender
- is the interpreter's state prior to the callback. Reestablish that state."
- | calloutContext |
- <export: true>
- (objectMemory fetchClassOf: callbackContext) ~~ (objectMemory splObj: ClassMethodContext) ifTrue:
- [^false].
- calloutContext := objectMemory fetchPointer: SenderIndex ofObject: callbackContext.
- self newActiveContext: calloutContext.
- ^true!
Item was removed:
- ----- Method: Interpreter>>removeFirstLinkOfList: (in category 'process primitive support') -----
- removeFirstLinkOfList: aList
- "Remove the first process from the given linked list."
- | first last next |
- first := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
- last := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
- first = last
- ifTrue: [objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: objectMemory getNilObj.
- objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory getNilObj]
- ifFalse: [next := objectMemory fetchPointer: NextLinkIndex ofObject: first.
- objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: next].
- objectMemory storePointer: NextLinkIndex ofObject: first withValue: objectMemory getNilObj.
- ^ first!
Item was removed:
- ----- Method: Interpreter>>removeProcess:fromList: (in category 'process primitive support') -----
- removeProcess: aProcess fromList: aList
- "Remove a given process from a linked list. May fail if aProcess is not on the list."
- | firstLink lastLink nextLink tempLink |
- firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
- lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
- aProcess == firstLink ifTrue:[
- nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess .
- objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: nextLink.
- aProcess == lastLink ifTrue:[
- objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory nilObject.
- ].
- ] ifFalse:[
- tempLink := firstLink.
- [tempLink == objectMemory nilObject ifTrue:[^self success: false]. "fail"
- nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
- nextLink == aProcess] whileFalse:[
- tempLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
- ].
- nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess.
- objectMemory storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink.
- aProcess == lastLink ifTrue:[
- objectMemory storePointer: LastLinkIndex ofObject: aList withValue: tempLink.
- ].
- ].
- objectMemory storePointer: NextLinkIndex ofObject: aProcess withValue: objectMemory nilObject.
- !
Item was removed:
- ----- Method: Interpreter>>resume: (in category 'process primitive support') -----
- resume: aProcess
- | activeProc activePriority newPriority |
- activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
- activePriority := self quickFetchInteger: PriorityIndex ofObject: activeProc.
- newPriority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
- newPriority > activePriority
- ifTrue: [self putToSleep: activeProc.
- self transferTo: aProcess]
- ifFalse: [self putToSleep: aProcess]!
Item was removed:
- ----- Method: Interpreter>>returnFalse (in category 'return bytecodes') -----
- returnFalse
- localReturnContext := self sender.
- localReturnValue := objectMemory getFalseObj.
- self commonReturn.
- !
Item was removed:
- ----- Method: Interpreter>>returnNil (in category 'return bytecodes') -----
- returnNil
- localReturnContext := self sender.
- localReturnValue := objectMemory getNilObj.
- self commonReturn.!
Item was removed:
- ----- Method: Interpreter>>returnReceiver (in category 'return bytecodes') -----
- returnReceiver
- localReturnContext := self sender.
- localReturnValue := receiver.
- self commonReturn.!
Item was removed:
- ----- Method: Interpreter>>returnTopFromBlock (in category 'return bytecodes') -----
- returnTopFromBlock
- "Return to the caller of the method containing the block."
- localReturnContext := self caller. "Note: caller, not sender!!"
- localReturnValue := self internalStackTop.
- self commonReturn.!
Item was removed:
- ----- Method: Interpreter>>returnTopFromMethod (in category 'return bytecodes') -----
- returnTopFromMethod
- localReturnContext := self sender.
- localReturnValue := self internalStackTop.
- self commonReturn.!
Item was removed:
- ----- Method: Interpreter>>returnTrue (in category 'return bytecodes') -----
- returnTrue
- localReturnContext := self sender.
- localReturnValue := objectMemory getTrueObj.
- self commonReturn.!
Item was removed:
- ----- Method: Interpreter>>reverseBytesInImage (in category 'image save/restore') -----
- reverseBytesInImage
- "Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."
-
- "First, byte-swap every word in the image. This fixes objects headers."
- objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory getEndOfMemory.
-
- "Second, return the bytes of bytes-type objects to their orginal order."
- self byteSwapByteObjects.!
Item was removed:
- ----- Method: Interpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
- reverseDisplayFrom: startIndex to: endIndex
- "Reverse the given range of Display words (at different bit
- depths, this will reverse different numbers of pixels). Used to
- give feedback during VM activities such as garbage
- collection when debugging. It is assumed that the given
- word range falls entirely within the first line of the Display."
- | displayObj dispBitsPtr w reversed |
- displayObj := objectMemory splObj: TheDisplay.
- ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
- w := self fetchInteger: 1 ofObject: displayObj.
- dispBitsPtr := objectMemory fetchPointer: 0 ofObject: displayObj.
- (objectMemory isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
- dispBitsPtr := dispBitsPtr + objectMemory baseHeaderSize.
- dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
- do: [:ptr |
- reversed := (objectMemory long32At: ptr) bitXor: 4294967295.
- objectMemory longAt: ptr put: reversed].
- self initPrimCall.
- self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
- self ioForceDisplayUpdate!
Item was removed:
- ----- Method: Interpreter>>rewriteMethodCacheSel:class:primIndex: (in category 'method lookup cache') -----
- rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex
-
- "Rewrite the cache entry with the given primitive index and matching function pointer"
- | primPtr |
- <var: #primPtr declareC: 'void (*primPtr)(void)'>
- <inline: false>
- localPrimIndex = 0
- ifTrue: [primPtr := 0]
- ifFalse: [primPtr := primitiveTable at: localPrimIndex].
- self
- rewriteMethodCacheSel: selector class: class
- primIndex: localPrimIndex primFunction: primPtr!
Item was removed:
- ----- Method: Interpreter>>rewriteMethodCacheSel:class:primIndex:primFunction: (in category 'method lookup cache') -----
- rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex primFunction: localPrimAddress
- "Rewrite an existing entry in the method cache with a new primitive
- index & function address. Used by primExternalCall to make direct jumps to found external prims"
- | probe hash |
- <inline: false>
- <var: #localPrimAddress declareC: 'void (*localPrimAddress)(void)'>
- hash := selector bitXor: class.
- 0 to: CacheProbeMax - 1 do: [:p |
- probe := hash >> p bitAnd: MethodCacheMask.
- ((methodCache at: probe + MethodCacheSelector) = selector
- and: [(methodCache at: probe + MethodCacheClass) = class])
- ifTrue: [methodCache at: probe + MethodCachePrim put: localPrimIndex.
- methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: localPrimAddress to: 'long').
- ^ nil]]!
Item was removed:
- ----- Method: Interpreter>>roomToPushNArgs: (in category 'primitive support') -----
- roomToPushNArgs: n
- "Answer if there is room to push n arguments onto the current stack.
- There may be room in this stackPage but there may not be room if
- the frame were converted into a context."
- | cntxSize |
- ((self headerOf: method) bitAnd: LargeContextBit) ~= 0
- ifTrue: [cntxSize := objectMemory largeContextSize / objectMemory bytesPerWord - ReceiverIndex]
- ifFalse: [cntxSize := objectMemory smallContextSize / objectMemory bytesPerWord - ReceiverIndex].
- ^self stackPointerIndex + n <= cntxSize!
Item was removed:
- ----- Method: Interpreter>>saveProcessSignalingLowSpace (in category 'process primitive support') -----
- saveProcessSignalingLowSpace
- "The low space semaphore is about to be signaled. Save the currently active
- process in the special objects array so that the low space handler will be able
- to determine the process that first triggered a low space condition. The low
- space handler (in the image) is expected to nil out the special objects array
- slot when it handles the low space condition."
-
- | lastSavedProcess sched currentProc |
- lastSavedProcess := objectMemory splObj: ProcessSignalingLowSpace.
- (lastSavedProcess == objectMemory nilObject) ifTrue:
- [sched := self schedulerPointer.
- currentProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
- objectMemory storePointer: ProcessSignalingLowSpace ofObject: objectMemory getSpecialObjectsOop withValue: currentProc]!
Item was removed:
- ----- Method: Interpreter>>secondExtendedSendBytecode (in category 'send bytecodes') -----
- secondExtendedSendBytecode
- "This replaces the Blue Book double-extended super-send [134],
- which is subsumed by the new double-extended do-anything [132].
- It offers a 2-byte send of 0-3 args for up to 63 literals, for which
- the Blue Book opcode set requires a 3-byte instruction."
-
- | descriptor |
- descriptor := self fetchByte.
- messageSelector := self literal: (descriptor bitAnd: 16r3F).
- argumentCount := descriptor >> 6.
- self normalSend.
- !
Item was removed:
- ----- Method: Interpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'alien support') -----
- sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
- "Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
- to Alien class with the supplied args. The arguments are raw C addresses
- and are converted to integer objects on the way."
- | where |
- <export: true>
- objectMemory pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
- objectMemory pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
- objectMemory pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
- objectMemory pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
- receiver := objectMemory splObj: ClassAlien.
- lkupClass := objectMemory fetchClassOfNonInt: receiver.
- messageSelector := objectMemory splObj: objectMemory invokeCallbackSelector.
- (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
- [(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
- [^false]].
- primitiveIndex ~= 0 ifTrue:
- [^false].
- self storeContextRegisters: activeContext.
- self internalJustActivateNewMethod.
- where := activeContext + objectMemory baseHeaderSize + (ReceiverIndex << objectMemory shiftForWord).
- objectMemory longAt: where + (1 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
- objectMemory longAt: where + (2 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
- objectMemory longAt: where + (3 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
- objectMemory longAt: where + (4 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
- self fetchContextRegisters: activeContext.
- self callInterpreter.
- "not reached"
- ^true!
Item was removed:
- ----- Method: Interpreter>>sendLiteralSelectorBytecode (in category 'send bytecodes') -----
- sendLiteralSelectorBytecode
- "Can use any of the first 16 literals for the selector and pass up to 2 arguments."
-
- messageSelector := self literal: (currentBytecode bitAnd: 16rF).
- argumentCount := ((currentBytecode >> 4) bitAnd: 3) - 1.
- self normalSend!
Item was removed:
- ----- Method: Interpreter>>sender (in category 'contexts') -----
- sender
-
- | context closureOrNil |
- context := localHomeContext.
- [(closureOrNil := objectMemory fetchPointer: ClosureIndex ofObject: context) ~~ objectMemory getNilObj] whileTrue:
- [context := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closureOrNil].
- ^objectMemory fetchPointer: SenderIndex ofObject: context!
Item was removed:
- ----- Method: Interpreter>>setCompilerInitialized: (in category 'compiler support') -----
- setCompilerInitialized: newFlag
- | oldFlag |
- oldFlag := compilerInitialized.
- compilerInitialized := newFlag.
- ^oldFlag!
Item was removed:
- ----- Method: Interpreter>>setFullScreenFlag: (in category 'plugin primitive support') -----
- setFullScreenFlag: value
- fullScreenFlag := value!
Item was removed:
- ----- Method: Interpreter>>setInterruptCheckCounter: (in category 'plugin primitive support') -----
- setInterruptCheckCounter: value
- interruptCheckCounter := value!
Item was removed:
- ----- Method: Interpreter>>setInterruptKeycode: (in category 'plugin primitive support') -----
- setInterruptKeycode: value
- interruptKeycode := value!
Item was removed:
- ----- Method: Interpreter>>setInterruptPending: (in category 'plugin primitive support') -----
- setInterruptPending: value
- interruptPending := value!
Item was removed:
- ----- Method: Interpreter>>setMicroSeconds:andOffset: (in category 'utilities') -----
- setMicroSeconds: microSeconds andOffset: utcOffset
- "A default substitute for unimplemented ioUtcWithOffset external function."
- <var: #microSeconds type: 'sqLong *'>
- <var: #utcOffset type: 'int *'>
-
- self flag: #toRemove. "after implementing ioUtcWithOffset in support code for all platforms"
-
- ^ -1
-
- "The corresponding platform support function for a GNU unix system is:
- sqInt ioUtcWithOffset(sqLong *microSeconds, int *offset)
- {
- struct timeval timeval;
- if (gettimeofday(&timeval, NULL) == -1) return -1;
- long long seconds = timeval.tv_sec;
- suseconds_t usec = timeval.tv_usec;
- *microSeconds = seconds * 1000000 + usec;
- *offset = localtime(&seconds)->tm_gmtoff;
- return 0;
- }"
- !
Item was removed:
- ----- Method: Interpreter>>setNextWakeupTick: (in category 'plugin primitive support') -----
- setNextWakeupTick: value
- nextWakeupTick := value!
Item was removed:
- ----- Method: Interpreter>>setSavedWindowSize: (in category 'plugin primitive support') -----
- setSavedWindowSize: value
- savedWindowSize := value!
Item was removed:
- ----- Method: Interpreter>>shortConditionalJump (in category 'jump bytecodes') -----
- shortConditionalJump
-
- self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.!
Item was removed:
- ----- Method: Interpreter>>shortUnconditionalJump (in category 'jump bytecodes') -----
- shortUnconditionalJump
-
- self jump: (currentBytecode bitAnd: 7) + 1.!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>signalExternalSemaphores (in category 'process primitive support') -----
- signalExternalSemaphores
- "Signal all requested semaphores"
- | xArray xSize index sema |
- semaphoresUseBufferA := semaphoresUseBufferA not.
- xArray := objectMemory splObj: ExternalObjectsArray.
- xSize := self stSizeOf: xArray.
- semaphoresUseBufferA
- ifTrue: ["use opposite buffer during read"
- 1 to: semaphoresToSignalCountB do: [:i |
- index := semaphoresToSignalB at: i.
- index <= xSize
- ifTrue: [sema := objectMemory fetchPointer: index - 1 ofObject: xArray.
- "Note: semaphore indices are 1-based"
- (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
- ifTrue: [self synchronousSignal: sema]]].
- semaphoresToSignalCountB := 0]
- ifFalse: [1 to: semaphoresToSignalCountA do: [:i |
- index := semaphoresToSignalA at: i.
- index <= xSize
- ifTrue: [sema := objectMemory fetchPointer: index - 1 ofObject: xArray.
- "Note: semaphore indices are 1-based"
- (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
- ifTrue: [self synchronousSignal: sema]]].
- semaphoresToSignalCountA := 0]!
Item was removed:
- ----- Method: Interpreter>>signalFinalization: (in category 'process primitive support') -----
- signalFinalization: weakReferenceOop
- "If it is not there already, record the given semaphore index in the list of semaphores to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."
-
- self forceInterruptCheck.
- pendingFinalizationSignals := pendingFinalizationSignals + 1.!
Item was removed:
- ----- Method: Interpreter>>signalSemaphoreWithIndex: (in category 'process primitive support') -----
- signalSemaphoreWithIndex: index
- "Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Force a real interrupt check as soon as possible."
-
- index <= 0 ifTrue: [^ nil]. "bad index; ignore it"
-
- semaphoresUseBufferA
- ifTrue: [semaphoresToSignalCountA < SemaphoresToSignalSize
- ifTrue: [ semaphoresToSignalCountA := semaphoresToSignalCountA + 1.
- semaphoresToSignalA at: semaphoresToSignalCountA put: index]]
- ifFalse: [semaphoresToSignalCountB < SemaphoresToSignalSize
- ifTrue: [ semaphoresToSignalCountB := semaphoresToSignalCountB + 1.
- semaphoresToSignalB at: semaphoresToSignalCountB put: index]].
- self forceInterruptCheck
- !
Item was removed:
- ----- Method: Interpreter>>signed32BitIntegerFor: (in category 'primitive support') -----
- signed32BitIntegerFor: integerValue
- "Return a full 32 bit integer object for the given integer value"
- | newLargeInteger value largeClass |
- <inline: false>
- <var: #integerValue type: 'int'>
- (objectMemory isIntegerValue: integerValue)
- ifTrue: [^ objectMemory integerObjectOf: integerValue].
- integerValue < 0
- ifTrue:[ largeClass := objectMemory classLargeNegativeInteger.
- value := 0 - integerValue]
- ifFalse:[ largeClass := objectMemory classLargePositiveInteger.
- value := integerValue].
- newLargeInteger := objectMemory instantiateClass: largeClass indexableSize: 4.
- objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((value >> 24) bitAnd: 16rFF).
- objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((value >> 16) bitAnd: 16rFF).
- objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((value >> 8) bitAnd: 16rFF).
- objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (value bitAnd: 16rFF).
- ^ newLargeInteger!
Item was removed:
- ----- Method: Interpreter>>signed64BitIntegerFor: (in category 'primitive support') -----
- 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 := objectMemory classLargeNegativeInteger.
- magnitude := 0 - integerValue]
- ifFalse:[ largeClass := objectMemory classLargePositiveInteger.
- magnitude := integerValue].
-
- magnitude <= 16r7FFFFFFF ifTrue:[^self signed32BitIntegerFor: integerValue].
-
- highWord := self
- cCode: 'magnitude >> 32' "shift is coerced to usqInt otherwise"
- inSmalltalk: [magnitude bitShift: -32].
- 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 := objectMemory instantiateClass: largeClass indexableSize: sz.
- 0 to: sz-1 do: [:i |
- intValue := self
- cCode: '(magnitude >> (i * 8)) & 255'
- inSmalltalk: [(magnitude bitShift: (i * 8) negated) bitAnd: 16rFF].
- objectMemory storeByte: i ofObject: newLargeInteger withValue: intValue].
- ^ newLargeInteger!
Item was removed:
- ----- Method: Interpreter>>singleExtendedSendBytecode (in category 'send bytecodes') -----
- singleExtendedSendBytecode
- "Can use any of the first 32 literals for the selector and pass up to 7 arguments."
-
- | descriptor |
- descriptor := self fetchByte.
- messageSelector := self literal: (descriptor bitAnd: 16r1F).
- argumentCount := descriptor >> 5.
- self normalSend.!
Item was removed:
- ----- Method: Interpreter>>singleExtendedSuperBytecode (in category 'send bytecodes') -----
- singleExtendedSuperBytecode
- "Can use any of the first 32 literals for the selector and pass up to 7 arguments."
-
- | descriptor |
- descriptor := self fetchByte.
- messageSelector := self literal: (descriptor bitAnd: 16r1F).
- argumentCount := descriptor >> 5.
- self superclassSend.
- !
Item was removed:
- ----- Method: Interpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') -----
- sizeOfSTArrayFromCPrimitive: cPtr
- "Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
- "Note: Only called by translated primitive code."
-
- | oop |
- <var: #cPtr type: 'void *'>
- oop := (objectMemory oopForPointer: (self cCoerce: cPtr to: 'char *')) - objectMemory baseHeaderSize.
- (objectMemory isWordsOrBytes: oop) ifFalse: [
- self primitiveFail.
- ^0].
- ^objectMemory lengthOf: oop
- !
Item was removed:
- ----- Method: Interpreter>>snapshot: (in category 'image save/restore') -----
- snapshot: embedded
- "update state of active context"
- | activeProc dataSize rcvr setMacType |
- <var: #setMacType type: 'void *'>
- compilerInitialized
- ifTrue: [self compilerPreSnapshot]
- ifFalse: [self storeContextRegisters: activeContext].
-
- "update state of active process"
- activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
- objectMemory
- storePointer: SuspendedContextIndex
- ofObject: activeProc
- withValue: activeContext.
-
- "compact memory and compute the size of the memory actually in use"
- objectMemory incrementalGC.
-
- "maximimize space for forwarding table"
- objectMemory fullGC.
- self snapshotCleanUp.
-
- dataSize := objectMemory getFreeBlock - objectMemory startOfMemory. "Assume all objects are below the start of the free block"
- self successful
- ifTrue: [rcvr := self popStack.
- "pop rcvr"
- self push: objectMemory getTrueObj.
- self writeImageFile: dataSize.
- embedded
- ifFalse: ["set Mac file type and creator; this is a noop on other platforms"
- setMacType := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
- setMacType = 0
- ifFalse: [self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
- self pop: 1].
-
- "activeContext was unmarked in #snapshotCleanUp, mark it old "
- objectMemory beRootIfOld: activeContext.
- self successful
- ifTrue: [self push: objectMemory getFalseObj]
- ifFalse: [self push: rcvr].
- compilerInitialized
- ifTrue: [self compilerPostSnapshot]!
Item was removed:
- ----- Method: Interpreter>>snapshotCleanUp (in category 'image save/restore') -----
- snapshotCleanUp
- "Clean up right before saving an image, sweeping memory and:
- * nilling out all fields of contexts above the stack pointer.
- * flushing external primitives
- * clearing the root bit of any object in the root table "
- | oop header fmt sz |
- oop := objectMemory firstObject.
- [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory]
- whileTrue: [(objectMemory isFreeObject: oop)
- ifFalse: [header := objectMemory longAt: oop.
- fmt := header >> 8 bitAnd: 15.
- "Clean out context"
- (fmt = 3 and: [self isContextHeader: header])
- ifTrue: [sz := objectMemory sizeBitsOf: oop.
- (objectMemory lastPointerOf: oop) + objectMemory bytesPerWord
- to: sz - objectMemory baseHeaderSize by: objectMemory bytesPerWord
- do: [:i | objectMemory longAt: oop + i put: objectMemory getNilObj]].
- "Clean out external functions"
- fmt >= 12
- ifTrue: ["This is a compiled method"
- (self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
- ifTrue: ["It's primitiveExternalCall"
- self flushExternalPrimitiveOf: oop]]].
- oop := objectMemory objectAfter: oop].
- objectMemory clearRootsTable!
Item was removed:
- ----- Method: Interpreter>>specialSelector: (in category 'message sending') -----
- specialSelector: index
-
- ^ objectMemory fetchPointer: (index * 2) ofObject: (objectMemory splObj: SpecialSelectors)!
Item was removed:
- ----- Method: Interpreter>>sqImage:read:size:length: (in category 'image save/restore') -----
- sqImage: memoryAddress read: fileStream size: elementSize length: length
- "Normally implemented in support code as fread().
- See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation."
-
- <inline: true>
- <returnTypeC: 'size_t'>
- <var: #memoryAddress type: 'char *'>
- <var: #elementSize type: 'size_t'>
- <var: #length type: 'size_t'>
- <var: #fileStream type: 'sqImageFile'>
- ^ self sqImage: memoryAddress File: elementSize ReadEntire: length Image: fileStream
-
- !
Item was removed:
- ----- Method: Interpreter>>sqImage:write:size:length: (in category 'image save/restore') -----
- sqImage: memoryAddress write: fileStream size: elementSize length: length
- "Normally implemented in support code as fwrite()"
-
- <inline: true>
- <returnTypeC: 'size_t'>
- <var: #memoryAddress type: 'char *'>
- <var: #elementSize type: 'size_t'>
- <var: #length type: 'size_t'>
- <var: #fileStream type: 'sqImageFile'>
- ^ self sq: memoryAddress Image: elementSize File: length Write: fileStream "sqImageFileWrite()"
- !
Item was removed:
- ----- Method: Interpreter>>stObject:at: (in category 'array primitive support') -----
- stObject: array at: index
- "Return what ST would return for <obj> at: index."
-
- | hdr fmt totalLength fixedFields stSize |
- <inline: false>
- hdr := objectMemory baseHeader: array.
- fmt := (hdr >> 8) bitAnd: 16rF.
- totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
- fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
- (fmt = 3 and: [self isContextHeader: hdr])
- ifTrue: [stSize := self fetchStackPointerOf: array]
- ifFalse: [stSize := totalLength - fixedFields].
- ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
- and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt]
- ifFalse: [self primitiveFail. ^ 0].!
Item was removed:
- ----- Method: Interpreter>>stObject:at:put: (in category 'array primitive support') -----
- stObject: array at: index put: value
- "Do what ST would return for <obj> at: index put: value."
- | hdr fmt totalLength fixedFields stSize |
- <inline: false>
- hdr := objectMemory baseHeader: array.
- fmt := (hdr >> 8) bitAnd: 16rF.
- totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
- fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
- (fmt = 3 and: [self isContextHeader: hdr])
- ifTrue: [stSize := self fetchStackPointerOf: array]
- ifFalse: [stSize := totalLength - fixedFields].
- ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
- and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
- ifFalse: [self primitiveFail]!
Item was removed:
- ----- Method: Interpreter>>stSizeOf: (in category 'array primitive support') -----
- stSizeOf: oop
- "Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for <obj> size)."
- "Note: Assume oop is not a SmallInteger!!"
-
- | hdr fmt totalLength fixedFields |
- <inline: false>
- hdr := objectMemory baseHeader: oop.
- fmt := (hdr >> 8) bitAnd: 16rF.
- totalLength := objectMemory lengthOf: oop baseHeader: hdr format: fmt.
- fixedFields := objectMemory fixedFieldsOf: oop format: fmt length: totalLength.
- (fmt = 3 and: [self isContextHeader: hdr])
- ifTrue: [^ self fetchStackPointerOf: oop]
- ifFalse: [^ totalLength - fixedFields]!
Item was removed:
- ----- Method: Interpreter>>stackFloatValue: (in category 'contexts') -----
- stackFloatValue: offset
- "Note: May be called by translated primitive code."
- | result floatPointer |
- <returnTypeC: 'double'>
- <var: #result type: 'double '>
- floatPointer := objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord).
- (objectMemory fetchClassOf: floatPointer) = (objectMemory splObj: ClassFloat)
- ifFalse:[self primitiveFail. ^0.0].
- self cCode: '' inSmalltalk: [result := Float new: 2].
- self fetchFloatAt: floatPointer + objectMemory baseHeaderSize into: result.
- ^ result!
Item was removed:
- ----- Method: Interpreter>>stackIntegerValue: (in category 'contexts') -----
- stackIntegerValue: offset
- | integerPointer |
- integerPointer := objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord).
- ^self checkedIntegerValueOf: integerPointer!
Item was removed:
- ----- Method: Interpreter>>stackObjectValue: (in category 'contexts') -----
- stackObjectValue: offset
- "Ensures that the given object is a real object, not a SmallInteger."
-
- | oop |
- oop := objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord).
- (objectMemory isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
- ^ oop
- !
Item was removed:
- ----- Method: Interpreter>>stackPointerIndex (in category 'contexts') -----
- stackPointerIndex
- "Return the 0-based index rel to the current context.
- (This is what stackPointer used to be before conversion to pointer"
- ^ (stackPointer - activeContext - objectMemory baseHeaderSize) >> objectMemory shiftForWord!
Item was removed:
- ----- Method: Interpreter>>stackTop (in category 'contexts') -----
- stackTop
- ^objectMemory longAt: stackPointer!
Item was removed:
- ----- Method: Interpreter>>stackValue: (in category 'contexts') -----
- stackValue: offset
- ^ objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord)!
Item was removed:
- ----- Method: Interpreter>>stackValue:put: (in category 'contexts') -----
- stackValue: offset put: oop
- ^objectMemory longAt: stackPointer - (offset * objectMemory bytesPerWord)
- put: oop!
Item was removed:
- ----- Method: Interpreter>>storeAndPopReceiverVariableBytecode (in category 'stack bytecodes') -----
- storeAndPopReceiverVariableBytecode
- "Note: This code uses
- storePointerUnchecked:ofObject:withValue: and does the
- store check explicitely in order to help the translator
- produce better code."
- | rcvr top |
- self flag: #'requires currentBytecode to be expanded to a constant'.
- self fetchNextBytecode.
- "this bytecode will be expanded so that refs to currentBytecode below will be constant"
- rcvr := receiver.
- top := self internalStackTop.
- (objectMemory oop: rcvr isLessThan: objectMemory getYoungStart)
- ifTrue: [objectMemory possibleRootStoreInto: rcvr value: top].
- objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top.
- self internalPop: 1!
Item was removed:
- ----- Method: Interpreter>>storeAndPopRemoteTempLongBytecode (in category 'stack bytecodes') -----
- storeAndPopRemoteTempLongBytecode
- self storeRemoteTempLongBytecode.
- self internalPop: 1!
Item was removed:
- ----- Method: Interpreter>>storeAndPopTemporaryVariableBytecode (in category 'stack bytecodes') -----
- storeAndPopTemporaryVariableBytecode
-
- self flag: #'requires currentBytecode to be expanded to a constant'.
- self fetchNextBytecode.
- "this bytecode will be expanded so that refs to currentBytecode below will be constant"
- objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
- ofObject: localHomeContext
- withValue: self internalStackTop.
- self internalPop: 1.
- !
Item was removed:
- ----- Method: Interpreter>>storeContextRegisters: (in category 'contexts') -----
- storeContextRegisters: activeCntx
- "Note: internalStoreContextRegisters: should track changes to this method."
-
- "InstructionPointer is a pointer variable equal to
- method oop + ip + objectMemory baseHeaderSize
- -1 for 0-based addressing of fetchByte
- -1 because it gets incremented BEFORE fetching currentByte"
-
- <inline: true>
- objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
- withValue: (objectMemory integerObjectOf: (instructionPointer - method - (objectMemory baseHeaderSize - 2))).
- objectMemory storePointerUnchecked: StackPointerIndex ofObject: activeCntx
- withValue: (objectMemory integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
- !
Item was removed:
- ----- Method: Interpreter>>storeInstructionPointerValue:inContext: (in category 'contexts') -----
- storeInstructionPointerValue: value inContext: contextPointer
- "Assume: value is an integerValue"
-
- objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: contextPointer withValue: (objectMemory integerObjectOf: value).!
Item was changed:
----- Method: Interpreter>>storeInteger:ofObject:withValue: (in category 'utilities') -----
storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue
"Note: May be called by translated primitive code."
(objectMemory isIntegerValue: integerValue)
ifTrue: [objectMemory storePointerUnchecked: fieldIndex ofObject: objectPointer
withValue: (objectMemory integerObjectOf: integerValue)]
+ ifFalse: [self primitiveFail].
+ ^nil!
- ifFalse: [self primitiveFail]!
Item was removed:
- ----- Method: Interpreter>>storeRemoteTemp:inVectorAt: (in category 'stack bytecodes') -----
- storeRemoteTemp: index inVectorAt: tempVectorIndex
- | tempVector |
- tempVector := self temporary: tempVectorIndex.
- objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop.!
Item was removed:
- ----- 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 removed:
- ----- Method: Interpreter>>storeStackPointerValue:inContext: (in category 'contexts') -----
- storeStackPointerValue: value inContext: contextPointer
- "Assume: value is an integerValue"
-
- objectMemory storePointerUnchecked: StackPointerIndex ofObject: contextPointer
- withValue: (objectMemory integerObjectOf: value).!
Item was removed:
- ----- Method: Interpreter>>subscript:with:format: (in category 'array primitive support') -----
- subscript: array with: index format: fmt
- "Note: This method assumes that the index is within bounds!!"
-
- <inline: true>
- fmt <= 4 ifTrue: [ "pointer type objects"
- ^ objectMemory fetchPointer: index - 1 ofObject: array].
- fmt < 8 ifTrue: [ "long-word type objects"
- ^ self positive32BitIntegerFor:
- (objectMemory fetchLong32: index - 1 ofObject: array)
- ] ifFalse: [ "byte-type objects"
- ^ objectMemory integerObjectOf:
- (objectMemory fetchByte: index - 1 ofObject: array)
- ].!
Item was removed:
- ----- Method: Interpreter>>subscript:with:storing:format: (in category 'array primitive support') -----
- subscript: array with: index storing: oopToStore format: fmt
- "Note: This method assumes that the index is within bounds!!"
- | valueToStore |
- <inline: true>
- fmt <= 4
- ifTrue: ["pointer type objects"
- objectMemory storePointer: index - 1 ofObject: array
- withValue: oopToStore]
- ifFalse: [fmt < 8
- ifTrue: ["long-word type objects"
- valueToStore := self positive32BitValueOf: oopToStore.
- self successful
- ifTrue: [objectMemory storeLong32: index - 1 ofObject: array
- withValue: valueToStore]]
- ifFalse: ["byte-type objects"
- (objectMemory isIntegerObject: oopToStore)
- ifFalse: [self primitiveFail].
- valueToStore := objectMemory integerValueOf: oopToStore.
- (valueToStore >= 0
- and: [valueToStore <= 255])
- ifFalse: [self primitiveFail].
- self successful
- ifTrue: [objectMemory
- storeByte: index - 1
- ofObject: array
- withValue: valueToStore]]]!
Item was removed:
- ----- Method: Interpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
- sufficientSpaceToInstantiate: classOop indexableSize: size
- "Return true if there is enough space to allocate an instance of the given class with the given number of indexable fields."
- "Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
- | format |
- <inline: true>
- <var: #size type: 'usqInt'>
- <var: #bytesNeeded type: 'usqInt'>
- format := (objectMemory formatOfClass: classOop) >> 8 bitAnd: 16rF.
-
- "Fail if attempting to call new: on non-indexable class"
- (size > 0 and: [format < 2])
- ifTrue: [^ false].
-
- format < 8
- ifTrue: ["indexable fields are words or pointers"
- (objectMemory isExcessiveAllocationRequest: size shift: objectMemory shiftForWord) ifTrue: [^ false].
- ^ objectMemory sufficientSpaceToAllocate: 2500 + (size * objectMemory bytesPerWord)]
- ifFalse: ["indexable fields are bytes"
- (objectMemory isExcessiveAllocationRequest: size shift: 0) ifTrue: [^ false].
- ^ objectMemory sufficientSpaceToAllocate: 2500 + size]
- !
Item was removed:
- ----- Method: Interpreter>>superclassOf: (in category 'message sending') -----
- superclassOf: classPointer
-
- ^ objectMemory fetchPointer: SuperclassIndex ofObject: classPointer!
Item was removed:
- ----- Method: Interpreter>>superclassSend (in category 'message sending') -----
- superclassSend
- "Send a message to self, starting lookup with the superclass of the class containing the currently executing method."
- "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack,"
- "Note: This method is inlined into the interpreter dispatch loop."
- | rcvr |
- <inline: true>
- self sharedCodeNamed: 'commonSupersend' inCase: 133.
- lkupClass := self superclassOf: (self methodClassOf: method).
- rcvr := self internalStackValue: argumentCount.
- receiverClass := objectMemory fetchClassOf: rcvr.
- self commonSend.!
Item was removed:
- ----- Method: Interpreter>>synchronousSignal: (in category 'process primitive support') -----
- synchronousSignal: aSemaphore
- "Signal the given semaphore from within the interpreter."
- | excessSignals |
- <inline: false>
- (self isEmptyList: aSemaphore)
- ifTrue: ["no process is waiting on this semaphore"
- excessSignals := self fetchInteger: ExcessSignalsIndex ofObject: aSemaphore.
- self storeInteger: ExcessSignalsIndex ofObject: aSemaphore withValue: excessSignals + 1]
- ifFalse: [self resume: (self removeFirstLinkOfList: aSemaphore)]!
Item was removed:
- ----- Method: Interpreter>>tempCountOf: (in category 'compiled methods') -----
- tempCountOf: methodPointer
- ^ ((self headerOf: methodPointer) >> 19) bitAnd: 16r3F!
Item was removed:
- ----- Method: Interpreter>>temporary: (in category 'contexts') -----
- temporary: offset
-
- ^ objectMemory fetchPointer: offset + TempFrameStart ofObject: localHomeContext!
Item was removed:
- ----- Method: Interpreter>>transfer:from:to: (in category 'utilities') -----
- transfer: count from: src to: dst
- | in out lastIn |
- <inline: true>
- self flag: #Dan. "Need to check all senders before converting this for 64 bits"
- in := src - objectMemory bytesPerWord.
- lastIn := in + (count * objectMemory bytesPerWord).
- out := dst - objectMemory bytesPerWord.
- [objectMemory oop: in isLessThan: lastIn]
- whileTrue: [self
- longAt: (out := out + objectMemory bytesPerWord)
- put: (objectMemory longAt: (in := in + objectMemory bytesPerWord))]!
Item was removed:
- ----- Method: Interpreter>>transfer:fromIndex:ofObject:toIndex:ofObject: (in category 'utilities') -----
- transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop
- "Transfer the specified fullword fields, as from calling context to called context"
-
- "Assume: beRootIfOld: will be called on toOop."
- | fromIndex toIndex lastFrom |
- <inline: true>
- self flag: #Dan. "Need to check all senders before converting this for 64 bits"
- fromIndex := fromOop + (firstFrom * objectMemory bytesPerWord).
- toIndex := toOop + (firstTo * objectMemory bytesPerWord).
- lastFrom := fromIndex + (count * objectMemory bytesPerWord).
- [objectMemory oop: fromIndex isLessThan: lastFrom]
- whileTrue: [fromIndex := fromIndex + objectMemory bytesPerWord.
- toIndex := toIndex + objectMemory bytesPerWord.
- objectMemory
- longAt: toIndex
- put: (objectMemory longAt: fromIndex)]!
Item was removed:
- ----- Method: Interpreter>>transferTo: (in category 'process primitive support') -----
- transferTo: aProc
- "Record a process to be awoken on the next interpreter cycle.
- ikp 11/24/1999 06:07 -- added hook for external runtime
- compiler "
- | sched oldProc newProc |
- newProc := aProc.
- sched := self schedulerPointer.
- oldProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
- objectMemory storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
- compilerInitialized
- ifTrue: [self compilerProcessChange: oldProc to: newProc]
- ifFalse: [objectMemory storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
- self newActiveContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: newProc).
- objectMemory storePointer: SuspendedContextIndex ofObject: newProc withValue: objectMemory getNilObj].
- reclaimableContextCount := 0!
Item was removed:
- ----- Method: Interpreter>>unPop: (in category 'contexts') -----
- unPop: nItems
- stackPointer := stackPointer + (nItems * objectMemory bytesPerWord)!
Item was removed:
- ----- Method: Interpreter>>unknownBytecode (in category 'interpreter shell') -----
- unknownBytecode
- "This should never get called; it means that an unimplemented bytecode appears in a CompiledMethod."
-
- self error: 'Unknown bytecode'.!
Item was removed:
- ----- Method: Interpreter>>vmEndianness (in category 'plugin support') -----
- vmEndianness
- "return 0 for little endian, 1 for big endian"
-
- self isBigEnder ifTrue: [^ 1] ifFalse: [^ 0]
- !
Item was removed:
- ----- Method: Interpreter>>wakeHighestPriority (in category 'process primitive support') -----
- wakeHighestPriority
- "Return the highest priority process that is ready to run."
- "Note: It is a fatal VM error if there is no runnable process."
- | schedLists p processList |
- schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
- p := objectMemory fetchWordLengthOf: schedLists.
- p := p - 1.
- "index of last indexable field"
- processList := objectMemory fetchPointer: p ofObject: schedLists.
- [self isEmptyList: processList]
- whileTrue: [p := p - 1.
- p < 0 ifTrue: [self error: 'scheduler could not find a runnable process'].
- processList := objectMemory fetchPointer: p ofObject: schedLists].
- ^ self removeFirstLinkOfList: processList!
Item was removed:
- ----- Method: Interpreter>>writeImageFile: (in category 'image save/restore') -----
- writeImageFile: imageBytes
-
- | fn |
- <var: #fn type: 'void *'>
- self writeImageFileIO: imageBytes.
- "set Mac file type and creator; this is a noop on other platforms"
- fn := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
- fn = 0 ifFalse:[
- self cCode:'((sqInt (*)(char*, char*, char*))fn)(imageName, "STim", "FAST")'.
- ].
- !
Item was removed:
- ----- Method: Interpreter>>writeImageFileIO: (in category 'image save/restore') -----
- writeImageFileIO: imageBytes
-
- | headerStart headerSize f bytesWritten sCWIfn okToWrite |
- <var: #f type: 'sqImageFile'>
- <var: #headerStart type: 'squeakFileOffsetType '>
- <var: #sCWIfn type: 'void *'>
-
- "If the security plugin can be loaded, use it to check for write permission.
- If not, assume it's ok"
- sCWIfn := self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
- sCWIfn ~= 0 ifTrue:[okToWrite := self cCode: '((sqInt (*)(void))sCWIfn)()'.
- okToWrite ifFalse:[^self primitiveFail]].
-
- "local constants"
- headerStart := 0.
- headerSize := 16 * objectMemory bytesPerWord. "header size in bytes; do not change!!"
-
- f := self cCode: 'sqImageFileOpen(imageName, "wb")'.
- f = nil ifTrue: [
- "could not open the image file for writing"
- self success: false.
- ^ nil].
-
- headerStart := self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
- self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
- "position file to start of header"
- self sqImageFile: f Seek: headerStart.
-
- self putLong: (self imageFormatVersion) toFile: f.
- self putLong: headerSize toFile: f.
- self putLong: imageBytes toFile: f.
- self putLong: (objectMemory startOfMemory) toFile: f.
- self putLong: objectMemory getSpecialObjectsOop toFile: f.
- self putLong: objectMemory getLastHash toFile: f.
- self putLong: (self ioScreenSize) toFile: f.
- self putLong: fullScreenFlag toFile: f.
- self putLong: extraVMMemory toFile: f.
- 1 to: 7 do: [:i | self putLong: 0 toFile: f]. "fill remaining header words with zeros"
- self successful ifFalse: [
- "file write or seek failure"
- self cCode: 'sqImageFileClose(f)'.
- ^ nil].
-
- "position file after the header"
- self sqImageFile: f Seek: headerStart + headerSize.
-
- "write the image data"
- bytesWritten := self
- sqImage: (objectMemory pointerForOop: objectMemory getMemory)
- write: f
- size: (self cCode: 'sizeof(unsigned char)')
- length: imageBytes.
- self success: bytesWritten = imageBytes.
- self cCode: 'sqImageFileClose(f)'.
-
- !
Item was changed:
VMClass subclass: #InterpreterPrimitives
+ instanceVariableNames: 'objectMemory primitiveTable primFailCode argumentCount interruptKeycode newMethod preemptionYields'
+ classVariableNames: 'CrossedX EndOfRun InterpreterSourceVersion MillisecondClockMask PrimitiveExternalCallIndex PrimitiveTable'
- instanceVariableNames: 'objectMemory primFailCode argumentCount interruptKeycode newMethod preemptionYields'
- classVariableNames: 'CrossedX EndOfRun InterpreterSourceVersion MillisecondClockMask'
poolDictionaries: 'VMObjectIndices VMSqueakV3ObjectRepresentationConstants'
category: 'VMMaker-Interpreter'!
!InterpreterPrimitives commentStamp: 'dtl 4/14/2013 23:16' prior: 0!
InterpreterPrimitives implements most of the VM's core primitives. It is the root of the interpreter hierarchy so as to share the core primitives amongst the various interpreters.
Instance Variables
argumentCount: <Integer>
messageSelector: <Integer>
newMethod: <Integer>
nextProfileTick: <Integer>
objectMemory: <ObjectMemory> (simulation only)
preemptionYields: <Boolean>
primFailCode: <Integer>
profileMethod: <Integer>
profileProcess: <Integer>
profileSemaphore: <Integer>
argumentCount
- the number of arguments of the current message
messageSelector
- the oop of the selector of the current message
newMethod
- the oop of the result of looking up the current message
nextProfileTick
- the millisecond clock value of the next profile tick (if profiling is in effect)
objectMemory
- the memory manager and garbage collector that manages the heap
preemptionYields
- a boolean controlling the process primitives. If true (old, incorrect, blue-book semantics) a preempted process is sent to the back of its run-queue. If false, a process preempted by a higher-priority process is put back at the head of its run queue, hence preserving cooperative scheduling within priorities.
primFailCode
- primtiive success/failure flag, 0 for success, otherwise the reason code for failure
profileMethod
- the oop of the method at the time nextProfileTick was reached
profileProcess
- the oop of the activeProcess at the time nextProfileTick was reached
profileSemaphore
- the oop of the semaphore to signal when nextProfileTick is reached
!
Item was added:
+ ----- Method: InterpreterPrimitives class>>primitiveTable (in category 'constants') -----
+ primitiveTable
+
+ ^ PrimitiveTable!
Item was added:
+ ----- Method: InterpreterPrimitives class>>primitiveTableString (in category 'translation') -----
+ primitiveTableString
+ "Interpreter initializePrimitiveTable primitiveTableString"
+ | table |
+ table := self primitiveTable.
+ ^ String
+ streamContents: [:s |
+ s nextPut: ${.
+ table
+ withIndexDo: [:primSpec :index | s cr; tab;
+ nextPutAll: '/* ';
+ nextPutAll: (index - 1) printString;
+ nextPutAll: '*/ ';
+ nextPutAll: '(void (*)(void))'; "keep this matching the declaration of primitiveTable in Interpreter class>declareCVarsIn:"
+ nextPutAll: primSpec;
+ nextPut: $,].
+ s cr; nextPutAll: ' 0 }']!
Item was removed:
- ----- Method: InterpreterPrimitives>>primitiveNewMethod (in category 'compiled methods') -----
- primitiveNewMethod
- | header bytecodeCount class size theMethod literalCount |
- header := self popStack.
- bytecodeCount := self popInteger.
- self success: (objectMemory isIntegerObject: header).
- self successful ifFalse:
- [self unPop: 2. ^nil].
- class := self popStack.
- size := (self literalCountOfHeader: header) + 1 * objectMemory bytesPerWord + bytecodeCount.
- theMethod := objectMemory instantiateClass: class indexableSize: size.
- objectMemory storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
- literalCount := self literalCountOfHeader: header.
- 1 to: literalCount do:
- [:i | objectMemory storePointer: i ofObject: theMethod withValue: objectMemory getNilObj].
- self push: theMethod!
Item was added:
+ ----- Method: InterpreterPrimitives>>transfer:from:to: (in category 'utilities') -----
+ transfer: count from: src to: dst
+ | in out lastIn |
+ <inline: true>
+ self flag: #Dan. "Need to check all senders before converting this for 64 bits"
+ in := src - objectMemory bytesPerWord.
+ lastIn := in + (count * objectMemory bytesPerWord).
+ out := dst - objectMemory bytesPerWord.
+ [objectMemory oop: in isLessThan: lastIn]
+ whileTrue: [self
+ longAt: (out := out + objectMemory bytesPerWord)
+ put: (objectMemory longAt: (in := in + objectMemory bytesPerWord))]!
Item was added:
+ ----- Method: InterpreterPrimitivesTest>>testLargeIntegerBugFixedInVMMakerOscog1744 (in category 'testing - largeIntegers') -----
+ testLargeIntegerBugFixedInVMMakerOscog1744
+ "LargeIntegersPlugin bug fixed in VMMaker.oscog-nice.1743 VMMaker-dtl.379"
+
+ "Date: Sun, 27 Mar 2016 19:03:48 +0200
+ Subject: Re: [Vm-dev] vm problem on cog and stack spur
+ From: Nicolas Cellier <nicolas.cellier.aka.nice at gmail.com>
+ To: Squeak Virtual Machine Development Discussion <vm-dev at lists.squeakfoundation.org>
+
+ I reduced the failing test to:
+ "
+
+ | a b |
+ a := 1598335257761788022467377781654101148543282249044465229239888363328190330275719997501596724768507889233831388734160190922469363547795602076820594918.
+ b := 49612.
+ self assert: a - ((a quo: b)*b) < b
+
+
+ !
Item was changed:
+ ContextInterpreter subclass: #InterpreterSimulator
- Interpreter subclass: #InterpreterSimulator
instanceVariableNames: 'bytesPerWord byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging'
classVariableNames: ''
poolDictionaries: 'VMObjectIndices VMSqueakV3ObjectRepresentationConstants'
category: 'VMMaker-InterpreterSimulation'!
!InterpreterSimulator commentStamp: 'dtl 5/5/2011 19:42' prior: 0!
This class defines basic memory access and primitive simulation so that the Interpreter can run simulated in the Squeak environment. It also defines a number of handy object viewing methods to facilitate pawing around in the object memory.
To see the thing actually run, you could (after backing up this image and changes), execute
(InterpreterSimulator new openOn: Smalltalk imageName) test
and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be. We usually do this with a small and simple benchmark image. You will probably have more luck using InterpreterSimulatorLSB or InterpreterSimulatorMSB as befits your machine.!
Item was changed:
----- Method: InterpreterSimulator>>initialize (in category 'initialization') -----
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."
"copy of bytesPerWord to avoid extra indirection that may affect performance"
bytesPerWord := objectMemory bytesPerWord.
"initialize class variables"
ObjectMemory initializeConstants.
+ ContextInterpreter initialize.
- 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 := objectMemory integerObjectOf: -1.
methodCache := Array new: MethodCacheSize.
atCache := Array new: AtCacheTotalSize.
self flushMethodCache.
objectMemory setRootTable: (Array new: ObjectMemory rootTableSize).
objectMemory setWeakRoots: (Array new: ObjectMemory rootTableSize + ObjectMemory remapBufferSize + 100).
objectMemory setRemapBuffer: (Array new: ObjectMemory 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.
objectMemory setHeaderTypeBytes: (CArrayAccessor on: (Array with: bytesPerWord * 2 with: bytesPerWord with: 0 with: 0)).
transcript := Transcript.
objectMemory transcript: Transcript.
displayForm := 'Display has not yet been installed' asDisplayText form.
!
Item was changed:
----- Method: ObjectMemory class>>interpreterClass (in category 'translation') -----
interpreterClass
"Answer the interpreter class that is commonly used in collaboration with
this type of object memory. When generating inlined methods, some methods
from the interpreter class may be inlined into methods in the object memory."
+ ^ContextInterpreter
- ^Interpreter
!
Item was added:
+ ----- Method: SlangTest>>testConditionalInAndBlock (in category 'testing interpreter') -----
+ testConditionalInAndBlock
+ "Expand ifTrue:ifFalse: properly within a block."
+
+ "(SlangTest selector: #testConditionalInAndBlock) debug"
+
+ | stssi m expected |
+ stssi := SlangTestSupportInterpreter inline: true.
+ m := stssi asCString: #conditionalInAndBlock.
+
+ m := (m copyWithoutAll: ('' , Character cr)) copyReplaceAll: ('' , Character tab) with: ' '.
+ expected := 'sqInt conditionalInAndBlock(void) { return 1 && ((0 ? TRUE : FALSE));}'.
+
+ self deny: ('*1 && (if (0) {*' match: m). "prior faulty translation"
+ self assert: expected = m.
+ !
Item was changed:
----- Method: SlangTest>>testRemoveTypeDeclarationForRemovedIntermediate (in category 'testing var decl requires memoryaccess') -----
testRemoveTypeDeclarationForRemovedIntermediate
"Document a bug in variable declaration. This is hard to reproduce, so the test uses
the actual failure. Necessary conditions are to use MemoryAccess (requires deep
inlining), then generate the entire interpreter. The error condition appears in the
reverseDisplayFrom:to: method. Generating that method alone is not sufficient to
reproduce the bug, the entire interpreter must first be generated, after which the
method may be individually generated to inspect for the error condition. Symptoms
are that #ptr, which is used as a sqInt, is incorrectly declared as (char *) due to a
left over unreferenced declaration in one of the inlined methods.
The bug exists as of VMMaker-dtl.342 and is corrected in VMMaker-dtl.343."
| ma maState |
ma := Smalltalk classNamed: #MemoryAccess.
ma ifNil: [^ self
"requires these accessors in combination with object memory / interpreter refactoring in order to reproduce bug"].
maState := ma isEnabled.
[ | s cg strm meth |
ma enable.
cg := CCodeGenerator new initialize.
cg declareMethodsStatic: false.
+ ContextInterpreter initializeCodeGenerator: cg.
+ cg vmClass: ContextInterpreter.
- Interpreter initializeCodeGenerator: cg.
- cg vmClass: Interpreter.
strm := ReadWriteStream on: ''.
cg emitCCodeOn: strm doInlining: true doAssertions: false.
meth := cg methodNamed: 'reverseDisplayFrom:to:' .
strm := ReadWriteStream on: ''.
meth emitCCodeOn: strm generator: cg.
s := strm contents.
self shouldnt: ('*char #ptr;*' match: s).
self should: ('*sqInt ptr;*' match: s)
] ensure: [maState
ifTrue: [ma enable]
ifFalse: [ma disable]]
!
Item was added:
+ ----- Method: SlangTestSupportInterpreter>>conditionalInAndBlock (in category 'blocks and conditionals') -----
+ conditionalInAndBlock
+ ^true
+ and: [false
+ ifTrue: [#TRUE]
+ ifFalse: [#FALSE]]!
Item was changed:
+ Interpreter subclass: #StackInterpreter
+ instanceVariableNames: 'currentBytecode localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue primitiveFunctionPointer methodCache atCache lkupClass highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods 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 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'
- InterpreterPrimitives subclass: #StackInterpreter
- instanceVariableNames: 'currentBytecode localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue primitiveFunctionPointer methodCache atCache lkupClass highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods 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 messageSelector profileProcess nextProfileTick profileMethod profileSemaphore'
- classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BytecodeTable BytesPerWord COGMTVM COGVM CacheProbeMax DirBadPath DirEntryFound DirNoMoreEntries DumpStackOnLowSpace EnclosingMixinIndex EnclosingObjectIndex FailImbalancedPrimitives HeaderFlagBitPosition IMMUTABILITY MULTIPLEBYTECODESETS MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MaxQuickPrimitiveIndex MixinIndex NewspeakVM PrimitiveExternalCallIndex PrimitiveTable 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 frame 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>'.
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: #(instructionPointer method newMethod)
as: #usqInt
in: aCCodeGenerator.
"These are all pointers; char * because Slang has no support for C pointer arithmetic."
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, ' */]'.
- aCCodeGenerator
- var: #primitiveTable
- declareC: 'void (*primitiveTable[MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex +2) printString, ' */])(void) = ', self primitiveTableString.
self primitiveTable do:
[:symbolOrNot|
(symbolOrNot isSymbol
and: [symbolOrNot ~~ #primitiveFail]) ifTrue:
[(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil:
[:tMethod| tMethod returnType: #void]]].
aCCodeGenerator
var: #primitiveFunctionPointer
declareC: 'void (*primitiveFunctionPointer)()'.
- aCCodeGenerator
- var: #externalPrimitiveTable
- declareC: 'void (*externalPrimitiveTable[MaxExternalPrimitiveTableSize + 1 /* ', (MaxExternalPrimitiveTableSize + 1) printString, ' */])(void)'.
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!
Item was changed:
----- Method: StackInterpreter class>>initializeCaches (in category 'initialization') -----
initializeCaches
- | atCacheEntrySize |
MethodCacheEntries := 1024.
MethodCacheSelector := 1.
MethodCacheClass := 2.
MethodCacheMethod := 3.
MethodCachePrimFunction := 4.
MethodCacheEntrySize := 4. "Must be power of two for masking scheme."
MethodCacheMask := (MethodCacheEntries - 1) * MethodCacheEntrySize.
MethodCacheSize := MethodCacheEntries * MethodCacheEntrySize.
CacheProbeMax := 3.
-
- AtCacheEntries := 8. "Must be a power of two"
- AtCacheOop := 1.
- AtCacheSize := 2.
- AtCacheFmt := 3.
- AtCacheFixedFields := 4.
- atCacheEntrySize := 4. "Must be power of two for masking scheme."
- AtCacheMask := (AtCacheEntries-1) * atCacheEntrySize.
- AtPutBase := AtCacheEntries * atCacheEntrySize.
- AtCacheTotalSize := AtCacheEntries * atCacheEntrySize * 2.
!
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.
- "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"
FailImbalancedPrimitives := true!
Item was removed:
- ----- Method: StackInterpreter class>>primitiveTable (in category 'constants') -----
- primitiveTable
-
- ^ PrimitiveTable!
Item was removed:
- ----- Method: StackInterpreter class>>vmCallbackHeader (in category 'translation') -----
- vmCallbackHeader
- ^String streamContents:
- [:s|
- s nextPutAll: '#define VM_CALLBACK_INC 1'; cr; cr.
- VMCallbackContext printTypedefOn: s.
- s cr]!
Item was removed:
- ----- Method: StackInterpreter>>areIntegers:and: (in category 'utilities') -----
- areIntegers: oop1 and: oop2
- "Test oop1 and oop2 to make sure both are SmallIntegers."
- ^ ((oop1 bitAnd: oop2) bitAnd: 1) ~= 0!
Item was removed:
- ----- Method: StackInterpreter>>checkedIntegerValueOf: (in category 'utilities') -----
- checkedIntegerValueOf: intOop
- "Note: May be called by translated primitive code."
-
- (objectMemory isIntegerObject: intOop)
- ifTrue: [ ^ objectMemory integerValueOf: intOop ]
- ifFalse: [ self primitiveFail. ^ 0 ]!
Item was removed:
- ----- Method: StackInterpreter>>makePointwithxValue:yValue: (in category 'utilities') -----
- makePointwithxValue: xValue yValue: yValue
- "make a Point xValue at yValue.
- We know both will be integers so no value nor root checking is needed"
- | pointResult |
- pointResult := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassPoint) sizeInBytes: 3 * objectMemory bytesPerWord.
- objectMemory storePointerUnchecked: XIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: xValue).
- objectMemory storePointerUnchecked: YIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: yValue).
- ^ pointResult!
Item was changed:
----- Method: StackInterpreter>>restoreCStackStateForCallbackContext: (in category 'callback support') -----
restoreCStackStateForCallbackContext: vmCallbackContext
+ "<var: #vmCallbackContext type: #'VMCallbackContext *'>"
- <var: #vmCallbackContext type: #'VMCallbackContext *'>
"this is a no-op for the Stack VM"!
Item was removed:
- ----- Method: StackInterpreter>>returnAs:ThroughCallback:Context: (in category 'callback support') -----
- returnAs: returnTypeOop ThroughCallback: vmCallbackContext Context: callbackMethodContext
- "callbackMethodContext is an activation of invokeCallback:[stack:registers:jmpbuf:].
- Its sender is the VM's state prior to the callback. Reestablish that state (via longjmp),
- and mark callbackMethodContext as dead."
- <export: true>
- <var: #vmCallbackContext type: #'VMCallbackContext *'>
- | calloutMethodContext theFP thePage |
- <var: #theFP type: #'char *'>
- <var: #thePage type: #'StackPage *'>
- ((self isIntegerObject: returnTypeOop)
- and: [self isLiveContext: callbackMethodContext]) ifFalse:
- [^false].
- calloutMethodContext := self externalInstVar: SenderIndex ofContext: callbackMethodContext.
- (self isLiveContext: calloutMethodContext) ifFalse:
- [^false].
- "Mark callbackMethodContext as dead; the common case is that it is the current frame.
- We go the extra mile for the debugger."
- (self isSingleContext: callbackMethodContext)
- ifTrue: [self markContextAsDead: callbackMethodContext]
- ifFalse:
- [theFP := self frameOfMarriedContext: callbackMethodContext.
- framePointer = theFP "common case"
- ifTrue:
- [(self isBaseFrame: theFP)
- ifTrue: [stackPages freeStackPage: stackPage]
- ifFalse: "calloutMethodContext is immediately below on the same page. Make it current."
- [instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger.
- stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory bytesPerWord.
- framePointer := self frameCallerFP: framePointer.
- self restoreCStackStateForCallbackContext: vmCallbackContext.
- "N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
- This matches the use of _setjmp in ia32abicc.c."
- self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
- ^true]]
- ifFalse:
- [self externalDivorceFrame: theFP andContext: callbackMethodContext.
- self markContextAsDead: callbackMethodContext]].
- "Make the calloutMethodContext the active frame. The case where calloutMethodContext
- is immediately below callbackMethodContext on the same page is handled above."
- (self isStillMarriedContext: calloutMethodContext)
- ifTrue:
- [theFP := self frameOfMarriedContext: calloutMethodContext.
- thePage := stackPages stackPageFor: theFP.
- "findSPOf:on: points to the word beneath the instructionPointer, but
- there is no instructionPointer on the top frame of the current page."
- self assert: thePage ~= stackPage.
- stackPointer := (self findSPOf: theFP on: thePage) - objectMemory bytesPerWord.
- framePointer := theFP]
- ifFalse:
- [thePage := self makeBaseFrameFor: calloutMethodContext.
- framePointer := thePage headFP.
- stackPointer := thePage headSP].
- instructionPointer := self popStack.
- self setStackPageAndLimit: thePage.
- self restoreCStackStateForCallbackContext: vmCallbackContext.
- "N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
- This matches the use of _setjmp in ia32abicc.c."
- self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
- "NOTREACHED"
- ^true!
Item was changed:
----- Method: StackInterpreter>>saveCStackStateForCallbackContext: (in category 'callback support') -----
saveCStackStateForCallbackContext: vmCallbackContext
+ "<var: #vmCallbackContext type: #'VMCallbackContext *'>"
- <var: #vmCallbackContext type: #'VMCallbackContext *'>
"this is a no-op for the Stack VM"!
Item was removed:
- ----- Method: StackInterpreter>>sendInvokeCallbackContext: (in category 'callback support') -----
- sendInvokeCallbackContext: vmCallbackContext
- "Send the calllback message to Alien class with the supplied arg(s). Use either the
- 1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf:
- message, depending on what selector is installed in the specialObjectsArray.
- Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the
- vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:).
- The arguments are raw C addresses and are converted to integer objects on the way."
- <export: true>
- <var: #vmCallbackContext type: #'VMCallbackContext *'>
- lkupClass := self fetchClassOfNonInt: (self splObj: ClassAlien).
- messageSelector := self splObj: SelectorInvokeCallback.
- (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
- [(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue:
- [^false]].
- primitiveFunctionPointer ~= 0 ifTrue:
- [^false].
- self saveCStackStateForCallbackContext: vmCallbackContext.
- self push: (self splObj: ClassAlien). "receiver"
- self cppIf: [objectMemory bytesPerWord = 8]
- ifTrue:
- [(self argumentCountOf: newMethod) = 4 ifTrue:
- [self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
- self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
- self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
- self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)]
- ifFalse:
- [(self argumentCountOf: newMethod) = 4 ifTrue:
- [self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
- self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
- self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
- self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)].
- self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector.
- self justActivateNewMethod.
- (self isMachineCodeFrame: framePointer) ifFalse:
- [self maybeFlagMethodAsInterpreted: newMethod].
- self externalWriteBackHeadFramePointers.
- self handleStackOverflow.
- self enterSmalltalkExecutiveFromCallback.
- "not reached"
- ^true!
Item was removed:
- ----- Method: StackInterpreter>>signExtend16: (in category 'utilities') -----
- signExtend16: int16
- "Convert a signed 16-bit integer into a signed 32-bit integer value. The integer bit is not added here."
-
- (int16 bitAnd: 16r8000) = 0
- ifTrue: [ ^ int16 ]
- ifFalse: [ ^ int16 - 16r10000 ].!
Item was removed:
- ----- Method: StackInterpreter>>storeInteger:ofObject:withValue: (in category 'utilities') -----
- storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue
- "Note: May be called by translated primitive code."
- (objectMemory isIntegerValue: integerValue)
- ifTrue: [objectMemory storePointerUnchecked: fieldIndex ofObject: objectPointer
- withValue: (objectMemory integerObjectOf: integerValue)]
- ifFalse: [self primitiveFail].
- ^nil!
Item was changed:
----- Method: TSendNode>>emitCCodeOn:level:generator: (in category 'C code generation') -----
emitCCodeOn: aStream level: level generator: aCodeGen
"Emit the receiver as a statement."
"If the selector is a built-in construct, translate it and return"
+ (self isExpression
+ ifFalse: [aCodeGen emitBuiltinConstructFor: self on: aStream level: level]
+ ifTrue: [aCodeGen emitBuiltinConstructAsArgumentFor: self on: aStream level: level])
+ ifFalse:
+ ["If it is a pointer dereference generate it"
+ (self emitCCodeAsPointerDereferenceOn: aStream level: level generator: aCodeGen) ifFalse:
+ ["Otherwise generate the vanilla C function call."
+ self emitCCodeAsFunctionCallOn: aStream level: level generator: aCodeGen]]!
- (aCodeGen emitBuiltinConstructFor: self on: aStream level: level) ifFalse:
- ["If it is a pointer dereference generate it"
- (self emitCCodeAsPointerDereferenceOn: aStream level: level generator: aCodeGen) ifFalse:
- ["Otherwise generate the vanilla C function call."
- self emitCCodeAsFunctionCallOn: aStream level: level generator: aCodeGen]]!
Item was changed:
----- Method: VMConstantsTest>>initializeVMConstants (in category 'running') -----
initializeVMConstants
"Restore default values as used during normal intepreter code generation"
ObjectMemory initialize.
+ ContextInterpreter initialize.
- Interpreter initialize.
!
Item was changed:
----- Method: VMConstantsTest>>testConstMinusOne (in category 'testing') -----
testConstMinusOne
"ConstMinusOne is the object reference for integer -1. It must be handled specially
in the interpreter simulator because it resolves to a negative integer that cannot be
directly stored into a BitMap. See InterpreterSimulator>>initialize. Note that an
interpreter simulator modifies constants that are used in code generation. VMMaker
is expected to always initialize constants prior to generating code."
| interp |
self initializeVMConstants.
self assert: InterpreterSimulator constMinusOne = -1.
+ [self assert: ContextInterpreter constMinusOne = -1.
- [self assert: Interpreter constMinusOne = -1.
interp := InterpreterSimulator new. "modifies the constants in simulation"
self deny: InterpreterSimulator constMinusOne = -1.
+ self deny: ContextInterpreter constMinusOne = -1.
+ self assert: ContextInterpreter constMinusOne = 16rFFFFFFFF.
- self deny: Interpreter constMinusOne = -1.
- self assert: Interpreter constMinusOne = 16rFFFFFFFF.
" interp bytesPerWord: 8."
" interp initialize."
"Note: Integer value of -1 is the same in 64 bit object memory because
SmallInteger format is currently the same as in 32 bit object memory."
+ self assert: ContextInterpreter constMinusOne = 16rFFFFFFFF]
- self assert: Interpreter constMinusOne = 16rFFFFFFFF]
ensure: [self initializeVMConstants].
self assert: InterpreterSimulator constMinusOne = -1.
!
Item was changed:
----- Method: VMMaker>>generateInterpreterFile (in category 'generate sources') -----
generateInterpreterFile
"Translate the Smalltalk description of the virtual machine into C. If 'self doInlining' is true, small method bodies are inlined to reduce procedure call overhead. On the PPC, this results in a factor of three speedup with only 30% increase in code size. Subclasses can use specialised versions of CCodeGenerator and interpreterClass."
| cg |
self needsToRegenerateInterpreterFile ifFalse: [^nil].
self interpreterClass initialize.
ObjectMemory initializeConstants.
ObjectMemory initializeSmallIntegers. "Overridden in simulation, restore for code generation"
+ ContextInterpreter initializeInterpreterSourceVersion.
- Interpreter initializeInterpreterSourceVersion.
cg := self createCodeGenerator.
cg declareMethodsStatic: false.
self interpreterClass initializeCodeGenerator: cg.
cg vmClass: self interpreterClass.
cg storeHeaderFor: interpreterClassName onFile: self interpreterHeaderPath.
cg storeCodeOnFile: self interpreterFilePath doInlining: self doInlining.
self interpreterClass additionalHeadersDo:
[:headerName :headerContents| | filePath |
filePath := self coreVMDirectory fullNameFor: headerName.
(cg needToGenerateHeader: headerName file: filePath contents: headerContents) ifTrue:
[cg storeHeaderOnFile: filePath contents: headerContents]].
self interpreterClass apiExportHeaderName ifNotNil:
[cg storeAPIExportHeader: self interpreterClass apiExportHeaderName
OnFile: (self sourceFilePathFor: self interpreterClass apiExportHeaderName)].
!
Item was changed:
----- Method: VMMaker>>initialize (in category 'initialize') -----
initialize
logger := Transcript.
inline := true.
forBrowser := false.
internalPlugins := SortedCollection new.
externalPlugins := SortedCollection new.
platformName := self class machinesDirName.
allFilesList := Dictionary new.
+ interpreterClassName := ContextInterpreter name!
- interpreterClassName := Interpreter name!
Item was changed:
----- Method: VMMakerTool class>>defaultUnixSpec (in category 'configurations') -----
defaultUnixSpec
"Typical VMMaker spec for a unix/linux target platform"
"VMMakerTool defaultUnixSpec"
^#(
#( "internal plugins"
#ADPCMCodecPlugin
#AsynchFilePlugin
#BMPReadWriterPlugin
#BalloonEnginePlugin
#BitBltSimulation
#CroquetPlugin
#DESPlugin
#DSAPlugin
#DeflatePlugin
#DropPlugin
#FFTPlugin
#FilePlugin
#FloatArrayPlugin
#FloatMathPlugin
#GeniePlugin
#JPEGReadWriter2Plugin
#JPEGReaderPlugin
#JoystickTabletPlugin
#KlattSynthesizerPlugin
#LargeIntegersPlugin
#LocalePlugin
#MD5Plugin
#Matrix2x3Plugin
#MiscPrimitivePlugin
#RandPlugin
#RePlugin
#SHA256Plugin
#SecurityPlugin
#SerialPlugin
#SlangTestPlugin
#SlangTestSupportPlugin
#SocketPlugin
#SoundCodecPlugin
#SoundGenerationPlugin
#SoundPlugin
#StarSqueakPlugin
#SurfacePlugin
)
#( "external plugins"
#B3DAcceleratorPlugin
#B3DEnginePlugin
#ClipboardExtendedPlugin
#DBusPlugin
#FFIPlugin
#FileCopyPlugin
#FT2Plugin
#GStreamerPlugin
#HostWindowPlugin
#KedamaPlugin2
#MIDIPlugin
#Mpeg3Plugin
#RomePlugin
#UUIDPlugin
#UnixAioPlugin
#UnixOSProcessPlugin
#XDisplayControlPlugin
#CameraPlugin
#ScratchPlugin
#UnicodePlugin
#WeDoPlugin
#SqueakSSLPlugin
)
true "inline flag"
false "forBrowser flag"
'unix' "platform"
'src' "source directory for generated sources"
'platforms' "path to platform sources"
4 "unused, was bytesPerWord which is now a compile time definition"
true "unused, was flag for source directtory pathname is relative"
true "unused, was flag for platforms directory path is relative"
+ 'ContextInterpreter' "interpreter class name"
- 'Interpreter' "interpreter class name"
)!
Item was changed:
----- Method: VMMakerTool class>>minimalSpec (in category 'configurations') -----
minimalSpec
"VMMaker spec for a minimal VM"
"VMMakerTool minimalSpec"
^#(
#( "internal plugins required for a minimum usable VM"
#BitBltSimulation
#BalloonEnginePlugin
#FilePlugin
)
#( "external plugins not strictly required"
#SocketPlugin
)
true "inline flag"
false "forBrowser flag"
nil "platform (unspecified)"
'src' "source directory for generated sources"
'platforms' "path to platform sources"
4 "unused, was bytesPerWord which is now a compile time definition"
true "unused, was flag for source directtory pathname is relative"
true "unused, was flag for platforms directory path is relative"
+ 'ContextInterpreter' "interpreter class name"
- 'Interpreter' "interpreter class name"
)!
More information about the Vm-dev
mailing list