[Vm-dev] VM Maker: VMMaker-dtl.387.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Nov 8 22:33:20 UTC 2016
David T. Lewis uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-dtl.387.mcz
==================== Summary ====================
Name: VMMaker-dtl.387
Author: dtl
Time: 8 November 2016, 5:28:04.555 pm
UUID: ef7038c9-f871-4632-b087-ba2f03a89ebc
Ancestors: VMMaker-dtl.386
VMMaker 4.15.9
Various refactorings for stack/context interpreters.
VMMaker tool allow selection of context or stack interpreter (stack is not yet functional, requires struct code generation).
Add some FilePlugin updates from oscog, excluding those with platforms code dependencies (primitiveDirectoryEntry, primitiveDirectoryDelimitor).
Retire some old primitives in Interpreter class>>initializePrimitiveTable to align with oscog.
=============== Diff against VMMaker-dtl.386 ===============
Item was added:
+ ----- Method: CCodeGenerator>>addStructClass: (in category 'public') -----
+ addStructClass: aClass
+ "Add the non-accessor methods of the given struct class to the code base."
+
+ aClass prepareToBeAddedToCodeGenerator: self.
+ self addClassVarsFor: aClass.
+ self addPoolVarsFor: aClass.
+ self retainMethods: (aClass requiredMethodNames).
+
+ 'Adding Class ' , aClass name , '...'
+ displayProgressAt: Sensor cursorPoint
+ from: 0
+ to: aClass selectors size
+ during:
+ [:bar |
+ aClass selectors doWithIndex:
+ [:sel :i |
+ bar value: i.
+ self addStructMethodFor: aClass selector: sel]].
+ aClass declareCVarsIn: self!
Item was added:
+ ----- Method: CCodeGenerator>>addStructClasses: (in category 'accessing') -----
+ addStructClasses: classes
+ "Add the struct classes and save them for emitCTypesOn: later."
+ structClasses := classes.
+ structClasses do:
+ [:structClass| self addStructClass: structClass]!
Item was added:
+ ----- Method: CCodeGenerator>>addStructMethodFor:selector: (in category 'utilities') -----
+ addStructMethodFor: aClass selector: selector
+ "Add the given struct method to the code base and answer its translation
+ or nil if it shouldn't be translated."
+ ^(self addMethodFor: aClass selector: selector) ifNotNil:
+ [:tmethod|
+ tmethod transformToStructClassMethodFor: self.
+ tmethod]!
Item was changed:
----- Method: CCodeGenerator>>prepareMethods (in category 'utilities') -----
prepareMethods
"Prepare methods for browsing."
| globals |
globals := Set new: 200.
globals addAll: variables.
methods do: [ :m |
(m locals, m args) do: [ :var |
(globals includes: var) ifTrue: [
self error: 'Local variable name may mask global when inlining: ', var.
].
(methods includesKey: var) ifTrue: [
+ self notify: 'Local variable name may mask method when inlining: ', var.
- self error: 'Local variable name may mask method when inlining: ', var.
].
].
m mapReceiversIn: receiverDict.
m bindClassVariablesIn: constants.
m prepareMethodIn: self.
].!
Item was changed:
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 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 TempFrameStart'
- instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector currentBytecode primitiveIndex primitiveFunctionPointer methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptPending 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 changed:
----- Method: ContextInterpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
aCCodeGenerator addHeaderFile: '<setjmp.h>'.
aCCodeGenerator var: #interpreterProxy type: #'struct VirtualMachine*'.
"declare primitiveTable as an array of pointers to a function returning void, taking no arguments"
aCCodeGenerator var: #primitiveFunctionPointer declareC: 'void (*primitiveFunctionPointer)(void)'.
aCCodeGenerator var: #methodCache declareC: 'long methodCache[' , (MethodCacheSize + 1) printString , ']'.
aCCodeGenerator var: #atCache declareC: 'sqInt atCache[' , (AtCacheTotalSize + 1) printString , ']'.
aCCodeGenerator var: #statGCTime type: #sqLong.
aCCodeGenerator var: #statFullGCMSecs type: #sqLong.
aCCodeGenerator var: #statIGCDeltaTime type: #sqLong.
aCCodeGenerator var: #statIncrGCMSecs type: #sqLong.
aCCodeGenerator var: #localIP type: #'char*'.
aCCodeGenerator var: #localSP type: #'char*'.
aCCodeGenerator var: #showSurfaceFn type: #'void*'.
- aCCodeGenerator var: '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'.
+ aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[' , (MaxPrimitiveIndex + 2) printString , '] )(void)= ' , self primitiveTableString.
+ aCCodeGenerator var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[' , (MaxExternalPrimitiveTableSize + 1) printString , '])(void)'.
+ !
- aCCodeGenerator var: #imageFormatInitialVersion declareC: 'sqInt imageFormatInitialVersion = 0'!
Item was changed:
----- Method: ContextInterpreter class>>initialize (in category 'initialization') -----
initialize
"Interpreter initialize"
super initialize. "initialize ObjectMemory constants"
self initializeAssociationIndex.
self initializeBytecodeTable.
self initializeCaches.
self initializeCharacterIndex.
self initializeCharacterScannerIndices.
self initializeClassIndices.
self initializeCompilerHooks.
self initializeContextIndices.
self initializeDirectoryLookupResultCodes.
self initializeMessageIndices.
self initializeMethodIndices.
self initializePointIndices.
self initializePrimitiveTable.
self initializeSchedulerIndices.
self initializeStreamIndices.
self initializeInterpreterSourceVersion.
- 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 removed:
- ----- 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 changed:
+ ----- Method: ContextInterpreter class>>primitiveTableString (in category 'translation') -----
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: ContextInterpreter>>characterTable (in category 'plugin support') -----
- characterTable
- ^objectMemory splObj: CharacterTable!
Item was changed:
----- Method: ContextInterpreter>>initializeInterpreter: (in category 'initialization') -----
initializeInterpreter: bytesToShift
"Initialize Interpreter state before starting execution of a new image."
+ self initializeInterpreter.
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: 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>>primitiveFindHandlerContext (in category 'control primitives') -----
+ primitiveFindHandlerContext
+ "Primitive. Search up the context stack for the next method context marked for exception handling starting at the receiver. Return nil if none found"
+ | thisCntx nilOop |
+ thisCntx := self popStack.
+ nilOop := objectMemory getNilObj.
+
+ [(self isHandlerMarked: thisCntx) ifTrue:[
+ self push: thisCntx.
+ ^nil].
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
+ thisCntx = nilOop] whileFalse.
+
+ ^self push: objectMemory getNilObj!
Item was added:
+ ----- Method: ContextInterpreter>>primitiveFindNextUnwindContext (in category 'control primitives') -----
+ primitiveFindNextUnwindContext
+ "Primitive. Search up the context stack for the next method context marked for unwind handling from the receiver up to but not including the argument. Return nil if none found."
+ | thisCntx nilOop aContext unwindMarked |
+ aContext := self popStack.
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: self popStack.
+ nilOop := objectMemory getNilObj.
+
+ [(thisCntx = aContext) or: [thisCntx = nilOop]] whileFalse: [
+ unwindMarked := self isUnwindMarked: thisCntx.
+ unwindMarked ifTrue:[
+ self push: thisCntx.
+ ^nil].
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx].
+
+ ^self push: nilOop!
Item was removed:
- ----- Method: ContextInterpreter>>primitivePushFalse (in category 'quick primitives') -----
- primitivePushFalse
- self popStack.
- self push: objectMemory getFalseObj!
Item was removed:
- ----- Method: ContextInterpreter>>primitivePushMinusOne (in category 'quick primitives') -----
- primitivePushMinusOne
- self popStack.
- self push: ConstMinusOne!
Item was removed:
- ----- Method: ContextInterpreter>>primitivePushNil (in category 'quick primitives') -----
- primitivePushNil
- self popStack.
- self push: objectMemory getNilObj!
Item was removed:
- ----- Method: ContextInterpreter>>primitivePushOne (in category 'quick primitives') -----
- primitivePushOne
- self popStack.
- self push: ConstOne!
Item was removed:
- ----- Method: ContextInterpreter>>primitivePushSelf (in category 'quick primitives') -----
- primitivePushSelf
- " no-op, really...
- thisReceiver := self popStack.
- self push: thisReceiver
- "!
Item was removed:
- ----- Method: ContextInterpreter>>primitivePushTrue (in category 'quick primitives') -----
- primitivePushTrue
- self popStack.
- self push: objectMemory getTrueObj!
Item was removed:
- ----- Method: ContextInterpreter>>primitivePushTwo (in category 'quick primitives') -----
- primitivePushTwo
- self popStack.
- self push: ConstTwo!
Item was removed:
- ----- Method: ContextInterpreter>>primitivePushZero (in category 'quick primitives') -----
- primitivePushZero
- self popStack.
- self push: ConstZero!
Item was removed:
- ----- 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 removed:
- ----- 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 changed:
----- Method: ContextInterpreter>>signalExternalSemaphores (in category 'process primitive support') -----
signalExternalSemaphores
"Signal all requested semaphores"
| xArray xSize index sema |
semaphoresUseBufferA := semaphoresUseBufferA not.
+ xArray := self splObj: ExternalObjectsArray.
- 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 := self fetchPointer: index - 1 ofObject: xArray.
- ifTrue: [sema := objectMemory fetchPointer: index - 1 ofObject: xArray.
"Note: semaphore indices are 1-based"
+ (self fetchClassOf: sema) = (self splObj: ClassSemaphore)
- (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 := self fetchPointer: index - 1 ofObject: xArray.
- ifTrue: [sema := objectMemory fetchPointer: index - 1 ofObject: xArray.
"Note: semaphore indices are 1-based"
+ (self fetchClassOf: sema) = (self splObj: ClassSemaphore)
- (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
ifTrue: [self synchronousSignal: sema]]].
semaphoresToSignalCountA := 0]!
Item was removed:
- ----- 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 removed:
- ----- 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 changed:
----- Method: FilePlugin class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
+ self declareC: #('sCCPfn' 'sCDFfn' 'sCDPfn' 'sCGFTfn' 'sCLPfn' 'sCOFfn' 'sCRFfn' 'sCSFTfn' 'sDFAfn' 'sHFAfn')
+ as: #'void *'
+ in: aCCodeGenerator.
- aCCodeGenerator var: 'sCCPfn' type: 'void *'.
- aCCodeGenerator var: 'sCDPfn' type: 'void *'.
- aCCodeGenerator var: 'sCGFTfn' type: 'void *'.
- aCCodeGenerator var: 'sCLPfn' type: 'void *'.
- aCCodeGenerator var: 'sCSFTfn' type: 'void *'.
- aCCodeGenerator var: 'sDFAfn' type: 'void *'.
- aCCodeGenerator var: 'sCDFfn' type: 'void *'.
- aCCodeGenerator var: 'sCOFfn' type: 'void *'.
- aCCodeGenerator var: 'sCRFfn' type: 'void *'.
- aCCodeGenerator var: 'sHFAfn' type: 'void *'.
aCCodeGenerator addHeaderFile: '"FilePlugin.h"'!
Item was changed:
----- Method: FilePlugin>>asciiDirectoryDelimiter (in category 'directory primitives') -----
asciiDirectoryDelimiter
+ ^ self
+ cCode: 'dir_Delimitor()'
+ inSmalltalk:
+ [(Smalltalk classNamed: #FileSystem)
+ ifNotNil: [:fileSystem| fileSystem disk delimiter asciiValue]
+ ifNil: [FileDirectory pathNameDelimiter asciiValue]]!
- ^ self cCode: 'dir_Delimitor()' inSmalltalk: [FileDirectory pathNameDelimiter asciiValue]!
Item was changed:
----- Method: FilePlugin>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'directory primitives') -----
makeDirEntryName: entryName size: entryNameSize
createDate: createDate modDate: modifiedDate
isDir: dirFlag fileSize: fileSize
| modDateOop createDateOop nameString results stringPtr fileSizeOop |
<var: 'entryName' type: 'char *'>
<var: 'stringPtr' type:'char *'>
<var: 'fileSize' type:'squeakFileOffsetType '>
"allocate storage for results, remapping newly allocated
oops in case GC happens during allocation"
interpreterProxy pushRemappableOop:
(interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 5).
interpreterProxy pushRemappableOop:
+ (interpreterProxy instantiateClass: (interpreterProxy classString) indexableSize: entryNameSize).
- (interpreterProxy instantiateClass: (interpreterProxy classString) indexableSize: entryNameSize)..
interpreterProxy pushRemappableOop:
(interpreterProxy positive32BitIntegerFor: createDate).
interpreterProxy pushRemappableOop:
(interpreterProxy positive32BitIntegerFor: modifiedDate).
interpreterProxy pushRemappableOop:
(interpreterProxy positive64BitIntegerFor: fileSize).
fileSizeOop := interpreterProxy popRemappableOop.
modDateOop := interpreterProxy popRemappableOop.
createDateOop := interpreterProxy popRemappableOop.
nameString := interpreterProxy popRemappableOop.
results := interpreterProxy popRemappableOop.
"copy name into Smalltalk string"
stringPtr := interpreterProxy firstIndexableField: nameString.
0 to: entryNameSize - 1 do: [ :i |
stringPtr at: i put: (entryName at: i).
].
interpreterProxy storePointer: 0 ofObject: results withValue: nameString.
interpreterProxy storePointer: 1 ofObject: results withValue: createDateOop.
interpreterProxy storePointer: 2 ofObject: results withValue: modDateOop.
dirFlag
ifTrue: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy trueObject ]
ifFalse: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy falseObject ].
interpreterProxy storePointer: 4 ofObject: results withValue: fileSizeOop.
^ results!
Item was added:
+ ----- Method: FilePlugin>>makeDirEntryName:size:createDate:modDate:isDir:fileSize:posixPermissions:isSymlink: (in category 'directory primitives') -----
+ makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize posixPermissions: posixPermissions isSymlink: symlinkFlag
+ <var: 'entryName' type: 'char *'>
+ <var: 'fileSize' type: 'squeakFileOffsetType '>
+ <option: #PharoVM>
+
+ | modDateOop createDateOop nameString results stringPtr posixPermissionsOop fileSizeOop |
+ <var: 'stringPtr' type: 'char *'>
+
+ "allocate storage for results, remapping newly allocated
+ oops in case GC happens during allocation"
+ interpreterProxy pushRemappableOop:
+ (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 7).
+ interpreterProxy pushRemappableOop:
+ (interpreterProxy instantiateClass: (interpreterProxy classString) indexableSize: entryNameSize).
+ interpreterProxy pushRemappableOop:
+ (interpreterProxy positive32BitIntegerFor: createDate).
+ interpreterProxy pushRemappableOop:
+ (interpreterProxy positive32BitIntegerFor: modifiedDate).
+ interpreterProxy pushRemappableOop:
+ (interpreterProxy positive64BitIntegerFor: fileSize).
+ interpreterProxy pushRemappableOop:
+ (interpreterProxy positive32BitIntegerFor: posixPermissions).
+
+ posixPermissionsOop := interpreterProxy popRemappableOop.
+ fileSizeOop := interpreterProxy popRemappableOop.
+ modDateOop := interpreterProxy popRemappableOop.
+ createDateOop := interpreterProxy popRemappableOop.
+ nameString := interpreterProxy popRemappableOop.
+ results := interpreterProxy popRemappableOop.
+
+ "copy name into Smalltalk string"
+ stringPtr := interpreterProxy firstIndexableField: nameString.
+ 0 to: entryNameSize - 1 do: [ :i |
+ stringPtr at: i put: (entryName at: i).
+ ].
+
+ interpreterProxy storePointer: 0 ofObject: results withValue: nameString.
+ interpreterProxy storePointer: 1 ofObject: results withValue: createDateOop.
+ interpreterProxy storePointer: 2 ofObject: results withValue: modDateOop.
+ dirFlag
+ ifTrue: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy trueObject ]
+ ifFalse: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy falseObject ].
+ interpreterProxy storePointer: 4 ofObject: results withValue: fileSizeOop.
+ interpreterProxy storePointer: 5 ofObject: results withValue: posixPermissionsOop.
+ symlinkFlag
+ ifTrue: [ interpreterProxy storePointer: 6 ofObject: results withValue: interpreterProxy trueObject ]
+ ifFalse: [ interpreterProxy storePointer: 6 ofObject: results withValue: interpreterProxy falseObject ].
+ ^ results!
Item was changed:
----- Method: FilePlugin>>primitiveDirectoryCreate (in category 'directory primitives') -----
primitiveDirectoryCreate
| dirName dirNameIndex dirNameSize okToCreate |
<var: #dirNameIndex type: 'char *'>
<export: true>
dirName := interpreterProxy stackValue: 0.
+ (interpreterProxy isBytes: dirName) ifFalse:
+ [^interpreterProxy primitiveFail].
- (interpreterProxy isBytes: dirName)
- ifFalse: [^interpreterProxy primitiveFail].
dirNameIndex := interpreterProxy firstIndexableField: dirName.
dirNameSize := interpreterProxy byteSizeOf: dirName.
"If the security plugin can be loaded, use it to check for permission.
If not, assume it's ok"
+ sCCPfn ~= 0 ifTrue:
+ [okToCreate := self cCode: ' ((sqInt (*)(char *, sqInt))sCCPfn)(dirNameIndex, dirNameSize)'
+ inSmalltalk: [true].
+ okToCreate ifFalse:
+ [^interpreterProxy primitiveFail]].
- sCCPfn ~= 0
- ifTrue: [okToCreate := self cCode: ' ((sqInt (*)(char *, sqInt))sCCPfn)(dirNameIndex, dirNameSize)'.
- okToCreate
- ifFalse: [^interpreterProxy primitiveFail]].
(self
+ cCode: 'dir_Create(dirNameIndex, dirNameSize)'
+ inSmalltalk: [self createDirectory: (interpreterProxy asString: dirNameIndex)]) ifFalse:
+ [^interpreterProxy primitiveFail].
- cCode: 'dir_Create(dirNameIndex, dirNameSize)'
- inSmalltalk: [false])
- ifFalse: [^interpreterProxy primitiveFail].
interpreterProxy pop: 1!
Item was changed:
----- Method: FilePlugin>>primitiveDirectoryDelete (in category 'directory primitives') -----
primitiveDirectoryDelete
| dirName dirNameIndex dirNameSize okToDelete |
<var: #dirNameIndex type: 'char *'>
<export: true>
dirName := interpreterProxy stackValue: 0.
(interpreterProxy isBytes: dirName)
ifFalse: [^interpreterProxy primitiveFail].
dirNameIndex := interpreterProxy firstIndexableField: dirName.
dirNameSize := interpreterProxy byteSizeOf: dirName.
"If the security plugin can be loaded, use it to check for permission.
If not, assume it's ok"
sCDPfn ~= 0
+ ifTrue: [okToDelete := self cCode: ' ((sqInt (*)(char *, sqInt))sCDPfn)(dirNameIndex, dirNameSize)' inSmalltalk: [false].
- ifTrue: [okToDelete := self cCode: ' ((sqInt (*)(char *, sqInt))sCDPfn)(dirNameIndex, dirNameSize)'.
okToDelete
ifFalse: [^interpreterProxy primitiveFail]].
(self
cCode: 'dir_Delete(dirNameIndex, dirNameSize)'
inSmalltalk: [false])
ifFalse: [^interpreterProxy primitiveFail].
interpreterProxy pop: 1!
Item was changed:
----- Method: FilePlugin>>primitiveDirectoryLookup (in category 'directory primitives') -----
primitiveDirectoryLookup
+ | index pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag symlinkFlag posixPermissions fileSize okToList |
+
- | index pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag fileSize okToList |
<var: 'entryName' declareC: 'char entryName[256]'>
<var: 'pathNameIndex' type: 'char *'>
<var: 'fileSize' type: 'squeakFileOffsetType'>
<export: true>
index := interpreterProxy stackIntegerValue: 0.
pathName := interpreterProxy stackValue: 1.
(interpreterProxy isBytes: pathName)
ifFalse: [^interpreterProxy primitiveFail].
pathNameIndex := interpreterProxy firstIndexableField: pathName.
pathNameSize := interpreterProxy byteSizeOf: pathName.
"If the security plugin can be loaded, use it to check for permission.
If not, assume it's ok"
sCLPfn ~= 0
ifTrue: [okToList := self cCode: '((sqInt (*)(char *, sqInt))sCLPfn)(pathNameIndex, pathNameSize)']
ifFalse: [okToList := true].
okToList
+ ifTrue: [
+ self isDefined: 'PharoVM'
+ inSmalltalk: [ status := -1 ]
+ comment: 'platform support code diverged for pharo'
+ ifTrue: [
+ status := self cCode: 'dir_Lookup(pathNameIndex, pathNameSize, index,
- ifTrue: [status := self cCode: 'dir_Lookup(pathNameIndex, pathNameSize, index,
entryName, &entryNameSize, &createDate,
+ &modifiedDate, &dirFlag, &fileSize,
+ &posixPermissions, &symlinkFlag)' ]
+ ifFalse: [
+ status := self cCode: 'dir_Lookup(pathNameIndex, pathNameSize, index,
+ entryName, &entryNameSize, &createDate,
+ &modifiedDate, &dirFlag, &fileSize)' ] ]
- &modifiedDate, &dirFlag, &fileSize)']
ifFalse: [status := DirNoMoreEntries].
interpreterProxy failed
ifTrue: [^nil].
status = DirNoMoreEntries
ifTrue: ["no more entries; return nil"
interpreterProxy pop: 3 "pop pathName, index, rcvr"
thenPush: interpreterProxy nilObject.
^nil].
status = DirBadPath
ifTrue: [^interpreterProxy primitiveFail]."bad path"
+ self isDefined: 'PharoVM'
+ inSmalltalk: [ status := -1 ]
+ comment: 'platform support code diverged for pharo'
+ ifTrue: [
+ interpreterProxy
+ pop: 3 "pop pathName, index, rcvr"
+ thenPush: (self
+ makeDirEntryName: entryName
+ size: entryNameSize
+ createDate: createDate
+ modDate: modifiedDate
+ isDir: dirFlag
+ fileSize: fileSize
+ posixPermissions: posixPermissions
+ isSymlink: symlinkFlag) ]
+ ifFalse: [
+ interpreterProxy
+ pop: 3 "pop pathName, index, rcvr"
+ thenPush: (self
+ makeDirEntryName: entryName
+ size: entryNameSize
+ createDate: createDate
+ modDate: modifiedDate
+ isDir: dirFlag
+ fileSize: fileSize) ]!
- interpreterProxy pop: 3 "pop pathName, index, rcvr"
- thenPush: (self
- makeDirEntryName: entryName
- size: entryNameSize
- createDate: createDate
- modDate: modifiedDate
- isDir: dirFlag
- fileSize: fileSize)!
Item was changed:
----- Method: FilePlugin>>primitiveDirectorySetMacTypeAndCreator (in category 'directory primitives') -----
primitiveDirectorySetMacTypeAndCreator
+ | creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize okToSet |
- | creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize okToSet |
<var: 'creatorStringIndex' type: 'char *'>
<var: 'typeStringIndex' type: 'char *'>
<var: 'fileNameIndex' type: 'char *'>
<export: true>
creatorString := interpreterProxy stackValue: 0.
typeString := interpreterProxy stackValue: 1.
fileName := interpreterProxy stackValue: 2.
((interpreterProxy isBytes: creatorString)
+ and: [(interpreterProxy isBytes: typeString)
+ and: [(interpreterProxy isBytes: fileName)
+ and: [(interpreterProxy byteSizeOf: creatorString) = 4
+ and: [(interpreterProxy byteSizeOf: typeString) = 4]]]]) ifFalse:
+ [^interpreterProxy primitiveFail].
- and: [(interpreterProxy byteSizeOf: creatorString)
- = 4])
- ifFalse: [^interpreterProxy primitiveFail].
- ((interpreterProxy isBytes: typeString)
- and: [(interpreterProxy byteSizeOf: typeString)
- = 4])
- ifFalse: [^interpreterProxy primitiveFail].
- (interpreterProxy isBytes: fileName)
- ifFalse: [^interpreterProxy primitiveFail].
creatorStringIndex := interpreterProxy firstIndexableField: creatorString.
typeStringIndex := interpreterProxy firstIndexableField: typeString.
fileNameIndex := interpreterProxy firstIndexableField: fileName.
fileNameSize := interpreterProxy byteSizeOf: fileName.
"If the security plugin can be loaded, use it to check for permission.
If not, assume it's ok"
+ sCSFTfn ~= 0 ifTrue:
+ [okToSet := self
+ cCode: '((sqInt (*)(char *, sqInt))sCSFTfn)(fileNameIndex, fileNameSize)'
+ inSmalltalk: [true].
+ okToSet ifFalse:
+ [^interpreterProxy primitiveFail]].
- sCSFTfn ~= 0
- ifTrue: [okToSet := self cCode: ' ((sqInt (*)(char *, sqInt))sCSFTfn)(fileNameIndex, fileNameSize)'.
- okToSet
- ifFalse: [^interpreterProxy primitiveFail]].
(self
+ cCode: 'dir_SetMacFileTypeAndCreator(fileNameIndex, fileNameSize, typeStringIndex, creatorStringIndex)'
+ inSmalltalk: [true]) ifFalse:
+ [^interpreterProxy primitiveFail].
- cCode: 'dir_SetMacFileTypeAndCreator(fileNameIndex, fileNameSize,typeStringIndex, creatorStringIndex)'
- inSmalltalk: [true])
- ifFalse: [^interpreterProxy primitiveFail].
interpreterProxy pop: 3!
Item was changed:
----- Method: FilePlugin>>primitiveFileDelete (in category 'file primitives') -----
primitiveFileDelete
| namePointer nameIndex nameSize okToDelete |
<var: 'nameIndex' type: 'char *'>
<export: true>
namePointer := interpreterProxy stackValue: 0.
(interpreterProxy isBytes: namePointer)
ifFalse: [^ interpreterProxy primitiveFail].
nameIndex := interpreterProxy firstIndexableField: namePointer.
nameSize := interpreterProxy byteSizeOf: namePointer.
"If the security plugin can be loaded, use it to check for permission.
If not, assume it's ok"
sCDFfn ~= 0
+ ifTrue: [okToDelete := self cCode: ' ((sqInt (*)(char *, sqInt))sCDFfn)(nameIndex, nameSize)' inSmalltalk: [true].
- ifTrue: [okToDelete := self cCode: ' ((sqInt (*)(char *, sqInt))sCDFfn)(nameIndex, nameSize)'.
okToDelete
ifFalse: [^ interpreterProxy primitiveFail]].
self
sqFileDeleteName: nameIndex
Size: nameSize.
interpreterProxy failed
ifFalse: [interpreterProxy pop: 1]!
Item was changed:
----- Method: FilePlugin>>primitiveFileRead (in category 'file primitives') -----
primitiveFileRead
<export: true>
+ "self cppIf: SPURVM"
+ self isDefined: 'SPURVM'
+ inSmalltalk: [ self primitiveFileReadWithoutPinning ]
+ comment: 'use primitiveFileReadWithPinning for SPUR'
+ ifTrue: [self primitiveFileReadWithPinning]
+ ifFalse: [self primitiveFileReadWithoutPinning]!
- | retryCount count startIndex array file elementSize bytesRead |
- <var: 'file' type: #'SQFile *'>
- <var: 'count' type: #'size_t'>
- <var: 'startIndex' type: #'size_t'>
- <var: 'elementSize' type: #'size_t'>
-
- retryCount := 0.
- count := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
- startIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
-
- [array := interpreterProxy stackValue: 2.
- file := self fileValueOf: (interpreterProxy stackValue: 3).
-
- (interpreterProxy failed
- "buffer can be any indexable words or bytes object except CompiledMethod"
- or: [(interpreterProxy isWordsOrBytes: array) not]) ifTrue:
- [^interpreterProxy primitiveFailFor: PrimErrBadArgument].
-
- elementSize := (interpreterProxy isWords: array) ifTrue: [4] ifFalse: [1].
- (startIndex >= 1
- and: [(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)]) ifFalse:
- [^interpreterProxy primitiveFailFor: PrimErrBadIndex].
-
- "Note: adjust startIndex for zero-origin indexing"
- bytesRead := self
- sqFile: file
- Read: count * elementSize
- Into: (self cCoerce: (interpreterProxy firstIndexableField: array) to: #'char *')
- At: (startIndex - 1) * elementSize.
- interpreterProxy primitiveFailureCode = PrimErrObjectMayMove
- and: [(retryCount := retryCount + 1) <= 2] "Two objects, the file and the array can move"] whileTrue:
- [interpreterProxy
- tenuringIncrementalGC;
- primitiveFailFor: PrimNoErr].
- interpreterProxy failed ifFalse:
- [interpreterProxy
- pop: 5 "pop rcvr, file, array, startIndex, count"
- thenPush:(interpreterProxy integerObjectOf: bytesRead // elementSize) "push # of elements read"]!
Item was added:
+ ----- Method: FilePlugin>>primitiveFileReadWithPinning (in category 'file primitives') -----
+ primitiveFileReadWithPinning
+ "This version of primitiveFileRead is for garbage collectors that support pinning."
+ | count startIndex array file elementSize bytesRead |
+ <inline: true>
+ <var: 'file' type: #'SQFile *'>
+ <var: 'count' type: #'size_t'>
+ <var: 'startIndex' type: #'size_t'>
+ <var: 'elementSize' type: #'size_t'>
+ count := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
+ startIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
+ array := interpreterProxy stackValue: 2.
+ file := self fileValueOf: (interpreterProxy stackValue: 3).
+
+ (interpreterProxy failed
+ "buffer can be any indexable words or bytes object except CompiledMethod"
+ or: [(interpreterProxy isWordsOrBytes: array) not]) ifTrue:
+ [^interpreterProxy primitiveFailFor: PrimErrBadArgument].
+
+ elementSize := (interpreterProxy isWords: array) ifTrue: [4] ifFalse: [1].
+ (startIndex >= 1
+ and: [(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)]) ifFalse:
+ [^interpreterProxy primitiveFailFor: PrimErrBadIndex].
+
+ "Note: adjust startIndex for zero-origin indexing"
+ bytesRead := self
+ sqFile: file
+ Read: count * elementSize
+ Into: (interpreterProxy cCoerce: (interpreterProxy firstIndexableField: array) to: #'char *')
+ At: (startIndex - 1) * elementSize.
+ interpreterProxy failed ifFalse:
+ [interpreterProxy
+ pop: 5 "pop rcvr, file, array, startIndex, count"
+ thenPush:(interpreterProxy integerObjectOf: bytesRead // elementSize) "push # of elements read"]!
Item was added:
+ ----- Method: FilePlugin>>primitiveFileReadWithoutPinning (in category 'file primitives') -----
+ primitiveFileReadWithoutPinning
+ "This version of primitiveFileRead is for garbage collectors without support for pinning."
+ | retryCount count startIndex array file elementSize bytesRead |
+ <inline: true>
+ <var: 'file' type: #'SQFile *'>
+ <var: 'count' type: #'size_t'>
+ <var: 'startIndex' type: #'size_t'>
+ <var: 'elementSize' type: #'size_t'>
+ retryCount := 0.
+ count := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
+ startIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
+
+ [array := interpreterProxy stackValue: 2.
+ file := self fileValueOf: (interpreterProxy stackValue: 3).
+
+ (interpreterProxy failed
+ "buffer can be any indexable words or bytes object except CompiledMethod"
+ or: [(interpreterProxy isWordsOrBytes: array) not]) ifTrue:
+ [^interpreterProxy primitiveFailFor: PrimErrBadArgument].
+
+ elementSize := (interpreterProxy isWords: array) ifTrue: [4] ifFalse: [1].
+ (startIndex >= 1
+ and: [(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)]) ifFalse:
+ [^interpreterProxy primitiveFailFor: PrimErrBadIndex].
+
+ "Note: adjust startIndex for zero-origin indexing"
+ bytesRead := self
+ sqFile: file
+ Read: count * elementSize
+ Into: (interpreterProxy cCoerce: (interpreterProxy firstIndexableField: array) to: #'char *')
+ At: (startIndex - 1) * elementSize.
+ interpreterProxy primitiveFailureCode = PrimErrObjectMayMove
+ and: [(retryCount := retryCount + 1) <= 2] "Two objects, the file and the array can move"] whileTrue:
+ [interpreterProxy
+ tenuringIncrementalGC;
+ primitiveFailFor: PrimNoErr].
+ interpreterProxy failed ifFalse:
+ [interpreterProxy
+ pop: 5 "pop rcvr, file, array, startIndex, count"
+ thenPush:(interpreterProxy integerObjectOf: bytesRead // elementSize) "push # of elements read"]!
Item was changed:
----- Method: FilePlugin>>primitiveFileSetPosition (in category 'file primitives') -----
primitiveFileSetPosition
+ | newPosition file |
- | newPosition file sz |
<var: 'file' type: 'SQFile *'>
<var: 'newPosition' type: 'squeakFileOffsetType'>
<export: true>
+ (interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > (self sizeof: #squeakFileOffsetType) ifTrue:
+ [^interpreterProxy primitiveFail].
- (interpreterProxy isIntegerObject: (interpreterProxy stackValue: 0)) ifFalse:
- [sz := self cCode: 'sizeof(squeakFileOffsetType)'.
- (interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > sz
- ifTrue: [^interpreterProxy primitiveFail]].
newPosition := interpreterProxy positive64BitValueOf: (interpreterProxy stackValue: 0).
file := self fileValueOf: (interpreterProxy stackValue: 1).
+ interpreterProxy failed ifFalse:
+ [self sqFile: file SetPosition: newPosition ].
+ interpreterProxy failed ifFalse:
+ [interpreterProxy pop: 2] "pop position, file; leave rcvr on stack"!
- interpreterProxy failed ifFalse:[
- self sqFile: file SetPosition: newPosition ].
- interpreterProxy failed ifFalse:[
- interpreterProxy pop: 2 "pop position, file; leave rcvr on stack" ].!
Item was changed:
----- Method: FilePlugin>>primitiveFileStdioHandles (in category 'file primitives') -----
primitiveFileStdioHandles
"Answer an Array of file handles for standard in, standard out and standard error,
with nil in entries that are unvailable, e.g. because the platform does not provide
standard error, etc. Fail if there are no standard i/o facilities on the platform or
if the security plugin denies access or if memory runs out."
| fileRecords result validMask |
<export: true>
<var: 'fileRecords' declareC: 'SQFile fileRecords[3]'>
sHFAfn ~= 0 ifTrue:
[(self cCode: ' ((sqInt (*)(void))sHFAfn)()' inSmalltalk: [true]) ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrUnsupported]].
self cCode: '' inSmalltalk: [fileRecords := Array new: 3].
validMask := self sqFileStdioHandlesInto: fileRecords.
validMask = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrUnsupported].
result := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 3.
result = nil ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoMemory].
interpreterProxy pushRemappableOop: result.
0 to: 2 do:
[:index|
(validMask bitAnd: (1 << index)) ~= 0 ifTrue:
[result := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self fileRecordSize.
result = nil ifTrue:
[interpreterProxy popRemappableOop.
^interpreterProxy primitiveFailFor: PrimErrNoMemory].
interpreterProxy storePointer: index ofObject: interpreterProxy topRemappableOop withValue: result.
self
cCode:
[self mem: (interpreterProxy firstIndexableField: result)
cp: (self addressOf: (fileRecords at: index))
y: self fileRecordSize]
inSmalltalk:
[(interpreterProxy firstIndexableField: result)
+ unitSize: interpreterProxy wordSize;
- unitSize: self bytesPerWord;
at: 0 put: (fileRecords at: index + 1)]]].
+ "In the non-Spur threaded VM ensure the handles are old, so that sqFileReadIntoAt is unaffected
+ by incremental GCs. See platforms/Cross/plugins/FilePlugin/sqFilePluginBasicPrims.c. The Spur
+ VM uses pinning, so it doesn't need the GC."
+
self isDefined: 'COGMTVM'
+ inSmalltalk: [ Smalltalk garbageCollect ]
- inSmalltalk: [Smalltalk garbageCollect]
comment: 'In the threaded VM ensure the handles are old, so that sqFileReadIntoAt is unaffected by incremental GCs. See platforms/Cross/plugins/FilePlugin/sqFilePluginBasicPrims.c.'
+ ifTrue: [ self isDefined: 'SPURVM'
+ inSmalltalk: [ ]
+ comment: 'The Spur VM uses pinning, so it does not need the GC.'
+ ifTrue: [ true ]
+ ifFalse: [ interpreterProxy fullGC ]. ].
+
- ifTrue: [interpreterProxy fullGC].
result := interpreterProxy popRemappableOop.
interpreterProxy pop: 1 thenPush: result!
Item was changed:
----- Method: FilePlugin>>primitiveFileTruncate (in category 'file primitives') -----
primitiveFileTruncate
"ftruncate is not an ansi function so we have a macro to point to a suitable platform implementation"
+ | truncatePosition file |
+ <var: 'file' type: #'SQFile *'>
+ <var: 'truncatePosition' type: #squeakFileOffsetType>
- | truncatePosition file sz |
- <var: 'file' type: 'SQFile *'>
- <var: 'truncatePosition' type: 'squeakFileOffsetType'>
<export: true>
+ (interpreterProxy isIntegerObject: (interpreterProxy stackValue: 0)) ifFalse:
+ [(interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > (self sizeof: #squeakFileOffsetType) ifTrue:
+ [^interpreterProxy primitiveFail]].
+ truncatePosition := interpreterProxy positive64BitValueOf: (interpreterProxy stackValue: 0).
- (interpreterProxy isIntegerObject: (interpreterProxy stackValue: 0))
- ifFalse: [sz := self cCode: 'sizeof(squeakFileOffsetType)'.
- (interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > sz
- ifTrue: [^ interpreterProxy primitiveFail]].
- truncatePosition := interpreterProxy
- positive64BitValueOf: (interpreterProxy stackValue: 0).
file := self fileValueOf: (interpreterProxy stackValue: 1).
+ interpreterProxy failed ifFalse:
+ [self sqFile: file Truncate: truncatePosition].
+ interpreterProxy failed ifFalse:
+ [interpreterProxy pop: 2 "pop position, file; leave rcvr on stack"]!
- interpreterProxy failed
- ifFalse: [self sqFile: file Truncate: truncatePosition].
- interpreterProxy failed
- ifFalse: [interpreterProxy pop: 2 "pop position, file; leave rcvr on stack"]!
Item was changed:
----- Method: FilePlugin>>primitiveFileWrite (in category 'file primitives') -----
primitiveFileWrite
+ | count startIndex array file elementSize bytesWritten |
- | count startIndex array file byteSize arrayIndex bytesWritten |
<var: 'file' type: 'SQFile *'>
- <var: 'arrayIndex' type: 'char *'>
<var: 'count' type: 'size_t'>
<var: 'startIndex' type: 'size_t'>
+ <var: 'elementSize' type: 'size_t'>
- <var: 'byteSize' type: 'size_t'>
<export: true>
count := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
startIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
array := interpreterProxy stackValue: 2.
file := self fileValueOf: (interpreterProxy stackValue: 3).
+
+ (interpreterProxy failed
+ "buffer can be any indexable words or bytes object except CompiledMethod"
+ or: [(interpreterProxy isWordsOrBytes: array) not]) ifTrue:
+ [^interpreterProxy primitiveFailFor: PrimErrBadArgument].
+
+ elementSize := (interpreterProxy isWords: array) ifTrue: [4] ifFalse: [1].
+ (startIndex >= 1
+ and: [(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)]) ifFalse:
+ [^interpreterProxy primitiveFailFor: PrimErrBadIndex].
+
+ "Note: adjust startIndex for zero-origin indexing"
+ bytesWritten := self
- "buffer can be any indexable words or bytes object except CompiledMethod "
- (interpreterProxy isWordsOrBytes: array)
- ifFalse: [^ interpreterProxy primitiveFail].
- (interpreterProxy isWords: array)
- ifTrue: [byteSize := 4]
- ifFalse: [byteSize := 1].
- (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)])
- ifFalse: [^ interpreterProxy primitiveFail].
- interpreterProxy failed
- ifFalse: [arrayIndex := interpreterProxy firstIndexableField: array.
- "Note: adjust startIndex for zero-origin indexing"
- bytesWritten := self
sqFile: file
+ Write: count * elementSize
+ From: (interpreterProxy cCoerce: (interpreterProxy firstIndexableField: array) to: #'char *')
+ At: startIndex - 1 * elementSize.
+ interpreterProxy failed ifFalse:
+ [interpreterProxy pop: 5 thenPush: (interpreterProxy integerObjectOf: bytesWritten // elementSize)]!
- Write: count * byteSize
- From: arrayIndex
- At: startIndex - 1 * byteSize].
- interpreterProxy failed
- ifFalse: [interpreterProxy pop: 5 thenPush:( interpreterProxy integerObjectOf: bytesWritten // byteSize)]!
Item was changed:
InterpreterPrimitives subclass: #Interpreter
+ instanceVariableNames: 'semaphoresUseBufferA semaphoresToSignalA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB'
+ classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase MaxExternalPrimitiveTableSize MaxPrimitiveIndex SemaphoresToSignalSize'
- instanceVariableNames: ''
- classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase MaxExternalPrimitiveTableSize MaxPrimitiveIndex'
poolDictionaries: ''
category: 'VMMaker-Interpreter'!
!Interpreter commentStamp: 'dtl 4/22/2016 22:14' prior: 0!
This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas.
ContextInterpreter is the Squeak interpreter VM as originally implemented by Dan Ingalls.
StackInterpreter is the stack mapped interpreter by Eliot Miranda, which provides the basis for later Cog and Spur VMs.!
Item was changed:
----- Method: Interpreter class>>declareCVarsIn: (in category 'translation') -----
+ declareCVarsIn: aCCodeGenerator
- declareCVarsIn: aCCodeGenerator
- aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[' , (MaxPrimitiveIndex + 2) printString , '] )(void)= ' , self primitiveTableString.
- aCCodeGenerator var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[' , (MaxExternalPrimitiveTableSize + 1) printString , '])(void)'.
+ aCCodeGenerator var: 'semaphoresToSignalA' declareC: 'sqInt semaphoresToSignalA[' , (SemaphoresToSignalSize + 1) printString , ']'.
+ aCCodeGenerator var: 'semaphoresToSignalB' declareC: 'sqInt semaphoresToSignalB[' , (SemaphoresToSignalSize + 1) printString , ']'.
+
!
Item was changed:
----- Method: Interpreter class>>initialize (in category 'initialization') -----
initialize
"Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)"
MaxExternalPrimitiveTableSize := 4096. "entries"
self initializeCaches.
+ SemaphoresToSignalSize := 500.
+
!
Item was added:
+ ----- 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 primitiveFail) "Blue Book: primitiveBlockCopy"
+ (81 primitiveFail) "Blue Book: primitiveValue"
+ (82 primitiveFail) "Blue Book: 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 primitiveFail) "was primitiveValueUninterruptably"
+ (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 for context interpreter"
+ (256 primitivePushSelf)
+ (257 primitivePushTrue)
+ (258 primitivePushFalse)
+ (259 primitivePushNil)
+ (260 primitivePushMinusOne)
+ (261 primitivePushZero)
+ (262 primitivePushOne)
+ (263 primitivePushTwo)
+
+ "Quick push inst var methods (next 256) for context interpreter"
+ (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: Interpreter class>>primitiveTableString (in category 'translation') -----
+ primitiveTableString
+ "Interpreter initializePrimitiveTable primitiveTableString"
+
+ self flag: #FIXME. "Implemented differently in context versus stack interpreters. Not sure
+ if this is required by different handling of the table at runtime, or if it is just
+ a TODO for refactoring. -dtl Sept 2016"!
Item was added:
+ ----- Method: Interpreter>>byteSwapByteObjectsFrom:to: (in category 'utilities') -----
+ 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: Interpreter>>initializeInterpreter (in category 'initialization') -----
+ initializeInterpreter
+ semaphoresUseBufferA := true.
+ semaphoresToSignalCountA := 0.
+ semaphoresToSignalCountB := 0.
+ !
Item was added:
+ ----- Method: Interpreter>>signalExternalSemaphores (in category 'process primitive support') -----
+ signalExternalSemaphores
+ "Signal all requested semaphores"
+
+ "n.b.StackInterpreter references doSignalExternalSemaphores implemented
+ externally in the oscog platform sources Cross/vm/sqExternalSemaphores.c."
+
+ self subclassResponsibility.!
Item was added:
+ ----- 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 added:
+ ----- 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: 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 added:
+ ----- Method: InterpreterPrimitives>>cStringOrNullFor: (in category 'primitive support') -----
+ cStringOrNullFor: oop
+ "Answer either a malloced string with the null-terminated contents of oop if oop is a string,
+ or the null pointer if oop is nil, or fail. It is the client's responsibility to free the string later."
+ <api>
+ <returnTypeC: #'char *'>
+ | isString len cString |
+ <var: 'cString' type: #'char *'>
+ isString := self isInstanceOfClassByteString: oop.
+ isString ifFalse:
+ [oop ~= objectMemory nilObject ifTrue:
+ [self primitiveFailFor: PrimErrBadArgument].
+ ^0].
+ len := objectMemory lengthOf: oop.
+ len = 0 ifTrue:
+ [^0].
+ cString := self malloc: len + 1.
+ cString ifNil:
+ [self primitiveFailFor: PrimErrNoCMemory.
+ ^0].
+ self mem: cString cp: (objectMemory firstIndexableField: oop) y: len.
+ cString at: len put: 0.
+ ^cString!
Item was added:
+ ----- Method: InterpreterPrimitives>>positiveMachineIntegerValueOf: (in category 'primitive support') -----
+ positiveMachineIntegerValueOf: oop
+ "Answer a value of an integer in address range, i.e up to the size of a machine word.
+ The object may be either a positive SmallInteger or a LargePositiveInteger of size <= word size."
+ <returnTypeC: #'unsigned long'>
+ <inline: true> "only two callers & one is primitiveNewWithArg"
+ | value bs ok |
+ (objectMemory isIntegerObject: oop) ifTrue:
+ [value := objectMemory integerValueOf: oop.
+ value < 0 ifTrue: [^self primitiveFail].
+ ^value].
+
+ (objectMemory isNonIntegerImmediate: oop) ifTrue:
+ [self primitiveFail.
+ ^0].
+
+ ok := objectMemory
+ isClassOfNonImm: oop
+ equalTo: (objectMemory splObj: ClassLargePositiveInteger)
+ compactClassIndex: ClassLargePositiveIntegerCompactIndex.
+ ok ifFalse:
+ [self primitiveFail.
+ ^0].
+ bs := objectMemory numBytesOfBytes: oop.
+ bs > (self sizeof: #'unsigned long') ifTrue:
+ [self primitiveFail.
+ ^0].
+
+ ((self sizeof: #'unsigned long') = 8
+ and: [bs > 4]) ifTrue:
+ [^self isBigEnder
+ ifTrue:
+ [ (objectMemory fetchByte: 0 ofObject: oop)
+ + ((objectMemory fetchByte: 1 ofObject: oop) << 8)
+ + ((objectMemory fetchByte: 2 ofObject: oop) << 16)
+ + ((objectMemory fetchByte: 3 ofObject: oop) << 24)
+ + ((objectMemory fetchByte: 4 ofObject: oop) << 32)
+ + ((objectMemory fetchByte: 5 ofObject: oop) << 40)
+ + ((objectMemory fetchByte: 6 ofObject: oop) << 48)
+ + ((objectMemory fetchByte: 7 ofObject: oop) << 56)]
+ ifFalse:
+ [objectMemory fetchLong64: 0 ofObject: oop]]
+ ifFalse:
+ [^self isBigEnder
+ ifTrue:
+ [ (objectMemory fetchByte: 0 ofObject: oop)
+ + ((objectMemory fetchByte: 1 ofObject: oop) << 8)
+ + ((objectMemory fetchByte: 2 ofObject: oop) << 16)
+ + ((objectMemory fetchByte: 3 ofObject: oop) << 24)]
+ ifFalse:
+ [objectMemory fetchLong32: 0 ofObject: oop]]!
Item was added:
+ ----- Method: InterpreterPrimitives>>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 changed:
----- Method: InterpreterPrimitives>>primitiveFindHandlerContext (in category 'control primitives') -----
primitiveFindHandlerContext
+ "Primitive. Search up the context stack for the next method context marked
+ for exception handling starting at the receiver. Return nil if none found"
+ self subclassResponsibility!
- "Primitive. Search up the context stack for the next method context marked for exception handling starting at the receiver. Return nil if none found"
- | thisCntx nilOop |
- thisCntx := self popStack.
- nilOop := objectMemory getNilObj.
-
- [(self isHandlerMarked: thisCntx) ifTrue:[
- self push: thisCntx.
- ^nil].
- thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- thisCntx = nilOop] whileFalse.
-
- ^self push: objectMemory getNilObj!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveFindNextUnwindContext (in category 'control primitives') -----
primitiveFindNextUnwindContext
+ "Primitive. Search up the context stack for the next method context marked for unwind
+ handling from the receiver up to but not including the argument. Return nil if none found."
+ self subclassResponsibility!
- "Primitive. Search up the context stack for the next method context marked for unwind handling from the receiver up to but not including the argument. Return nil if none found."
- | thisCntx nilOop aContext unwindMarked |
- aContext := self popStack.
- thisCntx := objectMemory fetchPointer: SenderIndex ofObject: self popStack.
- nilOop := objectMemory getNilObj.
-
- [(thisCntx = aContext) or: [thisCntx = nilOop]] whileFalse: [
- unwindMarked := self isUnwindMarked: thisCntx.
- unwindMarked ifTrue:[
- self push: thisCntx.
- ^nil].
- thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx].
-
- ^self push: nilOop!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveFormPrint (in category 'I/O primitives') -----
primitiveFormPrint
"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h
depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '>
<var: #hScale type: 'double '>
landscapeFlag := self booleanValueOf: self stackTop.
vScale := self floatValueOf: (self stackValue: 1).
hScale := self floatValueOf: (self stackValue: 2).
rcvr := self stackValue: 3.
(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
self successful ifTrue: [
((objectMemory isPointers: rcvr) and: [(objectMemory lengthOf: rcvr) >= 4])
ifFalse: [self success: false]].
self successful ifTrue: [
bitsArray := objectMemory fetchPointer: 0 ofObject: rcvr.
w := self fetchInteger: 1 ofObject: rcvr.
h := self fetchInteger: 2 ofObject: rcvr.
depth := self fetchInteger: 3 ofObject: rcvr.
(w > 0 and: [h > 0]) ifFalse: [self success: false].
pixelsPerWord := 32 // depth.
wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
((rcvr isIntegerObject: rcvr) not and: [objectMemory isWordsOrBytes: bitsArray])
ifTrue: [
+ bitsArraySize := objectMemory byteLengthOf: bitsArray.
- bitsArraySize := self byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
self successful ifTrue: [
objectMemory bytesPerWord = 8
ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)']
ifFalse: [ok := self cCode: 'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'].
self success: ok].
self successful ifTrue: [
self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePushFalse (in category 'quick primitives - context interpreter') -----
+ primitivePushFalse
+ self popStack.
+ self push: objectMemory getFalseObj!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePushMinusOne (in category 'quick primitives - context interpreter') -----
+ primitivePushMinusOne
+ self popStack.
+ self push: ConstMinusOne!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePushNil (in category 'quick primitives - context interpreter') -----
+ primitivePushNil
+ self popStack.
+ self push: objectMemory getNilObj!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePushOne (in category 'quick primitives - context interpreter') -----
+ primitivePushOne
+ self popStack.
+ self push: ConstOne!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePushSelf (in category 'quick primitives - context interpreter') -----
+ primitivePushSelf
+ " no-op, really...
+ thisReceiver := self popStack.
+ self push: thisReceiver
+ "!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePushTrue (in category 'quick primitives - context interpreter') -----
+ primitivePushTrue
+ self popStack.
+ self push: objectMemory getTrueObj!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePushTwo (in category 'quick primitives - context interpreter') -----
+ primitivePushTwo
+ self popStack.
+ self push: ConstTwo!
Item was added:
+ ----- Method: InterpreterPrimitives>>primitivePushZero (in category 'quick primitives - context interpreter') -----
+ primitivePushZero
+ self popStack.
+ self push: ConstZero!
Item was added:
+ ----- Method: InterpreterPrimitives>>signalNoResume: (in category 'primitive support') -----
+ signalNoResume: aSemaphore
+ "Signal the given semaphore from within the interpreter. Used to serialize callbacks."
+ | empty |
+ <api>
+ <inline: false>
+ empty := self isEmptyList: aSemaphore.
+ empty ifFalse:
+ [self putToSleep: (self removeFirstLinkOfList: aSemaphore) yieldingIf: true].
+ ^empty!
Item was added:
+ ----- Method: InterpreterPrimitives>>signedMachineIntegerValueOf: (in category 'primitive support') -----
+ signedMachineIntegerValueOf: oop
+ "Answer a signed value of an integer up to the size of a machine word.
+ The object may be either a positive SmallInteger or a LargeInteger of size <= word size."
+ <returnTypeC: #'long'>
+ | negative ok bs value bits |
+ <var: #value type: #long>
+ (objectMemory isIntegerObject: oop) ifTrue:
+ [^objectMemory integerValueOf: oop].
+
+ (objectMemory isNonIntegerImmediate: oop) ifTrue:
+ [^self primitiveFail].
+
+ ok := objectMemory isClassOfNonImm: oop
+ equalTo: (objectMemory splObj: ClassLargePositiveInteger)
+ compactClassIndex: ClassLargePositiveIntegerCompactIndex.
+ ok
+ ifTrue: [negative := false]
+ ifFalse:
+ [negative := true.
+ ok := objectMemory isClassOfNonImm: oop
+ equalTo: (objectMemory splObj: ClassLargeNegativeInteger)
+ compactClassIndex: ClassLargeNegativeIntegerCompactIndex.
+ ok ifFalse: [^self primitiveFail]].
+ bs := objectMemory numBytesOf: oop.
+ bs > (self sizeof: #'unsigned long') ifTrue:
+ [^self primitiveFail].
+
+ ((self sizeof: #'unsigned long') = 8
+ and: [bs > 4]) ifTrue:
+ [value := self isBigEnder
+ ifTrue:
+ [ (objectMemory fetchByte: 0 ofObject: oop)
+ + ((objectMemory fetchByte: 1 ofObject: oop) << 8)
+ + ((objectMemory fetchByte: 2 ofObject: oop) << 16)
+ + ((objectMemory fetchByte: 3 ofObject: oop) << 24)
+ + ((objectMemory fetchByte: 4 ofObject: oop) << 32)
+ + ((objectMemory fetchByte: 5 ofObject: oop) << 40)
+ + ((objectMemory fetchByte: 6 ofObject: oop) << 48)
+ + ((objectMemory fetchByte: 7 ofObject: oop) << 56)]
+ ifFalse:
+ [objectMemory fetchLong64: 0 ofObject: oop]]
+ ifFalse:
+ [value := self isBigEnder
+ ifTrue:
+ [ (objectMemory fetchByte: 0 ofObject: oop)
+ + ((objectMemory fetchByte: 1 ofObject: oop) << 8)
+ + ((objectMemory fetchByte: 2 ofObject: oop) << 16)
+ + ((objectMemory fetchByte: 3 ofObject: oop) << 24)]
+ ifFalse:
+ [(objectMemory fetchLong32: 0 ofObject: oop) asUnsignedInteger]].
+
+ self cCode: []
+ inSmalltalk:
+ [bits := (self sizeof: #long) * 8.
+ (value bitShift: 1 - bits) > 0 ifTrue:
+ [value := value - (1 bitShift: bits)]].
+ value < 0 ifTrue:
+ ["Don't fail for -16r80000000[00000000].
+ Alas the simple (negative and: [value - 1 > 0]) isn't adequate since in C the result of signed integer
+ overflow is undefined and hence under optimization this may fail. The shift, however, is well-defined."
+ (negative and: [0 = (self cCode: [value << 1]
+ inSmalltalk: [value << 1 bitAnd: (1 << bits) - 1])]) ifTrue:
+ [^value].
+ ^self primitiveFail].
+ ^negative
+ ifTrue: [0 - value]
+ ifFalse: [value]!
Item was added:
+ ----- Method: InterpreterPrimitives>>sizeFieldOfAlien: (in category 'primitive support') -----
+ sizeFieldOfAlien: alienObj
+ "Answer the first field of alienObj which is assumed to be an Alien of at least 8 bytes"
+ <inline: true>
+ ^self longAt: alienObj + objectMemory baseHeaderSize!
Item was added:
+ ----- Method: InterpreterPrimitives>>sizeOfAlienData: (in category 'primitive support') -----
+ sizeOfAlienData: oop
+ "Answer the start of the Alien's data or fail if oop is not an Alien."
+ <api>
+ <returnTypeC: #usqInt>
+ | size |
+ (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifFalse:
+ [self primitiveFailFor: PrimErrBadArgument.
+ ^0].
+ size := self sizeFieldOfAlien: oop.
+ ^size abs!
Item was added:
+ ----- Method: InterpreterPrimitives>>startOfAlienData: (in category 'primitive support') -----
+ startOfAlienData: oop
+ "Answer the start of the Alien's data or fail if oop is not an Alien."
+ <api>
+ <returnTypeC: #'void *'>
+ (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifFalse:
+ [self primitiveFailFor: PrimErrBadArgument.
+ ^0].
+ ^self cCoerceSimple: ((self isDirectAlien: oop)
+ ifTrue: [oop + objectMemory baseHeaderSize + objectMemory bytesPerOop]
+ ifFalse: [self longAt: oop + objectMemory baseHeaderSize + objectMemory bytesPerOop])
+ to: #'void *'!
Item was added:
+ ----- Method: InterpreterProxy>>characterObjectOf: (in category 'object access') -----
+ characterObjectOf: characterCode
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^StackInterpreter objectMemoryClass characterObjectOf: characterCode!
Item was removed:
- ----- Method: InterpreterStackPage>>baseAddress: (in category 'accessing') -----
- baseAddress: anAddress
- ^baseAddress := anAddress!
Item was removed:
- ----- Method: InterpreterStackPage>>baseFP: (in category 'accessing') -----
- baseFP: pointer "<Integer>"
- "Set the value of baseFP"
- self assert: (pointer = 0 or: [pointer < baseAddress and: [realStackLimit < pointer]]).
- ^baseFP := pointer!
Item was removed:
- ----- Method: InterpreterStackPage>>headFP: (in category 'accessing') -----
- headFP: pointer "<Integer>"
- "Set the value of headFP"
- "N.B. This assert is run in simulation only because headFP:
- becomes a simple field assignment in the C code."
- self assert: (pointer = 0 or: [pointer < baseAddress and: [realStackLimit - (LargeContextBytes / 2) <= pointer]]).
- ^headFP := pointer!
Item was removed:
- ----- Method: InterpreterStackPage>>headSP: (in category 'accessing') -----
- headSP: pointer "<Integer>"
- "Set the value of headSP"
- "N.B. This assert is run in simulation only because headFP:
- becomes a simple field assignment in the C code."
- self assert: (pointer = 0 or: [pointer < baseAddress and: [realStackLimit - LargeContextBytes <= pointer]]).
- ^headSP := pointer!
Item was removed:
- ----- Method: InterpreterStackPage>>lastAddress: (in category 'accessing') -----
- lastAddress: anAddress
- ^lastAddress := anAddress!
Item was removed:
- ----- Method: InterpreterStackPage>>nextPage: (in category 'accessing') -----
- nextPage: anObject
- "Set the value of nextPage"
-
- ^nextPage := anObject!
Item was removed:
- ----- Method: InterpreterStackPage>>prevPage: (in category 'accessing') -----
- prevPage: anObject
- "Set the value of prevPage"
-
- ^prevPage := anObject!
Item was removed:
- ----- Method: InterpreterStackPage>>realStackLimit: (in category 'accessing') -----
- realStackLimit: anObject
- "Set the value of realStackLimit"
-
- ^realStackLimit := anObject!
Item was added:
+ ----- Method: InterpreterStackPage>>setBaseAddress: (in category 'accessing') -----
+ setBaseAddress: anAddress
+ ^baseAddress := anAddress!
Item was added:
+ ----- Method: InterpreterStackPage>>setBaseFP: (in category 'accessing') -----
+ setBaseFP: pointer "<Integer>"
+ "Set the value of baseFP"
+ self assert: (pointer = 0 or: [pointer < baseAddress and: [realStackLimit < pointer]]).
+ ^baseFP := pointer!
Item was added:
+ ----- Method: InterpreterStackPage>>setHeadFP: (in category 'accessing') -----
+ setHeadFP: pointer "<Integer>"
+ "Set the value of headFP"
+ "N.B. This assert is run in simulation only because headFP:
+ becomes a simple field assignment in the C code."
+ self assert: (pointer = 0 or: [pointer < baseAddress and: [realStackLimit - (LargeContextBytes / 2) <= pointer]]).
+ ^headFP := pointer!
Item was added:
+ ----- Method: InterpreterStackPage>>setHeadSP: (in category 'accessing') -----
+ setHeadSP: pointer "<Integer>"
+ "Set the value of headSP"
+ "N.B. This assert is run in simulation only because headFP:
+ becomes a simple field assignment in the C code."
+ self assert: (pointer = 0 or: [pointer < baseAddress and: [realStackLimit - LargeContextBytes <= pointer]]).
+ ^headSP := pointer!
Item was added:
+ ----- Method: InterpreterStackPage>>setLastAddress: (in category 'accessing') -----
+ setLastAddress: anAddress
+ ^lastAddress := anAddress!
Item was added:
+ ----- Method: InterpreterStackPage>>setNextPage: (in category 'accessing') -----
+ setNextPage: anObject
+ "Set the value of nextPage"
+
+ ^nextPage := anObject!
Item was added:
+ ----- Method: InterpreterStackPage>>setPrevPage: (in category 'accessing') -----
+ setPrevPage: anObject
+ "Set the value of prevPage"
+
+ ^prevPage := anObject!
Item was added:
+ ----- Method: InterpreterStackPage>>setRealStackLimit: (in category 'accessing') -----
+ setRealStackLimit: anObject
+ "Set the value of realStackLimit"
+
+ ^realStackLimit := anObject!
Item was added:
+ ----- Method: InterpreterStackPage>>setStackLimit: (in category 'accessing') -----
+ setStackLimit: anObject
+ "Set the value of stackLimit"
+
+ ^stackLimit := anObject!
Item was added:
+ ----- Method: InterpreterStackPage>>setTrace: (in category 'accessing') -----
+ setTrace: anInteger
+ "Set the page's trace state.
+ 0 = untraced. 1 = should be traced. 2 = has been traced.
+ -1 = invalid (for assertions)"
+ ^trace := anInteger!
Item was removed:
- ----- Method: InterpreterStackPage>>trace: (in category 'accessing') -----
- trace: anInteger
- "Set the page's trace state.
- 0 = untraced. 1 = should be traced. 2 = has been traced.
- -1 = invalid (for assertions)"
- ^trace := anInteger!
Item was changed:
----- Method: InterpreterStackPages>>freeStackPageNoAssert: (in category 'page access') -----
freeStackPageNoAssert: aPage "<InterpreterStackPage>"
"MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
| prev |
<var: #aPage type: #'StackPage *'>
<var: #prev type: #'StackPage *'>
+ aPage setBaseFP: 0.
- aPage baseFP: 0.
aPage == mostRecentlyUsedPage ifTrue:
[mostRecentlyUsedPage := mostRecentlyUsedPage prevPage.
^nil].
"lack of type inferrence means ``self isFree: aPage prevPage''
isn't turned into a direct field test; sigh..."
prev := aPage prevPage.
(self isFree: prev) ifTrue:
[^nil].
+ prev setNextPage: aPage nextPage.
+ aPage nextPage setPrevPage: prev.
+ aPage setNextPage: mostRecentlyUsedPage nextPage.
+ mostRecentlyUsedPage nextPage setPrevPage: aPage.
+ aPage setPrevPage: mostRecentlyUsedPage.
+ mostRecentlyUsedPage setNextPage: aPage!
- prev nextPage: aPage nextPage.
- aPage nextPage prevPage: prev.
- aPage nextPage: mostRecentlyUsedPage nextPage.
- mostRecentlyUsedPage nextPage prevPage: aPage.
- aPage prevPage: mostRecentlyUsedPage.
- mostRecentlyUsedPage nextPage: aPage!
Item was changed:
----- Method: InterpreterStackPages>>initializeStack:numSlots:pageSize: (in category 'initialization') -----
initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage
"Initialize the stack pages. For testing I want stack addresses to be disjoint from
normal memory addresses so stack addresses are negative. The first address is
-pageSize bytes. So for example if there are 1024 bytes per page and 3 pages
then the pages are organized as
byte address: -1024 <-> -2047 | -2048 <-> -3071 | -3072 <-> -4096 |
page 3 page 2 page 1
mem index: 769 <-> 513 | 512 <-> 257 | 256 <-> 1 |
The byte address is the external address corresponding to a real address in the VM.
mem index is the index in the memory Array holding the stack, an index internal to
the stack pages. The first stack page allocated will be the last page in the array of pages
at the highest effective address. Its base address be -1024 and grow down towards -2047."
"The lFoo's are to get around the foo->variable scheme in the C call to allocStackPages below."
<var: #theStackPages type: #'char *'>
| page structStackPageSize pageStructBase count |
<var: #page type: #'StackPage *'>
<var: #pageStructBase type: #'char *'>
self cCode: ''
inSmalltalk:
[self assert: stackMemory size = stackSlots.
self assert: stackMemory size - self extraStackBytes \\ slotsPerPage = 0.
self assert: stackMemory == theStackPages].
stackMemory := theStackPages. "For initialization in the C code."
self cCode: '' inSmalltalk: [pageSizeInSlots := slotsPerPage].
structStackPageSize := interpreter sizeof: InterpreterStackPage.
bytesPerPage := slotsPerPage * self bytesPerWord.
numPages := stackSlots // (slotsPerPage + (structStackPageSize / self bytesPerWord)).
"Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
subtracting bytesPerWord from baseAddress and lastAddress in the init loop below we simply
push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
pageStructBase := theStackPages + (numPages * bytesPerPage) + self bytesPerWord.
pages := self cCode: '(StackPage *)pageStructBase'
inSmalltalk:
[pageStructBase class.
(1 to: numPages) collect: [:i| InterpreterStackPage new]].
"Simulation only. Since addresses are negative the offset is positive. To make all
stack addresses negative we make the offset a page more than it needs to be so the
address of the last slot in memory (the highest address in the stack, or its start) is
- pageByteSize
and the address of the first slot (the lowest address, or its end) is
- pageByteSize * (numPages + 1)"
self cCode: '' inSmalltalk: [indexOffset := (numPages + 1) * slotsPerPage].
"make sure there's enough headroom"
self assert: interpreter stackPageByteSize - interpreter stackLimitBytes - interpreter stackLimitOffset
>= interpreter stackPageHeadroom.
0 to: numPages - 1 do:
[:index|
page := self stackPageAt: index.
page
+ setLastAddress: (self cCode: '(char *)theStackPages + (index * GIV(bytesPerPage))'
- lastAddress: (self cCode: '(char *)theStackPages + (index * GIV(bytesPerPage))'
inSmalltalk: [(index * slotsPerPage - indexOffset) * self bytesPerWord]);
+ setBaseAddress: (page lastAddress + bytesPerPage);
+ setStackLimit: page baseAddress - interpreter stackLimitBytes;
+ setRealStackLimit: page stackLimit;
+ setBaseFP: 0;
+ setNextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
+ setPrevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
- baseAddress: (page lastAddress + bytesPerPage);
- stackLimit: page baseAddress - interpreter stackLimitBytes;
- realStackLimit: page stackLimit;
- baseFP: 0;
- nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
- prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
self cCode: ''
inSmalltalk:
[| lowestAddress highestAddress |
lowestAddress := (pages at: 1) lastAddress + self bytesPerWord.
highestAddress := (pages at: numPages) baseAddress.
"see InterpreterStackPages>>longAt:"
self assert: lowestAddress // self bytesPerWord + indexOffset = 1.
self assert: highestAddress // self bytesPerWord + indexOffset = (numPages * slotsPerPage)].
"The overflow limit is the amount of stack to retain when moving frames from an overflowing
stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
page := self stackPageAt: 0.
overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
0 to: numPages - 1 do:
[:index|
page := self stackPageAt: index.
self assert: (self pageIndexFor: page baseAddress) == index.
self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * self bytesPerWord)) == index.
self assert: (self stackPageFor: page baseAddress) == page.
self assert: (self stackPageFor: page stackLimit) == page.
self cCode: ''
inSmalltalk:
[| memIndex |
memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
== (memIndex + slotsPerPage - 1).
index < (numPages - 1) ifTrue:
[self assert: (self stackPageFor: page baseAddress + self bytesPerWord) == (self stackPageAt: index + 1)]].
+ self assert: (page setTrace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"].
- self assert: (page trace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"].
mostRecentlyUsedPage := self stackPageAt: 0.
page := mostRecentlyUsedPage.
count := 0.
[| theIndex |
count := count + 1.
theIndex := self pageIndexFor: page baseAddress.
self assert: (self stackPageAt: theIndex) == page.
self assert: (self pageIndexFor: page baseAddress) == theIndex.
self assert: (self pageIndexFor: page stackLimit) == theIndex.
self assert: (self pageIndexFor: page lastAddress + self bytesPerWord) == theIndex.
(page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
self assert: count == numPages.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>longAt: (in category 'memory access') -----
longAt: byteAddress
"Note: Adjusted for Smalltalk's 1-based array indexing."
+ <doNotGenerate>
self assert: (byteAddress bitAnd: self bytesPerWord - 1) == 0.
^stackMemory at: byteAddress // self bytesPerWord + indexOffset!
Item was changed:
----- Method: InterpreterStackPages>>longAt:put: (in category 'memory access') -----
longAt: byteAddress put: a32BitValue
"Note: Adjusted for Smalltalk's 1-based array indexing."
+ <doNotGenerate>
self assert: (byteAddress bitAnd: self bytesPerWord - 1) == 0.
^stackMemory at: byteAddress // self bytesPerWord + indexOffset put: a32BitValue!
Item was changed:
----- Method: InterpreterStackPages>>markStackPageLeastMostRecentlyUsed: (in category 'page access') -----
markStackPageLeastMostRecentlyUsed: page "<InterpreterStackPage>"
"This method is used to move a page to the end of the used pages.
This is to keep asserts checking pageListIsWellFormed happy."
"MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
<var: #page type: #'StackPage *'>
<returnTypeC: #void>
| lastUsedPage |
<var: #lastUsedPage type: #'StackPage *'>
self assert: page = mostRecentlyUsedPage nextPage.
lastUsedPage := page nextPage.
[lastUsedPage isFree] whileTrue:
[lastUsedPage := lastUsedPage nextPage].
lastUsedPage nextPage = page ifTrue:
[^nil].
+ page prevPage setNextPage: page nextPage.
+ page nextPage setPrevPage: page prevPage.
+ lastUsedPage prevPage setNextPage: page.
+ page setPrevPage: lastUsedPage prevPage.
+ page setNextPage: lastUsedPage.
+ lastUsedPage setPrevPage: page.
- page prevPage nextPage: page nextPage.
- page nextPage prevPage: page prevPage.
- lastUsedPage prevPage nextPage: page.
- page prevPage: lastUsedPage prevPage.
- page nextPage: lastUsedPage.
- lastUsedPage prevPage: page.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>markStackPageMostRecentlyUsed: (in category 'page access') -----
markStackPageMostRecentlyUsed: page "<InterpreterStackPage>"
"MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
<var: #page type: #'StackPage *'>
<asmLabel: false>
page == mostRecentlyUsedPage ifTrue:
[^nil].
"Common case; making new page most recently used."
page prevPage == mostRecentlyUsedPage ifTrue:
[mostRecentlyUsedPage := page.
self assert: self pageListIsWellFormed.
^nil].
+ page prevPage setNextPage: page nextPage.
+ page nextPage setPrevPage: page prevPage.
+ mostRecentlyUsedPage nextPage setPrevPage: page.
+ page setPrevPage: mostRecentlyUsedPage.
+ page setNextPage: mostRecentlyUsedPage nextPage.
+ mostRecentlyUsedPage setNextPage: page.
- page prevPage nextPage: page nextPage.
- page nextPage prevPage: page prevPage.
- mostRecentlyUsedPage nextPage prevPage: page.
- page prevPage: mostRecentlyUsedPage.
- page nextPage: mostRecentlyUsedPage nextPage.
- mostRecentlyUsedPage nextPage: page.
mostRecentlyUsedPage := page.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>markStackPageNextMostRecentlyUsed: (in category 'page access') -----
markStackPageNextMostRecentlyUsed: page "<InterpreterStackPage>"
"This method is used to move a page to a position in the list such that it cannot
be deallocated when a new page is allocated, without changing the most recently
used page. There must be at least 3 pages in the system. So making the page
the MRU's prevPage is sufficient to ensure it won't be deallocated."
"MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
<var: #page type: #'StackPage *'>
self assert: page ~~ mostRecentlyUsedPage.
page nextPage == mostRecentlyUsedPage ifTrue:
[^nil].
+ page prevPage setNextPage: page nextPage.
+ page nextPage setPrevPage: page prevPage.
+ mostRecentlyUsedPage prevPage setNextPage: page.
+ page setPrevPage: mostRecentlyUsedPage prevPage.
+ page setNextPage: mostRecentlyUsedPage.
+ mostRecentlyUsedPage setPrevPage: page.
- page prevPage nextPage: page nextPage.
- page nextPage prevPage: page prevPage.
- mostRecentlyUsedPage prevPage nextPage: page.
- page prevPage: mostRecentlyUsedPage prevPage.
- page nextPage: mostRecentlyUsedPage.
- mostRecentlyUsedPage prevPage: page.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>pageIndexFor:stackMemory:bytesPerPage: (in category 'page access') -----
pageIndexFor: pointer "<Integer>" stackMemory: stackmem "<Integer>" bytesPerPage: pageByteSize "<Integer>"
"Answer the page index for a pointer into stack memory, i.e. the index
for the page the address is in. N.B. This is a zero-relative index."
+
+ <var: #pointer type: 'char *'>
+ self flag: #FIXME. "dtl - oscog original source below for reference. Was coded to use C macro at code
+ generation time, such that the Smalltalk would run in simulation. Maybe too clever by half.
+ For now write it in slang and implement simulator override later. If the C macro
+ approach is needed, adopt it from the oscog code generator, see #definedAsMacro.
+ But note that C macros provide no performance benefit, and add obfuscation."
+
+ ^ pointer - stackmem - 1 / pageByteSize
+
+ "| memIndex |
- | memIndex |
<cmacro: '(pointer,stackmem,pageByteSize) (((char *)(pointer) - (stackmem) - 1) / (pageByteSize))'>
memIndex := self memIndexFor: pointer.
self assert: (memIndex between: 1 and: stackMemory size).
+ ^memIndex - 1 // pageSizeInSlots"!
- ^memIndex - 1 // pageSizeInSlots!
Item was added:
+ ----- Method: ObjectMemory class>>characterObjectOf: (in category 'simulation only') -----
+ characterObjectOf: characterCode
+ ^(characterCode between: 0 and: 255) ifTrue:
+ [characterCode asCharacter]!
Item was added:
+ ----- Method: ObjectMemory>>byteLengthOf: (in category '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 := self baseHeader: oop.
+ (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self allButTypeMask ]
+ ifFalse: [ sz := header bitAnd: self sizeMask ].
+ fmt := (header >> 8) bitAnd: 16rF.
+ fmt < 8
+ ifTrue: [ ^ (sz - self baseHeaderSize)] "words"
+ ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was added:
+ ----- Method: ObjectMemory>>characterObjectOf: (in category 'object access') -----
+ characterObjectOf: characterCode
+ <api>
+ ^(characterCode between: 0 and: 255)
+ ifTrue: [self fetchPointer: characterCode ofObject: self characterTable]
+ ifFalse: [nilObj]!
Item was added:
+ ----- Method: ObjectMemory>>characterTable (in category 'plugin support') -----
+ characterTable
+ <api>
+ ^self splObj: CharacterTable!
Item was added:
+ ----- Method: ObjectMemory>>checkCompactIndex:isClass:named: (in category 'initialization') -----
+ checkCompactIndex: compactIndex isClass: specialIndex named: name
+ "Check that a class the VM assumes is compact has the right index."
+ <inline: true> "macrofication of the name arg in invalidCompactClassError only works if this method is inlined so the name is a string literal not a parameter"
+ (compactIndex ~= 0
+ and: [(self splObj: specialIndex) ~= (self compactClassAt: compactIndex)]) ifTrue:
+ [self invalidCompactClassError: name]!
Item was added:
+ ----- Method: ObjectMemory>>checkOopIntegrity:named: (in category 'debug support') -----
+ checkOopIntegrity: obj named: name
+ <inline: false>
+ <var: #name type: #'char *'>
+ (self heapMapAtWord: (self pointerForOop: obj)) ~= 0 ifTrue:
+ [^true].
+ self print: name; print: ' leak '; printHex: obj; cr.
+ ^false!
Item was added:
+ ----- Method: ObjectMemory>>checkOopIntegrity:named:index: (in category 'debug support') -----
+ checkOopIntegrity: obj named: name index: i
+ <inline: false>
+ <var: #name type: #'char *'>
+ (self heapMapAtWord: (self pointerForOop: obj)) ~= 0 ifTrue:
+ [^true].
+ self print: name; print: ' leak @ '; printNum: i; print: ' = '; printHex: obj; cr.
+ ^false!
Item was added:
+ ----- Method: ObjectMemory>>compactIndexOfClass: (in category 'initialization') -----
+ compactIndexOfClass: aClassOop
+ "Check that a class the VM assumes is compact has the right index."
+ | cct |
+ cct := self splObj: CompactClasses.
+ (self lengthOf: cct) - 1 to: 0 by: -2 do:
+ [:index|
+ (self fetchPointer: index ofObject: cct) = aClassOop ifTrue:
+ [^index + 1]].
+ ^0!
Item was added:
+ ----- Method: ObjectMemory>>is:instanceOf:compactClassIndex: (in category 'object access') -----
+ is: oop instanceOf: classOop compactClassIndex: compactClassIndex
+ "Answer if oop is an instance of the given class. If the class has a (non-zero)
+ compactClassIndex use that to speed up the check. N.B. Inlining should
+ result in classOop not being accessed if oop's compact class index and
+ compactClassIndex are non-zero."
+
+ <inline: true>
+ (self isIntegerObject: oop) ifTrue:
+ [^false].
+
+ ^self isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex!
Item was added:
+ ----- Method: ObjectMemory>>isClassOfNonImm:equalTo: (in category 'header access') -----
+ isClassOfNonImm: oop equalTo: classOop
+ "Answer if the given (non-immediate) object is an instance of the given class."
+
+ | ccIndex cl |
+ <inline: true>
+ self assert: (self isNonImmediate: oop).
+
+ cl := (ccIndex := self compactClassIndexOf: oop) = 0
+ ifTrue: [(self classHeader: oop) bitAnd: self allButTypeMask]
+ ifFalse: [self compactClassAt: ccIndex].
+ ^cl = classOop!
Item was added:
+ ----- Method: ObjectMemory>>isNonImmediate: (in category 'interpreter access') -----
+ isNonImmediate: anOop
+ ^self isNonIntegerObject: anOop!
Item was changed:
----- Method: StackInterpreter class>>additionalHeadersDo: (in category 'translation') -----
additionalHeadersDo: aBinaryBlock
"Evaluate aBinaryBlock with the names and contents of
any additional header files that need to be generated."
self objectMemoryClass additionalHeadersDo: aBinaryBlock.
+ aBinaryBlock
- "aBinaryBlock
value: 'vmCallback.h'
+ value: self vmCallbackHeader!
- value: self vmCallbackHeader"!
Item was changed:
----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses"
aCCodeGenerator
addHeaderFile:'<stddef.h> /* for e.g. alloca */';
+ addHeaderFile:'<setjmp.h>';
+ addHeaderFile:'"vmCallback.h"'.
- 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, ' */]'.
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: #showSurfaceFn type: #'void *'.
aCCodeGenerator
var: #jmpBuf
declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedCallbacks
declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedMethods
declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #interruptCheckChain
declareC: 'void (*interruptCheckChain)(void) = 0'.
aCCodeGenerator
var: #breakSelector type: #'char *';
var: #breakSelectorLength
declareC: 'sqInt breakSelectorLength = -1'.
self declareC: #(nextPollUsecs nextWakeupUsecs longRunningPrimitiveGCUsecs
longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs)
as: #usqLong
in: aCCodeGenerator.
+ aCCodeGenerator var: #nextProfileTick type: #sqLong.
+
+ aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[' , (MaxPrimitiveIndex + 2) printString , '] )(void)= ' , self primitiveTableString.
+ aCCodeGenerator var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[' , (MaxExternalPrimitiveTableSize + 1) printString , '])(void)'.
+ !
- aCCodeGenerator var: #nextProfileTick type: #sqLong!
Item was changed:
----- Method: StackInterpreter 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.
+
+ "fixme - there is a method for getting the non-struct classes, use that"
+ "add before the remapping - move this to init object memory if it works"
+ cg addClass: InterpreterStackPages.
+
+
+ self initializeNewObjectMemoryInCodeGenerator: cg.
+
+ "fixme - there is a method for getting the struct classes, use that"
+ cg addStructClasses: { VMCallbackContext . InterpreterStackPage }.
- ^ self initializeNewObjectMemoryInCodeGenerator: cg
!
Item was changed:
----- Method: StackInterpreter class>>initializePrimitiveTable (in category 'initialization') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: StackInterpreter class>>primitiveTableString (in category 'initialization') -----
primitiveTableString
"StackInterpreter initializePrimitiveTable primitiveTableString"
+ ^self primitiveTableStringFor: self primitiveTable!
- ^String streamContents:
- [:s |
- s nextPut: ${.
- self primitiveTable withIndexDo:
- [:primSpec :index |
- s
- crtab;
- nextPutAll: '/* ';
- print: index - 1;
- nextPutAll: ' */ ';
- nextPutAll: (primSpec isString
- ifTrue: [primSpec == #primitiveFail
- ifTrue: ['(void (*)(void))0']
- ifFalse: [primSpec]]
- ifFalse: ['(void (*)(void))', primSpec printString]);
- nextPut: $,].
- s cr; nextPutAll: ' 0 }']!
Item was added:
+ ----- Method: StackInterpreter class>>primitiveTableStringFor: (in category 'initialization') -----
+ primitiveTableStringFor: table
+ "StackInterpreter initializePrimitiveTable primitiveTableString"
+ ^String streamContents:
+ [:s |
+ s nextPut: ${.
+ table withIndexDo:
+ [:primSpec :index |
+ s
+ crtab;
+ nextPutAll: '/* ';
+ print: index - 1;
+ nextPutAll: ' */ ';
+ nextPutAll: (primSpec isString
+ ifTrue: [primSpec == #primitiveFail
+ ifTrue: ['(void (*)(void))0']
+ ifFalse: [primSpec]]
+ ifFalse: ['(void (*)(void))', primSpec printString]);
+ nextPut: $,].
+ s cr; nextPutAll: ' 0 }']!
Item was added:
+ ----- 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 changed:
----- Method: StackInterpreter>>divorceFramesIn: (in category 'frame access') -----
divorceFramesIn: aStackPage
| theFP calleeFP theSP theIP calleeContext theContext |
<inline: false>
<var: #aStackPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #calleeFP type: #'char *'>
<var: #theSP type: #'char *'>
statStackPageDivorce := statStackPageDivorce + 1.
theFP := aStackPage headFP.
theSP := aStackPage headSP.
theIP := stackPages longAt: theSP.
theSP := theSP + objectMemory bytesPerWord. "theSP points at hottest item on frame's stack"
calleeContext := nil.
[theContext := self ensureFrameIsMarried: theFP SP: theSP.
self updateStateOfSpouseContextForFrame: theFP WithSP: theSP.
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self contextInstructionPointer: theIP frame: theFP).
self assert: (self frameReceiver: theFP)
= (objectMemory fetchPointer: ReceiverIndex ofObject: theContext).
calleeContext ~~ nil ifTrue:
[objectMemory storePointer: SenderIndex
ofObject: calleeContext
withValue: theContext].
calleeContext := theContext.
calleeFP := theFP.
theIP := (self frameCallerSavedIP: theFP) asInteger.
theFP := self frameCallerFP: theFP.
theFP ~= 0] whileTrue:
["theSP points at stacked hottest item on frame's stack"
theSP := self frameCallerSP: calleeFP].
objectMemory storePointer: SenderIndex
ofObject: theContext
withValue: (self frameCallerContext: calleeFP).
"The page is now free; mark it so."
+ aStackPage setBaseFP: 0!
- aStackPage baseFP: 0!
Item was changed:
----- Method: StackInterpreter>>forceInterruptCheck (in category 'process primitive support') -----
forceInterruptCheck
"Force an interrupt check ASAP.
Must set the stack page's limit before stackLimit to avoid
a race condition if this is called from an interrupt handler."
| thePage iccFunc |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #iccFunc declareC: 'void (*iccFunc)()'>
"Do _not_ set stackLimit until the stack system has been initialized.
stackLimit is the initialization flag for the stack system."
stackLimit = 0 ifTrue:
[^nil].
thePage := stackPage.
thePage notNil ifTrue:
+ [thePage setStackLimit: (self cCoerceSimple: -1 signedIntToLong to: #'char *')].
- [thePage stackLimit: (self cCoerceSimple: -1 signedIntToLong to: #'char *')].
stackLimit := self cCoerceSimple: -1 signedIntToLong to: #'char *'.
self sqLowLevelMFence.
"There is a race condition if we test the function and then dereference
it a second time to call it. This is called from interrupt code but at the
same time other code could be clearing the interruptCheckChain via
setInterruptCheckChain:."
(iccFunc := interruptCheckChain) notNil ifTrue:
[self perform: iccFunc].
statForceInterruptCheck := statForceInterruptCheck + 1!
Item was changed:
----- Method: StackInterpreter>>handleStackOverflow (in category 'message sending') -----
handleStackOverflow
"Check for stack overflow, moving frames to another stack if so."
| newPage theFP callerFP overflowLimitAddress overflowCount |
<var: #newPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #overflowLimitAddress type: #'char *'>
"After checkForInterrupts another event check may have been forced, setting both
stackLimit and stackPage stackLimit to all ones. So here we must check against
the real stackLimit, not the effective stackLimit."
+ stackPointer < stackPage realStackLimit ifTrue: [
- stackPointer < stackPage realStackLimit ifFalse:
- [^self].
statStackOverflow := statStackOverflow + 1.
"The stack has overflowed this page. If the system is executing some recursive algorithm,
e.g. fibonacci, then the system could thrash overflowing the stack if the call soon returns
back to the current page. To avoid thrashing, since overflow is quite slow, we can move
more than one frame. The idea is to record which page has overflowed, and the first
time it overflows move one frame, the second time two frames, and so on. We move no
more frames than would leave the page half occupied."
theFP := framePointer.
stackPage = overflowedPage
ifTrue:
[overflowLimitAddress := stackPage baseAddress - stackPages overflowLimit.
overflowCount := extraFramesToMoveOnOverflow := extraFramesToMoveOnOverflow + 1.
[(overflowCount := overflowCount - 1) >= 0
and: [(callerFP := self frameCallerFP: theFP) < overflowLimitAddress
and: [(self isBaseFrame: callerFP) not]]] whileTrue:
[theFP := callerFP]]
ifFalse:
[overflowedPage := stackPage.
extraFramesToMoveOnOverflow := 0].
self ensureCallerContext: theFP.
newPage := self newStackPage.
self moveFramesIn: stackPage through: theFP toPage: newPage.
self setStackPageAndLimit: newPage.
framePointer := stackPage headFP.
stackPointer := stackPage headSP.
self isCog
ifFalse: "To overflow the stack this must be a new frame, but in Cog base frames are married."
[self assert: (self frameHasContext: framePointer) not.
self assert: (self validInstructionPointer: instructionPointer
inMethod: method
framePointer: framePointer)]
ifTrue:
[self assert: (self validInstructionPointer: instructionPointer
inFrame: framePointer).
self assert: ((self frameHasContext: framePointer) not
+ or: [self isContext: (self frameContext: framePointer)])]]!
- or: [self isContext: (self frameContext: framePointer)])]!
Item was changed:
----- Method: StackInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') -----
initializeExtraClassInstVarIndices
"Initialize metaclassSizeBytes and thisClassIndex which are used in debug printing, and
classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf:
via classNameOf:is: (evil but a reality we have to accept)."
| classArrayObj classArrayClass |
classNameIndex := 6. "default"
thisClassIndex := 5. "default"
classArrayObj := objectMemory splObj: ClassArray.
classArrayClass := objectMemory fetchClassOfNonInt: classArrayObj.
metaclassSizeBytes := objectMemory sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)"
InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayClass) do:
[:i|
(objectMemory fetchPointer: i ofObject: classArrayClass) = classArrayObj ifTrue:
[thisClassIndex := i]].
InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayObj) do:
[:i| | oop |
oop := objectMemory fetchPointer: i ofObject: classArrayObj.
((objectMemory isBytes: oop)
and: [(objectMemory lengthOf: oop) = 5
+ and: [(self str: 'Array' n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue:
- and: [(self str: #Array n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue:
[classNameIndex := i]]!
Item was changed:
----- Method: StackInterpreter>>initializeInterpreter: (in category 'initialization') -----
initializeInterpreter: bytesToShift
"Initialize Interpreter state before starting execution of a new image."
+ self initializeInterpreter.
interpreterProxy := self sqGetInterpreterProxy.
self dummyReferToProxy.
objectMemory initializeObjectMemory: bytesToShift.
self checkAssumedCompactClasses.
primFailCode := 0.
self initializeExtraClassInstVarIndices.
stackLimit := 0. "This is also the initialization flag for the stack system."
stackPage := overflowedPage := 0.
extraFramesToMoveOnOverflow := 0.
self setMethod: objectMemory nilObject.
messageSelector := objectMemory nilObject.
newMethod := objectMemory nilObject.
lkupClass := objectMemory nilObject.
self flushMethodCache.
self flushAtCache.
self initialCleanup.
highestRunnableProcessPriority := 0.
nextProfileTick := 0.
profileSemaphore := objectMemory nilObject.
profileProcess := objectMemory nilObject.
profileMethod := objectMemory nilObject.
nextPollUsecs := 0.
nextWakeupUsecs := 0.
tempOop := 0.
interruptKeycode := 2094. "cmd-. as used for Mac but no other OS"
interruptPending := false.
inIOProcessEvents := 0.
deferDisplayUpdates := false.
pendingFinalizationSignals := statPendingFinalizationSignals := 0.
globalSessionID := 0.
[globalSessionID = 0]
whileTrue: [globalSessionID := self
cCode: 'time(NULL) + ioMSecs()'
inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]].
jmpDepth := 0.
longRunningPrimitiveStartUsecs :=
longRunningPrimitiveStopUsecs := 0.
maxExtSemTabSizeSet := false.
statForceInterruptCheck := 0.
statStackOverflow := 0.
statCheckForEvents := 0.
statProcessSwitch := 0.
statIOProcessEvents := 0.
statStackPageDivorce := 0!
Item was changed:
----- Method: StackInterpreter>>makeBaseFrameFor: (in category 'frame access') -----
makeBaseFrameFor: aContext "<Integer>"
"Marry aContext with the base frame of a new stack page. Build
the base frame to reflect the context's state. Answer the new page."
| page pointer theMethod numArgs stackPtrIndex maybeClosure |
<inline: false>
<var: #page type: #'StackPage *'>
<var: #pointer type: #'char *'>
<returnTypeC: 'StackPage *'>
self assert: (self isSingleContext: aContext).
page := self newStackPage.
pointer := page baseAddress.
theMethod := objectMemory fetchPointer: MethodIndex ofObject: aContext.
"If the frame is a closure activation then the closure should be on the stack in
the pushed receiver position (closures receiver the value[:value:] messages).
Otherwise it should be the receiver proper."
maybeClosure := (objectMemory fetchPointer: ClosureIndex ofObject: aContext).
maybeClosure ~= objectMemory nilObject
ifTrue: [numArgs := self argumentCountOfClosure: maybeClosure.
stackPages longAt: pointer put: maybeClosure]
ifFalse:
[numArgs := self argumentCountOf: theMethod.
stackPages longAt: pointer put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext)].
"Put the arguments on the stack"
1 to: numArgs do:
[:i|
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"saved caller ip is sender context in base frame"
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (objectMemory fetchPointer: SenderIndex ofObject: aContext).
"base frame's saved fp is null"
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: 0.
+ page setBaseFP: pointer; setHeadFP: pointer.
- page baseFP: pointer; headFP: pointer.
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: theMethod.
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (self encodeFrameFieldHasContext: true isBlock: maybeClosure ~= objectMemory nilObject numArgs: numArgs).
self assert: (self frameHasContext: page baseFP).
self assert: (self frameNumArgs: page baseFP) == numArgs.
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: aContext.
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext).
stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext.
self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext).
numArgs + 1 to: stackPtrIndex do:
[:i|
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"last thing on stack is the instruction pointer"
(objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)) ifFalse:
[self error: 'context is not resumable'].
stackPages
longAt: (pointer := pointer - objectMemory bytesPerWord)
put: (self frameInstructionPointerForContext: aContext method: theMethod).
self assert: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)
= (self contextInstructionPointer: (stackPages longAt: pointer) frame: page baseFP).
+ page setHeadSP: pointer.
- page headSP: pointer.
"Mark context as married by setting its sender to the frame pointer plus SmallInteger
tags and the InstructionPointer to the saved fp (which ensures correct alignment
w.r.t. the frame when we check for validity)"
objectMemory storePointerUnchecked: SenderIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: page baseFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: 0).
self assert: (objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)).
self assert: (self frameOfMarriedContext: aContext) = page baseFP.
^page!
Item was changed:
----- Method: StackInterpreter>>markAndTraceAndMaybeFreeStackPages: (in category 'object memory support') -----
markAndTraceAndMaybeFreeStackPages: fullGCFlag
"Read markAndTraceStackPages:'s comment. Finish tracing to-be-traced pages.
Then free any untraced pages."
| thePage foundToBeTracedPage |
<var: #thePage type: #'StackPage *'>
<inline: false>
fullGCFlag ifFalse:
[0 to: numStackPages - 1 do:
[:i|
thePage := stackPages stackPageAt: i.
+ self assert: (thePage setTrace: -1) ~= 0]. "Invalidate the trace state for assertion checks"
- self assert: (thePage trace: -1) ~= 0]. "Invalidate the trace state for assertion checks"
^nil].
[foundToBeTracedPage := false.
0 to: numStackPages - 1 do:
[:i|
thePage := stackPages stackPageAt: i.
((stackPages isFree: thePage) not
and: [thePage trace = 1]) ifTrue:
[foundToBeTracedPage := true.
+ thePage setTrace: 2.
- thePage trace: 2.
self markAndTraceStackPage: thePage]].
foundToBeTracedPage] whileTrue.
0 to: numStackPages - 1 do:
[:i|
thePage := stackPages stackPageAt: i.
((stackPages isFree: thePage) not
and: [thePage trace = 0]) ifTrue:
[self assert: (self noMarkedContextsOnPage: thePage).
stackPages freeStackPage: thePage].
+ self assert: (thePage setTrace: -1) ~= 0] "Invalidate the trace state for assertion checks"!
- self assert: (thePage trace: -1) ~= 0] "Invalidate the trace state for assertion checks"!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPages: (in category 'object memory support') -----
markAndTraceStackPages: fullGCFlag
"GC of pages. Throwing away all stack pages on full GC is simple but dangerous
because it causes us to allocate lots of contexts immediately before a GC.
Reclaiming pages whose top context is not referenced is poor because it would
take N incrementalGCs to reclaim N unused pages. Only the page whose top
context is not referred to by the bottom context of any other page would be
reclaimed. Not until the next GC would the page whose top contect is the
previously reclaimed page's base frame's bottom context be reclaimed.
Better is to not mark stack pages until their contexts are encountered. We can
eagerly trace the active page and the page reachable from its bottom context
if any, and so on. Other pages can be marked when we encounter a married
context."
| thePage context |
<var: #thePage type: #'StackPage *'>
<inline: false>
"Need to write back the frame pointers unless all pages are free (as in snapshot)"
stackPage ~= 0 ifTrue:
[self externalWriteBackHeadFramePointers].
0 to: numStackPages - 1 do:
[:i|
thePage := stackPages stackPageAt: i.
+ thePage setTrace: 0].
- thePage trace: 0].
"On an incremental GC simply consider all non-free stack pages to be roots."
fullGCFlag ifFalse:
[0 to: numStackPages - 1 do:
[:i|
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
+ [thePage setTrace: 2.
- [thePage trace: 2.
self markAndTraceStackPage: thePage]].
^nil].
"On a full GC only eagerly trace pages referenced from the active page."
stackPage = 0 ifTrue: [^nil].
thePage := stackPage.
+ [thePage setTrace: 2.
- [thePage trace: 2.
self markAndTraceStackPage: thePage.
context := self frameCallerContext: thePage baseFP.
((self isContext: context)
and: [(self isMarriedOrWidowedContext: context)
and: [self isStillMarriedContext: context]]) ifTrue:
[thePage := stackPages stackPageFor: (self frameOfMarriedContext: context).
self assert: (stackPages isFree: thePage) not].
thePage trace = 0] whileTrue!
Item was changed:
----- Method: StackInterpreter>>moveFramesIn:through:toPage: (in category 'frame access') -----
moveFramesIn: oldPage through: theFP toPage: newPage
"Move frames from the hot end of oldPage through to theFP to newPage.
This has the effect of making theFP a base frame which can be stored into.
Answer theFP's new location."
| newSP newFP stackedReceiverOffset delta callerFP callerIP fpInNewPage offsetCallerFP theContext |
<inline: false>
<var: #oldPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #newSP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #fpInNewPage type: #'char *'>
<var: #offsetCallerFP type: #'char *'>
<var: #source type: #'char *'>
<returnTypeC: 'char *'>
newSP := newPage baseAddress + objectMemory bytesPerWord.
stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
"First move the data. We will fix up frame pointers later."
theFP + stackedReceiverOffset
to: oldPage headSP
by: objectMemory bytesPerWord negated
do: [:source|
newSP := newSP - objectMemory bytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
"newSP = oldSP + delta => delta = newSP - oldSP"
delta := newSP - oldPage headSP.
newFP := newPage baseAddress - stackedReceiverOffset.
self setHeadFP: oldPage headFP + delta andSP: newSP inPage: newPage.
+ newPage setBaseFP: newFP.
- newPage baseFP: newFP.
callerFP := self frameCallerFP: theFP.
self assert: (self isBaseFrame: theFP) not.
self assert: (self frameHasContext: callerFP).
callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
stackPages longAt: theFP + stackedReceiverOffset put: callerIP.
oldPage
+ setHeadFP: callerFP;
+ setHeadSP: theFP + stackedReceiverOffset.
- headFP: callerFP;
- headSP: theFP + stackedReceiverOffset.
"Mark the new base frame in the new page (FoxCallerContext a.k.a. FoxCallerSavedIP)"
stackPages longAt: newFP + FoxCallerContext put: (self frameContext: callerFP).
stackPages longAt: newFP + FoxSavedFP put: 0.
"Now relocate frame pointers, updating married contexts to refer to their moved spouse frames."
fpInNewPage := newPage headFP.
[offsetCallerFP := self frameCallerFP: fpInNewPage.
offsetCallerFP ~= 0 ifTrue:
[offsetCallerFP := offsetCallerFP + delta].
stackPages longAt: fpInNewPage + FoxSavedFP put: (self oopForPointer: offsetCallerFP).
(self frameHasContext: fpInNewPage) ifTrue:
[theContext := self frameContext: fpInNewPage.
objectMemory storePointerUnchecked: SenderIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: fpInNewPage).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: offsetCallerFP)].
fpInNewPage := offsetCallerFP.
fpInNewPage ~= 0] whileTrue.
^newFP!
Item was changed:
----- Method: StackInterpreter>>printAllStacks (in category 'debug printing') -----
printAllStacks
"Print all the stacks of all running processes, including those that are currently suspended."
<api>
| oop classObj proc semaphoreClass mutexClass schedLists p processList |
<inline: false>
proc := self activeProcess.
self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5; space; printHex: proc.
self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr.
self printCallStackFP: framePointer. "first the current activation"
semaphoreClass := objectMemory classSemaphore.
mutexClass := objectMemory classMutex.
oop := objectMemory firstObject.
[self oop: oop isLessThan: objectMemory freeStart] whileTrue:
[classObj := objectMemory fetchClassOfNonInt: oop.
(classObj = semaphoreClass
or: [classObj = mutexClass]) ifTrue:
[self printProcsOnList: oop].
oop := objectMemory objectAfter: oop].
schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ highestRunnableProcessPriority = 0
+ ifTrue: [p := objectMemory fetchWordLengthOf: schedLists]
+ ifFalse: [p := highestRunnableProcessPriority].
- p := highestRunnableProcessPriority = 0
- ifTrue: [objectMemory fetchWordLengthOf: schedLists]
- ifFalse: [highestRunnableProcessPriority].
p - 1 to: 0 by: -1 do:
[:pri|
processList := objectMemory fetchPointer: pri ofObject: schedLists.
(self isEmptyList: processList) ifFalse:
[self cr; print: 'processes at priority '; printNum: pri + 1.
self printProcsOnList: processList]]!
Item was changed:
----- Method: StackInterpreter>>restoreStackLimit (in category 'stack pages') -----
restoreStackLimit
"restore the stackLimit if it has been smashed."
<inline: true>
+ stackPage setStackLimit: stackPage realStackLimit.
- stackPage stackLimit: stackPage realStackLimit.
stackLimit := stackPage stackLimit!
Item was added:
+ ----- 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].
+ "We're about to leave this stack page; must save the current frame's instructionPointer."
+ self push: instructionPointer.
+ self externalWriteBackHeadFramePointers.
+ "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 wordSize.
+ 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 wordSize.
+ framePointer := theFP]
+ ifFalse:
+ [thePage := self makeBaseFrameFor: calloutMethodContext.
+ framePointer := thePage headFP.
+ stackPointer := thePage headSP].
+ instructionPointer := self popStack.
+ self setMethod: (objectMemory fetchPointer: MethodIndex ofObject: calloutMethodContext).
+ 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 added:
+ ----- 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 *'>
+ | classTag |
+ classTag := self fetchClassTagOfNonImm: (self splObj: ClassAlien).
+ messageSelector := self splObj: SelectorInvokeCallback.
+ (self lookupInMethodCacheSel: messageSelector classTag: classTag) ifFalse:
+ [(self lookupOrdinaryNoMNUEtcInClass: (objectMemory classForClassTag: classTag)) ~= 0 ifTrue:
+ [^false]].
+ primitiveFunctionPointer ~= 0 ifTrue:
+ [^false].
+ self saveCStackStateForCallbackContext: vmCallbackContext.
+ self push: (self splObj: ClassAlien). "receiver"
+ (self argumentCountOf: newMethod) = 4 ifTrue:
+ [self push: (self positiveMachineIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
+ self push: (self positiveMachineIntegerFor: vmCallbackContext stackp asUnsignedInteger).
+ self push: (self positiveMachineIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
+ self push: (self positiveMachineIntegerFor: 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 changed:
----- Method: StackInterpreter>>setHeadFP:andSP:inPage: (in category 'stack pages') -----
setHeadFP: theFP andSP: theSP inPage: thePage
<inline: true>
<asmLabel: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #thePage type: #'StackPage *'>
self assert: theSP < theFP.
self assert: (theSP < thePage baseAddress
and: [theSP > (thePage realStackLimit - LargeContextSize)]).
self assert: (theFP < thePage baseAddress
and: [theFP > (thePage realStackLimit - (LargeContextSize / 2))]).
+ thePage setHeadFP: theFP; setHeadSP: theSP!
- thePage headFP: theFP; headSP: theSP!
Item was changed:
----- Method: StackInterpreter>>setTraceFlagOnContextsFramesPageIfNeeded: (in category 'object memory support') -----
setTraceFlagOnContextsFramesPageIfNeeded: aContext
| thePage |
<var: #thePage type: #'StackPage *'>
(self isStillMarriedContext: aContext) ifTrue:
[thePage := stackPages stackPageFor: (self frameOfMarriedContext: aContext).
self assert: (thePage trace between: 0 and: 2).
thePage trace = 0 ifTrue:
+ [thePage setTrace: 1]]!
- [thePage trace: 1]]!
Item was changed:
+ ----- Method: StackInterpreter>>stackSignedMachineIntegerValue: (in category 'stack access') -----
- ----- Method: StackInterpreter>>stackSignedMachineIntegerValue: (in category 'internal interpreter access') -----
stackSignedMachineIntegerValue: offset
<api>
+ <returnTypeC: #'long'>
"In the StackInterpreter stacks grow down."
| integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset*objectMemory wordSize).
- integerPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord).
^self signedMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>wakeHighestPriority (in category 'process primitive support') -----
wakeHighestPriority
"Return the highest priority process that is ready to run.
To save time looking at many empty lists before finding a
runnable process the VM maintains a variable holding the
highest priority runnable process. If this variable is 0 then the
VM does not know the highest priority and must search all lists.
Note: It is a fatal VM error if there is no runnable process."
| schedLists p processList |
schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ highestRunnableProcessPriority = 0
+ ifTrue: [p := objectMemory fetchWordLengthOf: schedLists]
+ ifFalse: [p := highestRunnableProcessPriority].
- p := highestRunnableProcessPriority = 0
- ifTrue: [objectMemory fetchWordLengthOf: schedLists]
- ifFalse: [highestRunnableProcessPriority].
p := p - 1.
"index of last indexable field"
[processList := objectMemory fetchPointer: p ofObject: schedLists.
self isEmptyList: processList] whileTrue:
[(p := p - 1) < 0 ifTrue:
[self error: 'scheduler could not find a runnable process']].
highestRunnableProcessPriority := p + 1.
^self removeFirstLinkOfList: processList!
Item was added:
+ ----- Method: StackInterpreterPrimitives>>primitiveFindHandlerContext (in category 'control primitives') -----
+ primitiveFindHandlerContext
+ "Primitive. Search up the context stack for the next method context marked
+ for exception handling starting at the receiver. Return nil if none found"
+ | handlerOrNilOrZero |
+ self externalWriteBackHeadFramePointers.
+ handlerOrNilOrZero := self
+ findMethodWithPrimitive: 199
+ FromContext: self stackTop
+ UpToContext: objectMemory nilObject.
+ handlerOrNilOrZero = 0 ifTrue:
+ [handlerOrNilOrZero := objectMemory nilObject].
+ self pop: 1 thenPush: handlerOrNilOrZero!
Item was added:
+ ----- Method: StackInterpreterPrimitives>>primitiveFindNextUnwindContext (in category 'control primitives') -----
+ primitiveFindNextUnwindContext
+ "Primitive. Search up the context stack for the next method context marked for unwind
+ handling from the receiver up to but not including the argument. Return nil if none found."
+ | stopContext calleeContext handlerOrNilOrZero |
+ <var: #theFP type: #'char *'>
+ stopContext := self stackTop.
+ calleeContext := self stackValue: 1.
+ (stopContext = objectMemory nilObject or: [objectMemory isContext: stopContext]) ifFalse:
+ [^self primitiveFail].
+ self externalWriteBackHeadFramePointers.
+ (self isStillMarriedContext: calleeContext)
+ ifTrue:
+ [| theFP |
+ theFP := self frameOfMarriedContext: calleeContext.
+ (self isBaseFrame: theFP)
+ ifTrue:
+ [handlerOrNilOrZero := self findMethodWithPrimitive: 198
+ FromContext: (self frameCallerContext: theFP)
+ UpToContext: stopContext]
+ ifFalse:
+ [handlerOrNilOrZero := self findMethodWithPrimitive: 198
+ FromFP: (self frameCallerFP: theFP)
+ UpToContext: stopContext]]
+ ifFalse:
+ [| startContext |
+ startContext := objectMemory fetchPointer: SenderIndex ofObject: calleeContext.
+ (objectMemory isContext: startContext)
+ ifTrue:
+ [handlerOrNilOrZero := self findMethodWithPrimitive: 198
+ FromContext: startContext
+ UpToContext: stopContext]
+ ifFalse:
+ [handlerOrNilOrZero := 0]].
+ handlerOrNilOrZero = 0 ifTrue:
+ [handlerOrNilOrZero := objectMemory nilObject].
+ self pop: 2 thenPush: handlerOrNilOrZero!
Item was added:
+ ----- Method: TMethod>>addTypeForSelf (in category 'utilities') -----
+ addTypeForSelf
+ "If self should be typed then add a suitable type declaration.
+ Preserve the flagging of an implicit self using the #implicit symbol as the fake type."
+ self typeForSelf ifNotNil:
+ [:typeForSelf|
+ self declarationAt: 'self'
+ put: (typeForSelf == #implicit
+ ifTrue: [typeForSelf]
+ ifFalse: [typeForSelf, ' self'])]!
Item was changed:
----- Method: TMethod>>inlineSend:directReturn:exitVar:in: (in category 'inlining') -----
inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: aCodeGen
"Answer a collection of statments to replace the given send. directReturn indicates that the send is the expression of a return statement, so returns can be left in the body of the inlined method. If exitVar is nil, the value returned by the send is not used; thus, returns need not assign to the output variable."
| sel meth exitLabel labelUsed inlineStmts |
sel := aSendNode selector.
meth := (aCodeGen methodNamed: sel) copy.
meth renameVarsForInliningInto: self in: aCodeGen.
meth renameLabelsForInliningInto: self.
self addVarsDeclarationsAndLabelsOf: meth except: #().
meth hasReturn ifTrue: [
directReturn ifTrue: [
"propagate the return type, if necessary"
- returnType = meth returnType ifFalse: [ self halt ]. "caller's return type should be declared by user"
returnType := meth returnType.
] ifFalse: [
exitLabel := self unusedLabelForInliningInto: self.
labelUsed := meth exitVar: exitVar label: exitLabel.
labelUsed
ifTrue: [ labels add: exitLabel ]
ifFalse: [ exitLabel := nil ].
].
"propagate type info if necessary"
((exitVar ~= nil) and: [meth returnType ~= 'sqInt']) ifTrue: [
declarations at: exitVar put: meth returnType, ' ', exitVar.
].
].
inlineStmts := OrderedCollection new: 100.
inlineStmts add: (TLabeledCommentNode new setComment: 'begin ', sel).
inlineStmts addAll:
(self argAssignmentsFor: meth args: aSendNode args in: aCodeGen).
inlineStmts addAll: meth statements. "method body"
(directReturn and: [meth endsWithReturn not]) ifTrue: [
inlineStmts add: (TReturnNode new setExpression: (TVariableNode new setName: 'nil')).
].
exitLabel ~= nil ifTrue: [
inlineStmts add:
(TLabeledCommentNode new
setLabel: exitLabel comment: 'end ', meth selector).
].
^inlineStmts!
Item was changed:
----- Method: TMethod>>setSelector:definingClass:args:locals:block:primitive:properties:comment: (in category 'initialization') -----
setSelector: sel definingClass: class args: argList locals: localList block: aBlockNode primitive: aNumber properties: methodProperties comment: aComment
"Initialize this method using the given information."
selector := sel.
definingClass := class.
returnType := #sqInt. "assume return type is long for now"
args := argList asOrderedCollection collect: [:arg | arg key].
locals := (localList asSortedCollection: [:a :b| a key < b key]) collect: [:arg | arg key].
declarations := Dictionary new.
+ self addTypeForSelf.
- "self addTypeForSelf." "<- Cog feature to be added later"
primitive := aNumber.
properties := methodProperties.
comment := aComment.
parseTree := aBlockNode asTranslatorNodeIn: self.
labels := OrderedCollection new.
complete := false. "set to true when all possible inlining has been done"
export := self extractExportDirective.
static := self extractStaticDirective.
canAsmLabel := self extractLabelDirective.
self extractSharedCase.
self removeFinalSelfReturn. "must preceed recordDeclarations because this may set returnType"
self recordDeclarations.
globalStructureBuildMethodHasFoo := 0!
Item was added:
+ ----- Method: TMethod>>transformToStructClassMethodFor: (in category 'transformations') -----
+ transformToStructClassMethodFor: aCCodeGenerator
+ "Transform this method so that it can be used on an instance of a struct class (VMStructType subclass).
+ Convert inst var refs into field dereferences of self. Add selfSelector as the first argument with the
+ right struct type. As a complete hack to avoid breaking the inlinert don't use 'self' as the name for self
+ as this causes serious type redefinitions ``somewhere'' in the inliner."
+ | replacements selfNode typeForSelf |
+ self isStructAccessor ifTrue:
+ [^self returnType: (definingClass returnTypeForAccessor: selector)].
+ replacements := IdentityDictionary new.
+ selfNode := TVariableNode new setName: 'self_in_', (aCCodeGenerator cFunctionNameFor: selector).
+ args do:
+ [:var|
+ (definingClass isAccessor: var) ifTrue:
+ [self error: 'In ', definingClass name, '>>', selector, ' ', var, ' arg shadows struct field and will break during translation!!']].
+ parseTree nodesDo:
+ [:node|
+ node isVariable ifTrue:
+ [node name = 'self' ifTrue:
+ [replacements at: node put: selfNode copy].
+ (definingClass isAccessor: node name) ifTrue:
+ [replacements
+ at: node
+ put: (TSendNode new
+ setSelector: node name asSymbol
+ receiver: selfNode
+ arguments: #())]]].
+ replacements notEmpty ifTrue:
+ [parseTree := parseTree replaceNodesIn: replacements].
+ typeForSelf := self typeForSelf.
+ self assert: (typeForSelf notNil and: [typeForSelf ~~ #implicit]).
+ self declarationAt: (args addFirst: selfNode name)
+ put: (declarations removeKey: 'self'), '_in_', (aCCodeGenerator cFunctionNameFor: selector)!
Item was added:
+ ----- Method: VMClass>>assert:l: (in category 'debug support') -----
+ assert: aBooleanExpression l: linenum
+ <doNotGenerate>
+ ^self assert: aBooleanExpression!
Item was added:
+ ----- Method: VMClass>>asserta: (in category 'debug support') -----
+ asserta: aBooleanExpression
+ <doNotGenerate>
+ | result |
+ (result := aBooleanExpression value) ifFalse:
+ [AssertionFailure signal: 'Assertion failed'].
+ ^result!
Item was added:
+ ----- Method: VMClass>>asserta:l: (in category 'debug support') -----
+ asserta: aBooleanExpression l: linenum
+ <doNotGenerate>
+ ^self asserta: aBooleanExpression!
Item was changed:
----- Method: VMMaker class>>versionString (in category 'version testing') -----
versionString
"VMMaker versionString"
+ ^'4.15.9'!
- ^'4.15.8'!
Item was changed:
Model subclass: #VMMakerTool
instanceVariableNames: 'vmMaker allPluginsList allPluginsSelection allPluginsSelectionsArray internalPluginsList internalPluginsSelection internalPluginsSelectionsArray externalPluginsList externalPluginsSelection externalPluginsSelectionsArray logger interpreterClassMorph platformPathMorph platformNameMorph generatedPathMorph configFileName'
+ classVariableNames: 'InterpreterTypes'
- classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-Building'!
!VMMakerTool commentStamp: '<historical>' prior: 0!
VMMakerTool help information
------------------------------------
If you really get stuck, send mail to the Squeak mailing list, squeak-dev at lists.squeakfoundation.org
VMMakerTool openInWorld
What this is
--------------
This tool is a simple interactive interface to VMMaker. You can change the directory paths for where the system looks for the platform files (those C files that are handwritten for each platform) and where it will put the assembled sources (the appropriate platform files and generated files) ready for you to compile into a new vm. You can change the platform for which it will generate files. You can choose which plugins are built and whether they are built for internal or external use.
How to use it
---------------
To build a configuration, drag plugins from the leftmost 'Plugins not built' list to either the 'Internal Plugins' list or the 'External Plugins' list. Plugins that cannot be built on your machine due to missing files will not be draggable.
Once you have a configuration, you can save it for later retrieval by pressing the 'Save Configuration' button. Unsurprisingly you can reload a saved configuration with the 'Load Configuration' button.
To generate an entire code tree, press the 'Generate All' button. This will process all the vm and plugin files needed for your configuration. To generate only the files for the vm and any internal plugins, use the 'Generate Core VM' button. This will be most useful if you are experimenting with the design of the vm internals or new object memory layouts etc. The 'Generate External Plugins' button will regenerate all the plugins in the External Plugins list. Note that 'excess' directories will be deleted each time you generate the vm in order to reduce potential confusion if you move a plugin from internal to external etc. If you repeatedly generate the vm only the files that appear to be out of date will be recreated; this drastically reduces the time taken if you have only changed a single plugin class for example.
You can also generate internal or external plugins singly, using the menus in the lists but be warned - internal plugins are tightly related to the generated file 'vm/sqNamedPrims.h' and adding or removing an internal plugin without regenerating this (via 'Generate Core VM' or 'Generate All') will cause much grief. The application attempts to prevent this, but there are surely ways to confuse both yourself and the code. In general when writing experimental plugins it is much simpler to build them as external during the development cycle.
If the default path for the platforms code is not correct for your machine you can use the 'Find Path' button to search for a plausible directory. Note that this could take an arbitrarily long time on a machine with connections to other machines since you may end up searching all their disc space as well.
You can choose from a menu of all known platforms (at least, all those known in the set of files on your machine) by using the 'Find platform' button. This is useful if you want to generate files for some other platform and feel uncertain of the exact spelling. By default the platform will be set to that upon which you are running.
If you feel the need to delete all the generated files you can press the 'Clean out' button - this will recursively delete everything below the path for the generated sources.
Details
-------
You really ought to read the class comment for VMMaker. Really. Go on, do it now.
Errors
-------
A number of errors are possible, mostly relating to the two directory paths and the platform name. As much as possible these are trapped and you will see 'inform' menus to let you know. Inevitably, if you put in the effort, you will be able to confuse the tool and break it.
!
Item was changed:
----- Method: VMMakerTool class>>initialize (in category 'class initialization') -----
initialize
+ self initializeInterpreterTypes.
Smalltalk at: #TheWorldMenu ifPresent: [ :class |
class class methodDict at: #registerOpenCommand: ifPresent: [ :method |
(method hasLiteral: #deprecated:) "n.b. use #hasLiteral: rather than #sendsSelector: for Squeak 3.8"
ifFalse: [ class registerOpenCommand: (Array with: 'VMMaker' with: (Array with: self with: #openInWorld)) ] ] ]!
Item was added:
+ ----- Method: VMMakerTool class>>initializeInterpreterTypes (in category 'class initialization') -----
+ initializeInterpreterTypes
+ "The list of supported interpreter types that will be presented as menu options.
+ Context interpreter is the traditional Squeak interpreter VM. Stack interpreter is
+ the newer stack interpreter that provides a basis for Cog and Spur developement.
+ Other selections may be added to specify e.g. a Cog VM."
+
+ InterpreterTypes := #( 'Context interpreter' 'Stack interpreter' )!
Item was changed:
----- Method: VMMakerTool>>buildCenterRows (in category 'window construction') -----
buildCenterRows
| rows color1 color2 labelWidth longestLabel |
color1 := Color blue veryMuchLighter.
color2 := Color green veryMuchLighter.
+ longestLabel := 'Path to generated sources:'. "calculate labelWidth for acceptable results on varous images"
+ labelWidth := (TextMorph new contents: longestLabel translated asText allBold) width.
- longestLabel := 'Path to platforms code:'. "calculate labelWidth for acceptable results on varous images"
- labelWidth := (TextMorph new contents: longestLabel translated asText allBold) width *1.13.
rows := Morph new color: Color transparent;
layoutPolicy: TableLayout new;
vResizing: #spaceFill;
extent: 550 @ (TextStyle defaultFont height * 16);
hResizing: #spaceFill;
listDirection: #topToBottom;
borderStyle: (BorderStyle complexAltRaised width: 2);
wrapDirection: #none;
wrapCentering: #center;
yourself.
rows
addMorphBack: ((self
entryRowWithLabel: 'Interpreter class name:'
labelWidth: labelWidth
balloonText: 'The name of the Interpreter class'
getFieldText: #interpreterClassName
setFieldText: #interpreterClassName:
+ buttonLabel: 'Select'
+ buttonAction: #interpreterListMenu
+ buttonBalloonText: 'Choose Context interpreter for the classic interpreter VM, or Stack interpreter as basis for Cog and later development')
- buttonLabel: nil
- buttonAction: nil
- buttonBalloonText: nil)
color: color1).
+ interpreterClassMorph := rows submorphs last submorphs second.
- interpreterClassMorph := rows submorphs last submorphs first.
rows
addMorphBack: ((self
entryRowWithLabel: 'Path to platforms code:'
labelWidth: labelWidth
balloonText: 'The directory where the platform source tree is found; can be edited in text field to the right. Default of {working directory}/src is strongly recommended'
getFieldText: #platformsPathText
setFieldText: #platformsPathText:
+ buttonLabel: 'Find path'
- buttonLabel: 'Find Path'
buttonAction: #findPlatformsPath
buttonBalloonText: 'Choose the directory where you keep the platform specific code from a file dialogue')
color: color2).
platformPathMorph := rows submorphs last submorphs second.
rows
addMorphBack: ((self
entryRowWithLabel: 'Platform name:'
labelWidth: labelWidth
balloonText: 'The platform name (as returned by Smalltalk platformName - unix, Mac OS, RISCOS, win32 etc); can be edited (in text field to the right) to cross generate'
getFieldText: #platformNameText
setFieldText: #platformNameText:
buttonLabel: 'Find platform'
buttonAction: #platformsListMenu
buttonBalloonText: 'Choose from a list of known platforms. The default is this current platform.')
color: color1).
platformNameMorph := rows submorphs last submorphs second.
rows
addMorphBack: ((self
entryRowWithLabel: 'Path to generated sources:'
labelWidth: labelWidth
balloonText: 'The directory where the built sources will be placed; can be edited in text field to the right. The default is strongly recommended; makefile alterations may be needed if you use a different path.'
getFieldText: #sourcePathText
setFieldText: #sourcePathText:
buttonLabel: 'Clean out'
buttonAction: #cleanoutSrcDir
buttonBalloonText: 'Clean out all the files in the target directory, ready for a clean build')
color: color2).
generatedPathMorph := rows submorphs last submorphs second.
^ rows!
Item was changed:
----- Method: VMMakerTool>>interpreterClassName: (in category 'path access') -----
interpreterClassName: aText
"set the interpreter class name"
+ [vmMaker interpreterClassName: aText asString.
+ self changed: #interpreterClassName]
- [vmMaker interpreterClassName: aText asString]
on: VMMakerException
do: [:ex| self inform:ex messageText.
^false].
^true!
Item was added:
+ ----- Method: VMMakerTool>>interpreterListMenu (in category 'menus') -----
+ interpreterListMenu
+ "create a menu of interpreter type selections. Use a list of descriptive names and
+ translate the selection to a class name appropriate for that selection. Note that this
+ is not necessarily the name of an interpreter class per se."
+
+ | choice interp |
+ choice := (PopUpMenu labelArray: InterpreterTypes
+ lines: #()) startUp.
+ choice = 0 ifTrue: [^self].
+ interp := (InterpreterTypes at: choice)
+ caseOf: {
+ [ 'Context interpreter' ] -> [ 'ContextInterpreter' ] .
+ [ 'Stack interpreter' ] -> [ 'StackInterpreterPrimitives' ]
+ }
+ otherwise: [ 'ContextInterpreter' ].
+ self interpreterClassName: interp asText!
Item was changed:
----- Method: VMMakerTool>>updateAllViews (in category 'initialisation') -----
updateAllViews
+ self changed: #interpreterClassName;
+ changed: #platformsPathText;
+ changed: #platformNameText;
+ changed: #sourcePathText;
+ changed: #availableModules;
+ changed: #internalModules;
+ changed: #externalModules!
- self changed: #platformsPathText;
- changed: #platformNameText;
- changed: #sourcePathText;
- changed: #availableModules;
- changed: #internalModules;
- changed: #externalModules!
Item was added:
+ ----- Method: VMStructType class>>isStructClass (in category 'translation') -----
+ isStructClass
+ ^true!
Item was added:
+ ----- Method: VMStructType class>>isTypeStruct: (in category 'translation') -----
+ isTypeStruct: type
+ StructTypeNameCache ifNil:
+ [StructTypeNameCache := Set new.
+ self allSubclassesDo:
+ [:sc| StructTypeNameCache add: sc name; add: sc structTypeName]].
+ ^type notNil
+ and: [StructTypeNameCache anySatisfy:
+ [:structType|
+ type = structType]]!
More information about the Vm-dev
mailing list