David T. Lewis uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-dtl.264.mcz
==================== Summary ====================
Name: VMMaker-dtl.264
Author: dtl
Time: 11 February 2012, 7:16:47.788 pm
UUID: 9b434edc-1fd1-4be7-ac3c-a855f72eafa3
Ancestors: VMMaker-dtl.263
VMMaker 4.8
Refactor Interpreter and ObjectMemory such that an interpreter has an object memory (not is an object memory). This is based on the organization in oscog and is intended as a step towards adoption of StackInterpreter.
Change formatting of code generated by emitDefaultMacrosOn: storeHeaderFor:onFile: and allocateMemory:minimum:imageFile:headerSize:
Add SlangTest>>testSetInstanceVariableWithAnAccessorMethod to document a Slang inliner deficiency exposed by the ObjectMemory refactoring (fixed in oscog, need to identify the fix and incorporate in trunk).
All generated sources are equivalent to those of the previous VMMaker version, with generated C code differing in variable declaration order or naming, and other minor artifacts of the code generator. A few (total of 8 in the entire enterpreter) extra intermediate variables are now being generated, but should be of no measurable impact, see #testSetInstanceVariableWithAnAccessorMethod for a test that documents the issue.
The corresponding refactoring of the interpreter simulator is incomplete and should be assumed broken for the time being. This requires providing simulator subclasses of ObjectMemory, as well as resolving references to Interpreter from ObjectMemory (add a back pointer or see oscog for a solution using #perform:withArguments:inSuperclass: ). This is to be corrected in the next VMMaker version.
A copy of StackInterpreter is included, but is not yet functional. As always, the oscog branch contains the supported version of StackInterpreter and Cog.
Note to self: The memory access methods in object memory simulator classes could be eliminated by incorporating MemoryAccess as an instance variable of ObjectMemory analogous to ObjectMemory as in instance variable of Interpreter, with alternative implementations for CPP macros and Slang.
=============== Diff against VMMaker-dtl.263 ===============
Item was changed:
SystemOrganization addCategory: #'VMMaker-Building'!
SystemOrganization addCategory: #'VMMaker-Interpreter'!
SystemOrganization addCategory: #'VMMaker-InterpreterSimulation'!
SystemOrganization addCategory: #'VMMaker-Plugins'!
SystemOrganization addCategory: #'VMMaker-SmartSyntaxPlugins'!
SystemOrganization addCategory: #'VMMaker-Translation to C'!
SystemOrganization addCategory: #'VMMaker-Tests'!
+ SystemOrganization addCategory: #'VMMaker-Support'!
Item was changed:
Object subclass: #CCodeGenerator
+ instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict receiverDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning pools'
- instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning'
classVariableNames: 'UseRightShiftForDivide'
poolDictionaries: ''
category: 'VMMaker-Translation to C'!
!CCodeGenerator commentStamp: 'tpr 5/2/2003 14:30' prior: 0!
This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.
See VMMaker for more useful info!
Item was changed:
----- Method: CCodeGenerator>>addClass:asInstanceVariable: (in category 'composition') -----
+ addClass: aClass asInstanceVariable: varName
- addClass: aClass asInstanceVariable: var
"For an instance variable var in one of the classes that has been added to
this code generator, assume that an instance of aClass would normally be
assigned to that variable. Arrange for the methods in aClass to be incorporated
into the generated C source module as if they had been methods in the class
with instance variable var.
+ n.b. See #addStructureClass: mechanism in Cog."
- Incorporate the methods of aClass, and rename with prefixes reflecting the
- variable name. This is a simple transformation intended to support MemoryAccess,
- with renaming to avoid conflict with standard sqMemoryAccess.h macros.
- n.b. See #addStructureClass: mechanism in Cog for object memory as instance
- variable in interpreter."
self addClass: aClass.
+ receiverDict at: varName asString put: 'self'.
+ variables remove: varName ifAbsent: []
- aClass selectors do: [:sel |
- self renameSelector: sel
- as: (var, '_', sel) asSymbol].
!
Item was added:
+ ----- Method: CCodeGenerator>>addClass:selectorPrefix: (in category 'composition') -----
+ addClass: aClass selectorPrefix: prefix
+ "Incorporate the methods of aClass, and rename with prefixes reflecting the
+ variable name. This is a simple transformation intended to support MemoryAccess,
+ with renaming to avoid conflict with standard sqMemoryAccess.h macros."
+
+ self addClass: aClass.
+ aClass selectors do: [:sel |
+ self renameSelector: sel
+ as: (prefix, '_', sel) asSymbol].
+ !
Item was changed:
----- Method: CCodeGenerator>>addPoolVarsFor: (in category 'public') -----
addPoolVarsFor: aClass
"Add the pool variables for the given class to the code base as constants."
+
+ (aClass sharedPools reject: [:pool| pools includes: pool]) do:
+ [:pool |
+ pools add: pool.
+ pool bindingsDo: [:assoc | | val node |
- | val node |
- aClass sharedPools do: [:pool |
- pool bindingsDo: [:assoc |
val := assoc value.
+ node := (useSymbolicConstants and:[self isCLiteral: val])
+ ifTrue:[TDefineNode new setName: assoc key asString value: assoc value]
+ ifFalse:[TConstantNode new setValue: assoc value].
- (useSymbolicConstants and:[self isCLiteral: val])
- ifTrue:[node := TDefineNode new setName: assoc key asString value: assoc value]
- ifFalse:[node := TConstantNode new setValue: assoc value].
constants at: assoc key asString put: node]].!
Item was changed:
----- Method: CCodeGenerator>>checkClassForNameConflicts: (in category 'error notification') -----
checkClassForNameConflicts: aClass
+ "Verify that the given class does not have constant, variable, or method names that conflict with
+ those of previously added classes. Raise an error if a conflict is found, otherwise just return."
- "Verify that the given class does not have constant, variable, or method names that conflict with those of previously added classes. Raise an error if a conflict is found, otherwise just return."
+ "check for constant name collisions in class pools"
+ aClass classPool associationsDo:
+ [:assoc |
+ (constants includesKey: assoc key asString) ifTrue:
+ [self error: 'Constant ', assoc key, ' was defined in a previously added class']].
- "check for constant name collisions"
- aClass classPool associationsDo: [ :assoc |
- (constants includesKey: assoc key asString) ifTrue: [
- self error: 'Constant was defined in a previously added class: ', assoc key.
- ].
- ].
- "ikp..."
- aClass sharedPools do: [:pool |
- pool bindingsDo: [ :assoc |
- (constants includesKey: assoc key asString) ifTrue: [
- self error: 'Constant was defined in a previously added class: ', assoc key.
- ].
- ].
- ].
+ "and in shared pools"
+ (aClass sharedPools reject: [:pool| pools includes: pool]) do:
+ [:pool |
+ pool bindingsDo:
+ [:assoc |
+ (constants includesKey: assoc key asString) ifTrue:
+ [self error: 'Constant ', assoc key, ' was defined in a previously added class']]].
+
"check for instance variable name collisions"
+ (aClass inheritsFrom: VMStructType) ifFalse:
+ [aClass instVarNames do:
+ [:varName |
+ (variables includes: varName) ifTrue:
+ [self error: 'Instance variable ', varName, ' was defined in a previously added class']]].
- aClass instVarNames do: [ :varName |
- (variables includes: varName) ifTrue: [
- self error: 'Instance variable was defined in a previously added class: ', varName.
- ].
- ].
"check for method name collisions"
+ aClass selectors do:
+ [:sel |
+ ((methods includesKey: sel)
+ and: [((aClass compiledMethodAt: sel) pragmaAt: #doNotGenerate) isNil]) ifTrue:
+ [self error: 'Method ', sel, ' was defined in a previously added class.']]!
- aClass selectors do: [ :sel |
- (methods includesKey: sel) ifTrue: [
- self error: 'Method was defined in a previously added class: ', sel.
- ].
- ].!
Item was changed:
----- Method: CCodeGenerator>>emitDefaultMacrosOn: (in category 'C code generator') -----
emitDefaultMacrosOn: aStream
"Emit macros to provide default implementations of certain functions used by
the interpreter. If not previously defined in config.h they will be defined here.
The definitions will be available to any module that includes sqMemoryAccess.h.
The default macros are chosen for backward compatibility with existing platform
support code."
+ "Reduce the obscurity of these macros by flagging some selectors to
+ make this method show up as a sender."
+
+ self flag: #allocateMemory:minimum:imageFile:headerSize:.
aStream cr;
nextPutAll: '#ifndef allocateMemoryMinimumImageFileHeaderSize'; cr;
nextPutAll: ' /* Called by Interpreter>>allocateMemory:minimum:imageFile:headerSize: */'; cr;
nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
nextPutAll: ' #define allocateMemoryMinimumImageFileHeaderSize(',
'heapSize, minimumMemory, fileStream, headerSize) \'; cr;
nextPutAll: ' sqAllocateMemory(minimumMemory, heapSize)'; cr;
+ nextPutAll: '#endif'; cr.
- nextPutAll: '#endif'; cr; cr;
+ self flag: #sqImage:read:size:length:.
+ aStream cr;
nextPutAll: '#ifndef sqImageFileReadEntireImage'; cr;
nextPutAll: ' /* Called by Interpreter>>sqImage:read:size:length: */'; cr;
nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
nextPutAll: ' #define sqImageFileReadEntireImage(memoryAddress, ',
'elementSize, length, fileStream) \'; cr;
nextPutAll: ' sqImageFileRead(memoryAddress, elementSize, length, fileStream)'; cr;
+ nextPutAll: '#endif'; cr.
- nextPutAll: '#endif'; cr; cr;
+ self flag: #error:.
+ aStream cr;
nextPutAll: '#ifndef error'; cr;
nextPutAll: ' /* error() function called from Interpreter */'; cr;
nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
nextPutAll: ' #define error(str) defaultErrorProc(str)'; cr;
+ nextPutAll: '#endif'; cr.
- nextPutAll: '#endif'; cr; cr;
+ self flag: #primitiveMicrosecondClock; flag: #ioMicroSecondClock.
+ aStream cr;
nextPutAll: '#ifndef ioMicroSecondClock'; cr;
nextPutAll: ' /* Called by Interpreter>>primitiveMicrosecondClock and GC methods */'; cr;
nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
nextPutAll: ' #define ioMicroSecondClock ioMSecs'; cr;
+ nextPutAll: '#endif'; cr.
- nextPutAll: '#endif'; cr; cr;
+ self flag: #primitiveUtcWithOffset; flag: #setMicroSeconds:andOffset:.
+ aStream cr;
nextPutAll: '#ifndef ioUtcWithOffset'; cr;
nextPutAll: ' /* Called by Interpreter>>primitiveUtcWithOffset */'; cr;
nextPutAll: ' /* Default definition if not previously defined in config.h */'; cr;
nextPutAll: ' #define ioUtcWithOffset(clock, offset) setMicroSecondsandOffset(clock, offset)'; cr;
nextPutAll: '#endif'; cr.
-
- self flag: #setMicroSeconds:andOffset: "referenced by these macros"
!
Item was changed:
----- Method: CCodeGenerator>>initialize (in category 'public') -----
initialize
translationDict := Dictionary new.
inlineList := Array new.
constants := Dictionary new: 100.
variables := OrderedCollection new: 100.
variableDeclarations := Dictionary new: 100.
methods := Dictionary new: 500.
macros := Dictionary new.
self initializeCTranslationDictionary.
+ receiverDict := Dictionary new.
headerFiles := OrderedCollection new.
globalVariableUsage := Dictionary new.
useSymbolicConstants := true.
generateDeadCode := true.
scopeStack := OrderedCollection new.
+ logger := (ProvideAnswerNotification new tag: #logger; signal) ifNil: [Transcript].
+ pools := IdentitySet new.!
- logger := (ProvideAnswerNotification new tag: #logger; signal) ifNil: [Transcript].!
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 error: 'Local variable name may mask method when inlining: ', var.
].
].
+ m mapReceiversIn: receiverDict.
m bindClassVariablesIn: constants.
m prepareMethodIn: self.
].!
Item was changed:
----- Method: CCodeGenerator>>storeHeaderFor:onFile: (in category 'public') -----
storeHeaderFor: interpreterClassName onFile: fileName
"Store C header code for this interpreter on the given file."
| aStream |
aStream := CrLfFileStream forceNewFileNamed: fileName.
aStream ifNil: [Error signal: 'Could not open C header file: ', fileName].
aStream
nextPutAll: '/* ';
nextPutAll: VMMaker headerNotice;
nextPutAll: ' */'; cr; cr;
nextPutAll: '#ifndef HAVE_INTERP_H'; cr;
+ nextPutAll: '# define HAVE_INTERP_H'; cr;
- nextPutAll: '#define HAVE_INTERP_H'; cr;
nextPutAll: '#endif'; cr; cr.
self emitVmmVersionOn: aStream.
(Smalltalk classNamed: interpreterClassName)
emitInterpreterProxyVersionOn: aStream.
self emitDefineBytesPerWordOn: aStream.
self emitDefineMemoryAccessInImageOn: aStream.
aStream cr.
aStream close
!
Item was changed:
InterpreterPrimitives subclass: #Interpreter
+ instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext localReturnContext localReturnValue messageSelector currentBytecode primitiveIndex primitiveFunctionPointer methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptPending semaphoresToSignalA semaphoresUseBufferA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks extraVMMemory newNativeMethod methodClass receiverClass interpreterVersion imageFormatVersionNumber interpreterProxy showSurfaceFn interruptCheckCounter interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTable globalSessionID jmpBuf jmpDepth jmpMax suspendedCallbacks suspendedMethods imageFormatInitialVersion'
+ classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockArgumentCountIndex BytecodeTable CacheProbeMax CallerIndex CharacterValueIndex ClosureFirstCopiedValueIndex ClosureIndex ClosureNumArgsIndex ClosureOuterContextIndex ClosureStartPCIndex CompilerHooksSize DirBadPath DirEntryFound DirNoMoreEntries DoBalanceChecks FirstLinkIndex HomeIndex InitialIPIndex InstanceSpecificationIndex LastLinkIndex MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MessageArgumentsIndex MessageDictionaryIndex MessageLookupClassIndex MessageSelectorIndex MethodArrayIndex MethodCacheNative MethodIndex NextLinkIndex PrimitiveExternalCallIndex PrimitiveTable SelectorStart SemaphoresToSignalSize StackPointerIndex StreamArrayIndex StreamIndexIndex StreamReadLimitIndex StreamWriteLimitIndex SuperclassIndex SuspendedContextIndex TempFrameStart ValueIndex'
+ poolDictionaries: 'VMMethodCacheConstants VMSqueakV3BytecodeConstants'
- 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 processSignalingLowSpace savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks extraVMMemory newNativeMethod methodClass receiverClass interpreterVersion imageFormatVersionNumber interpreterProxy showSurfaceFn interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable primitiveTable globalSessionID jmpBuf jmpDepth jmpMax suspendedCallbacks suspendedMethods imageFormatInitialVersion'
- classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockArgumentCountIndex BlockMethodIndex BytecodeTable CacheProbeMax CallerIndex CharacterValueIndex ClosureCopiedValuesIndex ClosureFirstCopiedValueIndex ClosureIndex ClosureMethodIndex ClosureNumArgsIndex ClosureOuterContextIndex ClosureStartPCIndex CompilerHooksSize DirBadPath DirEntryFound DirNoMoreEntries FirstLinkIndex HomeIndex InitialIPIndex InstanceSpecificationIndex JitterTable LastLinkIndex MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MessageArgumentsIndex MessageDictionaryIndex MessageLookupClassIndex MessageSelectorIndex MethodArrayIndex MethodCacheNative MethodIndex NextLinkIndex PrimitiveExternalCallIndex PrimitiveTable SelectorStart SemaphoresToSignalSize StackPointerIndex StreamArrayIndex StreamIndexIndex StreamReadLimitIndex StreamWriteLimitIndex SuperclassIndex SuspendedContextIndex TempFrameStart ValueIndex'
- poolDictionaries: 'VMMethodCacheConstants'
category: 'VMMaker-Interpreter'!
!Interpreter commentStamp: '<historical>' prior: 0!
This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas.
It has been modernized with 32-bit pointers, better management of Contexts, and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms.
In addition to SmallInteger arithmetic and Floats, it supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case.
NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future.
1. There are a number of things that should be done the next time we plan to release a copletely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item).
2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the systemTracer. A better solution would be to reserve one of the format codes for Contexts only.
3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes.
4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. !
Item was added:
+ ----- Method: Interpreter class>>buildCodeGenerator (in category 'translation') -----
+ buildCodeGenerator
+ "Build a CCodeGenerator. Use VMMaker to determine an appropriate
+ code generator for the current platform."
+ | cg |
+ cg := VMMaker new createCodeGenerator.
+ cg declareMethodsStatic: false.
+ cg permitMethodPruning: true.
+ ^self initializeCodeGenerator: cg.
+ !
Item was added:
+ ----- Method: Interpreter class>>constMinusOne (in category 'constants') -----
+ constMinusOne
+ ^ConstMinusOne!
Item was changed:
----- Method: Interpreter class>>initialize (in category 'initialization') -----
initialize
"Interpreter initialize"
super initialize. "initialize ObjectMemory constants"
self initializeAssociationIndex.
self initializeBytecodeTable.
self initializeCaches.
self initializeCharacterIndex.
self initializeCharacterScannerIndices.
self initializeClassIndices.
self initializeCompilerHooks.
self initializeContextIndices.
self initializeDirectoryLookupResultCodes.
self initializeMessageIndices.
self initializeMethodIndices.
self initializePointIndices.
self initializePrimitiveTable.
self initializeSchedulerIndices.
- self initializeSmallIntegers.
self initializeStreamIndices.
self initializeInterpreterSourceVersion.
SemaphoresToSignalSize := 500.
PrimitiveExternalCallIndex := 117. "Primitive index for #primitiveExternalCall"
MillisecondClockMask := 16r1FFFFFFF.
"Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)"
MaxExternalPrimitiveTableSize := 4096. "entries"
MaxJumpBuf := 32. "max. callback depth"
+
+ "Translation flags (booleans that control code generation via conditional translation):"
+ DoBalanceChecks := false. "generate stack balance checks"
!
Item was added:
+ ----- Method: Interpreter class>>initializeCodeGenerator: (in category 'translation') -----
+ initializeCodeGenerator: cg
+ "Load a code generator with classes in a manner suitable for generating
+ code for this class."
+
+ super initializeCodeGenerator: cg.
+ cg addClass: ObjectMemory asInstanceVariable: #objectMemory.
+ ^cg
+ !
Item was changed:
----- 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 primitiveFail)
(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)
(38 primitiveFail)
(39 primitiveFail)
"Float Primitives (40-59)"
(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 primitiveFlushCacheSelective)
"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 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 185 primitiveFail)
"Old closure primitives"
(186 primitiveFail) "was primitiveClosureValue"
(187 primitiveFail) "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 241 primitiveFail) "serial port primitives"
(242 primitiveFail)
(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."
- (255 primitiveInstVarsPutFromStack) "Never used except in Disney tests. Remove after 2.3 release."
"Quick Push Const Methods"
(256 primitivePushSelf)
(257 primitivePushTrue)
(258 primitivePushFalse)
(259 primitivePushNil)
(260 primitivePushMinusOne)
(261 primitivePushZero)
(262 primitivePushOne)
(263 primitivePushTwo)
"Quick Push Const Methods"
(264 519 primitiveLoadInstVar)
"These ranges used to be used by obsiolete indexed primitives."
(520 529 primitiveFail)
(530 539 primitiveFail)
(540 549 primitiveFail)
(550 559 primitiveFail)
(560 569 primitiveFail)
"External primitive support primitives"
(570 primitiveFlushExternalPrimitives)
(571 primitiveUnloadModule)
(572 primitiveListBuiltinModule)
(573 primitiveListExternalModule)
(574 primitiveFail) "reserved for addl. external support prims"
"Unassigned Primitives"
(575 primitiveFail)).
!
Item was removed:
- ----- Method: Interpreter class>>initializeSmallIntegers (in category 'initialization') -----
- initializeSmallIntegers
- "SmallIntegers"
- ConstMinusOne := Interpreter new integerObjectOf: -1.
- ConstZero := Interpreter new integerObjectOf: 0.
- ConstOne := Interpreter new integerObjectOf: 1.
- ConstTwo := Interpreter new integerObjectOf: 2!
Item was changed:
----- Method: Interpreter>>activateNewClosureMethod: (in category 'control primitives') -----
activateNewClosureMethod: blockClosure
"Similar to activateNewMethod but for Closure and newMethod."
| theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
DoAssertionChecks ifTrue:
[self okayOop: blockClosure].
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
- outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
DoAssertionChecks ifTrue:
[self okayOop: outerContext].
+ closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
- closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
methodHeader := self headerOf: closureMethod.
+ objectMemory pushRemappableOop: blockClosure.
+ newContext := objectMemory allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
- self pushRemappableOop: blockClosure.
- newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
"allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
+ theBlockClosure := objectMemory popRemappableOop.
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
+ numCopied := (objectMemory fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
- theBlockClosure := self popRemappableOop.
- outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
- numCopied := (self fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + objectMemory baseHeaderSize.
+ self longAt: where + (SenderIndex << objectMemory shiftForWord)
- where := newContext + self baseHeaderSize.
- self longAt: where + (SenderIndex << self shiftForWord)
put: activeContext.
+ self longAt: where + (InstructionPointerIndex << objectMemory shiftForWord)
+ put: (objectMemory fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
+ self longAt: where + (StackPointerIndex << objectMemory shiftForWord)
+ put: (objectMemory integerObjectOf: argumentCount + numCopied).
+ self longAt: where + (MethodIndex << objectMemory shiftForWord)
+ put: (objectMemory fetchPointer: MethodIndex ofObject: outerContext).
+ self longAt: where + (ClosureIndex << objectMemory shiftForWord)
- self longAt: where + (InstructionPointerIndex << self shiftForWord)
- put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
- self longAt: where + (StackPointerIndex << self shiftForWord)
- put: (self integerObjectOf: argumentCount + numCopied).
- self longAt: where + (MethodIndex << self shiftForWord)
- put: (self fetchPointer: MethodIndex ofObject: outerContext).
- self longAt: where + (ClosureIndex << self shiftForWord)
put: theBlockClosure.
+ self longAt: where + (ReceiverIndex << objectMemory shiftForWord)
+ put: (objectMemory fetchPointer: ReceiverIndex ofObject: outerContext).
- self longAt: where + (ReceiverIndex << self shiftForWord)
- put: (self fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the arguments..."
1 to: argumentCount do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord)
- [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord)
put: (self stackValue: argumentCount-i)].
"Copy the copied values..."
+ where := newContext + objectMemory baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << objectMemory shiftForWord).
- where := newContext + self baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << self shiftForWord).
0 to: numCopied - 1 do:
+ [:i| self longAt: where + (i << objectMemory shiftForWord)
+ put: (objectMemory fetchPointer: i + ClosureFirstCopiedValueIndex
- [:i| self longAt: where + (i << self shiftForWord)
- put: (self fetchPointer: i + ClosureFirstCopiedValueIndex
ofObject: theBlockClosure)].
"The initial instructions in the block nil-out remaining temps."
self pop: argumentCount + 1.
self newActiveContext: newContext!
Item was changed:
----- Method: Interpreter>>activateNewMethod (in category 'message sending') -----
activateNewMethod
| newContext methodHeader initialIP tempCount nilOop where |
methodHeader := self headerOf: newMethod.
+ newContext := objectMemory allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).
- newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).
+ initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1.
- initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1.
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + objectMemory baseHeaderSize.
+ self longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
+ self longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory nilObj.
- where := newContext + self baseHeaderSize.
- self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
- self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.
"Copy the receiver and arguments..."
0 to: argumentCount do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord) put: (self stackValue: argumentCount-i)].
- [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self stackValue: argumentCount-i)].
"clear remaining temps to nil in case it has been recycled"
+ nilOop := objectMemory nilObj.
- nilOop := nilObj.
argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | self longAt: where + (i << objectMemory shiftForWord) put: nilOop].
- [:i | self longAt: where + (i << self shiftForWord) put: nilOop].
self pop: argumentCount + 1.
reclaimableContextCount := reclaimableContextCount + 1.
self newActiveContext: newContext.!
Item was changed:
----- Method: Interpreter>>addLastLink:toList: (in category 'process primitive support') -----
addLastLink: proc toList: aList
"Add the given process to the given linked list and set the
backpointer of process to its new list."
| lastLink |
(self isEmptyList: aList)
+ ifTrue: [objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: proc]
+ ifFalse: [lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
+ objectMemory storePointer: NextLinkIndex ofObject: lastLink withValue: proc].
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: proc.
+ objectMemory storePointer: MyListIndex ofObject: proc withValue: aList!
- ifTrue: [self storePointer: FirstLinkIndex ofObject: aList withValue: proc]
- ifFalse: [lastLink := self fetchPointer: LastLinkIndex ofObject: aList.
- self storePointer: NextLinkIndex ofObject: lastLink withValue: proc].
- self storePointer: LastLinkIndex ofObject: aList withValue: proc.
- self storePointer: MyListIndex ofObject: proc withValue: aList!
Item was changed:
----- Method: Interpreter>>allAccessibleObjectsOkay (in category 'debug support') -----
allAccessibleObjectsOkay
"Ensure that all accessible objects in the heap are okay."
| oop |
+ oop := objectMemory firstAccessibleObject.
- oop := self firstAccessibleObject.
[oop = nil] whileFalse: [
self okayFields: oop.
+ oop := objectMemory accessibleObjectAfter: oop.
- oop := self accessibleObjectAfter: oop.
].!
Item was changed:
----- Method: Interpreter>>allocateMemory:minimum:imageFile:headerSize: (in category 'image save/restore') -----
allocateMemory: heapSize minimum: minimumMemory imageFile: fileStream headerSize: headerSize
"Translate to C function call with (case sensitive) camelCase. The purpose of this
method is to document the translation.
The default implementation is sqAllocateMemory(minimumMemory, heapSize). This may
be redefined to make use of the image file and header size parameters for efficient
implementation with mmap().
+ See CCodeGenerator>>emitDefaultMacrosOn: which specifies a default implementation."
- See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation."
<inline: true>
<returnTypeC: 'char *'>
<var: #fileStream type: 'sqImageFile'>
^ self
allocateMemory: heapSize
Minimum: minimumMemory
ImageFile: fileStream
HeaderSize: headerSize!
Item was changed:
----- Method: Interpreter>>argumentCountOfBlock: (in category 'contexts') -----
argumentCountOfBlock: blockPointer
| localArgCount |
+ localArgCount := objectMemory fetchPointer: BlockArgumentCountIndex ofObject: blockPointer.
- localArgCount := self fetchPointer: BlockArgumentCountIndex ofObject: blockPointer.
^self checkedIntegerValueOf: localArgCount!
Item was changed:
----- Method: Interpreter>>arrayValueOf: (in category 'utilities') -----
arrayValueOf: arrayOop
"Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
"Note: May be called by translated primitive code."
<returnTypeC: 'void *'>
+ ((objectMemory isIntegerObject: arrayOop) not and:
+ [objectMemory isWordsOrBytes: arrayOop])
+ ifTrue: [^ self pointerForOop: (arrayOop + objectMemory baseHeaderSize)].
- ((self isIntegerObject: arrayOop) not and:
- [self isWordsOrBytes: arrayOop])
- ifTrue: [^ self pointerForOop: (arrayOop + self baseHeaderSize)].
self primitiveFail.
!
Item was changed:
----- Method: Interpreter>>asciiOfCharacter: (in category 'array primitive support') -----
asciiOfCharacter: characterObj "Returns an integer object"
<inline: false>
+ self assertClassOf: characterObj is: (objectMemory splObj: ClassCharacter).
- self assertClassOf: characterObj is: (self splObj: ClassCharacter).
self successful
+ ifTrue: [^ objectMemory fetchPointer: CharacterValueIndex ofObject: characterObj]
- ifTrue: [^ self fetchPointer: CharacterValueIndex ofObject: characterObj]
ifFalse: [^ ConstZero] "in case some code needs an int"!
Item was changed:
----- Method: Interpreter>>assertClassOf:is: (in category 'utilities') -----
assertClassOf: oop is: classOop
"Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."
| ccIndex cl |
<inline: true>
+ (objectMemory isIntegerObject: oop)
- (self isIntegerObject: oop)
ifTrue: [ self primitiveFail. ^ nil ].
+ ccIndex := ((objectMemory baseHeader: oop) >> 12) bitAnd: 16r1F.
- ccIndex := ((self baseHeader: oop) >> 12) bitAnd: 16r1F.
ccIndex = 0
+ ifTrue: [ cl := ((objectMemory classHeader: oop) bitAnd: objectMemory allButTypeMask) ]
- ifTrue: [ cl := ((self classHeader: oop) bitAnd: self allButTypeMask) ]
ifFalse: [
"look up compact class"
+ cl := (objectMemory fetchPointer: (ccIndex - 1)
+ ofObject: (objectMemory fetchPointer: CompactClasses ofObject: objectMemory specialObjectsOop))].
- cl := (self fetchPointer: (ccIndex - 1)
- ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))].
self success: cl = classOop.
!
Item was changed:
----- Method: Interpreter>>balancedStack:afterPrimitive:withArgs: (in category 'debug support') -----
balancedStack: delta afterPrimitive: primIdx withArgs: nArgs
"Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)"
(primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true].
"81-88 are control primitives after which the stack may look unbalanced"
self successful ifTrue:[
"Successful prim, stack must have exactly nArgs arguments popped off"
+ ^(stackPointer - activeContext + (nArgs * objectMemory bytesPerWord)) = delta
- ^(stackPointer - activeContext + (nArgs * self bytesPerWord)) = delta
].
"Failed prim must leave stack intact"
^(stackPointer - activeContext) = delta
!
Item was changed:
----- Method: Interpreter>>booleanCheat: (in category 'utilities') -----
booleanCheat: cond
"cheat the interpreter out of the pleasure of handling the next bytecode IFF it is a jump-on-boolean. Which it is, often enough when the current bytecode is something like bytecodePrimEqual"
| bytecode offset |
<inline: true>
bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)"
self internalPop: 2.
(bytecode < 160 and: [bytecode > 151]) ifTrue: [ "short jumpIfFalse"
cond
ifTrue: [^ self fetchNextBytecode]
ifFalse: [^ self jump: bytecode - 151]].
bytecode = 172 ifTrue: [ "long jumpIfFalse"
offset := self fetchByte.
cond
ifTrue: [^ self fetchNextBytecode]
ifFalse: [^ self jump: offset]].
"not followed by a jumpIfFalse; undo instruction fetch and push boolean result"
localIP := localIP - 1.
self fetchNextBytecode.
cond
+ ifTrue: [self internalPush: objectMemory trueObj]
+ ifFalse: [self internalPush: objectMemory falseObj].
- ifTrue: [self internalPush: trueObj]
- ifFalse: [self internalPush: falseObj].
!
Item was changed:
----- Method: Interpreter>>booleanValueOf: (in category 'utilities') -----
booleanValueOf: obj
"convert true and false (Smalltalk) to true or false(C)"
+ obj = objectMemory trueObj ifTrue: [ ^ true ].
+ obj = objectMemory falseObj ifTrue: [ ^ false ].
- obj = trueObj ifTrue: [ ^ true ].
- obj = falseObj ifTrue: [ ^ false ].
self primitiveFail.
^ nil!
Item was changed:
----- Method: Interpreter>>byteLengthOf: (in category 'array primitive support') -----
byteLengthOf: oop
"Return the number of indexable bytes in the given object. This is basically a special copy of lengthOf: for BitBlt."
| header sz fmt |
+ header := objectMemory baseHeader: oop.
- header := self baseHeader: oop.
(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ sz := (objectMemory sizeHeader: oop) bitAnd: objectMemory allButTypeMask ]
+ ifFalse: [ sz := header bitAnd: objectMemory sizeMask ].
- ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self allButTypeMask ]
- ifFalse: [ sz := header bitAnd: self sizeMask ].
fmt := (header >> 8) bitAnd: 16rF.
fmt < 8
+ ifTrue: [ ^ (sz - objectMemory baseHeaderSize)] "words"
+ ifFalse: [ ^ (sz - objectMemory baseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
- ifTrue: [ ^ (sz - self baseHeaderSize)] "words"
- ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was changed:
----- Method: Interpreter>>byteSizeOf: (in category 'object format') -----
byteSizeOf: oop
| slots |
self flag: #Dan.
+ (objectMemory isIntegerObject: oop) ifTrue:[^0].
- (self isIntegerObject: oop) ifTrue:[^0].
slots := self slotSizeOf: oop.
+ (objectMemory isBytesNonInt: oop)
- (self isBytesNonInt: oop)
ifTrue:[^slots]
ifFalse:[^slots * 4]!
Item was changed:
----- Method: Interpreter>>byteSwapByteObjects (in category 'image save/restore') -----
byteSwapByteObjects
"Byte-swap the words of all bytes objects in the image. This returns these objects to their original byte ordering after blindly byte-swapping the entire image."
+ self byteSwapByteObjectsFrom: objectMemory firstObject to: objectMemory endOfMemory!
- self byteSwapByteObjectsFrom: self firstObject to: endOfMemory!
Item was changed:
----- Method: Interpreter>>byteSwapByteObjectsFrom:to: (in category 'image save/restore') -----
byteSwapByteObjectsFrom: startOop to: stopAddr
"Byte-swap the words of all bytes objects in a range of the
image, including Strings, ByteArrays, and CompiledMethods.
This returns these objects to their original byte ordering
after blindly byte-swapping the entire image. For compiled
methods, byte-swap only their bytecodes part."
| oop fmt wordAddr methodHeader |
oop := startOop.
+ [objectMemory oop: oop isLessThan: stopAddr]
+ whileTrue: [(objectMemory isFreeObject: oop)
+ ifFalse: [fmt := objectMemory formatOf: oop.
- [self oop: oop isLessThan: stopAddr]
- whileTrue: [(self isFreeObject: oop)
- ifFalse: [fmt := self formatOf: oop.
fmt >= 8
ifTrue: ["oop contains bytes"
+ wordAddr := oop + objectMemory baseHeaderSize.
- wordAddr := oop + self baseHeaderSize.
fmt >= 12
ifTrue: ["compiled method; start after methodHeader and literals"
+ methodHeader := self longAt: oop + objectMemory baseHeaderSize.
- methodHeader := self longAt: oop + self baseHeaderSize.
wordAddr := wordAddr + self bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * self bytesPerWord)].
+ objectMemory reverseBytesFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)].
- self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop)].
(fmt = 6 and: [self 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]!
- wordAddr := oop + self baseHeaderSize.
- self reverseWordsFrom: wordAddr to: oop + (self sizeBitsOf: oop)]].
- oop := self objectAfter: oop]!
Item was removed:
- ----- Method: Interpreter>>byteSwapped: (in category 'image save/restore') -----
- byteSwapped: w
- "Answer the given integer with its bytes in the reverse order."
-
- <inline: true>
- self isDefinedTrueExpression: 'BYTES_PER_WORD == 4'
- inSmalltalk: [self bytesPerWord = 4]
- comment: 'swap bytes in an object word'
- ifTrue:
- [^ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte0Mask)
- + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte1Mask)
- + ((w bitShift: Byte1Shift ) bitAnd: Byte2Mask)
- + ((w bitShift: Byte3Shift ) bitAnd: Byte3Mask)]
- ifFalse:
- [^ ((w bitShift: Byte7ShiftNegated) bitAnd: Byte0Mask)
- + ((w bitShift: Byte5ShiftNegated) bitAnd: Byte1Mask)
- + ((w bitShift: Byte3ShiftNegated) bitAnd: Byte2Mask)
- + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte3Mask)
- + ((w bitShift: Byte1Shift ) bitAnd: Byte4Mask)
- + ((w bitShift: Byte3Shift ) bitAnd: Byte5Mask)
- + ((w bitShift: Byte5Shift ) bitAnd: Byte6Mask)
- + ((w bitShift: Byte7Shift ) bitAnd: Byte7Mask)]!
Item was changed:
----- Method: Interpreter>>bytecodePrimAdd (in category 'common selector sends') -----
bytecodePrimAdd
| rcvr arg result |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg)
+ ifTrue: [result := (objectMemory integerValueOf: rcvr) + (objectMemory integerValueOf: arg).
+ (objectMemory isIntegerValue: result) ifTrue:
+ [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
- ifTrue: [result := (self integerValueOf: rcvr) + (self integerValueOf: arg).
- (self isIntegerValue: result) ifTrue:
- [self internalPop: 2 thenPush: (self integerObjectOf: result).
^ self fetchNextBytecode "success"]]
ifFalse: [self initPrimCall.
self externalizeIPandSP.
self primitiveFloatAdd: rcvr toArg: arg.
self internalizeIPandSP.
self successful ifTrue: [^ self fetchNextBytecode "success"]].
messageSelector := self specialSelector: 0.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimAt (in category 'common selector sends') -----
bytecodePrimAt
"BytecodePrimAt will only succeed if the receiver is in the atCache.
Otherwise it will fail so that the more general primitiveAt will put it in the
cache after validating that message lookup results in a primitive response."
| index rcvr result atIx |
index := self internalStackTop.
rcvr := self internalStackValue: 1.
+ ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isIntegerObject: index])
- ((self isIntegerObject: rcvr) not and: [self isIntegerObject: index])
ifTrue: [atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
(atCache at: atIx+AtCacheOop) = rcvr
ifTrue: [result := self
commonVariableInternal: rcvr
+ at: (objectMemory integerValueOf: index)
- at: (self integerValueOf: index)
cacheIndex: atIx.
self successful ifTrue:
[self fetchNextBytecode.
^self internalPop: 2 thenPush: result]]]
ifFalse: [self primitiveFail].
messageSelector := self specialSelector: 16.
argumentCount := 1.
self normalSend.
!
Item was changed:
----- Method: Interpreter>>bytecodePrimAtPut (in category 'common selector sends') -----
bytecodePrimAtPut
"BytecodePrimAtPut will only succeed if the receiver is in the atCache.
Otherwise it will fail so that the more general primitiveAtPut will put it in the
cache after validating that message lookup results in a primitive response."
| index rcvr atIx value |
value := self internalStackTop.
index := self internalStackValue: 1.
rcvr := self internalStackValue: 2.
+ ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isIntegerObject: index])
- ((self isIntegerObject: rcvr) not and: [self isIntegerObject: index])
ifTrue: [atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
(atCache at: atIx+AtCacheOop) = rcvr
ifTrue: [self
commonVariable: rcvr
+ at: (objectMemory integerValueOf: index)
- at: (self integerValueOf: index)
put: value cacheIndex: atIx.
self successful ifTrue: [self fetchNextBytecode.
^self internalPop: 3 thenPush: value]]]
ifFalse: [self primitiveFail].
messageSelector := self specialSelector: 17.
argumentCount := 2.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimBlockCopy (in category 'common selector sends') -----
bytecodePrimBlockCopy
| rcvr hdr |
rcvr := self internalStackValue: 1.
self initPrimCall.
+ hdr := objectMemory baseHeader: rcvr.
- hdr := self baseHeader: rcvr.
self success: (self isContextHeader: hdr).
self successful ifTrue: [self externalizeIPandSP.
self primitiveBlockCopy.
self internalizeIPandSP].
self successful ifFalse: [messageSelector := self specialSelector: 24.
argumentCount := 1.
^ self normalSend].
self fetchNextBytecode.
!
Item was changed:
----- Method: Interpreter>>bytecodePrimClass (in category 'common selector sends') -----
bytecodePrimClass
| rcvr |
rcvr := self internalStackTop.
+ self internalPop: 1 thenPush: (objectMemory fetchClassOf: rcvr).
- self internalPop: 1 thenPush: (self fetchClassOf: rcvr).
self fetchNextBytecode.
!
Item was changed:
----- Method: Interpreter>>bytecodePrimDiv (in category 'common selector sends') -----
bytecodePrimDiv
| quotient |
self initPrimCall.
quotient := self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0).
+ self successful ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: quotient).
- self successful ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: quotient).
^ self fetchNextBytecode "success"].
messageSelector := self specialSelector: 13.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimDivide (in category 'common selector sends') -----
bytecodePrimDivide
| rcvr arg result |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg)
+ ifTrue: [rcvr := objectMemory integerValueOf: rcvr.
+ arg := objectMemory integerValueOf: arg.
- ifTrue: [rcvr := self integerValueOf: rcvr.
- arg := self integerValueOf: arg.
(arg ~= 0 and: [rcvr \\ arg = 0])
ifTrue: [result := rcvr // arg.
"generates C / operation"
+ (objectMemory isIntegerValue: result)
+ ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
- (self isIntegerValue: result)
- ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result).
^ self fetchNextBytecode"success"]]]
ifFalse: [self initPrimCall.
self externalizeIPandSP.
self primitiveFloatDivide: rcvr byArg: arg.
self internalizeIPandSP.
self successful ifTrue: [^ self fetchNextBytecode"success"]].
messageSelector := self specialSelector: 9.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimGreaterOrEqual (in category 'common selector sends') -----
bytecodePrimGreaterOrEqual
| rcvr arg aBool |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg) ifTrue:
+ [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) >= (objectMemory integerValueOf: arg)].
- [self cCode: '' inSmalltalk: [^self booleanCheat: (self integerValueOf: rcvr) >= (self integerValueOf: arg)].
^self booleanCheat: rcvr >= arg].
self initPrimCall.
aBool := self primitiveFloatGreaterOrEqual: rcvr toArg: arg.
self successful ifTrue: [^self booleanCheat: aBool].
messageSelector := self specialSelector: 5.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimGreaterThan (in category 'common selector sends') -----
bytecodePrimGreaterThan
| rcvr arg aBool |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg) ifTrue:
+ [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) > (objectMemory integerValueOf: arg)].
- [self cCode: '' inSmalltalk: [^self booleanCheat: (self integerValueOf: rcvr) > (self integerValueOf: arg)].
^self booleanCheat: rcvr > arg].
self initPrimCall.
aBool := self primitiveFloatGreater: rcvr thanArg: arg.
self successful ifTrue: [^self booleanCheat: aBool].
messageSelector := self specialSelector: 3.
argumentCount := 1.
self normalSend
!
Item was changed:
----- Method: Interpreter>>bytecodePrimLessOrEqual (in category 'common selector sends') -----
bytecodePrimLessOrEqual
| rcvr arg aBool |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg) ifTrue:
+ [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) <= (objectMemory integerValueOf: arg)].
- [self cCode: '' inSmalltalk: [^self booleanCheat: (self integerValueOf: rcvr) <= (self integerValueOf: arg)].
^ self booleanCheat: rcvr <= arg].
self initPrimCall.
aBool := self primitiveFloatLessOrEqual: rcvr toArg: arg.
self successful ifTrue: [^self booleanCheat: aBool].
messageSelector := self specialSelector: 4.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimLessThan (in category 'common selector sends') -----
bytecodePrimLessThan
| rcvr arg aBool |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg) ifTrue:
+ [self cCode: '' inSmalltalk: [^self booleanCheat: (objectMemory integerValueOf: rcvr) < (objectMemory integerValueOf: arg)].
- [self cCode: '' inSmalltalk: [^self booleanCheat: (self integerValueOf: rcvr) < (self integerValueOf: arg)].
^ self booleanCheat: rcvr < arg].
self initPrimCall.
aBool := self primitiveFloatLess: rcvr thanArg: arg.
self successful ifTrue: [^ self booleanCheat: aBool].
messageSelector := self specialSelector: 2.
argumentCount := 1.
self normalSend
!
Item was changed:
----- Method: Interpreter>>bytecodePrimMod (in category 'common selector sends') -----
bytecodePrimMod
| mod |
self initPrimCall.
mod := self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0).
self successful ifTrue:
+ [self internalPop: 2 thenPush: (objectMemory integerObjectOf: mod).
- [self internalPop: 2 thenPush: (self integerObjectOf: mod).
^ self fetchNextBytecode "success"].
messageSelector := self specialSelector: 10.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimMultiply (in category 'common selector sends') -----
bytecodePrimMultiply
| rcvr arg result |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg)
+ ifTrue: [rcvr := objectMemory integerValueOf: rcvr.
+ arg := objectMemory integerValueOf: arg.
- ifTrue: [rcvr := self integerValueOf: rcvr.
- arg := self integerValueOf: arg.
result := rcvr * arg.
+ (arg = 0 or: [(result // arg) = rcvr and: [objectMemory isIntegerValue: result]])
+ ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
- (arg = 0 or: [(result // arg) = rcvr and: [self isIntegerValue: result]])
- ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result).
^ self fetchNextBytecode "success"]]
ifFalse: [self initPrimCall.
self externalizeIPandSP.
self primitiveFloatMultiply: rcvr byArg: arg.
self internalizeIPandSP.
self successful ifTrue: [^ self fetchNextBytecode "success"]].
messageSelector := self specialSelector: 8.
argumentCount := 1.
self normalSend.
!
Item was changed:
----- Method: Interpreter>>bytecodePrimPointX (in category 'common selector sends') -----
bytecodePrimPointX
| rcvr |
self initPrimCall.
rcvr := self internalStackTop.
+ self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
- self assertClassOf: rcvr is: (self splObj: ClassPoint).
self successful
+ ifTrue: [self internalPop: 1 thenPush: (objectMemory fetchPointer: XIndex ofObject: rcvr).
- ifTrue: [self internalPop: 1 thenPush: (self fetchPointer: XIndex ofObject: rcvr).
^ self fetchNextBytecode "success"].
messageSelector := self specialSelector: 30.
argumentCount := 0.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimPointY (in category 'common selector sends') -----
bytecodePrimPointY
| rcvr |
self initPrimCall.
rcvr := self internalStackTop.
+ self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
- self assertClassOf: rcvr is: (self splObj: ClassPoint).
self successful
+ ifTrue: [self internalPop: 1 thenPush: (objectMemory fetchPointer: YIndex ofObject: rcvr).
- ifTrue: [self internalPop: 1 thenPush: (self fetchPointer: YIndex ofObject: rcvr).
^ self fetchNextBytecode "success"].
messageSelector := self specialSelector: 31.
argumentCount := 0.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimSubtract (in category 'common selector sends') -----
bytecodePrimSubtract
| rcvr arg result |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg)
+ ifTrue: [result := (objectMemory integerValueOf: rcvr) - (objectMemory integerValueOf: arg).
+ (objectMemory isIntegerValue: result) ifTrue:
+ [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
- ifTrue: [result := (self integerValueOf: rcvr) - (self integerValueOf: arg).
- (self isIntegerValue: result) ifTrue:
- [self internalPop: 2 thenPush: (self integerObjectOf: result).
^self fetchNextBytecode "success"]]
ifFalse: [self initPrimCall.
self externalizeIPandSP.
self primitiveFloatSubtract: rcvr fromArg: arg.
self internalizeIPandSP.
self successful ifTrue: [^self fetchNextBytecode "success"]].
messageSelector := self specialSelector: 1.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: Interpreter>>bytecodePrimValue (in category 'common selector sends') -----
bytecodePrimValue
"In-line value for BlockClosure and BlockContext"
| maybeBlock rcvrClass |
maybeBlock := self internalStackTop.
argumentCount := 0.
self initPrimCall.
+ (objectMemory isNonIntegerObject: maybeBlock) ifTrue:
+ [rcvrClass := objectMemory fetchClassOfNonInt: maybeBlock.
+ rcvrClass = (objectMemory splObj: ClassBlockClosure)
- (self isNonIntegerObject: maybeBlock) ifTrue:
- [rcvrClass := self fetchClassOfNonInt: maybeBlock.
- rcvrClass = (self splObj: ClassBlockClosure)
ifTrue:
[self externalizeIPandSP.
self primitiveClosureValue.
self internalizeIPandSP]
ifFalse:
+ [rcvrClass = (objectMemory splObj: ClassBlockContext)
- [rcvrClass = (self splObj: ClassBlockContext)
ifTrue:
[self externalizeIPandSP.
self primitiveValue.
self internalizeIPandSP]
ifFalse:
[self primitiveFail]]].
self successful ifFalse:
[messageSelector := self specialSelector: 25.
^self normalSend].
self fetchNextBytecode!
Item was changed:
----- Method: Interpreter>>bytecodePrimValueWithArg (in category 'common selector sends') -----
bytecodePrimValueWithArg
"In-line value: for BlockClosure and BlockContext"
| maybeBlock rcvrClass |
maybeBlock := self internalStackValue: 1.
argumentCount := 1.
self initPrimCall.
+ (objectMemory isNonIntegerObject: maybeBlock) ifTrue:
+ [rcvrClass := objectMemory fetchClassOfNonInt: maybeBlock.
+ rcvrClass = (objectMemory splObj: ClassBlockClosure)
- (self isNonIntegerObject: maybeBlock) ifTrue:
- [rcvrClass := self fetchClassOfNonInt: maybeBlock.
- rcvrClass = (self splObj: ClassBlockClosure)
ifTrue:
[self externalizeIPandSP.
self primitiveClosureValue.
self internalizeIPandSP]
ifFalse:
+ [rcvrClass = (objectMemory splObj: ClassBlockContext)
- [rcvrClass = (self splObj: ClassBlockContext)
ifTrue:
[self externalizeIPandSP.
self primitiveValue.
self internalizeIPandSP]
ifFalse:
[self primitiveFail]]].
self successful ifFalse:
[messageSelector := self specialSelector: 26.
^self normalSend].
self fetchNextBytecode!
Item was changed:
----- Method: Interpreter>>callbackEnter: (in category 'callback support') -----
callbackEnter: callbackID
"Re-enter the interpreter for executing a callback"
| result activeProc |
<export: true>
<var: #callbackID declareC: 'sqInt *callbackID'>
"For now, do not allow a callback unless we're in a primitiveResponse"
primitiveIndex = 0 ifTrue:[^false].
"Check if we've exceeded the callback depth"
jmpDepth >= jmpMax ifTrue:[^false].
jmpDepth := jmpDepth + 1.
"Suspend the currently active process"
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex
- activeProc := self fetchPointer: ActiveProcessIndex
ofObject: self schedulerPointer.
suspendedCallbacks at: jmpDepth put: activeProc.
"We need to preserve newMethod explicitly since it is not activated yet
and therefore no context has been created for it. If the caller primitive
for any reason decides to fail we need to make sure we execute the correct
method and not the one 'last used' in the call back"
suspendedMethods at: jmpDepth put: newMethod.
self transferTo: self wakeHighestPriority.
"Typically, invoking the callback means that some semaphore has been
signaled to indicate the callback. Force an interrupt check right away."
self forceInterruptCheck.
result := self setjmp: (jmpBuf at: jmpDepth).
result == 0 ifTrue:["Fill in callbackID"
callbackID at: 0 put: jmpDepth.
"This is ugly but the inliner treats interpret() in very special and strange ways and calling any kind of 'self interpret' either directly or even via cCode:inSmalltalk: will cause this entire method to vanish."
self cCode: 'interpret()'.
].
"Transfer back to the previous process so that caller can push result"
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex
- activeProc := self fetchPointer: ActiveProcessIndex
ofObject: self schedulerPointer.
self putToSleep: activeProc.
activeProc := suspendedCallbacks at: jmpDepth.
newMethod := suspendedMethods at: jmpDepth. "see comment above"
self transferTo: activeProc.
jmpDepth := jmpDepth-1.
^true!
Item was changed:
----- Method: Interpreter>>caller (in category 'contexts') -----
caller
+ ^objectMemory fetchPointer: CallerIndex ofObject: activeContext!
- ^self fetchPointer: CallerIndex ofObject: activeContext!
Item was changed:
----- Method: Interpreter>>capturePendingFinalizationSignals (in category 'debug support') -----
capturePendingFinalizationSignals
+ objectMemory statpendingFinalizationSignals: pendingFinalizationSignals.
- statpendingFinalizationSignals := pendingFinalizationSignals.
!
Item was changed:
----- Method: Interpreter>>changeClassOf:to: (in category 'object access primitives') -----
changeClassOf: rcvr to: argClass
"Change the class of the receiver into the class specified by the argument given that the format of the receiver matches the format of the argument. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
| classHdr sizeHiBits byteSize argFormat rcvrFormat ccIndex |
"Check what the format of the class says"
classHdr := self formatOfClass: argClass. "Low 2 bits are 0"
"Compute the size of instances of the class (used for fixed field classes only)"
sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
classHdr := classHdr bitAnd: 16r1FFFF.
+ byteSize := (classHdr bitAnd: objectMemory sizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
- byteSize := (classHdr bitAnd: self sizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
"Check the receiver's format against that of the class"
argFormat := (classHdr >> 8) bitAnd: 16rF.
+ rcvrFormat := objectMemory formatOf: rcvr.
- rcvrFormat := self formatOf: rcvr.
argFormat = rcvrFormat ifFalse:[^self primitiveFail]. "no way"
"For fixed field classes, the sizes must match.
Note: byteSize-4 because base header is included in class size."
+ argFormat < 2 ifTrue:[(byteSize - objectMemory baseHeaderSize) = (self byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].
- argFormat < 2 ifTrue:[(byteSize - self baseHeaderSize) = (self byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].
+ (objectMemory headerType: rcvr) = HeaderTypeShort
- (self headerType: rcvr) = HeaderTypeShort
ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex"
ccIndex := classHdr bitAnd: CompactClassMask.
ccIndex = 0 ifTrue:[^self primitiveFail]. "class is not compact"
self longAt: rcvr put:
(((self longAt: rcvr) bitAnd: CompactClassMask bitInvert32)
bitOr: ccIndex)]
ifFalse:["Exchange the class pointer, which could make rcvr a root for argClass"
+ self longAt: rcvr - objectMemory baseHeaderSize put: (argClass bitOr: (objectMemory headerType: rcvr)).
+ (objectMemory oop: rcvr isLessThan: objectMemory youngStart)
+ ifTrue: [objectMemory possibleRootStoreInto: rcvr value: argClass]].
- self longAt: rcvr - self baseHeaderSize put: (argClass bitOr: (self headerType: rcvr)).
- (self oop: rcvr isLessThan: youngStart)
- ifTrue: [self possibleRootStoreInto: rcvr value: argClass]].
"Flush cache because rcvr's class has changed"
self flushMethodCache.
!
Item was changed:
----- Method: Interpreter>>characterForAscii: (in category 'array primitive support') -----
characterForAscii: ascii "Arg must lie in range 0-255!!"
<inline: true>
+ ^ objectMemory fetchPointer: ascii ofObject: (objectMemory splObj: CharacterTable)!
- ^ self fetchPointer: ascii ofObject: (self splObj: CharacterTable)!
Item was changed:
----- Method: Interpreter>>checkForInterrupts (in category 'process primitive support') -----
checkForInterrupts
"Check for possible interrupts and handle one if necessary."
| sema now |
<inline: false>
"Mask so same wrapping as primitiveMillisecondClock"
now := self ioMSecs bitAnd: MillisecondClockMask.
self interruptCheckForced ifFalse: [
"don't play with the feedback if we forced a check. It only makes life difficult"
now - lastTick < interruptChecksEveryNms
ifTrue: ["wrapping is not a concern, it'll get caught quickly
enough. This clause is trying to keep a reasonable
guess of how many times per interruptChecksEveryNms we are calling
quickCheckForInterrupts. Not sure how effective it really is."
interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset + 10]
ifFalse: [interruptCheckCounterFeedBackReset <= 1000
ifTrue: [interruptCheckCounterFeedBackReset := 1000]
ifFalse: [interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset - 12]]].
"reset the interrupt check counter"
interruptCheckCounter := interruptCheckCounterFeedBackReset.
+ objectMemory signalLowSpace
+ ifTrue: [objectMemory signalLowSpace: false. "reset flag"
+ sema := objectMemory splObj: TheLowSpaceSemaphore.
+ sema = objectMemory nilObj ifFalse: [self synchronousSignal: sema]].
- signalLowSpace
- ifTrue: [signalLowSpace := false. "reset flag"
- sema := self splObj: TheLowSpaceSemaphore.
- sema = nilObj ifFalse: [self synchronousSignal: sema]].
now < lastTick
ifTrue: ["millisecond clock wrapped so correct the nextPollTick"
nextPollTick := nextPollTick - MillisecondClockMask - 1].
now >= nextPollTick
ifTrue: [self ioProcessEvents.
"sets interruptPending if interrupt key pressed"
nextPollTick := now + 200
"msecs to wait before next call to ioProcessEvents.
Note that strictly speaking we might need to update
'now' at this point since ioProcessEvents could take a
very long time on some platforms"].
interruptPending
ifTrue: [interruptPending := false.
"reset interrupt flag"
+ sema := objectMemory splObj: TheInterruptSemaphore.
+ sema = objectMemory nilObj
- sema := self splObj: TheInterruptSemaphore.
- sema = nilObj
ifFalse: [self synchronousSignal: sema]].
nextWakeupTick ~= 0
ifTrue: [now < lastTick
ifTrue: ["the clock has wrapped. Subtract the wrap
interval from nextWakeupTick - this might just
possibly result in 0. Since this is used as a flag
value for 'no timer' we do the 0 check above"
nextWakeupTick := nextWakeupTick - MillisecondClockMask - 1].
now >= nextWakeupTick
ifTrue: [nextWakeupTick := 0.
"set timer interrupt to 0 for 'no timer'"
+ sema := objectMemory splObj: TheTimerSemaphore.
+ sema = objectMemory nilObj ifFalse: [self synchronousSignal: sema]]].
- sema := self splObj: TheTimerSemaphore.
- sema = nilObj ifFalse: [self synchronousSignal: sema]]].
"signal any pending finalizations"
pendingFinalizationSignals > 0
+ ifTrue: [sema := objectMemory splObj: TheFinalizationSemaphore.
+ (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
- ifTrue: [sema := self splObj: TheFinalizationSemaphore.
- (self fetchClassOf: sema) = (self splObj: ClassSemaphore)
ifTrue: [self synchronousSignal: sema].
pendingFinalizationSignals := 0].
"signal all semaphores in semaphoresToSignal"
(semaphoresToSignalCountA > 0 or: [semaphoresToSignalCountB > 0])
ifTrue: [self signalExternalSemaphores].
"update the tracking value"
lastTick := now!
Item was changed:
----- Method: Interpreter>>checkIntegerResult: (in category 'arithmetic primitive support') -----
checkIntegerResult: integerResult
+ (self successful and: [objectMemory isIntegerValue: integerResult])
- (self successful and: [self isIntegerValue: integerResult])
ifTrue: [self pushInteger: integerResult]
ifFalse: [self unPop: 2]!
Item was changed:
----- Method: Interpreter>>checkedIntegerValueOf: (in category 'utilities') -----
checkedIntegerValueOf: intOop
"Note: May be called by translated primitive code."
+ (objectMemory isIntegerObject: intOop)
+ ifTrue: [ ^ objectMemory integerValueOf: intOop ]
- (self isIntegerObject: intOop)
- ifTrue: [ ^ self integerValueOf: intOop ]
ifFalse: [ self primitiveFail. ^ 0 ]!
Item was changed:
----- Method: Interpreter>>classNameOf:Is: (in category 'plugin primitive support') -----
classNameOf: aClass Is: className
"Check if aClass's name is className"
| srcName name length |
<var: #className type: 'char *'>
<var: #srcName type: 'char *'>
(self lengthOf: aClass) <= 6 ifTrue: [^ false].
"Not a class but might be behavior"
+ name := objectMemory fetchPointer: 6 ofObject: aClass.
+ (objectMemory isBytes: name) ifFalse: [^ false].
- name := self fetchPointer: 6 ofObject: aClass.
- (self isBytes: name) ifFalse: [^ false].
length := self stSizeOf: name.
srcName := self cCoerce: (self arrayValueOf: name) to: 'char *'.
0 to: length - 1 do: [:i | (srcName at: i) = (className at: i) ifFalse: [^ false]].
"Check if className really ends at this point"
^ (className at: length) = 0!
Item was changed:
----- Method: Interpreter>>closureNumArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
closureNumArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
| newClosure |
<inline: true>
+ newClosure := objectMemory
+ instantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
+ sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize.
- newClosure := self
- instantiateSmallClass: (self splObj: ClassBlockClosure)
- sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
+ objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
- self storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (self integerObjectOf: initialIP).
- self storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (self integerObjectOf: numArgs).
"It is up to the caller to store the outer context and copiedValues."
^newClosure!
Item was changed:
----- Method: Interpreter>>commonAt: (in category 'array primitive support') -----
commonAt: stringy
"This code is called if the receiver responds primitively to at:.
If this is so, it will be installed in the atCache so that subsequent calls of at:
or next may be handled immediately in bytecode primitive routines."
| index rcvr atIx result |
index := self positive32BitValueOf: (self stackTop). "Sets primFailCode"
rcvr := self stackValue: 1.
+ self successful & (objectMemory isIntegerObject: rcvr) not
- self successful & (self isIntegerObject: rcvr) not
ifFalse: [^ self primitiveFail].
"NOTE: The at-cache, since it is specific to the non-super response to #at:.
Therefore we must determine that the message is #at: (not, eg, #basicAt:),
and that the send is not a super-send, before using the at-cache."
(messageSelector = (self specialSelector: 16)
+ and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)])
- and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
ifTrue:
["OK -- look in the at-cache"
atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
["Rcvr not in cache. Install it..."
self install: rcvr inAtCache: atCache at: atIx string: stringy].
self successful ifTrue:
[result := self commonVariable: rcvr at: index cacheIndex: atIx].
self successful ifTrue:
[^ self pop: argumentCount+1 thenPush: result]].
"The slow but sure way..."
self initPrimCall.
result := self stObject: rcvr at: index.
self successful ifTrue:
+ [stringy ifTrue: [result := self characterForAscii: (objectMemory integerValueOf: result)].
- [stringy ifTrue: [result := self characterForAscii: (self integerValueOf: result)].
^ self pop: argumentCount+1 thenPush: result]!
Item was changed:
----- Method: Interpreter>>commonAtPut: (in category 'array primitive support') -----
commonAtPut: stringy
"This code is called if the receiver responds primitively to at:Put:.
If this is so, it will be installed in the atPutCache so that subsequent calls of at:
or next may be handled immediately in bytecode primitive routines."
| value index rcvr atIx |
value := self stackTop.
index := self positive32BitValueOf: (self stackValue: 1). "Sets primFailCode"
rcvr := self stackValue: 2.
+ self successful & (objectMemory isIntegerObject: rcvr) not
- self successful & (self isIntegerObject: rcvr) not
ifFalse: [^ self primitiveFail].
"NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:.
Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:),
and that the send is not a super-send, before using the at-cache."
(messageSelector = (self specialSelector: 17)
+ and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)])
- and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
ifTrue:
["OK -- look in the at-cache"
atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
["Rcvr not in cache. Install it..."
self install: rcvr inAtCache: atCache at: atIx string: stringy].
self successful ifTrue:
[self commonVariable: rcvr at: index put: value cacheIndex: atIx].
self successful ifTrue:
[^ self pop: argumentCount+1 thenPush: value]].
"The slow but sure way..."
self initPrimCall.
stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
ifFalse: [self stObject: rcvr at: index put: value].
self successful ifTrue: [^ self pop: argumentCount+1 thenPush: value].
!
Item was changed:
----- Method: Interpreter>>commonReturn (in category 'return bytecodes') -----
commonReturn
"Note: Assumed to be inlined into the dispatch loop."
| nilOop thisCntx contextOfCaller localCntx localVal unwindMarked |
<inline: true>
self sharedCodeNamed: 'commonReturn' inCase: 120.
+ nilOop := objectMemory nilObj. "keep in a register"
- nilOop := nilObj. "keep in a register"
thisCntx := activeContext.
localCntx := localReturnContext.
localVal := localReturnValue.
"make sure we can return to the given context"
((localCntx = nilOop) or:
+ [(objectMemory fetchPointer: InstructionPointerIndex ofObject: localCntx) = nilOop]) ifTrue: [
- [(self fetchPointer: InstructionPointerIndex ofObject: localCntx) = nilOop]) ifTrue: [
"error: sender's instruction pointer or context is nil; cannot return"
^self internalCannotReturn: localVal].
"If this return is not to our immediate predecessor (i.e. from a method to its sender, or from a block to its caller), scan the stack for the first unwind marked context and inform this context and let it deal with it. This provides a chance for ensure unwinding to occur."
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: activeContext.
- thisCntx := self fetchPointer: SenderIndex ofObject: activeContext.
"Just possibly a faster test would be to compare the homeContext and activeContext - they are of course different for blocks. Thus we might be able to optimise a touch by having a different returnTo for the blockreteurn (since we know that must return to caller) and then if active ~= home we must be doing a non-local return. I think. Maybe."
[thisCntx = localCntx] whileFalse: [
thisCntx = nilOop ifTrue:[
"error: sender's instruction pointer or context is nil; cannot return"
^self internalCannotReturn: localVal].
"Climb up stack towards localCntx. Break out to a send of #aboutToReturn:through: if an unwind marked context is found"
unwindMarked := self isUnwindMarked: thisCntx.
unwindMarked ifTrue:[
"context is marked; break out"
^self internalAboutToReturn: localVal through: thisCntx].
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- thisCntx := self fetchPointer: SenderIndex ofObject: thisCntx.
].
"If we get here there is no unwind to worry about. Simply terminate the stack up to the localCntx - often just the sender of the method"
thisCntx := activeContext.
[thisCntx = localCntx]
whileFalse:
["climb up stack to localCntx"
+ contextOfCaller := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- contextOfCaller := self fetchPointer: SenderIndex ofObject: thisCntx.
"zap exited contexts so any future attempted use will be caught"
+ objectMemory storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.
- self storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.
- self storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.
reclaimableContextCount > 0 ifTrue:
["try to recycle this context"
reclaimableContextCount := reclaimableContextCount - 1.
+ objectMemory recycleContextIfPossible: thisCntx].
- self recycleContextIfPossible: thisCntx].
thisCntx := contextOfCaller].
activeContext := thisCntx.
+ (objectMemory oop: thisCntx isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: thisCntx ].
- (self oop: thisCntx isLessThan: youngStart) ifTrue: [ self beRootIfOld: thisCntx ].
self internalFetchContextRegisters: thisCntx. "updates local IP and SP"
self fetchNextBytecode.
self internalPush: localVal.
!
Item was changed:
----- Method: Interpreter>>commonVariable:at:cacheIndex: (in category 'array primitive support') -----
commonVariable: rcvr at: index cacheIndex: atIx
"This code assumes the receiver has been identified at location atIx in the atCache."
| stSize fmt fixedFields result |
stSize := atCache at: atIx+AtCacheSize.
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ((self oop: index isGreaterThanOrEqualTo: 1)
- and: [self oop: index isLessThanOrEqualTo: stSize])
ifTrue:
[fmt := atCache at: atIx+AtCacheFmt.
fmt <= 4 ifTrue:
[fixedFields := atCache at: atIx+AtCacheFixedFields.
+ ^ objectMemory fetchPointer: index + fixedFields - 1 ofObject: rcvr].
- ^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr].
fmt < 8 ifTrue: "Bitmap"
+ [result := objectMemory fetchLong32: index - 1 ofObject: rcvr.
- [result := self fetchLong32: index - 1 ofObject: rcvr.
result := self positive32BitIntegerFor: result.
^ result].
fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
ifTrue: "String"
+ [^ self characterForAscii: (objectMemory fetchByte: index - 1 ofObject: rcvr)]
- [^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)]
ifFalse: "ByteArray"
+ [^ objectMemory integerObjectOf: (objectMemory fetchByte: index - 1 ofObject: rcvr)]].
- [^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]].
self primitiveFail!
Item was changed:
----- Method: Interpreter>>commonVariable:at:put:cacheIndex: (in category 'array primitive support') -----
commonVariable: rcvr at: index put: value cacheIndex: atIx
"This code assumes the receiver has been identified at location atIx in the atCache."
| stSize fmt fixedFields valToPut |
<inline: true>
stSize := atCache at: atIx+AtCacheSize.
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ((self oop: index isGreaterThanOrEqualTo: 1)
- and: [self oop: index isLessThanOrEqualTo: stSize])
ifTrue:
[fmt := atCache at: atIx+AtCacheFmt.
fmt <= 4 ifTrue:
[fixedFields := atCache at: atIx+AtCacheFixedFields.
+ ^ objectMemory storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value].
- ^ self storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value].
fmt < 8 ifTrue: "Bitmap"
[valToPut := self positive32BitValueOf: value.
+ self successful ifTrue: [objectMemory storeLong32: index - 1 ofObject: rcvr withValue: valToPut].
- self successful ifTrue: [self storeLong32: index - 1 ofObject: rcvr withValue: valToPut].
^ nil].
fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
ifTrue: [valToPut := self asciiOfCharacter: value.
self successful ifFalse: [^ nil]]
ifFalse: [valToPut := value].
+ (objectMemory isIntegerObject: valToPut) ifTrue:
+ [valToPut := objectMemory integerValueOf: valToPut.
- (self isIntegerObject: valToPut) ifTrue:
- [valToPut := self integerValueOf: valToPut.
((valToPut >= 0) and: [valToPut <= 255]) ifFalse: [^ self primitiveFail].
+ ^ objectMemory storeByte: index - 1 ofObject: rcvr withValue: valToPut]].
- ^ self storeByte: index - 1 ofObject: rcvr withValue: valToPut]].
self primitiveFail!
Item was changed:
----- Method: Interpreter>>commonVariableInternal:at:cacheIndex: (in category 'array primitive support') -----
commonVariableInternal: rcvr at: index cacheIndex: atIx
"This code assumes the receiver has been identified at location atIx in the atCache."
| stSize fmt fixedFields result |
<inline: true>
stSize := atCache at: atIx+AtCacheSize.
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ((self oop: index isGreaterThanOrEqualTo: 1)
- and: [self oop: index isLessThanOrEqualTo: stSize])
ifTrue:
[fmt := atCache at: atIx+AtCacheFmt.
fmt <= 4 ifTrue:
[fixedFields := atCache at: atIx+AtCacheFixedFields.
+ ^ objectMemory fetchPointer: index + fixedFields - 1 ofObject: rcvr].
- ^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr].
fmt < 8 ifTrue: "Bitmap"
+ [result := objectMemory fetchLong32: index - 1 ofObject: rcvr.
- [result := self fetchLong32: index - 1 ofObject: rcvr.
self externalizeIPandSP.
result := self positive32BitIntegerFor: result.
self internalizeIPandSP.
^ result].
fmt >= 16 "Note fmt >= 16 is an artificial flag for strings"
ifTrue: "String"
+ [^ self characterForAscii: (objectMemory fetchByte: index - 1 ofObject: rcvr)]
- [^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)]
ifFalse: "ByteArray"
+ [^ objectMemory integerObjectOf: (objectMemory fetchByte: index - 1 ofObject: rcvr)]].
- [^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]].
self primitiveFail!
Item was changed:
----- Method: Interpreter>>compare31or32Bits:equal: (in category 'arithmetic primitive support') -----
compare31or32Bits: obj1 equal: obj2
"May set success to false"
"First compare two ST integers..."
+ ((objectMemory isIntegerObject: obj1)
+ and: [objectMemory isIntegerObject: obj2])
- ((self isIntegerObject: obj1)
- and: [self isIntegerObject: obj2])
ifTrue: [^ obj1 = obj2].
"Now compare, assuming positive integers, but setting fail if not"
^ (self positive32BitValueOf: obj1) = (self positive32BitValueOf: obj2)!
Item was added:
+ ----- Method: Interpreter>>constMinusOne (in category 'constants') -----
+ constMinusOne
+ ^ConstMinusOne!
Item was changed:
----- Method: Interpreter>>context:hasSender: (in category 'contexts') -----
context: thisCntx hasSender: aContext
"Does thisCntx have aContext in its sender chain?"
| s nilOop |
<inline: true>
thisCntx == aContext ifTrue: [^false].
+ nilOop := objectMemory nilObj.
+ s := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- nilOop := nilObj.
- s := self fetchPointer: SenderIndex ofObject: thisCntx.
[s == nilOop]
whileFalse: [s == aContext ifTrue: [^true].
+ s := objectMemory fetchPointer: SenderIndex ofObject: s].
- s := self fetchPointer: SenderIndex ofObject: s].
^false!
Item was changed:
----- Method: Interpreter>>createActualMessageTo: (in category 'message sending') -----
createActualMessageTo: aClass
"Bundle up the selector, arguments and lookupClass into a Message object.
In the process it pops the arguments off the stack, and pushes the message object.
This can then be presented as the argument of e.g. #doesNotUnderstand:.
ikp 11/20/1999 03:59 -- added hook for external runtime compilers."
"remap lookupClass in case GC happens during allocation"
| argumentArray message lookupClass |
+ objectMemory pushRemappableOop: aClass.
+ argumentArray := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount.
- self pushRemappableOop: aClass.
- argumentArray := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
"remap argumentArray in case GC happens during allocation"
+ objectMemory pushRemappableOop: argumentArray.
+ message := objectMemory instantiateClass: (objectMemory splObj: ClassMessage) indexableSize: 0.
+ argumentArray := objectMemory popRemappableOop.
+ lookupClass := objectMemory popRemappableOop.
+ objectMemory beRootIfOld: argumentArray.
- self pushRemappableOop: argumentArray.
- message := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
- argumentArray := self popRemappableOop.
- lookupClass := self popRemappableOop.
- self beRootIfOld: argumentArray.
compilerInitialized
ifTrue: [self compilerCreateActualMessage: message storingArgs: argumentArray]
+ ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * objectMemory bytesPerWord) to: argumentArray + objectMemory baseHeaderSize.
- ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * self bytesPerWord) to: argumentArray + self baseHeaderSize.
self pop: argumentCount thenPush: message].
argumentCount := 1.
+ objectMemory storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector.
+ objectMemory storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray.
+ (objectMemory lastPointerOf: message) >= (MessageLookupClassIndex * objectMemory bytesPerWord + objectMemory baseHeaderSize)
- self storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector.
- self storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray.
- (self lastPointerOf: message) >= (MessageLookupClassIndex * self bytesPerWord + self baseHeaderSize)
ifTrue: ["Only store lookupClass if message has 3 fields (old images don't)"
+ objectMemory storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]!
- self storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]!
Item was changed:
----- Method: Interpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') -----
displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
+ displayObj := objectMemory splObj: TheDisplay.
- displayObj := self splObj: TheDisplay.
aForm = displayObj ifFalse: [^ nil].
+ self success: ((objectMemory isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
- self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
self successful ifTrue: [
+ dispBits := objectMemory fetchPointer: 0 ofObject: displayObj.
- dispBits := self fetchPointer: 0 ofObject: displayObj.
w := self fetchInteger: 1 ofObject: displayObj.
h := self fetchInteger: 2 ofObject: displayObj.
d := self fetchInteger: 3 ofObject: displayObj.
].
l < 0 ifTrue:[left := 0] ifFalse: [left := l].
r > w ifTrue: [right := w] ifFalse: [right := r].
t < 0 ifTrue: [top := 0] ifFalse: [top := t].
b > h ifTrue: [bottom := h] ifFalse: [bottom := b].
((left <= right) and: [top <= bottom]) ifFalse: [^nil].
self successful ifTrue: [
+ (objectMemory isIntegerObject: dispBits) ifTrue: [
+ surfaceHandle := objectMemory integerValueOf: dispBits.
- (self isIntegerObject: dispBits) ifTrue: [
- surfaceHandle := self integerValueOf: dispBits.
showSurfaceFn = 0 ifTrue: [
showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
showSurfaceFn = 0 ifTrue: [^self success: false]].
self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
] ifFalse: [
+ dispBitsIndex := dispBits + objectMemory baseHeaderSize. "index in memory byte array"
- dispBitsIndex := dispBits + self baseHeaderSize. "index in memory byte array"
self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
inSmalltalk: [self showDisplayBits: dispBitsIndex
w: w h: h d: d
left: left right: right top: top bottom: bottom]
].
].!
Item was changed:
----- Method: Interpreter>>doPrimitiveDiv:by: (in category 'arithmetic primitive support') -----
doPrimitiveDiv: rcvr by: arg
"Rounds negative results towards negative infinity, rather than zero."
| result posArg posRcvr integerRcvr integerArg |
(self areIntegers: rcvr and: arg)
+ ifTrue: [integerRcvr := objectMemory integerValueOf: rcvr.
+ integerArg := objectMemory integerValueOf: arg.
- ifTrue: [integerRcvr := self integerValueOf: rcvr.
- integerArg := self integerValueOf: arg.
self success: integerArg ~= 0]
ifFalse: [self primitiveFail].
self successful ifFalse: [^ 1 "fail"].
integerRcvr > 0
ifTrue: [integerArg > 0
ifTrue: [result := integerRcvr // integerArg]
ifFalse: ["round negative result toward negative infinity"
posArg := 0 - integerArg.
result := 0 - ((integerRcvr + (posArg - 1)) // posArg)]]
ifFalse: [posRcvr := 0 - integerRcvr.
integerArg > 0
ifTrue: ["round negative result toward negative infinity"
result := 0 - ((posRcvr + (integerArg - 1)) // integerArg)]
ifFalse: [posArg := 0 - integerArg.
result := posRcvr // posArg]].
+ self success: (objectMemory isIntegerValue: result).
- self success: (self isIntegerValue: result).
^ result!
Item was changed:
----- Method: Interpreter>>doPrimitiveMod:by: (in category 'arithmetic primitive support') -----
doPrimitiveMod: rcvr by: arg
| integerResult integerRcvr integerArg |
(self areIntegers: rcvr and: arg)
+ ifTrue: [integerRcvr := objectMemory integerValueOf: rcvr.
+ integerArg := objectMemory integerValueOf: arg.
- ifTrue: [integerRcvr := self integerValueOf: rcvr.
- integerArg := self integerValueOf: arg.
self success: integerArg ~= 0]
ifFalse: [self primitiveFail].
self successful ifFalse: [^ 1 "fail"].
integerResult := integerRcvr \\ integerArg.
"ensure that the result has the same sign as the integerArg"
integerArg < 0
ifTrue: [integerResult > 0
ifTrue: [integerResult := integerResult + integerArg]]
ifFalse: [integerResult < 0
ifTrue: [integerResult := integerResult + integerArg]].
+ self success: (objectMemory isIntegerValue: integerResult).
- self success: (self isIntegerValue: integerResult).
^ integerResult
!
Item was changed:
----- Method: Interpreter>>doubleExtendedDoAnythingBytecode (in category 'send bytecodes') -----
doubleExtendedDoAnythingBytecode
"Replaces the Blue Book double-extended send [132], in which the first byte was wasted on 8 bits of argument count.
Here we use 3 bits for the operation sub-type (opType), and the remaining 5 bits for argument count where needed.
The last byte give access to 256 instVars or literals.
See also secondExtendedSendBytecode"
| byte2 byte3 opType top |
byte2 := self fetchByte.
byte3 := self fetchByte.
opType := byte2 >> 5.
opType = 0 ifTrue: [messageSelector := self literal: byte3.
argumentCount := byte2 bitAnd: 31.
^ self normalSend].
opType = 1 ifTrue: [messageSelector := self literal: byte3.
argumentCount := byte2 bitAnd: 31.
^ self superclassSend].
self fetchNextBytecode.
opType = 2 ifTrue: [^ self pushReceiverVariable: byte3].
opType = 3 ifTrue: [^ self pushLiteralConstant: byte3].
opType = 4 ifTrue: [^ self pushLiteralVariable: byte3].
opType = 5 ifTrue: [top := self internalStackTop.
+ ^ objectMemory storePointer: byte3 ofObject: receiver withValue: top].
- ^ self storePointer: byte3 ofObject: receiver withValue: top].
opType = 6
ifTrue: [top := self internalStackTop.
self internalPop: 1.
+ ^ objectMemory storePointer: byte3 ofObject: receiver withValue: top].
- ^ self storePointer: byte3 ofObject: receiver withValue: top].
opType = 7
ifTrue: [top := self internalStackTop.
+ ^ objectMemory storePointer: ValueIndex ofObject: (self literal: byte3) withValue: top]!
- ^ self storePointer: ValueIndex ofObject: (self literal: byte3) withValue: top]!
Item was changed:
----- Method: Interpreter>>dumpImage: (in category 'image save/restore') -----
dumpImage: fileName
"Dump the entire image out to the given file. Intended for debugging only."
| f dataSize result |
<export: true>
<var: #fileName type: 'char *'>
<var: #f type: 'sqImageFile'>
f := self cCode: 'sqImageFileOpen(fileName, "wb")'.
f = nil ifTrue: [^-1].
+ dataSize := objectMemory endOfMemory - objectMemory startOfMemory.
- dataSize := endOfMemory - self startOfMemory.
result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
self cCode: 'sqImageFileClose(f)'.
^result
!
Item was changed:
----- Method: Interpreter>>extendedStoreBytecode (in category 'stack bytecodes') -----
extendedStoreBytecode
| descriptor variableType variableIndex association |
<inline: true>
descriptor := self fetchByte.
self fetchNextBytecode.
variableType := descriptor >> 6 bitAnd: 3.
variableIndex := descriptor bitAnd: 63.
variableType = 0
+ ifTrue: [^ objectMemory storePointer: variableIndex ofObject: receiver withValue: self internalStackTop].
- ifTrue: [^ self storePointer: variableIndex ofObject: receiver withValue: self internalStackTop].
variableType = 1
+ ifTrue: [^ objectMemory storePointerUnchecked: variableIndex + TempFrameStart ofObject: localHomeContext withValue: self internalStackTop].
- ifTrue: [^ self storePointerUnchecked: variableIndex + TempFrameStart ofObject: localHomeContext withValue: self internalStackTop].
variableType = 2
ifTrue: [self error: 'illegal store'].
variableType = 3
ifTrue: [association := self literal: variableIndex.
+ ^ objectMemory storePointer: ValueIndex ofObject: association withValue: self internalStackTop]!
- ^ self storePointer: ValueIndex ofObject: association withValue: self internalStackTop]!
Item was changed:
----- Method: Interpreter>>fetchArray:ofObject: (in category 'utilities') -----
fetchArray: fieldIndex ofObject: objectPointer
"Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
"Note: May be called by translated primitive code."
| arrayOop |
<returnTypeC: 'void *'>
+ arrayOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
- arrayOop := self fetchPointer: fieldIndex ofObject: objectPointer.
^ self arrayValueOf: arrayOop
!
Item was changed:
----- Method: Interpreter>>fetchContextRegisters: (in category 'contexts') -----
fetchContextRegisters: activeCntx
"Note: internalFetchContextRegisters: should track changes to this method."
| tmp |
<inline: true>
+ tmp := objectMemory fetchPointer: MethodIndex ofObject: activeCntx.
+ (objectMemory isIntegerObject: tmp)
- tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
- (self isIntegerObject: tmp)
ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
+ tmp := objectMemory fetchPointer: HomeIndex ofObject: activeCntx.
+ (objectMemory oop: tmp isLessThan: objectMemory youngStart) ifTrue: [objectMemory beRootIfOld: tmp]]
- tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
- (self oop: tmp isLessThan: youngStart) ifTrue: [self beRootIfOld: tmp]]
ifFalse: ["otherwise, it is a method context and is its own home context "
tmp := activeCntx].
theHomeContext := tmp.
+ receiver := objectMemory fetchPointer: ReceiverIndex ofObject: tmp.
+ method := objectMemory fetchPointer: MethodIndex ofObject: tmp.
- receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
- method := self fetchPointer: MethodIndex ofObject: tmp.
"the instruction pointer is a pointer variable equal to
method oop + ip + self baseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte "
tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ instructionPointer := method + tmp + objectMemory baseHeaderSize - 2.
- instructionPointer := method + tmp + self baseHeaderSize - 2.
"the stack pointer is a pointer variable also..."
tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ stackPointer := activeCntx + objectMemory baseHeaderSize + (TempFrameStart + tmp - 1 * objectMemory bytesPerWord)!
- stackPointer := activeCntx + self baseHeaderSize + (TempFrameStart + tmp - 1 * self bytesPerWord)!
Item was changed:
----- Method: Interpreter>>fetchFloat:ofObject: (in category 'utilities') -----
fetchFloat: fieldIndex ofObject: objectPointer
"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
"Note: May be called by translated primitive code."
| floatOop |
<returnTypeC: 'double'>
+ floatOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
- floatOop := self fetchPointer: fieldIndex ofObject: objectPointer.
^ self floatValueOf: floatOop!
Item was changed:
----- Method: Interpreter>>fetchInteger:ofObject: (in category 'utilities') -----
fetchInteger: fieldIndex ofObject: objectPointer
"Note: May be called by translated primitive code."
| intOop |
<inline: false>
+ intOop := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
- intOop := self fetchPointer: fieldIndex ofObject: objectPointer.
^self checkedIntegerValueOf: intOop!
Item was changed:
----- Method: Interpreter>>fetchIntegerOrTruncFloat:ofObject: (in category 'utilities') -----
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
"Note: May be called by translated primitive code."
| intOrFloat floatVal frac trunc |
<inline: false>
<var: #floatVal type: 'double '>
<var: #frac type: 'double '>
<var: #trunc type: 'double '>
+ intOrFloat := objectMemory fetchPointer: fieldIndex ofObject: objectPointer.
+ (objectMemory isIntegerObject: intOrFloat) ifTrue: [^ objectMemory integerValueOf: intOrFloat].
+ self assertClassOf: intOrFloat is: (objectMemory splObj: ClassFloat).
- intOrFloat := self fetchPointer: fieldIndex ofObject: objectPointer.
- (self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
- self assertClassOf: intOrFloat is: (self splObj: ClassFloat).
self successful ifTrue: [
self cCode: '' inSmalltalk: [floatVal := Float new: 2].
+ self fetchFloatAt: intOrFloat + objectMemory baseHeaderSize into: floatVal.
- self fetchFloatAt: intOrFloat + self baseHeaderSize into: floatVal.
self cCode: 'frac = modf(floatVal, &trunc)'.
"the following range check is for C ints, with range -2^31..2^31-1"
self flag: #Dan. "The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.].
self successful
ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]]
ifFalse: [^ 0].
!
Item was changed:
----- Method: Interpreter>>fetchStackPointerOf: (in category 'contexts') -----
fetchStackPointerOf: aContext
"Return the stackPointer of a Context or BlockContext."
| sp |
<inline: true>
+ sp := objectMemory fetchPointer: StackPointerIndex ofObject: aContext.
+ (objectMemory isIntegerObject: sp) ifFalse: [^0].
+ ^objectMemory integerValueOf: sp!
- sp := self fetchPointer: StackPointerIndex ofObject: aContext.
- (self isIntegerObject: sp) ifFalse: [^0].
- ^self integerValueOf: sp!
Item was changed:
----- Method: Interpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
findClassOfMethod: meth forReceiver: rcvr
| currClass classDict classDictSize methodArray i done |
+ currClass := objectMemory fetchClassOf: rcvr.
- currClass := self fetchClassOf: rcvr.
done := false.
[done] whileFalse: [
+ classDict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currClass.
+ classDictSize := objectMemory fetchWordLengthOf: classDict.
+ methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
- classDict := self fetchPointer: MessageDictionaryIndex ofObject: currClass.
- classDictSize := self fetchWordLengthOf: classDict.
- methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i < (classDictSize - SelectorStart)] whileTrue: [
+ meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
- meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
i := i + 1.
].
+ currClass := objectMemory fetchPointer: SuperclassIndex ofObject: currClass.
+ done := currClass = objectMemory nilObj.
- currClass := self fetchPointer: SuperclassIndex ofObject: currClass.
- done := currClass = nilObj.
].
+ ^objectMemory fetchClassOf: rcvr "method not found in superclass chain"!
- ^self fetchClassOf: rcvr "method not found in superclass chain"!
Item was changed:
----- Method: Interpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') -----
findSelectorOfMethod: meth forReceiver: rcvr
| currClass done classDict classDictSize methodArray i |
+ currClass := objectMemory fetchClassOf: rcvr.
- currClass := self fetchClassOf: rcvr.
done := false.
[done] whileFalse: [
+ classDict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currClass.
+ classDictSize := objectMemory fetchWordLengthOf: classDict.
+ methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
- classDict := self fetchPointer: MessageDictionaryIndex ofObject: currClass.
- classDictSize := self fetchWordLengthOf: classDict.
- methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i <= (classDictSize - SelectorStart)] whileTrue: [
+ meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [
+ ^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
- meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [
- ^(self fetchPointer: i + SelectorStart ofObject: classDict)
].
i := i + 1.
].
+ currClass := objectMemory fetchPointer: SuperclassIndex ofObject: currClass.
+ done := currClass = objectMemory nilObj.
- currClass := self fetchPointer: SuperclassIndex ofObject: currClass.
- done := currClass = nilObj.
].
+ ^ objectMemory nilObj "method not found in superclass chain"!
- ^ nilObj "method not found in superclass chain"!
Item was changed:
----- Method: Interpreter>>firstFixedField: (in category 'plugin support') -----
firstFixedField: oop
<returnTypeC: 'char *'>
+ ^ self pointerForOop: oop + objectMemory baseHeaderSize!
- ^ self pointerForOop: oop + self baseHeaderSize!
Item was changed:
----- Method: Interpreter>>firstIndexableField: (in category 'plugin support') -----
firstIndexableField: oop
"NOTE: copied in InterpreterSimulator, so please duplicate any changes"
| hdr fmt totalLength fixedFields |
<returnTypeC: 'char *'>
+ hdr := objectMemory baseHeader: oop.
- hdr := self baseHeader: oop.
fmt := (hdr >> 8) bitAnd: 16rF.
totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
fmt < 8 ifTrue:
[fmt = 6 ifTrue:
["32 bit field objects"
+ ^ self pointerForOop: oop + objectMemory baseHeaderSize + (fixedFields << 2)].
- ^ self pointerForOop: oop + self baseHeaderSize + (fixedFields << 2)].
"full word objects (pointer or bits)"
+ ^ self pointerForOop: oop + objectMemory baseHeaderSize + (fixedFields << objectMemory shiftForWord)]
- ^ self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)]
ifFalse:
["Byte objects"
+ ^ self pointerForOop: oop + objectMemory baseHeaderSize + fixedFields]!
- ^ self pointerForOop: oop + self baseHeaderSize + fixedFields]!
Item was changed:
----- Method: Interpreter>>fixedFieldsOf:format:length: (in category 'object format') -----
fixedFieldsOf: oop format: fmt length: wordLength
"
NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
When we revise the image format, it should become...
^ (classFormat >> 2 bitAnd: 16rFF) - 1
"
| class classFormat |
<inline: true>
((fmt > 4) or: [fmt = 2]) ifTrue: [^ 0]. "indexable fields only"
fmt < 2 ifTrue: [^ wordLength]. "fixed fields only (zero or more)"
"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
+ class := objectMemory fetchClassOf: oop.
- class := self fetchClassOf: oop.
classFormat := self formatOfClass: class.
^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1
!
Item was changed:
----- Method: Interpreter>>floatObjectOf: (in category 'object format') -----
floatObjectOf: aFloat
| newFloatObj |
<var: #aFloat type: 'double '>
self flag: #Dan.
+ newFloatObj := objectMemory instantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + objectMemory baseHeaderSize.
- newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8 + self baseHeaderSize.
self storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat.
^ newFloatObj.
!
Item was changed:
----- Method: Interpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
"Note: May be called by translated primitive code."
| result |
<returnTypeC: 'double'>
<var: #result type: 'double '>
self flag: #Dan. "None of the float stuff has been converted for 64 bits"
+ self assertClassOf: oop is: (objectMemory splObj: ClassFloat).
- self assertClassOf: oop is: (self splObj: ClassFloat).
self successful
ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: oop + objectMemory baseHeaderSize into: result]
- self fetchFloatAt: oop + self baseHeaderSize into: result]
ifFalse: [result := 0.0].
^ result!
Item was changed:
----- Method: Interpreter>>flushExternalPrimitiveOf: (in category 'plugin primitive support') -----
flushExternalPrimitiveOf: methodPtr
"methodPtr is a CompiledMethod containing an external primitive. Flush the function address and session ID of the CM"
| lit |
(self literalCountOf: methodPtr) > 0 ifFalse:[^nil]. "Something's broken"
lit := self literal: 0 ofMethod: methodPtr.
+ ((objectMemory isArray: lit) and:[(self lengthOf: lit) = 4])
- ((self isArray: lit) and:[(self lengthOf: lit) = 4])
ifFalse:[^nil]. "Something's broken"
"ConstZero is a known SmallInt so no root check needed"
+ objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
+ objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
- self storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
- self storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
!
Item was changed:
----- Method: Interpreter>>flushExternalPrimitives (in category 'plugin primitive support') -----
flushExternalPrimitives
"Flush the references to external functions from plugin
primitives. This will force a reload of those primitives when
accessed next.
Note: We must flush the method cache here so that any
failed primitives are looked up again."
| oop primIdx |
+ oop := objectMemory firstObject.
+ [objectMemory oop: oop isLessThan: objectMemory endOfMemory]
+ whileTrue: [(objectMemory isFreeObject: oop)
+ ifFalse: [(objectMemory isCompiledMethod: oop)
- oop := self firstObject.
- [self oop: oop isLessThan: endOfMemory]
- whileTrue: [(self isFreeObject: oop)
- ifFalse: [(self isCompiledMethod: oop)
ifTrue: ["This is a compiled method"
primIdx := self primitiveIndexOf: oop.
primIdx = PrimitiveExternalCallIndex
ifTrue: ["It's primitiveExternalCall"
self flushExternalPrimitiveOf: oop]]].
+ oop := objectMemory objectAfter: oop].
- oop := self objectAfter: oop].
self flushMethodCache.
self flushExternalPrimitiveTable!
Item was changed:
----- Method: Interpreter>>flushMethodCacheFrom:to: (in category 'method lookup cache') -----
flushMethodCacheFrom: memStart to: memEnd
"Flush entries in the method cache only if the oop address is within the given memory range.
This reduces overagressive cache clearing. Note the AtCache is fully flushed, 70% of the time
cache entries live in newspace, new objects die young"
| probe |
probe := 0.
1 to: MethodCacheEntries do: [:i |
(methodCache at: probe + MethodCacheSelector) = 0
+ ifFalse: [(((((objectMemory oop: (methodCache at: probe + MethodCacheSelector) isGreaterThanOrEqualTo: memStart)
+ and: [objectMemory oop: (methodCache at: probe + MethodCacheSelector) isLessThan: memEnd])
+ or: [(objectMemory oop: (methodCache at: probe + MethodCacheClass) isGreaterThanOrEqualTo: memStart)
+ and: [objectMemory oop: (methodCache at: probe + MethodCacheClass) isLessThan: memEnd]])
+ or: [(objectMemory oop: (methodCache at: probe + MethodCacheMethod) isGreaterThanOrEqualTo: memStart)
+ and: [objectMemory oop: (methodCache at: probe + MethodCacheMethod) isLessThan: memEnd]])
+ or: [(objectMemory oop: (methodCache at: probe + MethodCacheNative) isGreaterThanOrEqualTo: memStart)
+ and: [objectMemory oop: (methodCache at: probe + MethodCacheNative) isLessThan: memEnd]])
- ifFalse: [(((((self oop: (methodCache at: probe + MethodCacheSelector) isGreaterThanOrEqualTo: memStart)
- and: [self oop: (methodCache at: probe + MethodCacheSelector) isLessThan: memEnd])
- or: [(self oop: (methodCache at: probe + MethodCacheClass) isGreaterThanOrEqualTo: memStart)
- and: [self oop: (methodCache at: probe + MethodCacheClass) isLessThan: memEnd]])
- or: [(self oop: (methodCache at: probe + MethodCacheMethod) isGreaterThanOrEqualTo: memStart)
- and: [self oop: (methodCache at: probe + MethodCacheMethod) isLessThan: memEnd]])
- or: [(self oop: (methodCache at: probe + MethodCacheNative) isGreaterThanOrEqualTo: memStart)
- and: [self oop: (methodCache at: probe + MethodCacheNative) isLessThan: memEnd]])
ifTrue: [methodCache at: probe + MethodCacheSelector put: 0]].
probe := probe + MethodCacheEntrySize].
1 to: AtCacheTotalSize do: [:i | atCache at: i put: 0]!
Item was changed:
----- Method: Interpreter>>formatOfClass: (in category 'object format') -----
formatOfClass: classPointer
"**should be in-lined**"
"Note that, in Smalltalk, the instSpec will be equal to the inst spec
part of the base header of an instance (without hdr type) shifted left 1.
In this way, apart from the smallInt bit, the bits
are just where you want them for the first header word."
"Callers expect low 2 bits (header type) to be zero!!"
+ ^ (objectMemory fetchPointer: InstanceSpecificationIndex ofObject: classPointer) - 1!
- ^ (self fetchPointer: InstanceSpecificationIndex ofObject: classPointer) - 1!
Item was changed:
----- Method: Interpreter>>fullDisplayUpdate (in category 'I/O primitive support') -----
fullDisplayUpdate
"Repaint the entire smalltalk screen, ignoring the affected rectangle. Used in some platform's code when the Smalltalk window is brought to the front or uncovered."
| displayObj w h |
+ displayObj := objectMemory splObj: TheDisplay.
+ ((objectMemory isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifTrue: [
- displayObj := self splObj: TheDisplay.
- ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifTrue: [
w := self fetchInteger: 1 ofObject: displayObj.
h := self fetchInteger: 2 ofObject: displayObj.
self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: h.
self ioForceDisplayUpdate].
!
Item was changed:
----- Method: Interpreter>>getLongFromFile:swap: (in category 'image save/restore') -----
getLongFromFile: aFile swap: swapFlag
"Answer the next word read from aFile, byte-swapped according to the swapFlag."
| w |
<var: #aFile type: 'sqImageFile '>
w := 0.
self cCode: 'sqImageFileRead(&w, sizeof(w), 1, aFile)'
inSmalltalk: [w := self nextLongFrom: aFile].
swapFlag
+ ifTrue: [^ objectMemory byteSwapped: w]
- ifTrue: [^ self byteSwapped: w]
ifFalse: [^ w].
!
Item was changed:
----- Method: Interpreter>>headerOf: (in category 'compiled methods') -----
headerOf: methodPointer
+ ^objectMemory fetchPointer: HeaderIndex ofObject: methodPointer!
- ^self fetchPointer: HeaderIndex ofObject: methodPointer!
Item was changed:
----- Method: Interpreter>>imageFormatBackwardCompatibilityVersion (in category 'image save/restore') -----
imageFormatBackwardCompatibilityVersion
"This VM is backwards-compatible with the immediately preceeding pre-closure version, and will allow loading images (or image segments) of that version."
+ objectMemory bytesPerWord == 4
- self bytesPerWord == 4
ifTrue: [^6502]
ifFalse: [^68000]!
Item was changed:
----- Method: Interpreter>>includesBehavior:ThatOf: (in category 'plugin primitive support') -----
includesBehavior: aClass ThatOf: aSuperclass
"Return the equivalent of
aClass includesBehavior: aSuperclass.
Note: written for efficiency and better inlining (only 1 temp)"
| theClass |
<inline: true>
+ aSuperclass = objectMemory nilObj ifTrue:
- aSuperclass = nilObj ifTrue:
[^false].
theClass := aClass.
[theClass = aSuperclass ifTrue:
[^true].
+ theClass ~= objectMemory nilObj] whileTrue:
- theClass ~= nilObj] whileTrue:
[theClass := self superclassOf: theClass].
^false!
Item was changed:
----- Method: Interpreter>>initialCleanup (in category 'initialization') -----
initialCleanup
"Images written by VMs earlier than 3.6/3.7 will wrongly have the root bit set on the active context. Besides clearing the root bit, we treat this as a marker that these images also lack a cleanup of external primitives (which has been introduced at the same time when the root bit problem was fixed). In this case, we merely flush them from here."
+ ((self longAt: activeContext) bitAnd: objectMemory rootBit) = 0 ifTrue:[^nil]. "root bit is clean"
- ((self longAt: activeContext) bitAnd: self rootBit) = 0 ifTrue:[^nil]. "root bit is clean"
"Clean root bit of activeContext"
+ self longAt: activeContext put: ((self longAt: activeContext) bitAnd: objectMemory allButRootBit).
- self longAt: activeContext put: ((self longAt: activeContext) bitAnd: self allButRootBit).
"Clean external primitives"
self flushExternalPrimitives.!
Item was changed:
----- Method: Interpreter>>initializeImageFormatVersionIfNeeded (in category 'image save/restore') -----
initializeImageFormatVersionIfNeeded
"Set the imageFormatVersionNumber to a default value for this word
size. Normally this will have been set at image load time, but set it to
a reasonable default if this has not been done."
<inline: false>
imageFormatVersionNumber = 0
+ ifTrue: [objectMemory bytesPerWord == 8
- ifTrue: [self bytesPerWord == 8
ifFalse: [imageFormatVersionNumber := 6502]
ifTrue: [imageFormatVersionNumber := 68000]]
!
Item was changed:
----- Method: Interpreter>>initializeInterpreter: (in category 'initialization') -----
initializeInterpreter: bytesToShift
"Initialize Interpreter state before starting execution of a new image."
interpreterProxy := self sqGetInterpreterProxy.
self dummyReferToProxy.
+ objectMemory initializeObjectMemory: bytesToShift.
- self initializeObjectMemory: bytesToShift.
self initCompilerHooks.
+ activeContext := objectMemory nilObj.
+ theHomeContext := objectMemory nilObj.
+ method := objectMemory nilObj.
+ receiver := objectMemory nilObj.
+ messageSelector := objectMemory nilObj.
+ newMethod := objectMemory nilObj.
+ methodClass := objectMemory nilObj.
+ lkupClass := objectMemory nilObj.
+ receiverClass := objectMemory nilObj.
+ newNativeMethod := objectMemory nilObj.
- activeContext := nilObj.
- theHomeContext := nilObj.
- method := nilObj.
- receiver := nilObj.
- messageSelector := nilObj.
- newMethod := nilObj.
- methodClass := nilObj.
- lkupClass := nilObj.
- receiverClass := nilObj.
- newNativeMethod := nilObj.
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 changed:
----- Method: Interpreter>>install:inAtCache:at:string: (in category 'indexing primitives') -----
install: rcvr inAtCache: cache at: atIx string: stringy
"Install the oop of this object in the given cache (at or atPut), along with
its size, format and fixedSize"
| hdr fmt totalLength fixedFields |
<var: #cache type: 'sqInt *'>
+ hdr := objectMemory baseHeader: rcvr.
- hdr := self baseHeader: rcvr.
fmt := (hdr >> 8) bitAnd: 16rF.
(fmt = 3 and: [self isContextHeader: hdr]) ifTrue:
["Contexts must not be put in the atCache, since their size is not constant"
^ self primitiveFail].
totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: rcvr format: fmt length: totalLength.
cache at: atIx+AtCacheOop put: rcvr.
stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16] "special flag for strings"
ifFalse: [cache at: atIx+AtCacheFmt put: fmt].
cache at: atIx+AtCacheFixedFields put: fixedFields.
cache at: atIx+AtCacheSize put: totalLength - fixedFields.
!
Item was changed:
----- Method: Interpreter>>internalAboutToReturn:through: (in category 'return bytecodes') -----
internalAboutToReturn: resultObj through: aContext
<inline: true>
self internalPush: activeContext.
self internalPush: resultObj.
self internalPush: aContext.
+ messageSelector := objectMemory splObj: SelectorAboutToReturn.
- messageSelector := self splObj: SelectorAboutToReturn.
argumentCount := 2.
^self normalSend!
Item was changed:
----- Method: Interpreter>>internalActivateNewMethod (in category 'message sending') -----
internalActivateNewMethod
| methodHeader newContext tempCount argCount2 needsLarge where |
<inline: true>
methodHeader := self headerOf: newMethod.
needsLarge := methodHeader bitAnd: LargeContextBit.
+ (needsLarge = 0 and: [objectMemory freeContexts ~= objectMemory nilContext])
+ ifTrue: [newContext := objectMemory freeContexts.
+ objectMemory freeContexts: (objectMemory fetchPointer: 0 ofObject: newContext)]
- (needsLarge = 0 and: [freeContexts ~= NilContext])
- ifTrue: [newContext := freeContexts.
- freeContexts := self fetchPointer: 0 ofObject: newContext]
ifFalse: ["Slower call for large contexts or empty free list"
self externalizeIPandSP.
+ newContext := objectMemory allocateOrRecycleContext: needsLarge.
- newContext := self allocateOrRecycleContext: needsLarge.
self internalizeIPandSP].
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + objectMemory baseHeaderSize.
+ self longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << objectMemory shiftForWord)
+ put: (objectMemory integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1)).
+ self longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
+ self longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory nilObj.
- where := newContext + self baseHeaderSize.
- self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << self shiftForWord)
- put: (self integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1)).
- self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
- self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.
"Copy the receiver and arguments..."
argCount2 := argumentCount.
0 to: argCount2 do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord) put: (self internalStackValue: argCount2-i)].
- [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self internalStackValue: argCount2-i)].
"clear remaining temps to nil in case it has been recycled"
+ methodHeader := objectMemory nilObj. "methodHeader here used just as faster (register?) temp"
- methodHeader := nilObj. "methodHeader here used just as faster (register?) temp"
argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | self longAt: where + (i << objectMemory shiftForWord) put: methodHeader].
- [:i | self longAt: where + (i << self shiftForWord) put: methodHeader].
self internalPop: argCount2 + 1.
reclaimableContextCount := reclaimableContextCount + 1.
self internalNewActiveContext: newContext.
!
Item was changed:
----- Method: Interpreter>>internalCannotReturn: (in category 'return bytecodes') -----
internalCannotReturn: resultObj
<inline: true>
self internalPush: activeContext.
self internalPush: resultObj.
+ messageSelector := objectMemory splObj: SelectorCannotReturn.
- messageSelector := self splObj: SelectorCannotReturn.
argumentCount := 1.
^ self normalSend!
Item was changed:
----- Method: Interpreter>>internalExecuteNewMethod (in category 'message sending') -----
internalExecuteNewMethod
| localPrimIndex delta nArgs |
<inline: true>
localPrimIndex := primitiveIndex.
localPrimIndex > 0
ifTrue: [(localPrimIndex > 255
and: [localPrimIndex < 520])
ifTrue: ["Internal return instvars"
localPrimIndex >= 264
+ ifTrue: [^ self internalPop: 1 thenPush: (objectMemory fetchPointer: localPrimIndex - 264 ofObject: self internalStackTop)]
- ifTrue: [^ self internalPop: 1 thenPush: (self fetchPointer: localPrimIndex - 264 ofObject: self internalStackTop)]
ifFalse: ["Internal return constants"
localPrimIndex = 256 ifTrue: [^ nil].
+ localPrimIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: objectMemory trueObj].
+ localPrimIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: objectMemory falseObj].
+ localPrimIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: objectMemory nilObj].
+ ^ self internalPop: 1 thenPush: (objectMemory integerObjectOf: localPrimIndex - 261)]]
- localPrimIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: trueObj].
- localPrimIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: falseObj].
- localPrimIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: nilObj].
- ^ self internalPop: 1 thenPush: (self integerObjectOf: localPrimIndex - 261)]]
ifFalse: [self externalizeIPandSP.
"self primitiveResponse. <-replaced with manually inlined code"
DoBalanceChecks
ifTrue: ["check stack balance"
nArgs := argumentCount.
delta := stackPointer - activeContext].
self initPrimCall.
self dispatchFunctionPointer: primitiveFunctionPointer. "branch direct to prim function from address stored in mcache"
DoBalanceChecks
ifTrue: [(self balancedStack: delta afterPrimitive: localPrimIndex withArgs: nArgs)
ifFalse: [self printUnbalancedStack: localPrimIndex]].
self internalizeIPandSP.
self successful
ifTrue: [self browserPluginReturnIfNeeded.
^ nil]]].
"if not primitive, or primitive failed, activate the method"
self internalActivateNewMethod.
"check for possible interrupts at each real send"
self internalQuickCheckForInterrupts!
Item was changed:
----- Method: Interpreter>>internalFetchContextRegisters: (in category 'contexts') -----
internalFetchContextRegisters: activeCntx
"Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."
| tmp |
<inline: true>
+ tmp := objectMemory fetchPointer: MethodIndex ofObject: activeCntx.
+ (objectMemory isIntegerObject: tmp) ifTrue: [
- tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
- (self isIntegerObject: tmp) ifTrue: [
"if the MethodIndex field is an integer, activeCntx is a block context"
+ tmp := objectMemory fetchPointer: HomeIndex ofObject: activeCntx.
+ (objectMemory oop: tmp isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: tmp ].
- tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
- (self oop: tmp isLessThan: youngStart) ifTrue: [ self beRootIfOld: tmp ].
] ifFalse: [
"otherwise, it is a method context and is its own home context"
tmp := activeCntx.
].
localHomeContext := tmp.
+ receiver := objectMemory fetchPointer: ReceiverIndex ofObject: tmp.
+ method := objectMemory fetchPointer: MethodIndex ofObject: tmp.
- receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
- method := self fetchPointer: MethodIndex ofObject: tmp.
"the instruction pointer is a pointer variable equal to
method oop + ip + self baseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ localIP := self pointerForOop: method + tmp + objectMemory baseHeaderSize - 2.
- localIP := self pointerForOop: method + tmp + self baseHeaderSize - 2.
"the stack pointer is a pointer variable also..."
tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ localSP := self pointerForOop: activeCntx + objectMemory baseHeaderSize + ((TempFrameStart + tmp - 1) * objectMemory bytesPerWord)!
- localSP := self pointerForOop: activeCntx + self baseHeaderSize + ((TempFrameStart + tmp - 1) * self bytesPerWord)!
Item was changed:
----- Method: Interpreter>>internalJustActivateNewMethod (in category 'message sending') -----
internalJustActivateNewMethod
"Activate the new method but *do not* copy receiver or argumernts from activeContext."
| methodHeader initialIP newContext tempCount needsLarge where |
<inline: true>
methodHeader := self headerOf: newMethod.
needsLarge := methodHeader bitAnd: LargeContextBit.
+ (needsLarge = 0 and: [objectMemory freeContexts ~= objectMemory nilContext])
+ ifTrue: [newContext := objectMemory freeContexts.
+ objectMemory freeContexts: (objectMemory fetchPointer: 0 ofObject: newContext)]
- (needsLarge = 0 and: [freeContexts ~= NilContext])
- ifTrue: [newContext := freeContexts.
- freeContexts := self fetchPointer: 0 ofObject: newContext]
ifFalse: ["Slower call for large contexts or empty free list"
+ newContext := objectMemory allocateOrRecycleContext: needsLarge].
+ initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1.
- newContext := self allocateOrRecycleContext: needsLarge].
- initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + 1.
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + objectMemory baseHeaderSize.
+ self longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
- where := newContext + self baseHeaderSize.
- self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
"Set the receiver..."
+ self longAt: where + (ReceiverIndex << objectMemory shiftForWord) put: receiver.
- self longAt: where + (ReceiverIndex << self shiftForWord) put: receiver.
"clear all args and temps to nil in case it has been recycled"
+ needsLarge := objectMemory nilObj. "needsLarge here used just as faster (register?) temp"
- needsLarge := nilObj. "needsLarge here used just as faster (register?) temp"
ReceiverIndex + 1 to: tempCount + ReceiverIndex do:
+ [:i | self longAt: where + (i << objectMemory shiftForWord) put: needsLarge].
- [:i | self longAt: where + (i << self shiftForWord) put: needsLarge].
reclaimableContextCount := reclaimableContextCount + 1.
activeContext := newContext.!
Item was changed:
----- Method: Interpreter>>internalNewActiveContext: (in category 'contexts') -----
internalNewActiveContext: aContext
"The only difference between this method and newActiveContext: is that this method uses internal context registers."
<inline: true>
self internalStoreContextRegisters: activeContext.
+ (objectMemory oop: aContext isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
- (self oop: aContext isLessThan: youngStart) ifTrue: [ self beRootIfOld: aContext ].
activeContext := aContext.
self internalFetchContextRegisters: aContext.!
Item was changed:
----- Method: Interpreter>>internalPop: (in category 'contexts') -----
internalPop: nItems
+ localSP := localSP - (nItems * objectMemory bytesPerWord).!
- localSP := localSP - (nItems * self bytesPerWord).!
Item was changed:
----- Method: Interpreter>>internalPop:thenPush: (in category 'contexts') -----
internalPop: nItems thenPush: oop
+ self longAtPointer: (localSP := localSP - ((nItems - 1) * objectMemory bytesPerWord)) put: oop.
- self longAtPointer: (localSP := localSP - ((nItems - 1) * self bytesPerWord)) put: oop.
!
Item was changed:
----- Method: Interpreter>>internalPrimitiveValue (in category 'control primitives') -----
internalPrimitiveValue
| newContext blockArgumentCount initialIP |
<inline: true>
self sharedCodeNamed: 'commonPrimitiveValue' inCase: 201.
self initPrimCall.
newContext := self internalStackValue: argumentCount.
+ self assertClassOf: newContext is: (objectMemory splObj: ClassBlockContext).
- self assertClassOf: newContext is: (self splObj: ClassBlockContext).
blockArgumentCount := self argumentCountOfBlock: newContext.
+ self success: (argumentCount = blockArgumentCount and: [(objectMemory fetchPointer: CallerIndex ofObject: newContext) = objectMemory nilObj]).
- self success: (argumentCount = blockArgumentCount and: [(self fetchPointer: CallerIndex ofObject: newContext) = nilObj]).
self successful
ifTrue: ["This code assumes argCount can only = 0 or 1"
argumentCount = 1
+ ifTrue: [objectMemory storePointer: TempFrameStart ofObject: newContext withValue: self internalStackTop].
- ifTrue: [self storePointer: TempFrameStart ofObject: newContext withValue: self internalStackTop].
self internalPop: argumentCount + 1.
"copy the initialIP value to the ip slot"
+ initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: newContext.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
- initialIP := self fetchPointer: InitialIPIndex ofObject: newContext.
- self storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
self storeStackPointerValue: argumentCount inContext: newContext.
+ objectMemory storePointerUnchecked: CallerIndex ofObject: newContext withValue: activeContext.
- self storePointerUnchecked: CallerIndex ofObject: newContext withValue: activeContext.
self internalNewActiveContext: newContext]
ifFalse: [messageSelector := self specialSelector: 25 + argumentCount.
self normalSend]!
Item was changed:
----- Method: Interpreter>>internalPush: (in category 'contexts') -----
internalPush: object
+ self longAtPointer: (localSP := localSP + objectMemory bytesPerWord) put: object.!
- self longAtPointer: (localSP := localSP + self bytesPerWord) put: object.!
Item was changed:
----- Method: Interpreter>>internalStackValue: (in category 'contexts') -----
internalStackValue: offset
+ ^ self longAtPointer: localSP - (offset * objectMemory bytesPerWord)!
- ^ self longAtPointer: localSP - (offset * self bytesPerWord)!
Item was changed:
----- Method: Interpreter>>internalStoreContextRegisters: (in category 'contexts') -----
internalStoreContextRegisters: activeCntx
"The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."
"InstructionPointer is a pointer variable equal to
method oop + ip + self baseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
<inline: true>
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
+ withValue: (objectMemory integerObjectOf:
+ ((self oopForPointer: localIP) + 2 - (method + objectMemory baseHeaderSize))).
+ objectMemory storePointerUnchecked: StackPointerIndex ofObject: activeCntx
+ withValue: (objectMemory integerObjectOf:
+ ((((self oopForPointer: localSP) - (activeCntx + objectMemory baseHeaderSize)) >> objectMemory shiftForWord) - TempFrameStart + 1)).
- self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
- withValue: (self integerObjectOf:
- ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))).
- self storePointerUnchecked: StackPointerIndex ofObject: activeCntx
- withValue: (self integerObjectOf:
- ((((self oopForPointer: localSP) - (activeCntx + self baseHeaderSize)) >> self shiftForWord) - TempFrameStart + 1)).
!
Item was changed:
----- Method: Interpreter>>is:KindOf: (in category 'plugin primitive support') -----
is: oop KindOf: className
"Support for external primitives."
| oopClass |
<var: #className type: 'char *'>
+ oopClass := objectMemory fetchClassOf: oop.
+ [oopClass == objectMemory nilObj] whileFalse:[
- oopClass := self fetchClassOf: oop.
- [oopClass == nilObj] whileFalse:[
(self classNameOf: oopClass Is: className) ifTrue:[^true].
oopClass := self superclassOf: oopClass].
^false!
Item was changed:
----- Method: Interpreter>>is:MemberOf: (in category 'plugin primitive support') -----
is: oop MemberOf: className
"Support for external primitives"
| oopClass |
<var: #className type: 'char *'>
+ oopClass := objectMemory fetchClassOf: oop.
- oopClass := self fetchClassOf: oop.
^(self classNameOf: oopClass Is: className)!
Item was changed:
----- Method: Interpreter>>isContext: (in category 'contexts') -----
isContext: oop
<inline: true>
+ ^(objectMemory isNonIntegerObject: oop) and: [self isContextHeader: (objectMemory baseHeader: oop)]!
- ^(self isNonIntegerObject: oop) and: [self isContextHeader: (self baseHeader: oop)]!
Item was changed:
----- Method: Interpreter>>isEmptyList: (in category 'process primitive support') -----
isEmptyList: aLinkedList
+ ^ (objectMemory fetchPointer: FirstLinkIndex ofObject: aLinkedList) = objectMemory nilObj!
- ^ (self fetchPointer: FirstLinkIndex ofObject: aLinkedList) = nilObj!
Item was changed:
----- Method: Interpreter>>isFloatObject: (in category 'plugin primitive support') -----
isFloatObject: oop
+ ^(objectMemory fetchClassOf: oop) == objectMemory classFloat!
- ^(self fetchClassOf: oop) == self classFloat!
Item was changed:
----- Method: Interpreter>>isHandlerMarked: (in category 'compiled methods') -----
isHandlerMarked: aContext
"Is this a MethodContext whose meth has a primitive number of 199?"
| header meth pIndex |
"NB: the use of a primitive number for marking the method is pretty grungy, but it is simple to use for a test sytem, not too expensive and we don't actually have the two spare method header bits we need. We can probably obtain them when the method format is changed.
NB 2: actually, the jitter will probably implement the prim to actually mark the volatile frame by changing the return function pointer."
<inline: true>
+ header := objectMemory baseHeader: aContext.
- header := self baseHeader: aContext.
(self isMethodContextHeader: header) ifFalse: [^false].
+ meth := objectMemory fetchPointer: MethodIndex ofObject: aContext.
- meth := self fetchPointer: MethodIndex ofObject: aContext.
pIndex := self primitiveIndexOf: meth.
^pIndex == 199
!
Item was changed:
----- Method: Interpreter>>isIndexable: (in category 'object format') -----
isIndexable: oop
+ ^(objectMemory formatOf: oop) >= 2!
- ^(self formatOf: oop) >= 2!
Item was changed:
----- Method: Interpreter>>isUnwindMarked: (in category 'compiled methods') -----
isUnwindMarked: aContext
"Is this a MethodContext whose meth has a primitive number of 198?"
| header meth pIndex |
"NB: the use of a primitive number for marking the method is pretty grungy, but it is simple to use for a test sytem, not too expensive and we don't actually have the two spare method header bits we need. We can probably obtain them when the method format is changed
NB 2: actually, the jitter will probably implement the prim to actually mark the volatile frame by changing the return function pointer."
<inline: true>
+ header := objectMemory baseHeader: aContext.
- header := self baseHeader: aContext.
(self isMethodContextHeader: header) ifFalse: [^false].
+ meth := objectMemory fetchPointer: MethodIndex ofObject: aContext.
- meth := self fetchPointer: MethodIndex ofObject: aContext.
pIndex := self primitiveIndexOf: meth.
^pIndex == 198
!
Item was changed:
----- Method: Interpreter>>jumplfFalseBy: (in category 'jump bytecodes') -----
jumplfFalseBy: offset
| boolean |
boolean := self internalStackTop.
+ boolean = objectMemory falseObj
- boolean = falseObj
ifTrue: [self jump: offset]
+ ifFalse: [boolean = objectMemory trueObj
+ ifFalse: [messageSelector := objectMemory splObj: SelectorMustBeBoolean.
- ifFalse: [boolean = trueObj
- ifFalse: [messageSelector := self splObj: SelectorMustBeBoolean.
argumentCount := 0.
^ self normalSend].
self fetchNextBytecode].
self internalPop: 1!
Item was changed:
----- Method: Interpreter>>jumplfTrueBy: (in category 'jump bytecodes') -----
jumplfTrueBy: offset
| boolean |
boolean := self internalStackTop.
+ boolean = objectMemory trueObj
- boolean = trueObj
ifTrue: [self jump: offset]
+ ifFalse: [boolean = objectMemory falseObj
+ ifFalse: [messageSelector := objectMemory splObj: SelectorMustBeBoolean.
- ifFalse: [boolean = falseObj
- ifFalse: [messageSelector := self splObj: SelectorMustBeBoolean.
argumentCount := 0.
^ self normalSend].
self fetchNextBytecode].
self internalPop: 1!
Item was changed:
----- Method: Interpreter>>lengthOf: (in category 'array primitive support') -----
lengthOf: oop
"Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."
| header |
<inline: true>
+ header := objectMemory baseHeader: oop.
- header := self baseHeader: oop.
^ self lengthOf: oop baseHeader: header format: ((header >> 8) bitAnd: 16rF)!
Item was changed:
----- Method: Interpreter>>lengthOf:baseHeader:format: (in category 'array primitive support') -----
lengthOf: oop baseHeader: hdr format: fmt
"Return the number of indexable bytes or words in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."
| sz |
<inline: true>
(hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ sz := (objectMemory sizeHeader: oop) bitAnd: objectMemory longSizeMask ]
+ ifFalse: [ sz := (hdr bitAnd: objectMemory sizeMask)].
+ sz := sz - (hdr bitAnd: objectMemory size4Bit).
- ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self longSizeMask ]
- ifFalse: [ sz := (hdr bitAnd: self sizeMask)].
- sz := sz - (hdr bitAnd: self size4Bit).
fmt <= 4
+ ifTrue: [ ^ (sz - objectMemory baseHeaderSize) >> objectMemory shiftForWord "words"].
- ifTrue: [ ^ (sz - self baseHeaderSize) >> self shiftForWord "words"].
fmt < 8
+ ifTrue: [ ^ (sz - objectMemory baseHeaderSize) >> 2 "32-bit longs"]
+ ifFalse: [ ^ (sz - objectMemory baseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
- ifTrue: [ ^ (sz - self baseHeaderSize) >> 2 "32-bit longs"]
- ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
Item was changed:
----- Method: Interpreter>>literal:ofMethod: (in category 'compiled methods') -----
literal: offset ofMethod: methodPointer
+ ^ objectMemory fetchPointer: offset + LiteralStart ofObject: methodPointer
- ^ self fetchPointer: offset + LiteralStart ofObject: methodPointer
!
Item was changed:
----- Method: Interpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
loadFloatOrIntFrom: floatOrInt
"If floatOrInt is an integer, then convert it to a C double float and return it.
If it is a Float, then load its value and return it.
Otherwise fail -- ie return with primFailCode set."
<inline: true>
<returnTypeC: 'double'>
+ (objectMemory isIntegerObject: floatOrInt) ifTrue:
+ [^ (objectMemory integerValueOf: floatOrInt) asFloat].
+ (objectMemory fetchClassOfNonInt: floatOrInt) = (objectMemory splObj: ClassFloat)
- (self isIntegerObject: floatOrInt) ifTrue:
- [^ (self integerValueOf: floatOrInt) asFloat].
- (self fetchClassOfNonInt: floatOrInt) = (self splObj: ClassFloat)
ifTrue: [^ self floatValueOf: floatOrInt].
self primitiveFail!
Item was changed:
----- Method: Interpreter>>loadInitialContext (in category 'initialization') -----
loadInitialContext
| sched proc |
+ sched := objectMemory fetchPointer: ValueIndex ofObject: (objectMemory splObj: SchedulerAssociation).
+ proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
+ activeContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
+ (objectMemory oop: activeContext isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: activeContext ].
- sched := self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation).
- proc := self fetchPointer: ActiveProcessIndex ofObject: sched.
- activeContext := self fetchPointer: SuspendedContextIndex ofObject: proc.
- (self oop: activeContext isLessThan: youngStart) ifTrue: [ self beRootIfOld: activeContext ].
self fetchContextRegisters: activeContext.
reclaimableContextCount := 0.!
Item was changed:
----- Method: Interpreter>>lookupMethodInClass: (in category 'message sending') -----
lookupMethodInClass: class
| currentClass dictionary found rclass |
<inline: false>
currentClass := class.
+ [currentClass ~= objectMemory nilObj]
- [currentClass ~= nilObj]
whileTrue:
+ [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
+ dictionary = objectMemory nilObj ifTrue:
- [dictionary := self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
- dictionary = nilObj ifTrue:
["MethodDict pointer is nil (hopefully due a swapped out stub)
-- raise exception #cannotInterpret:."
+ objectMemory pushRemappableOop: currentClass. "may cause GC!!"
- self pushRemappableOop: currentClass. "may cause GC!!"
self createActualMessageTo: class.
+ currentClass := objectMemory popRemappableOop.
+ messageSelector := objectMemory splObj: SelectorCannotInterpret.
- currentClass := self popRemappableOop.
- messageSelector := self splObj: SelectorCannotInterpret.
^ self lookupMethodInClass: (self superclassOf: currentClass)].
found := self lookupMethodInDictionary: dictionary.
found ifTrue: [^ methodClass := currentClass].
currentClass := self superclassOf: currentClass].
"Could not find #doesNotUnderstand: -- unrecoverable error."
+ messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue:
- messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue:
[self error: 'Recursive not understood error encountered'].
"Cound not find a normal message -- raise exception #doesNotUnderstand:"
+ objectMemory pushRemappableOop: class. "may cause GC!!"
- self pushRemappableOop: class. "may cause GC!!"
self createActualMessageTo: class.
+ rclass := objectMemory popRemappableOop.
+ messageSelector := objectMemory splObj: SelectorDoesNotUnderstand.
- rclass := self popRemappableOop.
- messageSelector := self splObj: SelectorDoesNotUnderstand.
^ self lookupMethodInClass: rclass!
Item was changed:
----- Method: Interpreter>>lookupMethodInDictionary: (in category 'message sending') -----
lookupMethodInDictionary: dictionary
"This method lookup tolerates integers as Dictionary keys to
support execution of images in which Symbols have been
compacted out"
| length index mask wrapAround nextSelector methodArray |
<inline: true>
+ length := objectMemory fetchWordLengthOf: dictionary.
- length := self fetchWordLengthOf: dictionary.
mask := length - SelectorStart - 1.
+ (objectMemory isIntegerObject: messageSelector)
+ ifTrue: [index := (mask bitAnd: (objectMemory integerValueOf: messageSelector)) + SelectorStart]
+ ifFalse: [index := (mask bitAnd: (objectMemory hashBitsOf: messageSelector)) + SelectorStart].
- (self isIntegerObject: messageSelector)
- ifTrue: [index := (mask bitAnd: (self integerValueOf: messageSelector)) + SelectorStart]
- ifFalse: [index := (mask bitAnd: (self hashBitsOf: messageSelector)) + SelectorStart].
"It is assumed that there are some nils in this dictionary, and search will
stop when one is encountered. However, if there are no nils, then wrapAround
will be detected the second time the loop gets to the end of the table."
wrapAround := false.
[true]
+ whileTrue: [nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
+ nextSelector = objectMemory nilObj ifTrue: [^ false].
- whileTrue: [nextSelector := self fetchPointer: index ofObject: dictionary.
- nextSelector = nilObj ifTrue: [^ false].
nextSelector = messageSelector
+ ifTrue: [methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
+ newMethod := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray.
- ifTrue: [methodArray := self fetchPointer: MethodArrayIndex ofObject: dictionary.
- newMethod := self fetchPointer: index - SelectorStart ofObject: methodArray.
"Check if newMethod is a CompiledMethod."
+ (objectMemory isCompiledMethod: newMethod)
- (self isCompiledMethod: newMethod)
ifTrue: [primitiveIndex := self primitiveIndexOf: newMethod.
primitiveIndex > MaxPrimitiveIndex
ifTrue: ["If primitiveIndex is out of range, set to zero before putting in
cache. This is equiv to primFail, and avoids the need to check on
every send."
primitiveIndex := 0]]
ifFalse: ["indicate that this is no compiled method - use primitiveInvokeObjectAsMethod"
primitiveIndex := 248].
^ true].
index := index + 1.
index = length
ifTrue: [wrapAround
ifTrue: [^ false].
wrapAround := true.
index := SelectorStart]]!
Item was changed:
----- Method: Interpreter>>lookupMethodNoMNUEtcInClass: (in category 'alien support') -----
lookupMethodNoMNUEtcInClass: class
"Lookup. Answer false on failure father than performing MNU processing etc."
| currentClass dictionary |
<inline: true>
currentClass := class.
+ [currentClass ~= objectMemory nilObj] whileTrue:
+ [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
+ (dictionary ~= objectMemory nilObj
- [currentClass ~= nilObj] whileTrue:
- [dictionary := self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
- (dictionary ~= nilObj
and: [self lookupMethodInDictionary: dictionary]) ifTrue:
[methodClass := currentClass.
^true].
currentClass := self superclassOf: currentClass].
^false!
Item was changed:
----- Method: Interpreter>>makePointwithxValue:yValue: (in category 'utilities') -----
makePointwithxValue: xValue yValue: yValue
"make a Point xValue@yValue.
We know both will be integers so no value nor root checking is needed"
| pointResult |
+ pointResult := objectMemory instantiateSmallClass: (objectMemory splObj: ClassPoint) sizeInBytes: 3 * objectMemory bytesPerWord.
+ objectMemory storePointerUnchecked: XIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: xValue).
+ objectMemory storePointerUnchecked: YIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: yValue).
- pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3 * self bytesPerWord.
- self storePointerUnchecked: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue).
- self storePointerUnchecked: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue).
^ pointResult!
Item was changed:
----- Method: Interpreter>>mapInterpreterOops (in category 'object memory support') -----
mapInterpreterOops
"Map all oops in the interpreter's state to their new values
during garbage collection or a become: operation."
"Assume: All traced variables contain valid oops."
| oop |
+ objectMemory nilObj: (objectMemory remap: objectMemory nilObj).
+ objectMemory falseObj: (objectMemory remap: objectMemory falseObj).
+ objectMemory trueObj: (objectMemory remap: objectMemory trueObj).
+ objectMemory specialObjectsOop: (objectMemory remap: objectMemory specialObjectsOop).
- nilObj := self remap: nilObj.
- falseObj := self remap: falseObj.
- trueObj := self remap: trueObj.
- specialObjectsOop := self remap: specialObjectsOop.
compilerInitialized
ifFalse: [stackPointer := stackPointer - activeContext. "*rel to active"
+ activeContext := objectMemory remap: activeContext.
- activeContext := self remap: activeContext.
stackPointer := stackPointer + activeContext. "*rel to active"
+ theHomeContext := objectMemory remap: theHomeContext].
- theHomeContext := self remap: theHomeContext].
instructionPointer := instructionPointer - method. "*rel to method"
+ method := objectMemory remap: method.
- method := self remap: method.
instructionPointer := instructionPointer + method. "*rel to method"
+ receiver := objectMemory remap: receiver.
+ messageSelector := objectMemory remap: messageSelector.
+ newMethod := objectMemory remap: newMethod.
+ methodClass := objectMemory remap: methodClass.
+ lkupClass := objectMemory remap: lkupClass.
+ receiverClass := objectMemory remap: receiverClass.
+ 1 to: objectMemory remapBufferCount do: [:i |
+ oop := objectMemory remapBuffer at: i.
+ (objectMemory isIntegerObject: oop)
+ ifFalse: [objectMemory remapBuffer at: i put: (objectMemory remap: oop)]].
- receiver := self remap: receiver.
- messageSelector := self remap: messageSelector.
- newMethod := self remap: newMethod.
- methodClass := self remap: methodClass.
- lkupClass := self remap: lkupClass.
- receiverClass := self remap: receiverClass.
- 1 to: remapBufferCount do: [:i |
- oop := remapBuffer at: i.
- (self isIntegerObject: oop)
- ifFalse: [remapBuffer at: i put: (self remap: oop)]].
"Callback support - trace suspended callback list"
1 to: jmpDepth do:[:i|
oop := suspendedCallbacks at: i.
+ (objectMemory isIntegerObject: oop)
+ ifFalse:[suspendedCallbacks at: i put: (objectMemory remap: oop)].
- (self isIntegerObject: oop)
- ifFalse:[suspendedCallbacks at: i put: (self remap: oop)].
oop := suspendedMethods at: i.
+ (objectMemory isIntegerObject: oop)
+ ifFalse:[suspendedMethods at: i put: (objectMemory remap: oop)].
- (self isIntegerObject: oop)
- ifFalse:[suspendedMethods at: i put: (self remap: oop)].
].
!
Item was changed:
----- Method: Interpreter>>markAndTraceInterpreterOops (in category 'object memory support') -----
markAndTraceInterpreterOops
"Mark and trace all oops in the interpreter's state."
"Assume: All traced variables contain valid oops."
| oop |
self compilerMarkHook.
+ objectMemory markAndTrace: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
- self markAndTrace: specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
compilerInitialized
+ ifTrue: [objectMemory markAndTrace: receiver.
+ objectMemory markAndTrace: method]
+ ifFalse: [objectMemory markAndTrace: activeContext].
+ objectMemory markAndTrace: messageSelector.
+ objectMemory markAndTrace: newMethod.
+ objectMemory markAndTrace: methodClass.
+ objectMemory markAndTrace: lkupClass.
+ objectMemory markAndTrace: receiverClass.
+ 1 to: objectMemory remapBufferCount do: [:i |
+ oop := objectMemory remapBuffer at: i.
+ (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]].
- ifTrue: [self markAndTrace: receiver.
- self markAndTrace: method]
- ifFalse: [self markAndTrace: activeContext].
- self markAndTrace: messageSelector.
- self markAndTrace: newMethod.
- self markAndTrace: methodClass.
- self markAndTrace: lkupClass.
- self markAndTrace: receiverClass.
- 1 to: remapBufferCount do: [:i |
- oop := remapBuffer at: i.
- (self isIntegerObject: oop) ifFalse: [self markAndTrace: oop]].
"Callback support - trace suspended callback list"
1 to: jmpDepth do:[:i|
oop := suspendedCallbacks at: i.
+ (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
- (self isIntegerObject: oop) ifFalse:[self markAndTrace: oop].
oop := suspendedMethods at: i.
+ (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
- (self isIntegerObject: oop) ifFalse:[self markAndTrace: oop].
].
!
Item was changed:
----- Method: Interpreter>>methodClassOf: (in category 'compiled methods') -----
methodClassOf: methodPointer
+ ^ objectMemory fetchPointer: ValueIndex ofObject: (self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer)!
- ^ self fetchPointer: ValueIndex ofObject: (self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer)!
Item was changed:
----- Method: Interpreter>>newActiveContext: (in category 'contexts') -----
newActiveContext: aContext
"Note: internalNewActiveContext: should track changes to this method."
self storeContextRegisters: activeContext.
+ (objectMemory oop: aContext isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
- (self oop: aContext isLessThan: youngStart) ifTrue: [ self beRootIfOld: aContext ].
activeContext := aContext.
self fetchContextRegisters: aContext.!
Item was changed:
----- Method: Interpreter>>nonWeakFieldsOf: (in category 'object format') -----
nonWeakFieldsOf: oop
"Return the number of non-weak fields in oop (i.e. the number of fixed fields).
Note: The following is copied from fixedFieldsOf:format:length: since we do know
the format of the oop (e.g. format = 4) and thus don't need the length."
| class classFormat |
<inline: false> "No need to inline - we won't call this often"
+ (objectMemory isWeakNonInt: oop) ifFalse:[self error:'Called fixedFieldsOfWeak: with a non-weak oop'].
- (self isWeakNonInt: oop) ifFalse:[self error:'Called fixedFieldsOfWeak: with a non-weak oop'].
"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
+ class := objectMemory fetchClassOf: oop.
- class := self fetchClassOf: oop.
classFormat := self formatOfClass: class.
^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1
!
Item was changed:
----- Method: Interpreter>>normalSend (in category 'message sending') -----
normalSend
"Send a message, starting lookup with the receiver's class."
"Assume: messageSelector and argumentCount have been set, and that
the receiver and arguments have been pushed onto the stack,"
"Note: This method is inlined into the interpreter dispatch loop."
| rcvr |
<inline: true>
self sharedCodeNamed: 'normalSend' inCase: 131.
rcvr := self internalStackValue: argumentCount.
+ lkupClass := objectMemory fetchClassOf: rcvr.
- lkupClass := self fetchClassOf: rcvr.
receiverClass := lkupClass.
self commonSend.!
Item was changed:
----- Method: Interpreter>>normalizeFloatOrderingInImage (in category 'image save/restore') -----
normalizeFloatOrderingInImage
"Float objects were saved in platform word ordering. Reorder them into the
traditional object format."
<inline: false>
<var: #floatData type: 'unsigned int *'>
<var: #val type: 'unsigned int'>
self isBigEnder
ifFalse: [ | oop | "Swap words within Float objects, taking them out of native platform ordering"
+ oop := objectMemory firstAccessibleObject.
- oop := self firstAccessibleObject.
[oop = nil] whileFalse: [ | val |
+ (objectMemory isFreeObject: oop) ifFalse: [
+ (objectMemory fetchClassOf: oop) = objectMemory classFloat
- (self isFreeObject: oop) ifFalse: [
- (self fetchClassOf: oop) = self classFloat
ifTrue: [ | floatData |
floatData := self cCoerce: (self firstIndexableField: oop) to: 'unsigned int *'.
val := floatData at: 0.
floatData at: 0 put: (floatData at: 1).
floatData at: 1 put: val].
+ oop := objectMemory accessibleObjectAfter: oop]]]
- oop := self accessibleObjectAfter: oop]]]
!
Item was changed:
----- Method: Interpreter>>okayActiveProcessStack (in category 'debug support') -----
okayActiveProcessStack
| cntxt |
cntxt := activeContext.
+ [cntxt = objectMemory nilObj] whileFalse: [
- [cntxt = nilObj] whileFalse: [
self okayFields: cntxt.
+ cntxt := (objectMemory fetchPointer: SenderIndex ofObject: cntxt).
- cntxt := (self fetchPointer: SenderIndex ofObject: cntxt).
].!
Item was changed:
----- Method: Interpreter>>okayFields: (in category 'debug support') -----
okayFields: oop
"If this is a pointers object, check that its fields are all okay oops."
| i fieldOop c |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ].
+ (objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
- (self isIntegerObject: oop) ifTrue: [ ^true ].
self okayOop: oop.
self oopHasOkayClass: oop.
+ (objectMemory isPointers: oop) ifFalse: [ ^true ].
+ c := objectMemory fetchClassOf: oop.
+ (c = (objectMemory splObj: ClassMethodContext)
+ or: [c = (objectMemory splObj: ClassBlockContext)])
- (self isPointers: oop) ifFalse: [ ^true ].
- c := self fetchClassOf: oop.
- (c = (self splObj: ClassMethodContext)
- or: [c = (self splObj: ClassBlockContext)])
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
ifFalse: [i := (self lengthOf: oop) - 1].
[i >= 0] whileTrue: [
+ fieldOop := objectMemory fetchPointer: i ofObject: oop.
+ (objectMemory isIntegerObject: fieldOop) ifFalse: [
- fieldOop := self fetchPointer: i ofObject: oop.
- (self isIntegerObject: fieldOop) ifFalse: [
self okayOop: fieldOop.
self oopHasOkayClass: fieldOop.
].
i := i - 1.
].!
Item was changed:
----- Method: Interpreter>>okayInterpreterObjects (in category 'debug support') -----
okayInterpreterObjects
| oopOrZero oop |
+ self okayFields: objectMemory nilObj.
+ self okayFields: objectMemory falseObj.
+ self okayFields: objectMemory trueObj.
+ self okayFields: objectMemory specialObjectsOop.
- self okayFields: nilObj.
- self okayFields: falseObj.
- self okayFields: trueObj.
- self okayFields: specialObjectsOop.
self okayFields: activeContext.
self okayFields: method.
self okayFields: receiver.
self okayFields: theHomeContext.
self okayFields: messageSelector.
self okayFields: newMethod.
self okayFields: lkupClass.
0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i |
oopOrZero := methodCache at: i + MethodCacheSelector.
oopOrZero = 0 ifFalse: [
self okayFields: (methodCache at: i + MethodCacheSelector).
self okayFields: (methodCache at: i + MethodCacheClass).
self okayFields: (methodCache at: i + MethodCacheMethod).
].
].
+ 1 to: objectMemory remapBufferCount do: [ :i |
+ oop := objectMemory remapBuffer at: i.
+ (objectMemory isIntegerObject: oop) ifFalse: [
- 1 to: remapBufferCount do: [ :i |
- oop := remapBuffer at: i.
- (self isIntegerObject: oop) ifFalse: [
self okayFields: oop.
].
].
self okayActiveProcessStack.!
Item was changed:
----- Method: Interpreter>>okayOop: (in category 'debug support') -----
okayOop: signedOop
"Verify that the given oop is legitimate. Check address, header, and size but not class."
| sz type fmt unusedBit oop |
<var: #oop type: 'usqInt'>
oop := self cCoerce: signedOop to: 'usqInt'.
"address and size checks"
+ (objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
+ (oop < objectMemory endOfMemory)
- (self isIntegerObject: oop) ifTrue: [ ^true ].
- (oop < endOfMemory)
ifFalse: [ self error: 'oop is not a valid address' ].
+ ((oop \\ objectMemory bytesPerWord) = 0)
- ((oop \\ self bytesPerWord) = 0)
ifFalse: [ self error: 'oop is not a word-aligned address' ].
+ sz := objectMemory sizeBitsOf: oop.
+ (oop + sz) < objectMemory endOfMemory
- sz := self sizeBitsOf: oop.
- (oop + sz) < endOfMemory
ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ].
"header type checks"
+ type := objectMemory headerType: oop.
+ type = objectMemory headerTypeFree
- type := self headerType: oop.
- type = HeaderTypeFree
ifTrue: [ self error: 'oop is a free chunk, not an object' ].
type = HeaderTypeShort ifTrue: [
+ (((objectMemory baseHeader: oop) >> 12) bitAnd: 16r1F) = 0
- (((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0
ifTrue: [ self error: 'cannot have zero compact class field in a short header' ].
].
+ type = objectMemory headerTypeClass ifTrue: [
+ ((oop >= objectMemory bytesPerWord) and: [(objectMemory headerType: oop - objectMemory bytesPerWord) = type])
- type = HeaderTypeClass ifTrue: [
- ((oop >= self bytesPerWord) and: [(self headerType: oop - self bytesPerWord) = type])
ifFalse: [ self error: 'class header word has wrong type' ].
].
type = HeaderTypeSizeAndClass ifTrue: [
+ ((oop >= (objectMemory bytesPerWord * 2)) and:
+ [(objectMemory headerType: oop - (objectMemory bytesPerWord * 2)) = type and:
+ [(objectMemory headerType: oop - objectMemory bytesPerWord) = type]])
- ((oop >= (self bytesPerWord * 2)) and:
- [(self headerType: oop - (self bytesPerWord * 2)) = type and:
- [(self headerType: oop - self bytesPerWord) = type]])
ifFalse: [ self error: 'class header word has wrong type' ].
].
"format check"
+ fmt := objectMemory formatOf: oop.
- fmt := self formatOf: oop.
((fmt = 5) | (fmt = 7))
ifTrue: [ self error: 'oop has an unknown format type' ].
"mark and root bit checks"
unusedBit := 16r20000000.
+ objectMemory bytesPerWord = 8
- self bytesPerWord = 8
ifTrue:
[unusedBit := unusedBit << 16.
unusedBit := unusedBit << 16].
((self longAt: oop) bitAnd: unusedBit) = 0
ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ].
"xxx
((self longAt: oop) bitAnd: MarkBit) = 0
ifFalse: [ self error: 'mark bit should not be set except during GC' ].
xxx"
+ (((self longAt: oop) bitAnd: objectMemory rootBit) = 1 and:
+ [oop >= objectMemory youngStart])
- (((self longAt: oop) bitAnd: self rootBit) = 1 and:
- [oop >= youngStart])
ifTrue: [ self error: 'root bit is set in a young object' ].
^true
!
Item was changed:
----- Method: Interpreter>>oopHasOkayClass: (in category 'debug support') -----
oopHasOkayClass: signedOop
"Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."
| oop oopClass formatMask behaviorFormatBits oopFormatBits |
<var: #oop type: 'usqInt'>
<var: #oopClass type: 'usqInt'>
oop := self cCoerce: signedOop to: 'usqInt'.
self okayOop: oop.
+ oopClass := self cCoerce: (objectMemory fetchClassOf: oop) to: 'usqInt'.
- oopClass := self cCoerce: (self fetchClassOf: oop) to: 'usqInt'.
+ (objectMemory isIntegerObject: oopClass)
- (self isIntegerObject: oopClass)
ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ].
self okayOop: oopClass.
+ ((objectMemory isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3])
- ((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3])
ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ].
+ (objectMemory isBytes: oop)
- (self isBytes: oop)
ifTrue: [ formatMask := 16rC00 ] "ignore extra bytes size bits"
ifFalse: [ formatMask := 16rF00 ].
behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask.
+ oopFormatBits := (objectMemory baseHeader: oop) bitAnd: formatMask.
- oopFormatBits := (self baseHeader: oop) bitAnd: formatMask.
behaviorFormatBits = oopFormatBits
ifFalse: [ self error: 'object and its class (behavior) formats differ' ].
^true!
Item was changed:
----- Method: Interpreter>>pop2AndPushIntegerIfOK: (in category 'contexts') -----
pop2AndPushIntegerIfOK: integerResult
self successful ifTrue:
+ [(objectMemory isIntegerValue: integerResult)
+ ifTrue: [self pop: 2 thenPush: (objectMemory integerObjectOf: integerResult)]
- [(self isIntegerValue: integerResult)
- ifTrue: [self pop: 2 thenPush: (self integerObjectOf: integerResult)]
ifFalse: [self primitiveFail]]!
Item was changed:
----- Method: Interpreter>>pop: (in category 'contexts') -----
pop: nItems
"Note: May be called by translated primitive code."
+ stackPointer := stackPointer - (nItems * objectMemory bytesPerWord).!
- stackPointer := stackPointer - (nItems * self bytesPerWord).!
Item was changed:
----- Method: Interpreter>>pop:thenPush: (in category 'contexts') -----
pop: nItems thenPush: oop
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord)) put: oop.
- self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) put: oop.
stackPointer := sp.
!
Item was changed:
----- Method: Interpreter>>pop:thenPushBool: (in category 'contexts') -----
pop: nItems thenPushBool: trueOrFalse
"A few places pop a few items off the stack and then push a boolean. Make it convenient"
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord))
+ put:(trueOrFalse ifTrue: [objectMemory trueObj] ifFalse: [objectMemory falseObj]).
- self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord))
- put:(trueOrFalse ifTrue: [trueObj] ifFalse: [falseObj]).
stackPointer := sp!
Item was changed:
----- Method: Interpreter>>pop:thenPushInteger: (in category 'contexts') -----
pop: nItems thenPushInteger: integerVal
"lots of places pop a few items off the stack and then push an integer. MAke it convenient"
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord)) put:(objectMemory integerObjectOf: integerVal).
- self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) put:(self integerObjectOf: integerVal).
stackPointer := sp.
!
Item was changed:
----- Method: Interpreter>>popFloat (in category 'stack bytecodes') -----
popFloat
"Note: May be called by translated primitive code."
| top result |
<returnTypeC: 'double'>
<var: #result type: 'double '>
top := self popStack.
+ self assertClassOf: top is: (objectMemory splObj: ClassFloat).
- self assertClassOf: top is: (self splObj: ClassFloat).
self successful ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: top + objectMemory baseHeaderSize into: result].
- self fetchFloatAt: top + self baseHeaderSize into: result].
^ result!
Item was changed:
----- Method: Interpreter>>popStack (in category 'contexts') -----
popStack
| top |
top := self longAt: stackPointer.
+ stackPointer := stackPointer - objectMemory bytesPerWord.
- stackPointer := stackPointer - self bytesPerWord.
^ top!
Item was changed:
----- Method: Interpreter>>positive32BitIntegerFor: (in category 'primitive support') -----
positive32BitIntegerFor: integerValue
| newLargeInteger |
"Note - integerValue is interpreted as POSITIVE, eg, as the result of
Bitmap>at:, or integer>bitAnd:."
integerValue >= 0
+ ifTrue: [(objectMemory isIntegerValue: integerValue)
+ ifTrue: [^ objectMemory integerObjectOf: integerValue]].
- ifTrue: [(self isIntegerValue: integerValue)
- ifTrue: [^ self integerObjectOf: integerValue]].
+ objectMemory bytesPerWord = 4
- self bytesPerWord = 4
ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size."
+ newLargeInteger := objectMemory instantiateSmallClass: (objectMemory splObj: ClassLargePositiveInteger)
+ sizeInBytes: objectMemory baseHeaderSize + 4]
- newLargeInteger := self instantiateSmallClass: (self splObj: ClassLargePositiveInteger)
- sizeInBytes: self baseHeaderSize + 4]
ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement."
+ newLargeInteger := objectMemory instantiateClass: (objectMemory splObj: ClassLargePositiveInteger)
- newLargeInteger := self instantiateClass: (self splObj: ClassLargePositiveInteger)
indexableSize: 4].
+ objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
+ objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
+ objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
+ objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
- self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
- self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
- self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
- self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
^ newLargeInteger!
Item was changed:
----- Method: Interpreter>>positive64BitIntegerFor: (in category 'primitive support') -----
positive64BitIntegerFor: integerValue
| newLargeInteger value highWord sz |
"Note - integerValue is interpreted as POSITIVE, eg, as the result of
Bitmap>at:, or integer>bitAnd:."
<var: 'integerValue' type: 'sqLong'>
(self sizeof: integerValue) = 4 ifTrue: [^self positive32BitIntegerFor: integerValue].
highWord := self cCode: 'integerValue >> 32'. "shift is coerced to usqInt otherwise"
highWord = 0 ifTrue:[^self positive32BitIntegerFor: integerValue].
sz := 5.
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
+ newLargeInteger := objectMemory instantiateClass: (objectMemory splObj: ClassLargePositiveInteger) indexableSize: sz.
- newLargeInteger := self instantiateClass: (self splObj: ClassLargePositiveInteger) indexableSize: sz.
0 to: sz-1 do: [:i |
value := self cCode: '(integerValue >> (i * 8)) & 255'.
+ objectMemory storeByte: i ofObject: newLargeInteger withValue: value].
- self storeByte: i ofObject: newLargeInteger withValue: value].
^ newLargeInteger
!
Item was changed:
----- Method: Interpreter>>postGCAction (in category 'object memory support') -----
postGCAction
"Mark the active and home contexts as roots if old. This
allows the interpreter to use storePointerUnchecked to
store into them."
compilerInitialized
ifTrue: [self compilerPostGC]
+ ifFalse: [(objectMemory oop: activeContext isLessThan: objectMemory youngStart)
+ ifTrue: [objectMemory beRootIfOld: activeContext].
+ (objectMemory oop: theHomeContext isLessThan: objectMemory youngStart)
+ ifTrue: [objectMemory beRootIfOld: theHomeContext]].
+ (objectMemory oop: (objectMemory sizeOfFree: objectMemory freeBlock) isGreaterThan: objectMemory shrinkThreshold)
- ifFalse: [(self oop: activeContext isLessThan: youngStart)
- ifTrue: [self beRootIfOld: activeContext].
- (self oop: theHomeContext isLessThan: youngStart)
- ifTrue: [self beRootIfOld: theHomeContext]].
- (self oop: (self sizeOfFree: freeBlock) isGreaterThan: shrinkThreshold)
ifTrue: ["Attempt to shrink memory after successfully
reclaiming lots of memory"
+ objectMemory shrinkObjectMemory: (objectMemory sizeOfFree: objectMemory freeBlock) - objectMemory growHeadroom].
- self shrinkObjectMemory: (self sizeOfFree: freeBlock) - growHeadroom].
+ self signalSemaphoreWithIndex: objectMemory gcSemaphoreIndex.
- self signalSemaphoreWithIndex: gcSemaphoreIndex.
!
Item was changed:
----- Method: Interpreter>>primitiveAsOop (in category 'object access primitives') -----
primitiveAsOop
| thisReceiver |
thisReceiver := self stackTop.
+ self success: (objectMemory isIntegerObject: thisReceiver) not.
- self success: (self isIntegerObject: thisReceiver) not.
self successful
+ ifTrue: [self pop:1 thenPushInteger: (objectMemory hashBitsOf: thisReceiver)]!
- ifTrue: [self pop:1 thenPushInteger: (self hashBitsOf: thisReceiver)]!
Item was changed:
----- Method: Interpreter>>primitiveAtEnd (in category 'deprecated - array and stream primitives') -----
primitiveAtEnd
"nb: This primitive was previously installed as primitive 67, but is no
longer in use."
| stream index limit |
stream := self popStack.
+ ((objectMemory isPointers: stream)
- ((self isPointers: stream)
and: [(self lengthOf: stream) >= (StreamReadLimitIndex+1)])
ifTrue: [index := self fetchInteger: StreamIndexIndex ofObject: stream.
limit := self fetchInteger: StreamReadLimitIndex ofObject: stream]
ifFalse: [self primitiveFail].
self successful
ifTrue: [self pushBool: (index >= limit)]
ifFalse: [self unPop: 1].!
Item was changed:
----- Method: Interpreter>>primitiveBlockCopy (in category 'control primitives') -----
primitiveBlockCopy
| context methodContext contextSize newContext initialIP |
context := self stackValue: 1.
+ (objectMemory isIntegerObject: (objectMemory fetchPointer: MethodIndex ofObject: context))
- (self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context))
ifTrue: ["context is a block; get the context of its enclosing method"
+ methodContext := objectMemory fetchPointer: HomeIndex ofObject: context]
- methodContext := self fetchPointer: HomeIndex ofObject: context]
ifFalse: [methodContext := context].
+ contextSize := objectMemory sizeBitsOf: methodContext. "in bytes, including header"
- contextSize := self sizeBitsOf: methodContext. "in bytes, including header"
context := nil. "context is no longer needed and is not preserved across allocation"
"remap methodContext in case GC happens during allocation"
+ objectMemory pushRemappableOop: methodContext.
+ newContext := objectMemory instantiateContext: (objectMemory splObj: ClassBlockContext) sizeInBytes: contextSize.
+ methodContext := objectMemory popRemappableOop.
- self pushRemappableOop: methodContext.
- newContext := self instantiateContext: (self splObj: ClassBlockContext) sizeInBytes: contextSize.
- methodContext := self popRemappableOop.
+ initialIP := objectMemory integerObjectOf: (instructionPointer+1+3) - (method + objectMemory baseHeaderSize).
- initialIP := self integerObjectOf: (instructionPointer+1+3) - (method + self baseHeaderSize).
"Was instructionPointer + 3, but now it's greater by 1 due to preIncrement"
"Assume: have just allocated a new context; it must be young.
Thus, can use uncheck stores. See the comment in fetchContextRegisters."
+ objectMemory storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
- self storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
- self storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
self storeStackPointerValue: 0 inContext: newContext.
+ objectMemory storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
+ objectMemory storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
+ objectMemory storePointerUnchecked: SenderIndex ofObject: newContext withValue: objectMemory nilObj.
- self storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
- self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
- self storePointerUnchecked: SenderIndex ofObject: newContext withValue: nilObj.
self pop: 2 thenPush: newContext.!
Item was changed:
----- Method: Interpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
primitiveClosureCopyWithCopiedValues
| newClosure copiedValues numCopiedValues numArgs |
numArgs := self stackIntegerValue: 1.
copiedValues := self stackTop.
+ self success: (objectMemory fetchClassOf: copiedValues) = (objectMemory splObj: ClassArray).
- self success: (self fetchClassOf: copiedValues) = (self splObj: ClassArray).
self successful ifFalse:
[^self primitiveFail].
+ numCopiedValues := objectMemory fetchWordLengthOf: copiedValues.
- numCopiedValues := self fetchWordLengthOf: copiedValues.
newClosure := self
closureNumArgs: numArgs
"greater by 1 due to preIncrement of localIP"
+ instructionPointer: instructionPointer + 2 - (method + objectMemory baseHeaderSize)
- instructionPointer: instructionPointer + 2 - (method + self baseHeaderSize)
numCopiedValues: numCopiedValues.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
- self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
numCopiedValues > 0 ifTrue:
["Allocation may have done a GC and copiedValues may have moved."
copiedValues := self stackTop.
0 to: numCopiedValues - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
- self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
+ withValue: (objectMemory fetchPointer: i ofObject: copiedValues)]].
- withValue: (self fetchPointer: i ofObject: copiedValues)]].
self pop: 3 thenPush: newClosure!
Item was changed:
----- Method: Interpreter>>primitiveClosureValue (in category 'control primitives') -----
primitiveClosureValue
| blockClosure blockArgumentCount closureMethod outerContext |
blockClosure := self stackValue: argumentCount.
blockArgumentCount := self argumentCountOfClosure: blockClosure.
argumentCount = blockArgumentCount ifFalse:
[^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard
in a robust system."
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
- outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
(self isContext: outerContext) ifFalse:
[^self primitiveFail].
+ closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
- closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
"Check if the closure's method is actually a CompiledMethod."
+ (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
- (self isOopCompiledMethod: closureMethod) ifFalse:
[^self primitiveFail].
self activateNewClosureMethod: blockClosure.
self quickCheckForInterrupts!
Item was changed:
----- Method: Interpreter>>primitiveClosureValueNoContextSwitch (in category 'control primitives') -----
primitiveClosureValueNoContextSwitch
"An exact clone of primitiveClosureValue except that this version will not
check for interrupts on stack overflow."
| blockClosure blockArgumentCount closureMethod outerContext |
blockClosure := self stackValue: argumentCount.
blockArgumentCount := self argumentCountOfClosure: blockClosure.
argumentCount = blockArgumentCount ifFalse:
[^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard
in a robust system."
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
- outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
(self isContext: outerContext) ifFalse:
[^self primitiveFail].
+ closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
- closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
"Check if the closure's method is actually a CompiledMethod."
+ (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
- (self isOopCompiledMethod: closureMethod) ifFalse:
[^self primitiveFail].
self activateNewClosureMethod: blockClosure!
Item was changed:
----- Method: Interpreter>>primitiveClosureValueWithArgs (in category 'control primitives') -----
primitiveClosureValueWithArgs
| argumentArray arraySize cntxSize blockClosure blockArgumentCount closureMethod index outerContext |
argumentArray := self stackTop.
+ (objectMemory isArray: argumentArray) ifFalse:
- (self isArray: argumentArray) ifFalse:
[^self primitiveFail].
"Check for enough space in thisContext to push all args"
+ arraySize := objectMemory fetchWordLengthOf: argumentArray.
+ cntxSize := objectMemory fetchWordLengthOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
(self stackPointerIndex + arraySize) < cntxSize ifFalse:
[^self primitiveFail].
blockClosure := self stackValue: argumentCount.
blockArgumentCount := self argumentCountOfClosure: blockClosure.
arraySize = blockArgumentCount ifFalse:
[^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard
in a robust system."
+ outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
- outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
(self isContext: outerContext) ifFalse:
[^self primitiveFail].
+ closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
- closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
"Check if the closure's method is actually a CompiledMethod."
+ (objectMemory isOopCompiledMethod: closureMethod) ifFalse:
- (self isOopCompiledMethod: closureMethod) ifFalse:
[^self primitiveFail].
self popStack.
"Copy the arguments to the stack, and activate"
index := 1.
[index <= arraySize]
whileTrue:
+ [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
- [self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
argumentCount := arraySize.
self activateNewClosureMethod: blockClosure.
self quickCheckForInterrupts!
Item was changed:
----- Method: Interpreter>>primitiveDeferDisplayUpdates (in category 'I/O primitives') -----
primitiveDeferDisplayUpdates
"Set or clear the flag that controls whether modifications of
the Display object are propagated to the underlying
platform's screen."
| flag |
flag := self stackTop.
+ flag = objectMemory trueObj
- flag = trueObj
ifTrue: [deferDisplayUpdates := true]
+ ifFalse: [flag = objectMemory falseObj
- ifFalse: [flag = falseObj
ifTrue: [deferDisplayUpdates := false]
ifFalse: [self primitiveFail]].
self successful
ifTrue: [self pop: 1]!
Item was changed:
----- Method: Interpreter>>primitiveDoPrimitiveWithArgs (in category 'control primitives') -----
primitiveDoPrimitiveWithArgs
| argumentArray arraySize index cntxSize primIdx |
argumentArray := self stackTop.
+ arraySize := objectMemory fetchWordLengthOf: argumentArray.
+ cntxSize := objectMemory fetchWordLengthOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
self success: self stackPointerIndex + arraySize < cntxSize.
+ (objectMemory isArray: argumentArray) ifFalse: [^ self primitiveFail].
- (self isArray: argumentArray) ifFalse: [^ self primitiveFail].
primIdx := self stackIntegerValue: 1.
self successful ifFalse: [^ self primitiveFail]. "invalid args"
"Pop primIndex and argArray, then push args in place..."
self pop: 2.
primitiveIndex := primIdx.
argumentCount := arraySize.
index := 1.
[index <= argumentCount]
+ whileTrue: [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
- whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
"Run the primitive (sets primFailCode)"
+ objectMemory pushRemappableOop: argumentArray. "prim might alloc/gc"
+ lkupClass := objectMemory nilObj.
- self pushRemappableOop: argumentArray. "prim might alloc/gc"
- lkupClass := nilObj.
self primitiveResponse.
+ argumentArray := objectMemory popRemappableOop.
- argumentArray := self popRemappableOop.
self successful
ifFalse: ["If primitive failed, then restore state for failure code"
self pop: arraySize.
self pushInteger: primIdx.
self push: argumentArray.
argumentCount := 2]!
Item was changed:
----- Method: Interpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') -----
primitiveExecuteMethodArgsArray
"receiver, argsArray, then method are on top of stack. Execute method against
receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives).
Set primitiveFunctionPointer because no cache lookup has been done for the
method, and hence primitiveFunctionPointer is stale."
| methodArgument argCnt argumentArray |
methodArgument := self stackTop.
argumentArray := self stackValue: 1.
+ ((objectMemory isOopCompiledMethod: methodArgument)
+ and: [objectMemory isArray: argumentArray]) ifFalse:
- ((self isOopCompiledMethod: methodArgument)
- and: [self isArray: argumentArray]) ifFalse:
[^self primitiveFail].
argCnt := self argumentCountOf: methodArgument.
+ argCnt = (objectMemory fetchWordLengthOf: argumentArray) ifFalse:
- argCnt = (self fetchWordLengthOf: argumentArray) ifFalse:
[^self primitiveFail].
argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod:
SqueakObjectPrimitives class >> receiver:withArguments:apply:
VMMirror>>ifFail:object:with:executeMethod: et al"
[argumentCount > 4 ifTrue:
[^self primitiveFail].
self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver"
"and push the actual arguments"
self pop: argumentCount.
0 to: argCnt - 1 do:
[:i|
+ self push: (objectMemory fetchPointer: i ofObject: argumentArray)].
- self push: (self fetchPointer: i ofObject: argumentArray)].
newMethod := methodArgument.
primitiveIndex := self primitiveIndexOf: newMethod.
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil.
argumentCount := argCnt.
"We set the messageSelector for executeMethod below since things
like the at cache read messageSelector and so it cannot be left stale."
+ messageSelector := objectMemory nilObject.
- messageSelector := self nilObject.
self executeNewMethod.
"Recursive xeq affects primFailCode"
self initPrimCall!
Item was changed:
----- Method: Interpreter>>primitiveExternalCall (in category 'plugin primitives') -----
primitiveExternalCall
"Call an external primitive. The external primitive methods
contain as first literal an array consisting of:
* The module name (String | Symbol)
* The function name (String | Symbol)
* The session ID (SmallInteger) [OBSOLETE]
* The function index (Integer) in the externalPrimitiveTable
For fast failures the primitive index of any method where the
external prim is not found is rewritten in the method cache
with zero. This allows for ultra fast responses as long as the
method stays in the cache.
The fast failure response relies on lkupClass being properly
set. This is done in
#addToMethodCacheSel:class:method:primIndex: to
compensate for execution of methods that are looked up in a
superclass (such as in primitivePerformAt).
With the latest modifications (e.g., actually flushing the
function addresses from the VM), the session ID is obsolete.
But for backward compatibility it is still kept around. Also, a
failed lookup is reported specially. If a method has been
looked up and not been found, the function address is stored
as -1 (e.g., the SmallInteger -1 to distinguish from
16rFFFFFFFF which may be returned from the lookup).
It is absolutely okay to remove the rewrite if we run into any
problems later on. It has an approximate speed difference of
30% per failed primitive call which may be noticable but if,
for any reasons, we run into problems (like with J3) we can
always remove the rewrite.
"
| lit addr moduleName functionName moduleLength functionLength index |
<var: #addr type: 'void *'>
"Fetch the first literal of the method"
self success: (self literalCountOf: newMethod) > 0. "@@: Could this be omitted for speed?!!"
self successful ifFalse: [^ nil].
lit := self literal: 0 ofMethod: newMethod.
"Check if it's an array of length 4"
+ self success: ((objectMemory isArray: lit) and: [(self lengthOf: lit) = 4]).
- self success: ((self isArray: lit) and: [(self lengthOf: lit) = 4]).
self successful ifFalse: [^ nil].
"Look at the function index in case it has been loaded before"
+ index := objectMemory fetchPointer: 3 ofObject: lit.
- index := self fetchPointer: 3 ofObject: lit.
index := self checkedIntegerValueOf: index.
self successful ifFalse: [^ nil].
"Check if we have already looked up the function and failed."
index < 0
ifTrue: ["Function address was not found in this session,
Rewrite the mcache entry with a zero primitive index."
self
rewriteMethodCacheSel: messageSelector
class: lkupClass
primIndex: 0.
^ self success: false].
"Try to call the function directly"
(index > 0 and: [index <= MaxExternalPrimitiveTableSize])
ifTrue: [addr := externalPrimitiveTable at: index - 1.
addr ~= 0
ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
self callExternalPrimitive: addr.
^ nil].
"if we get here, then an index to the external prim was
kept on the ST side although the underlying prim
table was already flushed"
^ self primitiveFail].
"Clean up session id and external primitive index"
+ objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
+ objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
- self storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
- self storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
"The function has not been loaded yet. Fetch module and function name."
+ moduleName := objectMemory fetchPointer: 0 ofObject: lit.
+ moduleName = objectMemory nilObj
- moduleName := self fetchPointer: 0 ofObject: lit.
- moduleName = nilObj
ifTrue: [moduleLength := 0]
+ ifFalse: [self success: (objectMemory isBytes: moduleName).
- ifFalse: [self success: (self isBytes: moduleName).
moduleLength := self lengthOf: moduleName.
self cCode: '' inSmalltalk:
[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName))
ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
+ functionName := objectMemory fetchPointer: 1 ofObject: lit.
+ self success: (objectMemory isBytes: functionName).
- functionName := self fetchPointer: 1 ofObject: lit.
- self success: (self isBytes: functionName).
functionLength := self lengthOf: functionName.
self successful ifFalse: [^ nil].
+ addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + objectMemory baseHeaderSize
- FromModule: moduleName + self baseHeaderSize
OfLength: moduleLength.
addr = 0
ifTrue: [index := -1]
ifFalse: ["add the function to the external primitive table"
index := self addToExternalPrimitiveTable: addr].
self success: index >= 0.
"Store the index (or -1 if failure) back in the literal"
+ objectMemory storePointerUnchecked: 3 ofObject: lit withValue: (objectMemory integerObjectOf: index).
- self storePointerUnchecked: 3 ofObject: lit withValue: (self integerObjectOf: index).
"If the function has been successfully loaded process it"
(self successful and: [addr ~= 0])
ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
self callExternalPrimitive: addr]
ifFalse: ["Otherwise rewrite the primitive index"
self
rewriteMethodCacheSel: messageSelector
class: lkupClass
primIndex: 0]!
Item was removed:
- ----- Method: Interpreter>>primitiveInstVarsPutFromStack (in category 'quick primitives') -----
- primitiveInstVarsPutFromStack
- "Note: this primitive has been decommissioned. It is only here for short-term compatibility with an internal 2.3beta-d image that used this. It did not save much time and it complicated several things. Plus Jitter will do it right anyway."
- | rcvr offsetBits |
- rcvr := self stackValue: argumentCount.
- "Mark dirty so stores below can be unchecked"
- (self oop: rcvr isLessThan: youngStart) ifTrue: [ self beRootIfOld: rcvr ].
- 0 to: argumentCount-1 do:
- [:i | (i bitAnd: 3) = 0 ifTrue:
- [offsetBits := self positive32BitValueOf: (self literal: i//4 ofMethod: newMethod)].
- self storePointerUnchecked: (offsetBits bitAnd: 16rFF) ofObject: rcvr
- withValue: (self stackValue: i).
- offsetBits := offsetBits >> 8].
- self pop: argumentCount!
Item was changed:
----- Method: Interpreter>>primitiveInvokeObjectAsMethod (in category 'control primitives') -----
primitiveInvokeObjectAsMethod
"Primitive. 'Invoke' an object like a function, sending the special message
run: originalSelector with: arguments in: aReceiver.
"
| runSelector runReceiver runArgs newReceiver lookupClass |
+ runArgs := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount.
+ objectMemory beRootIfOld: runArgs. "do we really need this?"
+ self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * objectMemory bytesPerWord) to: runArgs + objectMemory baseHeaderSize.
- runArgs := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
- self beRootIfOld: runArgs. "do we really need this?"
- self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * self bytesPerWord) to: runArgs + self baseHeaderSize.
runSelector := messageSelector.
runReceiver := self stackValue: argumentCount.
self pop: argumentCount+1.
"stack is clean here"
newReceiver := newMethod.
+ messageSelector := objectMemory splObj: SelectorRunWithIn.
- messageSelector := self splObj: SelectorRunWithIn.
argumentCount := 3.
self push: newReceiver.
self push: runSelector.
self push: runArgs.
self push: runReceiver.
+ lookupClass := objectMemory fetchClassOf: newReceiver.
- lookupClass := self fetchClassOf: newReceiver.
self findNewMethodInClass: lookupClass.
self executeNewMethodFromCache. "Recursive xeq affects primFailCode"
self initPrimCall.
!
Item was changed:
----- Method: Interpreter>>primitiveLoadInstVar (in category 'quick primitives') -----
primitiveLoadInstVar
| thisReceiver |
thisReceiver := self popStack.
+ self push: (objectMemory fetchPointer: primitiveIndex-264 ofObject: thisReceiver)!
- self push: (self fetchPointer: primitiveIndex-264 ofObject: thisReceiver)!
Item was changed:
----- Method: Interpreter>>primitiveNext (in category 'deprecated - array and stream primitives') -----
primitiveNext
"PrimitiveNext will succeed only if the stream's array is in the atCache.
Otherwise failure will lead to proper message lookup of at: and
subsequent installation in the cache if appropriate.
nb: This primitive was previously installed as primitive 65, but is no
longer in use."
| stream array index limit result atIx |
stream := self stackTop.
+ ((objectMemory isPointers: stream)
- ((self isPointers: stream)
and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)])
ifFalse: [^ self primitiveFail].
+ array := objectMemory fetchPointer: StreamArrayIndex ofObject: stream.
- array := self fetchPointer: StreamArrayIndex ofObject: stream.
index := self fetchInteger: StreamIndexIndex ofObject: stream.
limit := self fetchInteger: StreamReadLimitIndex ofObject: stream.
atIx := array bitAnd: AtCacheMask.
(index < limit and: [(atCache at: atIx+AtCacheOop) = array])
ifFalse: [^ self primitiveFail].
"OK -- its not at end, and the array is in the cache"
index := index + 1.
result := self commonVariable: array at: index cacheIndex: atIx.
"Above may cause GC, so can't use stream, array etc. below it"
self successful ifTrue:
[stream := self stackTop.
self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
^ self pop: 1 thenPush: result].
!
Item was changed:
----- Method: Interpreter>>primitiveNextPut (in category 'deprecated - array and stream primitives') -----
primitiveNextPut
"PrimitiveNextPut will succeed only if the stream's array is in the atPutCache.
Otherwise failure will lead to proper message lookup of at:put: and
subsequent installation in the cache if appropriate.
nb: This primitive was previously installed as primitive 66, but is no
longer in use."
| value stream index limit array atIx |
value := self stackTop.
stream := self stackValue: 1.
+ ((objectMemory isPointers: stream)
- ((self isPointers: stream)
and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)])
ifFalse: [^ self primitiveFail].
+ array := objectMemory fetchPointer: StreamArrayIndex ofObject: stream.
- array := self fetchPointer: StreamArrayIndex ofObject: stream.
index := self fetchInteger: StreamIndexIndex ofObject: stream.
limit := self fetchInteger: StreamWriteLimitIndex ofObject: stream.
atIx := (array bitAnd: AtCacheMask) + AtPutBase.
(index < limit and: [(atCache at: atIx+AtCacheOop) = array])
ifFalse: [^ self primitiveFail].
"OK -- its not at end, and the array is in the cache"
index := index + 1.
self commonVariable: array at: index put: value cacheIndex: atIx.
self successful ifTrue:
[self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
^ self pop: 2 thenPush: value].
!
Item was changed:
----- Method: Interpreter>>primitivePerform (in category 'control primitives') -----
primitivePerform
| performSelector newReceiver selectorIndex lookupClass performMethod |
performSelector := messageSelector.
performMethod := newMethod.
messageSelector := self stackValue: argumentCount - 1.
newReceiver := self stackValue: argumentCount.
"NOTE: the following lookup may fail and be converted to #doesNotUnderstand:, so we must adjust argumentCount and slide args now, so that would work."
"Slide arguments down over selector"
argumentCount := argumentCount - 1.
selectorIndex := self stackPointerIndex - argumentCount.
self
transfer: argumentCount
fromIndex: selectorIndex + 1
ofObject: activeContext
toIndex: selectorIndex
ofObject: activeContext.
self pop: 1.
+ lookupClass := objectMemory fetchClassOf: newReceiver.
- lookupClass := self fetchClassOf: newReceiver.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - other objects will have to take their chances"
+ (objectMemory isOopCompiledMethod: newMethod)
- (self isOopCompiledMethod: newMethod)
ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
self successful
ifTrue: [self executeNewMethodFromCache.
"Recursive xeq affects primFailCode"
self initPrimCall]
ifFalse: ["Slide the args back up (sigh) and re-insert the
selector. "
+ 1 to: argumentCount do: [:i | objectMemory
- 1 to: argumentCount do: [:i | self
storePointer: argumentCount - i + 1 + selectorIndex
ofObject: activeContext
+ withValue: (objectMemory fetchPointer: argumentCount - i + selectorIndex ofObject: activeContext)].
- withValue: (self fetchPointer: argumentCount - i + selectorIndex ofObject: activeContext)].
self unPop: 1.
+ objectMemory storePointer: selectorIndex
- self storePointer: selectorIndex
ofObject: activeContext
withValue: messageSelector.
argumentCount := argumentCount + 1.
newMethod := performMethod.
messageSelector := performSelector]!
Item was changed:
----- Method: Interpreter>>primitivePerformAt: (in category 'control primitives') -----
primitivePerformAt: lookupClass
"Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"
"NOTE: The case of doesNotUnderstand: is not a failure to perform.
The only failures are arg types and consistency of argumentCount."
| performSelector argumentArray arraySize index cntxSize performMethod performArgCount |
argumentArray := self stackTop.
+ (objectMemory isArray: argumentArray) ifFalse:[^self primitiveFail].
- (self isArray: argumentArray) ifFalse:[^self primitiveFail].
self successful ifTrue:
["Check for enough space in thisContext to push all args"
+ arraySize := objectMemory fetchWordLengthOf: argumentArray.
+ cntxSize := objectMemory fetchWordLengthOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
self success: (self stackPointerIndex + arraySize) < cntxSize].
self successful ifFalse: [^nil].
performSelector := messageSelector.
performMethod := newMethod.
performArgCount := argumentCount.
"pop the arg array and the selector, then push the args out of the array, as if they were on the stack"
self popStack.
messageSelector := self popStack.
"Copy the arguments to the stack, and execute"
index := 1.
[index <= arraySize]
whileTrue:
+ [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
- [self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
argumentCount := arraySize.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
+ (objectMemory isOopCompiledMethod: newMethod)
- (self isOopCompiledMethod: newMethod)
ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
self successful
ifTrue: [self executeNewMethodFromCache. "Recursive xeq affects primFailCode"
self initPrimCall]
ifFalse: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
self pop: argumentCount.
self push: messageSelector.
self push: argumentArray.
messageSelector := performSelector.
newMethod := performMethod.
argumentCount := performArgCount]
!
Item was changed:
----- Method: Interpreter>>primitivePerformInSuperclass (in category 'control primitives') -----
primitivePerformInSuperclass
| lookupClass rcvr currentClass |
lookupClass := self stackTop.
rcvr := self stackValue: 3.
+ currentClass := objectMemory fetchClassOf: rcvr.
- currentClass := self fetchClassOf: rcvr.
[currentClass ~= lookupClass]
whileTrue:
[currentClass := self superclassOf: currentClass.
+ currentClass = objectMemory nilObj ifTrue: [^self primitiveFailFor: PrimErrBadArgument]].
- currentClass = nilObj ifTrue: [^self primitiveFailFor: PrimErrBadArgument]].
argumentCount = 3
ifTrue: ["normal primitive call with 3 arguments expected on the stack"
self popStack.
self primitivePerformAt: lookupClass.
self successful ifFalse:
[self push: lookupClass]]
ifFalse: [argumentCount = 4
ifTrue: ["mirror primitive call with extra argument specifying object to serve as receiver"
| s1 s2 s3 s4 s5 |
"save stack contents"
s1 := self popStack. "lookupClass"
s2 := self popStack. "args"
s3 := self popStack. "selector"
s4 := self popStack. "mirror receiver"
s5 := self popStack. "actual receiver"
"slide stack up one, omitting the actual receiver parameter"
self push: s4. "mirror receiver"
self push: s3. "selector"
self push: s2. "args"
"perform as if mirror receiver had been the actual receiver"
self primitivePerformAt: lookupClass.
self successful ifFalse:
["restore original stack"
self pop: 3. "args, selector, mirror receiver"
self push: s5. "actual receiver"
self push: s4. "mirror receiver"
self push: s3. "selector"
self push: s2. "args"
self push: s1. "lookup class" ]]
ifFalse: ["wrong number of arguments"
^self primitiveFailFor: PrimErrBadNumArgs]]
!
Item was changed:
----- Method: Interpreter>>primitivePerformWithArgs (in category 'control primitives') -----
primitivePerformWithArgs
| lookupClass rcvr |
rcvr := self stackValue: argumentCount.
+ lookupClass := objectMemory fetchClassOf: rcvr.
- lookupClass := self fetchClassOf: rcvr.
self primitivePerformAt: lookupClass.
!
Item was changed:
----- Method: Interpreter>>primitivePushFalse (in category 'quick primitives') -----
primitivePushFalse
self popStack.
+ self push: objectMemory falseObj!
- self push: falseObj!
Item was changed:
----- Method: Interpreter>>primitivePushNil (in category 'quick primitives') -----
primitivePushNil
self popStack.
+ self push: objectMemory nilObj!
- self push: nilObj!
Item was changed:
----- Method: Interpreter>>primitivePushTrue (in category 'quick primitives') -----
primitivePushTrue
self popStack.
+ self push: objectMemory trueObj!
- self push: trueObj!
Item was changed:
----- Method: Interpreter>>primitiveSetGCSemaphore (in category 'memory space primitives') -----
primitiveSetGCSemaphore
"Primitive. Indicate the semaphore to be signalled for upon garbage collection"
| index |
<export: true>
index := self stackIntegerValue: 0.
self successful ifTrue:[
+ objectMemory gcSemaphoreIndex: index.
- gcSemaphoreIndex := index.
self pop: argumentCount.
].!
Item was changed:
----- Method: Interpreter>>primitiveSignalAtMilliseconds (in category 'system control primitives') -----
primitiveSignalAtMilliseconds
"Cause the time semaphore, if one has been registered, to
be signalled when the millisecond clock is greater than or
equal to the given tick value. A tick value of zero turns off
timer interrupts."
| tick sema |
tick := self popInteger.
sema := self popStack.
self successful
+ ifTrue: [(objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
+ ifTrue: [objectMemory
- ifTrue: [(self fetchClassOf: sema) = (self splObj: ClassSemaphore)
- ifTrue: [self
storePointer: TheTimerSemaphore
+ ofObject: objectMemory specialObjectsOop
- ofObject: specialObjectsOop
withValue: sema.
nextWakeupTick := tick]
+ ifFalse: [objectMemory
- ifFalse: [self
storePointer: TheTimerSemaphore
+ ofObject: objectMemory specialObjectsOop
+ withValue: objectMemory nilObj.
- ofObject: specialObjectsOop
- withValue: nilObj.
nextWakeupTick := 0]]
ifFalse: [self unPop: 2]!
Item was changed:
----- Method: Interpreter>>primitiveStoreStackp (in category 'object access primitives') -----
primitiveStoreStackp
"Atomic store into context stackPointer.
Also ensures that any newly accessible cells are initialized to nil "
| ctxt newStackp stackp |
ctxt := self stackValue: 1.
newStackp := self stackIntegerValue: 0.
+ self success: (objectMemory oop: newStackp isGreaterThanOrEqualTo: 0).
+ self success: (objectMemory oop: newStackp isLessThanOrEqualTo: (objectMemory largeContextSize - objectMemory baseHeaderSize // objectMemory bytesPerWord - CtxtTempFrameStart)).
- self success: (self oop: newStackp isGreaterThanOrEqualTo: 0).
- self success: (self oop: newStackp isLessThanOrEqualTo: (self largeContextSize - self baseHeaderSize // self bytesPerWord - CtxtTempFrameStart)).
self successful ifFalse: [^ self primitiveFail].
stackp := self fetchStackPointerOf: ctxt.
+ (objectMemory oop: newStackp isGreaterThan: stackp) ifTrue: ["Nil any newly accessible cells"
+ stackp + 1 to: newStackp do: [:i | objectMemory storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: objectMemory nilObj]].
- (self oop: newStackp isGreaterThan: stackp) ifTrue: ["Nil any newly accessible cells"
- stackp + 1 to: newStackp do: [:i | self storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: nilObj]].
self storeStackPointerValue: newStackp inContext: ctxt.
self pop: 1!
Item was changed:
----- Method: Interpreter>>primitiveVMParameter (in category 'system control primitives') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: Interpreter>>primitiveValue (in category 'control primitives') -----
primitiveValue
| blockContext blockArgumentCount initialIP |
blockContext := self stackValue: argumentCount.
blockArgumentCount := self argumentCountOfBlock: blockContext.
self success: (argumentCount = blockArgumentCount
+ and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory nilObj]).
- and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj]).
self successful
ifTrue: [self transfer: argumentCount
fromIndex: self stackPointerIndex - argumentCount + 1
ofObject: activeContext
toIndex: TempFrameStart
ofObject: blockContext.
"Assume: The call to transfer:... makes blockContext a root if necessary,
allowing use to use unchecked stored in the following code."
self pop: argumentCount + 1.
+ initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: blockContext.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP.
- initialIP := self fetchPointer: InitialIPIndex ofObject: blockContext.
- self storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP.
self storeStackPointerValue: argumentCount inContext: blockContext.
+ objectMemory storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext.
- self storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext.
self newActiveContext: blockContext]!
Item was changed:
----- Method: Interpreter>>primitiveValueWithArgs (in category 'control primitives') -----
primitiveValueWithArgs
| argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |
argumentArray := self popStack.
blockContext := self popStack.
blockArgumentCount := self argumentCountOfBlock: blockContext.
"If the argArray isnt actually an Array we ahve to unpop the above two"
+ (objectMemory isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
- (self isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
+ self successful ifTrue: [arrayArgumentCount := objectMemory fetchWordLengthOf: argumentArray.
- self successful ifTrue: [arrayArgumentCount := self fetchWordLengthOf: argumentArray.
self success: (arrayArgumentCount = blockArgumentCount
+ and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory nilObj])].
- and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])].
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
- initialIP := self fetchPointer: InitialIPIndex ofObject: blockContext.
- self
storePointerUnchecked: InstructionPointerIndex
ofObject: blockContext
withValue: initialIP.
self storeStackPointerValue: arrayArgumentCount inContext: blockContext.
+ objectMemory
- self
storePointerUnchecked: CallerIndex
ofObject: blockContext
withValue: activeContext.
self newActiveContext: blockContext]
ifFalse: [self unPop: 2]!
Item was changed:
----- Method: Interpreter>>printAllStacks (in category 'debug printing') -----
printAllStacks
"Print all the stacks of all running processes, including those that are currently suspended."
| oop proc ctx |
<export: true> "exported to permit access from plugins"
+ proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
+ self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5.
- proc := self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
- self printNameOfClass: (self fetchClassOf: proc) count: 5.
self cr.
self printCallStackOf: activeContext. "first the active context"
+ oop := objectMemory firstObject.
+ [objectMemory oop: oop isLessThan: objectMemory endOfMemory] whileTrue:[
+ (objectMemory fetchClassOf: oop) == objectMemory classSemaphore ifTrue:[
- oop := self firstObject.
- [self oop: oop isLessThan: endOfMemory] whileTrue:[
- (self fetchClassOf: oop) == self classSemaphore ifTrue:[
self cr.
+ proc := objectMemory fetchPointer: FirstLinkIndex ofObject: oop.
+ [proc == objectMemory nilObject] whileFalse:[
+ self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5.
- proc := self fetchPointer: FirstLinkIndex ofObject: oop.
- [proc == self nilObject] whileFalse:[
- self printNameOfClass: (self fetchClassOf: proc) count: 5.
self cr.
+ ctx := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
+ ctx == objectMemory nilObject ifFalse:[self printCallStackOf: ctx].
+ proc := objectMemory fetchPointer: NextLinkIndex ofObject: proc].
- ctx := self fetchPointer: SuspendedContextIndex ofObject: proc.
- ctx == self nilObject ifFalse:[self printCallStackOf: ctx].
- proc := self fetchPointer: NextLinkIndex ofObject: proc].
].
+ oop := objectMemory objectAfter: oop.
- oop := self objectAfter: oop.
].!
Item was changed:
----- Method: Interpreter>>printCallStackOf: (in category 'debug printing') -----
printCallStackOf: aContext
| ctxt home methClass methodSel message |
<inline: false>
ctxt := aContext.
+ [ctxt = objectMemory nilObj] whileFalse: [
+ (objectMemory fetchClassOf: ctxt) = (objectMemory splObj: ClassBlockContext)
+ ifTrue: [ home := objectMemory fetchPointer: HomeIndex ofObject: ctxt ]
- [ctxt = nilObj] whileFalse: [
- (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
- ifTrue: [ home := self fetchPointer: HomeIndex ofObject: ctxt ]
ifFalse: [ home := ctxt ].
methClass :=
+ self findClassOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
+ forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
- self findClassOfMethod: (self fetchPointer: MethodIndex ofObject: home)
- forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
methodSel :=
+ self findSelectorOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
+ forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
- self findSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
- forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
self printNum: ctxt.
self print: ' '.
ctxt = home ifFalse: [ self print: '[] in ' ].
self printNameOfClass: methClass count: 5.
self print: '>'.
+ methodSel = objectMemory nilObj
- methodSel = nilObj
ifTrue: [self print: '?']
ifFalse: [self printStringOf: methodSel].
+ methodSel = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue: [
- methodSel = (self splObj: SelectorDoesNotUnderstand) ifTrue: [
"print arg message selector"
+ message := objectMemory fetchPointer: 0 + TempFrameStart ofObject: home.
+ methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: message.
- message := self fetchPointer: 0 + TempFrameStart ofObject: home.
- methodSel := self fetchPointer: MessageSelectorIndex ofObject: message.
self print: ' '.
self printStringOf: methodSel.
].
self cr.
+ ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt).
- ctxt := (self fetchPointer: SenderIndex ofObject: ctxt).
].!
Item was changed:
----- Method: Interpreter>>printNameOfClass:count: (in category 'debug printing') -----
printNameOfClass: classOop count: cnt
"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
cnt <= 0 ifTrue: [ ^ self print: 'bad class' ].
+ (objectMemory sizeBitsOf: classOop) = (7 * objectMemory bytesPerWord) "(Metaclass instSize+1 * 4)"
+ ifTrue: [self printNameOfClass: (objectMemory fetchPointer: 5 "thisClass" ofObject: classOop)
- (self sizeBitsOf: classOop) = (7 * self bytesPerWord) "(Metaclass instSize+1 * 4)"
- ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop)
count: cnt - 1.
self print: ' class']
+ ifFalse: [self printStringOf: (objectMemory fetchPointer: 6 "name" ofObject: classOop)]!
- ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]!
Item was changed:
----- Method: Interpreter>>printStringOf: (in category 'debug printing') -----
printStringOf: oop
| fmt cnt i |
+ (objectMemory isIntegerObject: oop) ifTrue:[^nil].
+ fmt := objectMemory formatOf: oop.
- (self isIntegerObject: oop) ifTrue:[^nil].
- fmt := self formatOf: oop.
fmt < 8 ifTrue: [ ^nil ].
cnt := 100 min: (self lengthOf: oop).
i := 0.
[i < cnt] whileTrue: [
+ self printChar: (objectMemory fetchByte: i ofObject: oop).
- self printChar: (self fetchByte: i ofObject: oop).
i := i + 1.
].!
Item was changed:
----- Method: Interpreter>>printUnbalancedStackFromNamedPrimitive (in category 'debug printing') -----
printUnbalancedStackFromNamedPrimitive
| lit |
<inline: false>
self print: 'Stack unbalanced after '.
self successful
ifTrue:[self print:'successful ']
ifFalse:[self print: 'failed '].
lit := self literal: 0 ofMethod: newMethod.
+ self printStringOf: (objectMemory fetchPointer: 1 ofObject: lit).
- self printStringOf: (self fetchPointer: 1 ofObject: lit).
self print:' in '.
+ self printStringOf: (objectMemory fetchPointer: 0 ofObject: lit).
- self printStringOf: (self fetchPointer: 0 ofObject: lit).
self cr.
!
Item was changed:
----- Method: Interpreter>>push: (in category 'contexts') -----
push: object
| sp |
+ self longAt: (sp := stackPointer + objectMemory bytesPerWord) put: object.
- self longAt: (sp := stackPointer + self bytesPerWord) put: object.
stackPointer := sp.!
Item was changed:
----- Method: Interpreter>>pushBool: (in category 'contexts') -----
pushBool: trueOrFalse
trueOrFalse
+ ifTrue: [ self push: objectMemory trueObj ]
+ ifFalse: [ self push: objectMemory falseObj ].!
- ifTrue: [ self push: trueObj ]
- ifFalse: [ self push: falseObj ].!
Item was changed:
----- Method: Interpreter>>pushClosureCopyCopiedValuesBytecode (in category 'stack bytecodes') -----
pushClosureCopyCopiedValuesBytecode
"The compiler has pushed the values to be copied, if any. Find numArgs and numCopied in the byte following.
Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure.
Set numArgs as specified, and set startpc to the pc following the block size and jump over that code."
| newClosure numArgsNumCopied numArgs numCopied blockSize |
+ objectMemory bytesPerWord == 4
- self bytesPerWord == 4
ifTrue: [imageFormatVersionNumber := 6504]
ifFalse: [imageFormatVersionNumber := 68002].
numArgsNumCopied := self fetchByte.
numArgs := numArgsNumCopied bitAnd: 16rF.
numCopied := numArgsNumCopied bitShift: -4.
"Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
blockSize := self fetchByte << 8.
blockSize := blockSize + self fetchByte.
self externalizeIPandSP. "This is a pain."
newClosure := self
closureNumArgs: numArgs
+ instructionPointer: ((self oopForPointer: localIP) + 2 - (method + objectMemory baseHeaderSize))
- instructionPointer: ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))
numCopiedValues: numCopied.
self internalizeIPandSP.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext.
- self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext.
reclaimableContextCount := 0. "The closure refers to thisContext so it can't be reclaimed."
numCopied > 0 ifTrue:
[0 to: numCopied - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
- self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self internalStackValue: numCopied - i - 1)].
self internalPop: numCopied].
localIP := localIP + blockSize.
self fetchNextBytecode.
self internalPush: newClosure!
Item was changed:
----- Method: Interpreter>>pushConstantFalseBytecode (in category 'stack bytecodes') -----
pushConstantFalseBytecode
self fetchNextBytecode.
+ self internalPush: objectMemory falseObj.
- self internalPush: falseObj.
!
Item was changed:
----- Method: Interpreter>>pushConstantNilBytecode (in category 'stack bytecodes') -----
pushConstantNilBytecode
self fetchNextBytecode.
+ self internalPush: objectMemory nilObj.
- self internalPush: nilObj.
!
Item was changed:
----- Method: Interpreter>>pushConstantTrueBytecode (in category 'stack bytecodes') -----
pushConstantTrueBytecode
self fetchNextBytecode.
+ self internalPush: objectMemory trueObj.
- self internalPush: trueObj.
!
Item was changed:
----- Method: Interpreter>>pushInteger: (in category 'contexts') -----
pushInteger: integerValue
+ self push: (objectMemory integerObjectOf: integerValue).!
- self push: (self integerObjectOf: integerValue).!
Item was changed:
----- Method: Interpreter>>pushLiteralVariable: (in category 'stack bytecodes') -----
pushLiteralVariable: literalIndex
self internalPush:
+ (objectMemory fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).!
- (self fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).!
Item was changed:
----- Method: Interpreter>>pushNewArrayBytecode (in category 'stack bytecodes') -----
pushNewArrayBytecode
| size popValues array |
size := self fetchByte.
popValues := size > 127.
size := size bitAnd: 127.
self fetchNextBytecode.
self externalizeIPandSP.
+ array := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: size.
- array := self instantiateClass: (self splObj: ClassArray) indexableSize: size.
self internalizeIPandSP.
popValues ifTrue:
[0 to: size - 1 do:
[:i|
"Assume: have just allocated a new Array; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: i ofObject: array withValue: (self internalStackValue: size - i - 1)].
- self storePointerUnchecked: i ofObject: array withValue: (self internalStackValue: size - i - 1)].
self internalPop: size].
self internalPush: array!
Item was changed:
----- Method: Interpreter>>pushReceiverVariable: (in category 'stack bytecodes') -----
pushReceiverVariable: fieldIndex
self internalPush:
+ (objectMemory fetchPointer: fieldIndex ofObject: receiver).!
- (self fetchPointer: fieldIndex ofObject: receiver).!
Item was changed:
----- Method: Interpreter>>pushRemoteTemp:inVectorAt: (in category 'stack bytecodes') -----
pushRemoteTemp: index inVectorAt: tempVectorIndex
| tempVector |
tempVector := self temporary: tempVectorIndex.
+ self internalPush: (objectMemory fetchPointer: index ofObject: tempVector)!
- self internalPush: (self fetchPointer: index ofObject: tempVector)!
Item was changed:
----- Method: Interpreter>>putToSleep: (in category 'process primitive support') -----
putToSleep: aProcess
"Save the given process on the scheduler process list for its priority."
| priority processLists processList |
priority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
+ processLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ processList := objectMemory fetchPointer: priority - 1 ofObject: processLists.
- processLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
- processList := self fetchPointer: priority - 1 ofObject: processLists.
self addLastLink: aProcess toList: processList.!
Item was changed:
----- Method: Interpreter>>quickFetchInteger:ofObject: (in category 'utilities') -----
quickFetchInteger: fieldIndex ofObject: objectPointer
"Return the integer value of the field without verifying that it is an integer value!! For use in time-critical places where the integer-ness of the field can be guaranteed."
+ ^ objectMemory integerValueOf: (objectMemory fetchPointer: fieldIndex ofObject: objectPointer).!
- ^ self integerValueOf: (self fetchPointer: fieldIndex ofObject: objectPointer).!
Item was changed:
----- Method: Interpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
| swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
<var: #f type: 'sqImageFile '>
<var: #desiredHeapSize type: 'usqInt'>
<var: #headerStart type: 'squeakFileOffsetType '>
<var: #dataSize type: 'size_t '>
<var: #imageOffset type: 'squeakFileOffsetType '>
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - objectMemory bytesPerWord. "record header start position"
- headerStart := (self sqImageFilePosition: f) - self bytesPerWord. "record header start position"
headerSize := self getLongFromFile: f swap: swapBytes.
+ dataSize := self getLongFromFile: f swap: swapBytes.
+ oldBaseAddr := self getLongFromFile: f swap: swapBytes.
+ objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
+ objectMemory lastHash: (self getLongFromFile: f swap: swapBytes).
- dataSize := self getLongFromFile: f swap: swapBytes.
- oldBaseAddr := self getLongFromFile: f swap: swapBytes.
- specialObjectsOop := self getLongFromFile: f swap: swapBytes.
- lastHash := self getLongFromFile: f swap: swapBytes.
savedWindowSize := self getLongFromFile: f swap: swapBytes.
fullScreenFlag := self oldFormatFullScreenFlag: (self getLongFromFile: f swap: swapBytes).
+ extraVMMemory := self getLongFromFile: f swap: swapBytes.
- extraVMMemory := self getLongFromFile: f swap: swapBytes.
+ objectMemory lastHash = 0 ifTrue: [
- lastHash = 0 ifTrue: [
"lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
+ objectMemory lastHash: 999].
- lastHash := 999].
"decrease Squeak object heap to leave extra memory for the VM"
heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
"compare memory requirements with availability".
minimumMemory := dataSize + 100000. "need at least 100K of breathing room"
heapSize < minimumMemory ifTrue: [
self insufficientMemorySpecifiedError].
"allocate a contiguous block of memory for the Squeak heap"
+ objectMemory memory: (self
- memory := self
allocateMemory: heapSize
minimum: minimumMemory
imageFile: f
+ headerSize: headerSize).
+ objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError].
- headerSize: headerSize.
- memory = nil ifTrue: [self insufficientMemoryAvailableError].
+ memStart := objectMemory startOfMemory.
+ objectMemory memoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
+ objectMemory endOfMemory: memStart + dataSize.
- memStart := self startOfMemory.
- memoryLimit := (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
- endOfMemory := memStart + dataSize.
"position file after the header"
self sqImageFile: f Seek: headerStart + headerSize.
"read in the image in bulk, then swap the bytes if necessary"
bytesRead := self
+ sqImage: (self pointerForOop: objectMemory memory)
- sqImage: (self pointerForOop: memory)
read: f
size: (self cCode: 'sizeof(unsigned char)')
length: dataSize.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
+ objectMemory headerTypeBytes at: 0 put: objectMemory bytesPerWord * 2. "3-word header (type 0)"
+ objectMemory headerTypeBytes at: 1 put: objectMemory bytesPerWord. "2-word header (type 1)"
+ objectMemory headerTypeBytes at: 2 put: 0. "free chunk (type 2)"
+ objectMemory headerTypeBytes at: 3 put: 0. "1-word header (type 3)"
- headerTypeBytes at: 0 put: self bytesPerWord * 2. "3-word header (type 0)"
- headerTypeBytes at: 1 put: self bytesPerWord. "2-word header (type 1)"
- headerTypeBytes at: 2 put: 0. "free chunk (type 2)"
- headerTypeBytes at: 3 put: 0. "1-word header (type 3)"
swapBytes ifTrue: [self reverseBytesInImage].
"compute difference between old and new memory base addresses"
bytesToShift := memStart - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
self isBigEnder. "work out the machine endianness and cache the answer"
(self imageFormatInitialVersion bitAnd: 1) = 1
ifTrue: ["Low order bit set, indicating that the image was saved from
a StackInterpreter (Cog) VM. Storage of all Float objects must be
returned to older object memory format."
self normalizeFloatOrderingInImage].
^ dataSize
!
Item was changed:
----- Method: Interpreter>>readableFormat: (in category 'image save/restore') -----
readableFormat: imageVersion
"Anwer true if images of the given format are readable by this interpreter. Allows
a virtual machine to accept selected older image formats. In our case we can
select a newer (closure) image format as well as the existing format. Images with
platform-ordered floats (StackInterpreter and Cog format) are readable but will be
converted to traditional word ordering."
+ objectMemory bytesPerWord = 4
- self bytesPerWord = 4
ifTrue: [^ (imageVersion = 6502 "Original 32-bit Squeak image format"
or: [imageVersion = 6504]) "32-bit with closures"
or: [imageVersion = 6505]] "32-bit with closures and platform-ordered floats"
ifFalse: [^ (imageVersion = 68000 "Original 64-bit Squeak image format"
or: [imageVersion = 68002]) "64-bit with closures"
or: [imageVersion = 68003]] "64-bit with closures and platform-ordered floats"
!
Item was changed:
----- Method: Interpreter>>reestablishContextPriorToCallback: (in category 'contexts') -----
reestablishContextPriorToCallback: callbackContext
"callbackContext is an activation of invokeCallback:stack:registers:jmpbuf:. Its sender
is the interpreter's state prior to the callback. Reestablish that state."
| calloutContext |
<export: true>
+ (objectMemory fetchClassOf: callbackContext) ~~ (objectMemory splObj: ClassMethodContext) ifTrue:
- (self fetchClassOf: callbackContext) ~~ (self splObj: ClassMethodContext) ifTrue:
[^false].
+ calloutContext := objectMemory fetchPointer: SenderIndex ofObject: callbackContext.
- calloutContext := self fetchPointer: SenderIndex ofObject: callbackContext.
self newActiveContext: calloutContext.
^true!
Item was changed:
----- Method: Interpreter>>removeFirstLinkOfList: (in category 'process primitive support') -----
removeFirstLinkOfList: aList
"Remove the first process from the given linked list."
| first last next |
+ first := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
+ last := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
- first := self fetchPointer: FirstLinkIndex ofObject: aList.
- last := self fetchPointer: LastLinkIndex ofObject: aList.
first = last
+ ifTrue: [objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: objectMemory nilObj.
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory nilObj]
+ ifFalse: [next := objectMemory fetchPointer: NextLinkIndex ofObject: first.
+ objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: next].
+ objectMemory storePointer: NextLinkIndex ofObject: first withValue: objectMemory nilObj.
- ifTrue: [self storePointer: FirstLinkIndex ofObject: aList withValue: nilObj.
- self storePointer: LastLinkIndex ofObject: aList withValue: nilObj]
- ifFalse: [next := self fetchPointer: NextLinkIndex ofObject: first.
- self storePointer: FirstLinkIndex ofObject: aList withValue: next].
- self storePointer: NextLinkIndex ofObject: first withValue: nilObj.
^ first!
Item was changed:
----- Method: Interpreter>>removeProcess:fromList: (in category 'process primitive support') -----
removeProcess: aProcess fromList: aList
"Remove a given process from a linked list. May fail if aProcess is not on the list."
| firstLink lastLink nextLink tempLink |
+ firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
+ lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
- firstLink := self fetchPointer: FirstLinkIndex ofObject: aList.
- lastLink := self fetchPointer: LastLinkIndex ofObject: aList.
aProcess == firstLink ifTrue:[
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess .
+ objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: nextLink.
- nextLink := self fetchPointer: NextLinkIndex ofObject: aProcess .
- self storePointer: FirstLinkIndex ofObject: aList withValue: nextLink.
aProcess == lastLink ifTrue:[
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory nilObject.
- self storePointer: LastLinkIndex ofObject: aList withValue: self nilObject.
].
] ifFalse:[
tempLink := firstLink.
+ [tempLink == objectMemory nilObject ifTrue:[^self success: false]. "fail"
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
- [tempLink == self nilObject ifTrue:[^self success: false]. "fail"
- nextLink := self fetchPointer: NextLinkIndex ofObject: tempLink.
nextLink == aProcess] whileFalse:[
+ tempLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
- tempLink := self fetchPointer: NextLinkIndex ofObject: tempLink.
].
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess.
+ objectMemory storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink.
- nextLink := self fetchPointer: NextLinkIndex ofObject: aProcess.
- self storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink.
aProcess == lastLink ifTrue:[
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: tempLink.
- self storePointer: LastLinkIndex ofObject: aList withValue: tempLink.
].
].
+ objectMemory storePointer: NextLinkIndex ofObject: aProcess withValue: objectMemory nilObject.
- self storePointer: NextLinkIndex ofObject: aProcess withValue: self nilObject.
!
Item was changed:
----- Method: Interpreter>>resume: (in category 'process primitive support') -----
resume: aProcess
| activeProc activePriority newPriority |
<inline: false>
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
- activeProc := self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
activePriority := self quickFetchInteger: PriorityIndex ofObject: activeProc.
newPriority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
newPriority > activePriority
ifTrue: [self putToSleep: activeProc.
self transferTo: aProcess]
ifFalse: [self putToSleep: aProcess]!
Item was changed:
----- Method: Interpreter>>returnFalse (in category 'return bytecodes') -----
returnFalse
localReturnContext := self sender.
+ localReturnValue := objectMemory falseObj.
- localReturnValue := falseObj.
self commonReturn.
!
Item was changed:
----- Method: Interpreter>>returnNil (in category 'return bytecodes') -----
returnNil
localReturnContext := self sender.
+ localReturnValue := objectMemory nilObj.
- localReturnValue := nilObj.
self commonReturn.!
Item was changed:
----- Method: Interpreter>>returnTrue (in category 'return bytecodes') -----
returnTrue
localReturnContext := self sender.
+ localReturnValue := objectMemory trueObj.
- localReturnValue := trueObj.
self commonReturn.!
Item was removed:
- ----- Method: Interpreter>>reverseBytesFrom:to: (in category 'image save/restore') -----
- reverseBytesFrom: startAddr to: stopAddr
- "Byte-swap the given range of memory (not inclusive of stopAddr!!)."
- | addr |
- self flag: #Dan.
- addr := startAddr.
- [self oop: addr isLessThan: stopAddr] whileTrue:
- [self longAt: addr put: (self byteSwapped: (self longAt: addr)).
- addr := addr + self bytesPerWord].!
Item was changed:
----- Method: Interpreter>>reverseBytesInImage (in category 'image save/restore') -----
reverseBytesInImage
"Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."
"First, byte-swap every word in the image. This fixes objects headers."
+ objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory endOfMemory.
- self reverseBytesFrom: self startOfMemory to: endOfMemory.
"Second, return the bytes of bytes-type objects to their orginal order."
self byteSwapByteObjects.!
Item was changed:
----- Method: Interpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
reverseDisplayFrom: startIndex to: endIndex
"Reverse the given range of Display words (at different bit
depths, this will reverse different numbers of pixels). Used to
give feedback during VM activities such as garbage
collection when debugging. It is assumed that the given
word range falls entirely within the first line of the Display."
| displayObj dispBitsPtr w reversed |
+ displayObj := objectMemory splObj: TheDisplay.
+ ((objectMemory isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
- displayObj := self splObj: TheDisplay.
- ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
w := self fetchInteger: 1 ofObject: displayObj.
+ dispBitsPtr := objectMemory fetchPointer: 0 ofObject: displayObj.
+ (objectMemory isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
+ dispBitsPtr := dispBitsPtr + objectMemory baseHeaderSize.
- dispBitsPtr := self fetchPointer: 0 ofObject: displayObj.
- (self isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
- dispBitsPtr := dispBitsPtr + self baseHeaderSize.
dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
do: [:ptr |
reversed := (self long32At: ptr) bitXor: 4294967295.
self longAt: ptr put: reversed].
self initPrimCall.
self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
self ioForceDisplayUpdate!
Item was removed:
- ----- Method: Interpreter>>reverseWordsFrom:to: (in category 'image save/restore') -----
- reverseWordsFrom: startAddr to: stopAddr
- "Word-swap the given range of memory, excluding stopAddr."
-
- | addr |
- addr := startAddr.
- [self oop: addr isLessThan: stopAddr] whileTrue:
- [self longAt: addr put: (self wordSwapped: (self longAt: addr)).
- addr := addr + self bytesPerWord].!
Item was changed:
----- Method: Interpreter>>roomToPushNArgs: (in category 'primitive support') -----
roomToPushNArgs: n
"Answer if there is room to push n arguments onto the current stack.
There may be room in this stackPage but there may not be room if
the frame were converted into a context."
| cntxSize |
((self headerOf: method) bitAnd: LargeContextBit) ~= 0
+ ifTrue: [cntxSize := objectMemory largeContextSize / objectMemory bytesPerWord - ReceiverIndex]
+ ifFalse: [cntxSize := objectMemory smallContextSize / objectMemory bytesPerWord - ReceiverIndex].
- ifTrue: [cntxSize := self largeContextSize / self bytesPerWord - ReceiverIndex]
- ifFalse: [cntxSize := self smallContextSize / self bytesPerWord - ReceiverIndex].
^self stackPointerIndex + n <= cntxSize!
Item was changed:
----- Method: Interpreter>>saveProcessSignalingLowSpace (in category 'process primitive support') -----
saveProcessSignalingLowSpace
"The low space semaphore is about to be signaled. Save the currently active
process in the special objects array so that the low space handler will be able
to determine the process that first triggered a low space condition. The low
space handler (in the image) is expected to nil out the special objects array
slot when it handles the low space condition."
| lastSavedProcess sched currentProc |
+ lastSavedProcess := objectMemory splObj: ProcessSignalingLowSpace.
+ (lastSavedProcess == objectMemory nilObject) ifTrue:
- lastSavedProcess := self splObj: ProcessSignalingLowSpace.
- (lastSavedProcess == self nilObject) ifTrue:
[sched := self schedulerPointer.
+ currentProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
+ objectMemory storePointer: ProcessSignalingLowSpace ofObject: objectMemory specialObjectsOop withValue: currentProc]!
- currentProc := self fetchPointer: ActiveProcessIndex ofObject: sched.
- self storePointer: ProcessSignalingLowSpace ofObject: specialObjectsOop withValue: currentProc]!
Item was changed:
----- Method: Interpreter>>schedulerPointer (in category 'process primitive support') -----
schedulerPointer
+ ^ objectMemory fetchPointer: ValueIndex ofObject: (objectMemory splObj: SchedulerAssociation)!
- ^ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation)!
Item was changed:
----- Method: Interpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'alien support') -----
sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
"Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
to Alien class with the supplied args. The arguments are raw C addresses
and are converted to integer objects on the way."
| where |
<export: true>
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
+ receiver := objectMemory splObj: ClassAlien.
+ lkupClass := objectMemory fetchClassOfNonInt: receiver.
+ messageSelector := objectMemory splObj: InvokeCallbackSelector.
- self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
- self pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
- self pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
- self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
- receiver := self splObj: ClassAlien.
- lkupClass := self fetchClassOfNonInt: receiver.
- messageSelector := self splObj: InvokeCallbackSelector.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
[^false]].
primitiveIndex ~= 0 ifTrue:
[^false].
self storeContextRegisters: activeContext.
self internalJustActivateNewMethod.
+ where := activeContext + objectMemory baseHeaderSize + (ReceiverIndex << objectMemory shiftForWord).
+ self longAt: where + (1 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
+ self longAt: where + (2 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
+ self longAt: where + (3 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
+ self longAt: where + (4 << objectMemory shiftForWord) put: objectMemory popRemappableOop.
- where := activeContext + self baseHeaderSize + (ReceiverIndex << self shiftForWord).
- self longAt: where + (1 << self shiftForWord) put: self popRemappableOop.
- self longAt: where + (2 << self shiftForWord) put: self popRemappableOop.
- self longAt: where + (3 << self shiftForWord) put: self popRemappableOop.
- self longAt: where + (4 << self shiftForWord) put: self popRemappableOop.
self fetchContextRegisters: activeContext.
self callInterpreter.
"not reached"
^true!
Item was changed:
----- Method: Interpreter>>sender (in category 'contexts') -----
sender
| context closureOrNil |
context := localHomeContext.
+ [(closureOrNil := objectMemory fetchPointer: ClosureIndex ofObject: context) ~~ objectMemory nilObj] whileTrue:
+ [context := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closureOrNil].
+ ^objectMemory fetchPointer: SenderIndex ofObject: context!
- [(closureOrNil := self fetchPointer: ClosureIndex ofObject: context) ~~ nilObj] whileTrue:
- [context := self fetchPointer: ClosureOuterContextIndex ofObject: closureOrNil].
- ^self fetchPointer: SenderIndex ofObject: context!
Item was changed:
----- Method: Interpreter>>signalExternalSemaphores (in category 'process primitive support') -----
signalExternalSemaphores
"Signal all requested semaphores"
| xArray xSize index sema |
semaphoresUseBufferA := semaphoresUseBufferA not.
+ xArray := objectMemory splObj: ExternalObjectsArray.
- xArray := self splObj: ExternalObjectsArray.
xSize := self stSizeOf: xArray.
semaphoresUseBufferA
ifTrue: ["use opposite buffer during read"
1 to: semaphoresToSignalCountB do: [:i |
index := semaphoresToSignalB at: i.
index <= xSize
+ ifTrue: [sema := objectMemory fetchPointer: index - 1 ofObject: xArray.
- ifTrue: [sema := self fetchPointer: index - 1 ofObject: xArray.
"Note: semaphore indices are 1-based"
+ (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
- (self fetchClassOf: sema) = (self splObj: ClassSemaphore)
ifTrue: [self synchronousSignal: sema]]].
semaphoresToSignalCountB := 0]
ifFalse: [1 to: semaphoresToSignalCountA do: [:i |
index := semaphoresToSignalA at: i.
index <= xSize
+ ifTrue: [sema := objectMemory fetchPointer: index - 1 ofObject: xArray.
- ifTrue: [sema := self fetchPointer: index - 1 ofObject: xArray.
"Note: semaphore indices are 1-based"
+ (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
- (self fetchClassOf: sema) = (self splObj: ClassSemaphore)
ifTrue: [self synchronousSignal: sema]]].
semaphoresToSignalCountA := 0]!
Item was changed:
----- Method: Interpreter>>signed32BitIntegerFor: (in category 'primitive support') -----
signed32BitIntegerFor: integerValue
"Return a full 32 bit integer object for the given integer value"
| newLargeInteger value largeClass |
<inline: false>
<var: #integerValue type: 'int'>
+ (objectMemory isIntegerValue: integerValue)
+ ifTrue: [^ objectMemory integerObjectOf: integerValue].
- (self isIntegerValue: integerValue)
- ifTrue: [^ self integerObjectOf: integerValue].
integerValue < 0
+ ifTrue:[ largeClass := objectMemory classLargeNegativeInteger.
- ifTrue:[ largeClass := self classLargeNegativeInteger.
value := 0 - integerValue]
+ ifFalse:[ largeClass := objectMemory classLargePositiveInteger.
- ifFalse:[ largeClass := self classLargePositiveInteger.
value := integerValue].
+ newLargeInteger := objectMemory instantiateClass: largeClass indexableSize: 4.
+ objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((value >> 24) bitAnd: 16rFF).
+ objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((value >> 16) bitAnd: 16rFF).
+ objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((value >> 8) bitAnd: 16rFF).
+ objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (value bitAnd: 16rFF).
- newLargeInteger := self instantiateClass: largeClass indexableSize: 4.
- self storeByte: 3 ofObject: newLargeInteger withValue: ((value >> 24) bitAnd: 16rFF).
- self storeByte: 2 ofObject: newLargeInteger withValue: ((value >> 16) bitAnd: 16rFF).
- self storeByte: 1 ofObject: newLargeInteger withValue: ((value >> 8) bitAnd: 16rFF).
- self storeByte: 0 ofObject: newLargeInteger withValue: (value bitAnd: 16rFF).
^ newLargeInteger!
Item was changed:
----- Method: Interpreter>>signed64BitIntegerFor: (in category 'primitive support') -----
signed64BitIntegerFor: integerValue
"Return a Large Integer object for the given integer value"
| newLargeInteger magnitude largeClass intValue highWord sz |
<inline: false>
<var: 'integerValue' type: 'sqLong'>
<var: 'magnitude' type: 'unsigned sqLong'>
<var: 'highWord' type: 'usqInt'>
integerValue < 0
+ ifTrue:[ largeClass := objectMemory classLargeNegativeInteger.
- ifTrue:[ largeClass := self classLargeNegativeInteger.
magnitude := 0 - integerValue]
+ ifFalse:[ largeClass := objectMemory classLargePositiveInteger.
- ifFalse:[ largeClass := self classLargePositiveInteger.
magnitude := integerValue].
magnitude <= 16r7FFFFFFF ifTrue:[^self signed32BitIntegerFor: integerValue].
highWord := self
cCode: 'magnitude >> 32' "shift is coerced to usqInt otherwise"
inSmalltalk: [magnitude bitShift: -32].
highWord = 0
ifTrue:[sz := 4]
ifFalse:[
sz := 5.
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
].
+ newLargeInteger := objectMemory instantiateClass: largeClass indexableSize: sz.
- newLargeInteger := self instantiateClass: largeClass indexableSize: sz.
0 to: sz-1 do: [:i |
intValue := self
cCode: '(magnitude >> (i * 8)) & 255'
inSmalltalk: [(magnitude bitShift: (i * 8) negated) bitAnd: 16rFF].
+ objectMemory storeByte: i ofObject: newLargeInteger withValue: intValue].
- self storeByte: i ofObject: newLargeInteger withValue: intValue].
^ newLargeInteger!
Item was changed:
----- Method: Interpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') -----
sizeOfSTArrayFromCPrimitive: cPtr
"Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
"Note: Only called by translated primitive code."
| oop |
<var: #cPtr type: 'void *'>
+ oop := (self oopForPointer: (self cCoerce: cPtr to: 'char *')) - objectMemory baseHeaderSize.
+ (objectMemory isWordsOrBytes: oop) ifFalse: [
- oop := (self oopForPointer: (self cCoerce: cPtr to: 'char *')) - self baseHeaderSize.
- (self isWordsOrBytes: oop) ifFalse: [
self primitiveFail.
^0].
^self lengthOf: oop
!
Item was changed:
----- Method: Interpreter>>slotSizeOf: (in category 'object format') -----
slotSizeOf: oop
"Returns the number of slots in the receiver.
If the receiver is a byte object, return the number of bytes.
Otherwise return the number of words."
+ (objectMemory isIntegerObject: oop) ifTrue:[^0].
- (self isIntegerObject: oop) ifTrue:[^0].
^self lengthOf: oop!
Item was changed:
----- Method: Interpreter>>snapshot: (in category 'image save/restore') -----
snapshot: embedded
"update state of active context"
| activeProc dataSize rcvr setMacType |
<var: #setMacType type: 'void *'>
compilerInitialized
ifTrue: [self compilerPreSnapshot]
ifFalse: [self storeContextRegisters: activeContext].
"update state of active process"
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
+ objectMemory
- activeProc := self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
- self
storePointer: SuspendedContextIndex
ofObject: activeProc
withValue: activeContext.
"compact memory and compute the size of the memory actually in use"
+ objectMemory incrementalGC.
- self incrementalGC.
"maximimize space for forwarding table"
+ objectMemory fullGC.
- self fullGC.
self snapshotCleanUp.
+ dataSize := objectMemory freeBlock - objectMemory startOfMemory. "Assume all objects are below the start of the free block"
- dataSize := freeBlock - self startOfMemory. "Assume all objects are below the start of the free block"
self successful
ifTrue: [rcvr := self popStack.
"pop rcvr"
+ self push: objectMemory trueObj.
- self push: trueObj.
self writeImageFile: dataSize.
embedded
ifFalse: ["set Mac file type and creator; this is a noop on other platforms"
setMacType := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
setMacType = 0
ifFalse: [self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
self pop: 1].
"activeContext was unmarked in #snapshotCleanUp, mark it old "
+ objectMemory beRootIfOld: activeContext.
- self beRootIfOld: activeContext.
self successful
+ ifTrue: [self push: objectMemory falseObj]
- ifTrue: [self push: falseObj]
ifFalse: [self push: rcvr].
compilerInitialized
ifTrue: [self compilerPostSnapshot]!
Item was changed:
----- Method: Interpreter>>snapshotCleanUp (in category 'image save/restore') -----
snapshotCleanUp
"Clean up right before saving an image, sweeping memory and:
* nilling out all fields of contexts above the stack pointer.
* flushing external primitives
* clearing the root bit of any object in the root table "
| oop header fmt sz |
+ oop := objectMemory firstObject.
+ [objectMemory oop: oop isLessThan: objectMemory endOfMemory]
+ whileTrue: [(objectMemory isFreeObject: oop)
- oop := self firstObject.
- [self oop: oop isLessThan: endOfMemory]
- whileTrue: [(self isFreeObject: oop)
ifFalse: [header := self longAt: oop.
fmt := header >> 8 bitAnd: 15.
"Clean out context"
(fmt = 3 and: [self isContextHeader: header])
+ ifTrue: [sz := objectMemory sizeBitsOf: oop.
+ (objectMemory lastPointerOf: oop) + objectMemory bytesPerWord
+ to: sz - objectMemory baseHeaderSize by: objectMemory bytesPerWord
+ do: [:i | self longAt: oop + i put: objectMemory nilObj]].
- ifTrue: [sz := self sizeBitsOf: oop.
- (self lastPointerOf: oop) + self bytesPerWord
- to: sz - self baseHeaderSize by: self bytesPerWord
- do: [:i | self longAt: oop + i put: nilObj]].
"Clean out external functions"
fmt >= 12
ifTrue: ["This is a compiled method"
(self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
ifTrue: ["It's primitiveExternalCall"
self flushExternalPrimitiveOf: oop]]].
+ oop := objectMemory objectAfter: oop].
+ objectMemory clearRootsTable!
- oop := self objectAfter: oop].
- self clearRootsTable!
Item was changed:
----- Method: Interpreter>>specialSelector: (in category 'message sending') -----
specialSelector: index
+ ^ objectMemory fetchPointer: (index * 2) ofObject: (objectMemory splObj: SpecialSelectors)!
- ^ self fetchPointer: (index * 2) ofObject: (self splObj: SpecialSelectors)!
Item was changed:
----- Method: Interpreter>>stObject:at: (in category 'array primitive support') -----
stObject: array at: index
"Return what ST would return for <obj> at: index."
| hdr fmt totalLength fixedFields stSize |
<inline: false>
+ hdr := objectMemory baseHeader: array.
- hdr := self baseHeader: array.
fmt := (hdr >> 8) bitAnd: 16rF.
totalLength := self lengthOf: array baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: array format: fmt length: totalLength.
(fmt = 3 and: [self isContextHeader: hdr])
ifTrue: [stSize := self fetchStackPointerOf: array]
ifFalse: [stSize := totalLength - fixedFields].
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ((self oop: index isGreaterThanOrEqualTo: 1)
- and: [self oop: index isLessThanOrEqualTo: stSize])
ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt]
ifFalse: [self primitiveFail. ^ 0].!
Item was changed:
----- Method: Interpreter>>stObject:at:put: (in category 'array primitive support') -----
stObject: array at: index put: value
"Do what ST would return for <obj> at: index put: value."
| hdr fmt totalLength fixedFields stSize |
<inline: false>
+ hdr := objectMemory baseHeader: array.
- hdr := self baseHeader: array.
fmt := (hdr >> 8) bitAnd: 16rF.
totalLength := self lengthOf: array baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: array format: fmt length: totalLength.
(fmt = 3 and: [self isContextHeader: hdr])
ifTrue: [stSize := self fetchStackPointerOf: array]
ifFalse: [stSize := totalLength - fixedFields].
+ ((objectMemory oop: index isGreaterThanOrEqualTo: 1)
+ and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
- ((self oop: index isGreaterThanOrEqualTo: 1)
- and: [self oop: index isLessThanOrEqualTo: stSize])
ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
ifFalse: [self primitiveFail]!
Item was changed:
----- Method: Interpreter>>stSizeOf: (in category 'array primitive support') -----
stSizeOf: oop
"Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for <obj> size)."
"Note: Assume oop is not a SmallInteger!!"
| hdr fmt totalLength fixedFields |
<inline: false>
+ hdr := objectMemory baseHeader: oop.
- hdr := self baseHeader: oop.
fmt := (hdr >> 8) bitAnd: 16rF.
totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
(fmt = 3 and: [self isContextHeader: hdr])
ifTrue: [^ self fetchStackPointerOf: oop]
ifFalse: [^ totalLength - fixedFields]!
Item was changed:
----- Method: Interpreter>>stackFloatValue: (in category 'contexts') -----
stackFloatValue: offset
"Note: May be called by translated primitive code."
| result floatPointer |
<returnTypeC: 'double'>
<var: #result type: 'double '>
+ floatPointer := self longAt: stackPointer - (offset * objectMemory bytesPerWord).
+ (objectMemory fetchClassOf: floatPointer) = (objectMemory splObj: ClassFloat)
- floatPointer := self longAt: stackPointer - (offset * self bytesPerWord).
- (self fetchClassOf: floatPointer) = (self splObj: ClassFloat)
ifFalse:[self primitiveFail. ^0.0].
self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: floatPointer + objectMemory baseHeaderSize into: result.
- self fetchFloatAt: floatPointer + self baseHeaderSize into: result.
^ result!
Item was changed:
----- Method: Interpreter>>stackIntegerValue: (in category 'contexts') -----
stackIntegerValue: offset
| integerPointer |
+ integerPointer := self longAt: stackPointer - (offset * objectMemory bytesPerWord).
- integerPointer := self longAt: stackPointer - (offset * self bytesPerWord).
^self checkedIntegerValueOf: integerPointer!
Item was changed:
----- Method: Interpreter>>stackObjectValue: (in category 'contexts') -----
stackObjectValue: offset
"Ensures that the given object is a real object, not a SmallInteger."
| oop |
+ oop := self longAt: stackPointer - (offset * objectMemory bytesPerWord).
+ (objectMemory isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
- oop := self longAt: stackPointer - (offset * self bytesPerWord).
- (self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
^ oop
!
Item was changed:
----- Method: Interpreter>>stackPointerIndex (in category 'contexts') -----
stackPointerIndex
"Return the 0-based index rel to the current context.
(This is what stackPointer used to be before conversion to pointer"
+ ^ (stackPointer - activeContext - objectMemory baseHeaderSize) >> objectMemory shiftForWord!
- ^ (stackPointer - activeContext - self baseHeaderSize) >> self shiftForWord!
Item was changed:
----- Method: Interpreter>>stackValue: (in category 'contexts') -----
stackValue: offset
+ ^ self longAt: stackPointer - (offset * objectMemory bytesPerWord)!
- ^ self longAt: stackPointer - (offset * self bytesPerWord)!
Item was changed:
----- Method: Interpreter>>stackValue:put: (in category 'contexts') -----
stackValue: offset put: oop
+ ^self longAt: stackPointer - (offset * objectMemory bytesPerWord)
- ^self longAt: stackPointer - (offset * self bytesPerWord)
put: oop!
Item was changed:
----- Method: Interpreter>>storeAndPopReceiverVariableBytecode (in category 'stack bytecodes') -----
storeAndPopReceiverVariableBytecode
"Note: This code uses
storePointerUnchecked:ofObject:withValue: and does the
store check explicitely in order to help the translator
produce better code."
| rcvr top |
self flag: #'requires currentBytecode to be expanded to a constant'.
self fetchNextBytecode.
"this bytecode will be expanded so that refs to currentBytecode below will be constant"
rcvr := receiver.
top := self internalStackTop.
+ (objectMemory oop: rcvr isLessThan: objectMemory youngStart)
+ ifTrue: [objectMemory possibleRootStoreInto: rcvr value: top].
+ objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top.
- (self oop: rcvr isLessThan: youngStart)
- ifTrue: [self possibleRootStoreInto: rcvr value: top].
- self storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top.
self internalPop: 1!
Item was changed:
----- Method: Interpreter>>storeAndPopTemporaryVariableBytecode (in category 'stack bytecodes') -----
storeAndPopTemporaryVariableBytecode
self flag: #'requires currentBytecode to be expanded to a constant'.
self fetchNextBytecode.
"this bytecode will be expanded so that refs to currentBytecode below will be constant"
+ objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
- self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
ofObject: localHomeContext
withValue: self internalStackTop.
self internalPop: 1.
!
Item was changed:
----- Method: Interpreter>>storeContextRegisters: (in category 'contexts') -----
storeContextRegisters: activeCntx
"Note: internalStoreContextRegisters: should track changes to this method."
"InstructionPointer is a pointer variable equal to
method oop + ip + self baseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
<inline: true>
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
+ withValue: (objectMemory integerObjectOf: (instructionPointer - method - (objectMemory baseHeaderSize - 2))).
+ objectMemory storePointerUnchecked: StackPointerIndex ofObject: activeCntx
+ withValue: (objectMemory integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
- self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
- withValue: (self integerObjectOf: (instructionPointer - method - (self baseHeaderSize - 2))).
- self storePointerUnchecked: StackPointerIndex ofObject: activeCntx
- withValue: (self integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
!
Item was changed:
----- Method: Interpreter>>storeInstructionPointerValue:inContext: (in category 'contexts') -----
storeInstructionPointerValue: value inContext: contextPointer
"Assume: value is an integerValue"
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: contextPointer withValue: (objectMemory integerObjectOf: value).!
- self storePointerUnchecked: InstructionPointerIndex ofObject: contextPointer withValue: (self integerObjectOf: value).!
Item was changed:
----- Method: Interpreter>>storeInteger:ofObject:withValue: (in category 'utilities') -----
storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue
"Note: May be called by translated primitive code."
+ (objectMemory isIntegerValue: integerValue)
+ ifTrue: [objectMemory storePointerUnchecked: fieldIndex ofObject: objectPointer
+ withValue: (objectMemory integerObjectOf: integerValue)]
- (self isIntegerValue: integerValue)
- ifTrue: [self storePointerUnchecked: fieldIndex ofObject: objectPointer
- withValue: (self integerObjectOf: integerValue)]
ifFalse: [self primitiveFail]!
Item was changed:
----- Method: Interpreter>>storeRemoteTemp:inVectorAt: (in category 'stack bytecodes') -----
storeRemoteTemp: index inVectorAt: tempVectorIndex
| tempVector |
tempVector := self temporary: tempVectorIndex.
+ objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop.!
- self storePointer: index ofObject: tempVector withValue: self internalStackTop.!
Item was changed:
----- Method: Interpreter>>storeStackPointerValue:inContext: (in category 'contexts') -----
storeStackPointerValue: value inContext: contextPointer
"Assume: value is an integerValue"
+ objectMemory storePointerUnchecked: StackPointerIndex ofObject: contextPointer
+ withValue: (objectMemory integerObjectOf: value).!
- self storePointerUnchecked: StackPointerIndex ofObject: contextPointer
- withValue: (self integerObjectOf: value).!
Item was changed:
----- Method: Interpreter>>subscript:with:format: (in category 'array primitive support') -----
subscript: array with: index format: fmt
"Note: This method assumes that the index is within bounds!!"
<inline: true>
fmt <= 4 ifTrue: [ "pointer type objects"
+ ^ objectMemory fetchPointer: index - 1 ofObject: array].
- ^ self fetchPointer: index - 1 ofObject: array].
fmt < 8 ifTrue: [ "long-word type objects"
^ self positive32BitIntegerFor:
+ (objectMemory fetchLong32: index - 1 ofObject: array)
- (self fetchLong32: index - 1 ofObject: array)
] ifFalse: [ "byte-type objects"
+ ^ objectMemory integerObjectOf:
+ (objectMemory fetchByte: index - 1 ofObject: array)
- ^ self integerObjectOf:
- (self fetchByte: index - 1 ofObject: array)
].!
Item was changed:
----- Method: Interpreter>>subscript:with:storing:format: (in category 'array primitive support') -----
subscript: array with: index storing: oopToStore format: fmt
"Note: This method assumes that the index is within bounds!!"
| valueToStore |
<inline: true>
fmt <= 4
ifTrue: ["pointer type objects"
+ objectMemory storePointer: index - 1 ofObject: array
- self storePointer: index - 1 ofObject: array
withValue: oopToStore]
ifFalse: [fmt < 8
ifTrue: ["long-word type objects"
valueToStore := self positive32BitValueOf: oopToStore.
self successful
+ ifTrue: [objectMemory storeLong32: index - 1 ofObject: array
- ifTrue: [self storeLong32: index - 1 ofObject: array
withValue: valueToStore]]
ifFalse: ["byte-type objects"
+ (objectMemory isIntegerObject: oopToStore)
- (self isIntegerObject: oopToStore)
ifFalse: [self primitiveFail].
+ valueToStore := objectMemory integerValueOf: oopToStore.
- valueToStore := self integerValueOf: oopToStore.
(valueToStore >= 0
and: [valueToStore <= 255])
ifFalse: [self primitiveFail].
self successful
+ ifTrue: [objectMemory
- ifTrue: [self
storeByte: index - 1
ofObject: array
withValue: valueToStore]]]!
Item was changed:
----- Method: Interpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') -----
sufficientSpaceToInstantiate: classOop indexableSize: size
"Return true if there is enough space to allocate an instance of the given class with the given number of indexable fields."
"Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."
| format |
<inline: true>
<var: #size type: 'usqInt'>
<var: #bytesNeeded type: 'usqInt'>
format := (self formatOfClass: classOop) >> 8 bitAnd: 16rF.
"Fail if attempting to call new: on non-indexable class"
(size > 0 and: [format < 2])
ifTrue: [^ false].
format < 8
ifTrue: ["indexable fields are words or pointers"
+ (objectMemory isExcessiveAllocationRequest: size shift: objectMemory shiftForWord) ifTrue: [^ false].
+ ^ objectMemory sufficientSpaceToAllocate: 2500 + (size * objectMemory bytesPerWord)]
- (self isExcessiveAllocationRequest: size shift: self shiftForWord) ifTrue: [^ false].
- ^ self sufficientSpaceToAllocate: 2500 + (size * self bytesPerWord)]
ifFalse: ["indexable fields are bytes"
+ (objectMemory isExcessiveAllocationRequest: size shift: 0) ifTrue: [^ false].
+ ^ objectMemory sufficientSpaceToAllocate: 2500 + size]
- (self isExcessiveAllocationRequest: size shift: 0) ifTrue: [^ false].
- ^ self sufficientSpaceToAllocate: 2500 + size]
!
Item was changed:
----- Method: Interpreter>>superclassOf: (in category 'message sending') -----
superclassOf: classPointer
+ ^ objectMemory fetchPointer: SuperclassIndex ofObject: classPointer!
- ^ self fetchPointer: SuperclassIndex ofObject: classPointer!
Item was changed:
----- Method: Interpreter>>superclassSend (in category 'message sending') -----
superclassSend
"Send a message to self, starting lookup with the superclass of the class containing the currently executing method."
"Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack,"
"Note: This method is inlined into the interpreter dispatch loop."
| rcvr |
<inline: true>
self sharedCodeNamed: 'commonSupersend' inCase: 133.
lkupClass := self superclassOf: (self methodClassOf: method).
rcvr := self internalStackValue: argumentCount.
+ receiverClass := objectMemory fetchClassOf: rcvr.
- receiverClass := self fetchClassOf: rcvr.
self commonSend.!
Item was changed:
----- Method: Interpreter>>temporary: (in category 'contexts') -----
temporary: offset
+ ^ objectMemory fetchPointer: offset + TempFrameStart ofObject: localHomeContext!
- ^ self fetchPointer: offset + TempFrameStart ofObject: localHomeContext!
Item was changed:
----- Method: Interpreter>>transfer:from:to: (in category 'utilities') -----
transfer: count from: src to: dst
| in out lastIn |
<inline: true>
self flag: #Dan. "Need to check all senders before converting this for 64 bits"
+ in := src - objectMemory bytesPerWord.
+ lastIn := in + (count * objectMemory bytesPerWord).
+ out := dst - objectMemory bytesPerWord.
+ [objectMemory oop: in isLessThan: lastIn]
- in := src - self bytesPerWord.
- lastIn := in + (count * self bytesPerWord).
- out := dst - self bytesPerWord.
- [self oop: in isLessThan: lastIn]
whileTrue: [self
+ longAt: (out := out + objectMemory bytesPerWord)
+ put: (self longAt: (in := in + objectMemory bytesPerWord))]!
- longAt: (out := out + self bytesPerWord)
- put: (self longAt: (in := in + self bytesPerWord))]!
Item was changed:
----- Method: Interpreter>>transfer:fromIndex:ofObject:toIndex:ofObject: (in category 'utilities') -----
transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop
"Transfer the specified fullword fields, as from calling context to called context"
"Assume: beRootIfOld: will be called on toOop."
| fromIndex toIndex lastFrom |
<inline: true>
self flag: #Dan. "Need to check all senders before converting this for 64 bits"
+ fromIndex := fromOop + (firstFrom * objectMemory bytesPerWord).
+ toIndex := toOop + (firstTo * objectMemory bytesPerWord).
+ lastFrom := fromIndex + (count * objectMemory bytesPerWord).
+ [objectMemory oop: fromIndex isLessThan: lastFrom]
+ whileTrue: [fromIndex := fromIndex + objectMemory bytesPerWord.
+ toIndex := toIndex + objectMemory bytesPerWord.
- fromIndex := fromOop + (firstFrom * self bytesPerWord).
- toIndex := toOop + (firstTo * self bytesPerWord).
- lastFrom := fromIndex + (count * self bytesPerWord).
- [self oop: fromIndex isLessThan: lastFrom]
- whileTrue: [fromIndex := fromIndex + self bytesPerWord.
- toIndex := toIndex + self bytesPerWord.
self
longAt: toIndex
put: (self longAt: fromIndex)]!
Item was changed:
----- Method: Interpreter>>transferTo: (in category 'process primitive support') -----
transferTo: aProc
"Record a process to be awoken on the next interpreter cycle.
ikp 11/24/1999 06:07 -- added hook for external runtime
compiler "
| sched oldProc newProc |
newProc := aProc.
sched := self schedulerPointer.
+ oldProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
+ objectMemory storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
- oldProc := self fetchPointer: ActiveProcessIndex ofObject: sched.
- self storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
compilerInitialized
ifTrue: [self compilerProcessChange: oldProc to: newProc]
+ ifFalse: [objectMemory storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
+ self newActiveContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: newProc).
+ objectMemory storePointer: SuspendedContextIndex ofObject: newProc withValue: objectMemory nilObj].
- ifFalse: [self storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
- self newActiveContext: (self fetchPointer: SuspendedContextIndex ofObject: newProc).
- self storePointer: SuspendedContextIndex ofObject: newProc withValue: nilObj].
reclaimableContextCount := 0!
Item was changed:
----- Method: Interpreter>>unPop: (in category 'contexts') -----
unPop: nItems
+ stackPointer := stackPointer + (nItems * objectMemory bytesPerWord)!
- stackPointer := stackPointer + (nItems * self bytesPerWord)!
Item was changed:
----- Method: Interpreter>>verifyCleanHeaders (in category 'debug support') -----
verifyCleanHeaders
| oop |
+ oop := objectMemory firstObject.
+ [objectMemory oop: oop isLessThan: objectMemory endOfMemory] whileTrue:
+ [(objectMemory isFreeObject: oop)
- oop := self firstObject.
- [self oop: oop isLessThan: endOfMemory] whileTrue:
- [(self isFreeObject: oop)
ifTrue: ["There should only be one free block at end of memory."
+ (objectMemory objectAfter: oop) = objectMemory endOfMemory
- (self objectAfter: oop) = endOfMemory
ifFalse: [self error: 'Invalid obj with HeaderTypeBits = Free.']]
+ ifFalse: [((self longAt: oop) bitAnd: objectMemory markBit) = 0
- ifFalse: [((self longAt: oop) bitAnd: self markBit) = 0
ifFalse: [self error: 'Invalid obj with MarkBit set.']].
+ oop := objectMemory objectAfter: oop]!
- oop := self objectAfter: oop]!
Item was changed:
----- Method: Interpreter>>wakeHighestPriority (in category 'process primitive support') -----
wakeHighestPriority
"Return the highest priority process that is ready to run."
"Note: It is a fatal VM error if there is no runnable process."
| schedLists p processList |
+ schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ p := objectMemory fetchWordLengthOf: schedLists.
- schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
- p := self fetchWordLengthOf: schedLists.
p := p - 1.
"index of last indexable field"
+ processList := objectMemory fetchPointer: p ofObject: schedLists.
- processList := self fetchPointer: p ofObject: schedLists.
[self isEmptyList: processList]
whileTrue: [p := p - 1.
p < 0 ifTrue: [self error: 'scheduler could not find a runnable process'].
+ processList := objectMemory fetchPointer: p ofObject: schedLists].
- processList := self fetchPointer: p ofObject: schedLists].
^ self removeFirstLinkOfList: processList!
Item was changed:
----- Method: Interpreter>>wordSwapped: (in category 'image save/restore') -----
wordSwapped: w
"Return the given 64-bit integer with its halves in the reverse order."
<inline: true>
self isDefinedTrueExpression: 'BYTES_PER_WORD == 8'
+ inSmalltalk: [objectMemory bytesPerWord = 8]
- inSmalltalk: [self bytesPerWord = 8]
comment: 'swap 32-bit ends of a 64-bit object word'
+ ifTrue: [^ ((w bitShift: objectMemory byte4ShiftNegated) bitAnd: objectMemory bytes3to0Mask)
+ + ((w bitShift: objectMemory byte4Shift) bitAnd: objectMemory bytes7to4Mask)]
- ifTrue: [^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
- + ((w bitShift: Byte4Shift) bitAnd: Bytes7to4Mask)]
ifFalse: [self error: 'This cannot happen.']
!
Item was changed:
----- Method: Interpreter>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: imageBytes
| headerStart headerSize f bytesWritten sCWIfn okToWrite |
<var: #f type: 'sqImageFile'>
<var: #headerStart type: 'squeakFileOffsetType '>
<var: #sCWIfn type: 'void *'>
"If the security plugin can be loaded, use it to check for write permission.
If not, assume it's ok"
sCWIfn := self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
sCWIfn ~= 0 ifTrue:[okToWrite := self cCode: '((sqInt (*)(void))sCWIfn)()'.
okToWrite ifFalse:[^self primitiveFail]].
"local constants"
headerStart := 0.
+ headerSize := 16 * objectMemory bytesPerWord. "header size in bytes; do not change!!"
- headerSize := 16 * self bytesPerWord. "header size in bytes; do not change!!"
f := self cCode: 'sqImageFileOpen(imageName, "wb")'.
f = nil ifTrue: [
"could not open the image file for writing"
self success: false.
^ nil].
headerStart := self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
"position file to start of header"
self sqImageFile: f Seek: headerStart.
self putLong: (self imageFormatVersion) toFile: f.
self putLong: headerSize toFile: f.
self putLong: imageBytes toFile: f.
+ self putLong: (objectMemory startOfMemory) toFile: f.
+ self putLong: objectMemory specialObjectsOop toFile: f.
+ self putLong: objectMemory lastHash toFile: f.
- self putLong: (self startOfMemory) toFile: f.
- self putLong: specialObjectsOop toFile: f.
- self putLong: lastHash toFile: f.
self putLong: (self ioScreenSize) toFile: f.
self putLong: fullScreenFlag toFile: f.
self putLong: extraVMMemory toFile: f.
1 to: 7 do: [:i | self putLong: 0 toFile: f]. "fill remaining header words with zeros"
self successful ifFalse: [
"file write or seek failure"
self cCode: 'sqImageFileClose(f)'.
^ nil].
"position file after the header"
self sqImageFile: f Seek: headerStart + headerSize.
"write the image data"
bytesWritten := self
+ sqImage: (self pointerForOop: objectMemory memory)
- sqImage: (self pointerForOop: memory)
write: f
size: (self cCode: 'sizeof(unsigned char)')
length: imageBytes.
self success: bytesWritten = imageBytes.
self cCode: 'sqImageFileClose(f)'.
!
Item was changed:
+ VMClass subclass: #InterpreterPlugin
- Object subclass: #InterpreterPlugin
instanceVariableNames: 'interpreterProxy moduleName'
classVariableNames: ''
+ poolDictionaries: ''
- poolDictionaries: 'VMBasicConstants'
category: 'VMMaker-Plugins'!
InterpreterPlugin class
instanceVariableNames: 'timeStamp'!
!InterpreterPlugin commentStamp: 'tpr 5/5/2003 11:43' prior: 0!
This class provides the basic framework for creating VM plugins. Most of the useful methods are on the class side; particularly take note of the messages like #shouldBeTranslated and #requiresPlatformFiles.!
InterpreterPlugin class
instanceVariableNames: 'timeStamp'!
Item was removed:
- ----- Method: InterpreterPlugin 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.
- VMMaker addMemoryAccessTo: cg.
- ^cg
- !
Item was removed:
- ----- Method: InterpreterPlugin class>>timeStamp (in category 'accessing') -----
- timeStamp
- ^timeStamp ifNil:[0]!
Item was changed:
+ VMClass subclass: #InterpreterPrimitives
+ instanceVariableNames: 'objectMemory primFailCode argumentCount interruptKeycode newMethod'
- ObjectMemory subclass: #InterpreterPrimitives
- instanceVariableNames: 'primFailCode argumentCount interruptKeycode newMethod'
classVariableNames: 'CrossedX EndOfRun InterpreterSourceVersion MillisecondClockMask'
+ poolDictionaries: 'VMObjectIndices VMSqueakV3ObjectRepresentationConstants'
- poolDictionaries: ''
category: 'VMMaker-Interpreter'!
!InterpreterPrimitives commentStamp: 'dtl 5/17/2011 07:49' prior: 0!
InterpreterPrimitives implements most of the VM's core primitives. It is the root of the interpreter hierarchy so as to share the core primitives amongst the various interpreters.!
Item was changed:
----- Method: InterpreterPrimitives>>copyObj:toSegment:addr:stopAt:saveOopAt:headerAt: (in category 'image segment in/out') -----
copyObj: oop toSegment: segmentWordArray addr: lastSeg stopAt: stopAddr saveOopAt: oopPtr headerAt: hdrPtr
"Copy this object into the segment beginning at lastSeg.
Install a forwarding pointer, and save oop and header.
Fail if out of space. Return the next segmentAddr if successful."
"Copy the object..."
| extraSize bodySize hdrAddr |
self flag: #Dan. "None of the imageSegment stuff has been updated for 64 bits"
self successful ifFalse: [^ lastSeg].
+ extraSize := objectMemory extraHeaderBytes: oop.
+ bodySize := objectMemory sizeBitsOf: oop.
+ (objectMemory oop: (lastSeg + extraSize + bodySize) isGreaterThanOrEqualTo: stopAddr)
- extraSize := self extraHeaderBytes: oop.
- bodySize := self sizeBitsOf: oop.
- (self oop: (lastSeg + extraSize + bodySize) isGreaterThanOrEqualTo: stopAddr)
ifTrue: [^ self primitiveFail].
+ self transfer: extraSize + bodySize // objectMemory bytesPerWord "wordCount"
- self transfer: extraSize + bodySize // self bytesPerWord "wordCount"
from: oop - extraSize
+ to: lastSeg + objectMemory bytesPerWord.
- to: lastSeg + self bytesPerWord.
"Clear root and mark bits of all headers copied into the segment"
+ hdrAddr := lastSeg + objectMemory bytesPerWord + extraSize.
+ self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: objectMemory allButRootBit - objectMemory markBit).
- hdrAddr := lastSeg + self bytesPerWord + extraSize.
- self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: self allButRootBit - self markBit).
+ objectMemory forward: oop to: (lastSeg + objectMemory bytesPerWord + extraSize - segmentWordArray)
- self forward: oop to: (lastSeg + self bytesPerWord + extraSize - segmentWordArray)
savingOopAt: oopPtr andHeaderAt: hdrPtr.
"Return new end of segment"
^ lastSeg + extraSize + bodySize!
Item was changed:
----- Method: InterpreterPrimitives>>positive32BitValueOf: (in category 'primitive support') -----
positive32BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a four-byte LargePositiveInteger."
| sz value |
+ (objectMemory isIntegerObject: oop) ifTrue: [
+ value := objectMemory integerValueOf: oop.
- (self isIntegerObject: oop) ifTrue: [
- value := self integerValueOf: oop.
value < 0 ifTrue: [^ self primitiveFail].
^ value].
+ self assertClassOf: oop is: (objectMemory splObj: ClassLargePositiveInteger).
- self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger).
self successful ifTrue: [
sz := self lengthOf: oop.
sz = 4 ifFalse: [^ self primitiveFail]].
self successful ifTrue: [
+ ^ (objectMemory fetchByte: 0 ofObject: oop) +
+ ((objectMemory fetchByte: 1 ofObject: oop) << 8) +
+ ((objectMemory fetchByte: 2 ofObject: oop) << 16) +
+ ((objectMemory fetchByte: 3 ofObject: oop) << 24) ].!
- ^ (self fetchByte: 0 ofObject: oop) +
- ((self fetchByte: 1 ofObject: oop) << 8) +
- ((self fetchByte: 2 ofObject: oop) << 16) +
- ((self fetchByte: 3 ofObject: oop) << 24) ].!
Item was changed:
----- Method: InterpreterPrimitives>>positive64BitValueOf: (in category 'primitive support') -----
positive64BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a eight-byte LargePositiveInteger."
| sz szsqLong value |
<returnTypeC: 'sqLong'>
<var: 'value' type: 'sqLong'>
+ (objectMemory isIntegerObject: oop) ifTrue: [
+ value := objectMemory integerValueOf: oop.
- (self isIntegerObject: oop) ifTrue: [
- value := self integerValueOf: oop.
value < 0 ifTrue: [^ self primitiveFail].
^ value].
+ self assertClassOf: oop is: (objectMemory splObj: ClassLargePositiveInteger).
- self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger).
self successful ifFalse: [^ self primitiveFail].
szsqLong := self cCode: 'sizeof(sqLong)'.
sz := self lengthOf: oop.
sz > szsqLong
ifTrue: [^ self primitiveFail].
value := 0.
0 to: sz - 1 do: [:i |
+ value := value + ((self cCoerce: (objectMemory fetchByte: i ofObject: oop) to: 'sqLong') << (i*8))].
- value := value + ((self cCoerce: (self fetchByte: i ofObject: oop) to: 'sqLong') << (i*8))].
^value.!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveArrayBecome (in category 'object access primitives') -----
primitiveArrayBecome
"We must flush the method cache here, to eliminate stale references
to mutated classes and/or selectors."
| arg rcvr |
arg := self stackTop.
rcvr := self stackValue: 1.
+ self success: (objectMemory become: rcvr with: arg twoWay: true copyHash: true).
- self success: (self become: rcvr with: arg twoWay: true copyHash: true).
self successful ifTrue: [ self pop: 1 ].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveArrayBecomeOneWay (in category 'object access primitives') -----
primitiveArrayBecomeOneWay
"We must flush the method cache here, to eliminate stale references
to mutated classes and/or selectors."
| arg rcvr |
arg := self stackTop.
rcvr := self stackValue: 1.
+ self success: (objectMemory become: rcvr with: arg twoWay: false copyHash: true).
- self success: (self become: rcvr with: arg twoWay: false copyHash: true).
self successful ifTrue: [ self pop: 1 ].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveArrayBecomeOneWayCopyHash (in category 'object access primitives') -----
primitiveArrayBecomeOneWayCopyHash
"Similar to primitiveArrayBecomeOneWay but accepts a third argument whether to copy
the receiver's identity hash over the argument's identity hash."
| copyHashFlag arg rcvr |
copyHashFlag := self booleanValueOf: (self stackTop).
arg := self stackValue: 1.
rcvr := self stackValue: 2.
+ self success: (objectMemory become: rcvr with: arg twoWay: false copyHash: copyHashFlag).
- self success: (self become: rcvr with: arg twoWay: false copyHash: copyHashFlag).
self successful ifTrue: [ self pop: 2 ].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveBeCursor (in category 'I/O primitives') -----
primitiveBeCursor
"Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."
| cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |
self flag: #Dan. "This is disabled until we convert bitmaps appropriately"
+ objectMemory bytesPerWord = 8 ifTrue: [^ self pop: argumentCount].
- self bytesPerWord = 8 ifTrue: [^ self pop: argumentCount].
argumentCount = 0 ifTrue: [
cursorObj := self stackTop.
maskBitsIndex := nil].
argumentCount = 1 ifTrue: [
cursorObj := self stackValue: 1.
maskObj := self stackTop].
self success: (argumentCount < 2).
+ self success: ((objectMemory isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
- self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
self successful ifTrue: [
+ bitsObj := objectMemory fetchPointer: 0 ofObject: cursorObj.
- bitsObj := self fetchPointer: 0 ofObject: cursorObj.
extentX := self fetchInteger: 1 ofObject: cursorObj.
extentY := self fetchInteger: 2 ofObject: cursorObj.
depth := self fetchInteger: 3 ofObject: cursorObj.
+ offsetObj := objectMemory fetchPointer: 4 ofObject: cursorObj].
+ self success: ((objectMemory isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).
- offsetObj := self fetchPointer: 4 ofObject: cursorObj].
- self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).
self successful ifTrue: [
offsetX := self fetchInteger: 0 ofObject: offsetObj.
offsetY := self fetchInteger: 1 ofObject: offsetObj.
(argumentCount = 0 and: [depth = 32])
ifTrue: [
"Support arbitrary-sized 32 bit ARGB forms --bf 3/1/2007 23:51"
self success: ((extentX > 0) and: [extentY > 0]).
self success: ((offsetX >= (extentX * -1)) and: [offsetX <= 0]).
self success: ((offsetY >= (extentY * -1)) and: [offsetY <= 0]).
+ cursorBitsIndex := bitsObj + objectMemory baseHeaderSize.
+ self success: ((objectMemory isWords: bitsObj) and: [(self lengthOf: bitsObj) = (extentX * extentY)]).
- cursorBitsIndex := bitsObj + self baseHeaderSize.
- self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = (extentX * extentY)]).
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
depth: 32
fromArray: ((1 to: extentX * extentY) collect: [:i |
+ objectMemory fetchLong32: i-1 ofObject: bitsObj])
- self fetchLong32: i-1 ofObject: bitsObj])
offset: offsetX @ offsetY]]
ifFalse: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
self success: ((offsetX >= -16) and: [offsetX <= 0]).
self success: ((offsetY >= -16) and: [offsetY <= 0]).
+ self success: ((objectMemory isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
+ cursorBitsIndex := bitsObj + objectMemory baseHeaderSize.
- self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
- cursorBitsIndex := bitsObj + self baseHeaderSize.
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
fromArray: ((1 to: 16) collect: [:i |
+ ((objectMemory fetchLong32: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF])
- ((self fetchLong32: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF])
offset: offsetX @ offsetY]]].
argumentCount = 1 ifTrue: [
+ self success: ((objectMemory isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
- self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
self successful ifTrue: [
+ bitsObj := objectMemory fetchPointer: 0 ofObject: maskObj.
- bitsObj := self fetchPointer: 0 ofObject: maskObj.
extentX := self fetchInteger: 1 ofObject: maskObj.
extentY := self fetchInteger: 2 ofObject: maskObj.
depth := self fetchInteger: 3 ofObject: maskObj].
self successful ifTrue: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
+ self success: ((objectMemory isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
+ maskBitsIndex := bitsObj + objectMemory baseHeaderSize]].
- self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
- maskBitsIndex := bitsObj + self baseHeaderSize]].
self successful ifTrue: [
argumentCount = 0
ifTrue: [
depth = 32
ifTrue: [(self cCode: 'ioSetCursorARGB(cursorBitsIndex, extentX, extentY, offsetX, offsetY)'
inSmalltalk: [ourCursor show. Cursor currentCursor == ourCursor])
ifFalse: [^self success: false]]
ifFalse: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
inSmalltalk: [ourCursor show]]]
ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
inSmalltalk: [cursorBitsIndex == maskBitsIndex. "placate compiler"
ourCursor show]].
self pop: argumentCount]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveBeDisplay (in category 'I/O primitives') -----
primitiveBeDisplay
"Record the system Display object in the specialObjectsTable."
| rcvr |
rcvr := self stackTop.
+ self success: ((objectMemory isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
+ self successful ifTrue: [objectMemory storePointer: TheDisplay ofObject: objectMemory specialObjectsOop withValue: rcvr]!
- self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
- self successful ifTrue: [self storePointer: TheDisplay ofObject: specialObjectsOop withValue: rcvr]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveBytesLeft (in category 'memory space primitives') -----
primitiveBytesLeft
"Reports bytes available at this moment. For more meaningful
results, calls to this primitive should be preceeded by a full
or incremental garbage collection."
| aBool |
self methodArgumentCount = 0
ifTrue: ["old behavior - just return the size of the free block"
+ ^self pop: 1 thenPush: (self positive64BitIntegerFor: (objectMemory sizeOfFree: objectMemory freeBlock))].
- ^self pop: 1 thenPush: (self positive64BitIntegerFor: (self sizeOfFree: freeBlock))].
self methodArgumentCount = 1
ifTrue: ["new behaviour -including or excluding swap space depending on aBool"
aBool := self booleanValueOf: self stackTop.
self successful ifFalse: [^ nil].
+ ^self pop: 2 thenPush: (self positive64BitIntegerFor: (objectMemory bytesLeft: aBool))].
- ^self pop: 2 thenPush: (self positive64BitIntegerFor: (self bytesLeft: aBool))].
^ self primitiveFail!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveChangeClass (in category 'object access primitives') -----
primitiveChangeClass
"Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have."
| arg rcvr argClass |
self methodArgumentCount = 1 ifFalse: [self primitiveFail. ^ nil].
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
+ argClass := objectMemory fetchClassOf: arg.
- argClass := self fetchClassOf: arg.
self changeClassOf: rcvr to: argClass.
self successful ifTrue: [ self pop: 1 ].
^ nil.
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveClass (in category 'object access primitives') -----
primitiveClass
| instance |
instance := self stackTop.
+ self pop: argumentCount+1 thenPush: (objectMemory fetchClassOf: instance)!
- self pop: argumentCount+1 thenPush: (self fetchClassOf: instance)!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveClipboardText (in category 'I/O primitives') -----
primitiveClipboardText
"When called with a single string argument, post the string to
the clipboard. When called with zero arguments, return a
string containing the current clipboard contents."
| s sz |
argumentCount = 1
ifTrue: [s := self stackTop.
+ (objectMemory isBytes: s) ifFalse: [^ self primitiveFail].
- (self isBytes: s) ifFalse: [^ self primitiveFail].
self successful
ifTrue: [sz := self stSizeOf: s.
+ self clipboardWrite: sz From: s + objectMemory baseHeaderSize At: 0.
- self clipboardWrite: sz From: s + self baseHeaderSize At: 0.
self pop: 1]]
ifFalse: [sz := self clipboardSize.
+ (objectMemory sufficientSpaceToAllocate: sz) ifFalse:[^self primitiveFail].
+ s := objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: sz.
+ self clipboardRead: sz Into: s + objectMemory baseHeaderSize At: 0.
- (self sufficientSpaceToAllocate: sz) ifFalse:[^self primitiveFail].
- s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
- self clipboardRead: sz Into: s + self baseHeaderSize At: 0.
self pop: 1 thenPush: s]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveClone (in category 'object access primitives') -----
primitiveClone
"Return a shallow copy of the receiver."
| newCopy |
+ newCopy := objectMemory clone: (self stackTop).
- newCopy := self clone: (self stackTop).
newCopy = 0
ifTrue:["not enough memory most likely" ^self primitiveFail].
self pop: 1 thenPush: newCopy.!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveConstantFill (in category 'indexing primitives') -----
primitiveConstantFill
"Fill the receiver, which must be an indexable bytes or words
objects, with the given integer value."
| fillValue rcvr rcvrIsBytes end i |
<var: #end type: 'usqInt'>
<var: #i type: 'usqInt'>
fillValue := self positive32BitValueOf: self stackTop.
rcvr := self stackValue: 1.
+ self success: (objectMemory isWordsOrBytes: rcvr).
+ rcvrIsBytes := objectMemory isBytes: rcvr.
- self success: (self isWordsOrBytes: rcvr).
- rcvrIsBytes := self isBytes: rcvr.
rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])].
self successful
+ ifTrue: [end := rcvr + (objectMemory sizeBitsOf: rcvr).
+ i := rcvr + objectMemory baseHeaderSize.
- ifTrue: [end := rcvr + (self sizeBitsOf: rcvr).
- i := rcvr + self baseHeaderSize.
rcvrIsBytes
ifTrue: [[i < end]
whileTrue: [self byteAt: i put: fillValue.
i := i + 1]]
ifFalse: [[i < end]
whileTrue: [self long32At: i put: fillValue.
i := i + 4]].
self pop: 1]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveCopyObject (in category 'object access primitives') -----
primitiveCopyObject
"Primitive. Copy the state of the receiver from the argument.
Fail if receiver and argument are of a different class.
Fail if the receiver or argument are non-pointer objects.
Fail if receiver and argument have different lengths (for indexable objects).
"
| rcvr arg length |
self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self failed ifTrue:[^nil].
+ (objectMemory isPointers: rcvr) ifFalse:[^self primitiveFail].
+ (objectMemory fetchClassOf: rcvr) = (objectMemory fetchClassOf: arg) ifFalse:[^self primitiveFail].
- (self isPointers: rcvr) ifFalse:[^self primitiveFail].
- (self fetchClassOf: rcvr) = (self fetchClassOf: arg) ifFalse:[^self primitiveFail].
length := self lengthOf: rcvr.
length = (self lengthOf: arg) ifFalse:[^self primitiveFail].
"Now copy the elements"
0 to: length-1 do:[:i|
+ objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)].
- self storePointer: i ofObject: rcvr withValue: (self fetchPointer: i ofObject: arg)].
"Note: The above could be faster for young receivers but I don't think it'll matter"
self pop: 1. "pop arg; answer receiver"
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveFailAfterCleanup: (in category 'image segment in/out') -----
primitiveFailAfterCleanup: outPointerArray
"If the storeSegment primitive fails, it must clean up first."
| i lastAddr | "Store nils throughout the outPointer array."
+ lastAddr := outPointerArray + (objectMemory lastPointerOf: outPointerArray).
+ i := outPointerArray + objectMemory baseHeaderSize.
- lastAddr := outPointerArray + (self lastPointerOf: outPointerArray).
- i := outPointerArray + self baseHeaderSize.
[i <= lastAddr] whileTrue:
+ [self longAt: i put: objectMemory nilObj.
+ i := i + objectMemory bytesPerWord].
- [self longAt: i put: nilObj.
- i := i + self bytesPerWord].
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
self primitiveFail!
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"
| thisCntx nilOop |
thisCntx := self popStack.
+ nilOop := objectMemory nilObj.
- nilOop := nilObj.
[(self isHandlerMarked: thisCntx) ifTrue:[
self push: thisCntx.
^nil].
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- thisCntx := self fetchPointer: SenderIndex ofObject: thisCntx.
thisCntx = nilOop] whileFalse.
+ ^self push: objectMemory nilObj!
- ^self push: nilObj!
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."
| thisCntx nilOop aContext unwindMarked |
aContext := self popStack.
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: self popStack.
+ nilOop := objectMemory nilObj.
- thisCntx := self fetchPointer: SenderIndex ofObject: self popStack.
- nilOop := nilObj.
[(thisCntx = aContext) or: [thisCntx = nilOop]] whileFalse: [
unwindMarked := self isUnwindMarked: thisCntx.
unwindMarked ifTrue:[
self push: thisCntx.
^nil].
+ thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx].
- thisCntx := self fetchPointer: SenderIndex ofObject: thisCntx].
^self push: nilOop!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveForceTenure (in category 'I/O primitives') -----
primitiveForceTenure
"Set force tenure flag to true, this forces a tenure operation on the next incremental GC"
<export: true>
+ objectMemory forceTenureFlag: 1!
- forceTenureFlag := 1!
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: [(self lengthOf: rcvr) >= 4])
- ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
ifFalse: [self success: false]].
self successful ifTrue: [
+ bitsArray := objectMemory fetchPointer: 0 ofObject: rcvr.
- bitsArray := self 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])
- ((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
ifTrue: [
bitsArraySize := self byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
self successful ifTrue: [
+ objectMemory bytesPerWord = 8
- self 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 changed:
----- Method: InterpreterPrimitives>>primitiveFullGC (in category 'memory space primitives') -----
primitiveFullGC
"Do a full garbage collection and return the number of bytes available (including swap space if dynamic memory management is supported)."
self pop: 1.
+ objectMemory incrementalGC. "maximimize space for forwarding table"
+ objectMemory fullGC.
+ self push: (self positive64BitIntegerFor: (objectMemory bytesLeft: true))
- self incrementalGC. "maximimize space for forwarding table"
- self fullGC.
- self push: (self positive64BitIntegerFor: (self bytesLeft: true))
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveGetAttribute (in category 'system control primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The
result is a string, which will be empty if the attribute is not
defined."
| attr sz s |
attr := self stackIntegerValue: 0.
self successful
ifTrue: [sz := self attributeSize: attr].
self successful
+ ifTrue: [s := objectMemory
+ instantiateClass: (objectMemory splObj: ClassString)
- ifTrue: [s := self
- instantiateClass: (self splObj: ClassString)
indexableSize: sz.
self
getAttribute: attr
+ Into: s + objectMemory baseHeaderSize
- Into: s + self baseHeaderSize
Length: sz.
self pop: 2 thenPush: s]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveGetNextEvent (in category 'I/O primitives') -----
primitiveGetNextEvent
"Primitive. Return the next input event from the VM event queue."
| evtBuf arg value eventTypeIs |
<var: #evtBuf declareC: 'int evtBuf[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }'>
self cCode:'' inSmalltalk:[evtBuf := CArrayAccessor on: (IntegerArray new: 8)].
arg := self stackTop.
+ ((objectMemory isArray: arg) and:[(self slotSizeOf: arg) = 8]) ifFalse:[^self primitiveFail].
- ((self isArray: arg) and:[(self slotSizeOf: arg) = 8]) ifFalse:[^self primitiveFail].
self ioGetNextEvent: (self cCoerce: evtBuf to: 'sqInputEvent*').
self successful ifFalse:[^nil].
"Event type"
eventTypeIs := evtBuf at: 0.
self storeInteger: 0 ofObject: arg withValue: (evtBuf at: 0).
self successful ifFalse:[^nil].
"Event is Complex, assume evtBuf is populated correctly and return"
eventTypeIs = 6 ifTrue:
[1 to: 7 do: [:i |
value := evtBuf at: i.
+ objectMemory storePointer: i ofObject: arg withValue: value]]
- self storePointer: i ofObject: arg withValue: value]]
ifFalse: [
"Event time stamp"
self storeInteger: 1 ofObject: arg withValue: ((evtBuf at: 1) bitAnd: MillisecondClockMask).
self successful ifFalse:[^nil].
"Event arguments"
2 to: 7 do:[:i|
value := evtBuf at: i.
+ (objectMemory isIntegerValue: value)
- (self isIntegerValue: value)
ifTrue:[self storeInteger: i ofObject: arg withValue: value]
ifFalse:["Need to remap because allocation may cause GC"
+ objectMemory pushRemappableOop: arg.
- self pushRemappableOop: arg.
value := self positive32BitIntegerFor: value.
+ arg := objectMemory popRemappableOop.
+ objectMemory storePointer: i ofObject: arg withValue: value]]].
- arg := self popRemappableOop.
- self storePointer: i ofObject: arg withValue: value]]].
self successful ifFalse:[^nil].
self pop: 1.!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveIdentityHash (in category 'object access primitives') -----
primitiveIdentityHash
| thisReceiver |
thisReceiver := self stackTop.
+ (objectMemory isIntegerObject: thisReceiver)
- (self isIntegerObject: thisReceiver)
ifTrue: [self primitiveFail]
+ ifFalse: [self pop:1 thenPushInteger: (objectMemory hashBitsOf: thisReceiver)]!
- ifFalse: [self pop:1 thenPushInteger: (self hashBitsOf: thisReceiver)]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveImageName (in category 'other primitives') -----
primitiveImageName
"When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."
| s sz sCRIfn okToRename |
<var: #sCRIfn type: 'void *'>
argumentCount = 1 ifTrue: [
"If the security plugin can be loaded, use it to check for rename permission.
If not, assume it's ok"
sCRIfn := self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'.
sCRIfn ~= 0 ifTrue:[okToRename := self cCode:' ((sqInt (*)(void))sCRIfn)()'.
okToRename ifFalse:[^self primitiveFail]].
s := self stackTop.
+ self assertClassOf: s is: (objectMemory splObj: ClassString).
- self assertClassOf: s is: (self splObj: ClassString).
self successful ifTrue: [
sz := self stSizeOf: s.
+ self imageNamePut: (s + objectMemory baseHeaderSize) Length: sz.
- self imageNamePut: (s + self baseHeaderSize) Length: sz.
self pop: 1. "pop s, leave rcvr on stack"
].
] ifFalse: [
sz := self imageNameSize.
+ s := objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: sz.
+ self imageNameGet: (s + objectMemory baseHeaderSize) Length: sz.
- s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
- self imageNameGet: (s + self baseHeaderSize) Length: sz.
self pop: 1. "rcvr"
self push: s.
].
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveIncrementalGC (in category 'memory space primitives') -----
primitiveIncrementalGC
"Do a quick, incremental garbage collection and return the number of bytes immediately available. (Note: more space may be made available by doing a full garbage collection."
self pop: 1.
+ objectMemory incrementalGC.
- self incrementalGC.
self push: (self positive64BitIntegerFor: (self bytesLeft: false))
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveInputSemaphore (in category 'I/O primitives') -----
primitiveInputSemaphore
"Register the input semaphore. The argument is an index into the ExternalObjectsArray part of the specialObjectsArray and must have been allocated via 'Smalltalk registerExternalObject: the Semaphore' "
| arg |
arg := self stackTop.
+ (objectMemory isIntegerObject: arg)
- (self isIntegerObject: arg)
ifTrue: ["If arg is integer, then condsider it as an index into the external objects array and install it as the new event semaphore"
+ self ioSetInputSemaphore: (objectMemory integerValueOf: arg).
- self ioSetInputSemaphore: (self integerValueOf: arg).
self successful
ifTrue: [self pop: 1].
^ nil]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveInstVarAt (in category 'object access primitives') -----
primitiveInstVarAt
| index rcvr hdr fmt totalLength fixedFields value |
index := self stackIntegerValue: 0.
rcvr := self stackValue: 1.
self successful
+ ifTrue: [hdr := objectMemory baseHeader: rcvr.
- ifTrue: [hdr := self baseHeader: rcvr.
fmt := hdr >> 8 bitAnd: 15.
totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: rcvr format: fmt length: totalLength.
(index >= 1 and: [index <= fixedFields])
ifFalse: [self primitiveFail]].
self successful ifTrue: [value := self subscript: rcvr with: index format: fmt].
self successful ifTrue: [self pop: argumentCount + 1 thenPush: value]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveInstVarAtPut (in category 'object access primitives') -----
primitiveInstVarAtPut
| newValue index rcvr hdr fmt totalLength fixedFields |
newValue := self stackTop.
index := self stackIntegerValue: 1.
rcvr := self stackValue: 2.
self successful
+ ifTrue: [hdr := objectMemory baseHeader: rcvr.
- ifTrue: [hdr := self baseHeader: rcvr.
fmt := hdr >> 8 bitAnd: 15.
totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: rcvr format: fmt length: totalLength.
(index >= 1 and: [index <= fixedFields]) ifFalse: [self primitiveFail]].
self successful ifTrue: [self subscript: rcvr with: index storing: newValue format: fmt].
self successful ifTrue: [self pop: argumentCount + 1 thenPush: newValue]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveIntegerAt (in category 'indexing primitives') -----
primitiveIntegerAt
"Return the 32bit signed integer contents of a words receiver"
| index rcvr sz addr value intValue |
<var: #intValue type: 'int'>
index := self stackIntegerValue: 0.
rcvr := self stackValue: 1.
+ (objectMemory isIntegerObject: rcvr) ifTrue: [^self success: false].
+ (objectMemory isWords: rcvr) ifFalse: [^self success: false].
- (self isIntegerObject: rcvr) ifTrue: [^self success: false].
- (self isWords: rcvr) ifFalse: [^self success: false].
sz := self lengthOf: rcvr. "number of fields"
self success: ((index >= 1) and: [index <= sz]).
self successful ifTrue: [
+ addr := rcvr + objectMemory baseHeaderSize - 4 "for zero indexing" + (index * 4).
- addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4).
value := self intAt: addr.
self pop: 2. "pop rcvr, index"
"push element value"
+ (objectMemory isIntegerValue: value)
- (self isIntegerValue: value)
ifTrue: [self pushInteger: value]
ifFalse: [
intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt"
self push: (self signed32BitIntegerFor: intValue)]. "intValue may be sign extended to 64 bit sqInt"
].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveIntegerAtPut (in category 'indexing primitives') -----
primitiveIntegerAtPut
"Return the 32bit signed integer contents of a words receiver"
| index rcvr sz addr value valueOop |
valueOop := self stackValue: 0.
index := self stackIntegerValue: 1.
rcvr := self stackValue: 2.
+ (objectMemory isIntegerObject: rcvr) ifTrue:[^self success: false].
+ (objectMemory isWords: rcvr) ifFalse:[^self success: false].
- (self isIntegerObject: rcvr) ifTrue:[^self success: false].
- (self isWords: rcvr) ifFalse:[^self success: false].
sz := self lengthOf: rcvr. "number of fields"
((index >= 1) and: [index <= sz]) ifFalse:[^self success: false].
+ (objectMemory isIntegerObject: valueOop)
+ ifTrue:[value := objectMemory integerValueOf: valueOop]
- (self isIntegerObject: valueOop)
- ifTrue:[value := self integerValueOf: valueOop]
ifFalse:[value := self signed32BitValueOf: valueOop].
self successful ifTrue:[
+ addr := rcvr + objectMemory baseHeaderSize - 4 "for zero indexing" + (index * 4).
- addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4).
value := self intAt: addr put: value.
self pop: 3 thenPush: valueOop. "pop all; return value"
].
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveInterpreterSourceVersion (in category 'other primitives') -----
primitiveInterpreterSourceVersion
"Answer a string corresponding to the version of the interpreter source. This
represents the version level of the Smalltalk source code (interpreter and various
plugins) that is translated to C by a CCodeGenerator, as distinct from the external
platform source code, typically written in C and managed separately for each platform.
This is a named (not numbered) primitive in the null module (ie the VM)"
| len versionString p cString |
<export: true>
<var: #p type: 'char *'>
<var: #cString type: 'char *'>
cString := InterpreterSourceVersion.
len := self cCode: 'strlen(cString)' inSmalltalk: [0].
+ versionString := objectMemory instantiateClass: objectMemory classString indexableSize: len.
- versionString := self instantiateClass: self classString indexableSize: len.
p := self arrayValueOf: versionString.
self cCode: 'strncpy(p, cString, len)'.
self pop: 1 thenPush: versionString
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveInterruptSemaphore (in category 'I/O primitives') -----
primitiveInterruptSemaphore
"Register the user interrupt semaphore. If the argument is
not a Semaphore, unregister the current interrupt
semaphore. "
| arg |
arg := self popStack.
+ (objectMemory fetchClassOf: arg) = (objectMemory splObj: ClassSemaphore)
+ ifTrue: [objectMemory storePointer: TheInterruptSemaphore ofObject: objectMemory specialObjectsOop withValue: arg]
+ ifFalse: [objectMemory storePointer: TheInterruptSemaphore ofObject: objectMemory specialObjectsOop withValue: objectMemory nilObj]!
- (self fetchClassOf: arg) = (self splObj: ClassSemaphore)
- ifTrue: [self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: arg]
- ifFalse: [self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: nilObj]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveIsRoot (in category 'memory space primitives') -----
primitiveIsRoot
"Primitive. Answer whether the argument to the primitive is a root for young space"
| oop |
<export: true>
oop := self stackObjectValue: 0.
self successful ifTrue:[
self pop: argumentCount + 1.
+ self pushBool: ((objectMemory baseHeader: oop) bitAnd: objectMemory rootBit).
- self pushBool: ((self baseHeader: oop) bitAnd: self rootBit).
].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveIsYoung (in category 'memory space primitives') -----
primitiveIsYoung
"Primitive. Answer whether the argument to the primitive resides in young space."
| oop |
<export: true>
oop := self stackObjectValue: 0.
self successful ifTrue:[
self pop: argumentCount + 1.
+ self pushBool: (objectMemory oop: oop isGreaterThanOrEqualTo: objectMemory youngStart).
- self pushBool: (self oop: oop isGreaterThanOrEqualTo: youngStart).
].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveKbdNext (in category 'I/O primitives') -----
primitiveKbdNext
"Obsolete on virtually all platforms; old style input polling code.
Return the next keycode and remove it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."
| keystrokeWord |
self pop: 1.
keystrokeWord := self ioGetKeystroke.
keystrokeWord >= 0
ifTrue: [self pushInteger: keystrokeWord]
+ ifFalse: [self push: objectMemory nilObj].!
- ifFalse: [self push: nilObj].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveKbdPeek (in category 'I/O primitives') -----
primitiveKbdPeek
"Obsolete on virtually all platforms; old style input polling code.
Return the next keycode and without removing it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."
| keystrokeWord |
self pop: 1.
keystrokeWord := self ioPeekKeystroke.
keystrokeWord >= 0
ifTrue: [self pushInteger: keystrokeWord]
+ ifFalse: [self push: objectMemory nilObj].!
- ifFalse: [self push: nilObj].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveListBuiltinModule (in category 'plugin primitives') -----
primitiveListBuiltinModule
"Primitive. Return the n-th builtin module name."
| moduleName index length nameOop |
<var: #moduleName type: 'char *'>
self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
index := self stackIntegerValue: 0.
index <= 0 ifTrue:[^self primitiveFail].
moduleName := self ioListBuiltinModule: index.
moduleName == nil ifTrue:[
self pop: 2. "arg+rcvr"
+ ^self push: objectMemory nilObject].
- ^self push: self nilObject].
length := self strlen: moduleName.
+ nameOop := objectMemory instantiateClass: objectMemory classString indexableSize: length.
- nameOop := self instantiateClass: self classString indexableSize: length.
0 to: length-1 do:[:i|
+ objectMemory storeByte: i ofObject: nameOop withValue: (moduleName at: i)].
- self storeByte: i ofObject: nameOop withValue: (moduleName at: i)].
self forceInterruptCheck.
self pop: 2 thenPush: nameOop!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveListExternalModule (in category 'plugin primitives') -----
primitiveListExternalModule
"Primitive. Return the n-th loaded external module name."
| moduleName index length nameOop |
<var: #moduleName type: 'char *'>
self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
index := self stackIntegerValue: 0.
index <= 0 ifTrue:[^self primitiveFail].
moduleName := self ioListLoadedModule: index.
moduleName == nil ifTrue:[
self pop: 2. "arg+rcvr"
+ ^self push: objectMemory nilObject].
- ^self push: self nilObject].
length := self strlen: moduleName.
+ nameOop := objectMemory instantiateClass: objectMemory classString indexableSize: length.
- nameOop := self instantiateClass: self classString indexableSize: length.
0 to: length-1 do:[:i|
+ objectMemory storeByte: i ofObject: nameOop withValue: (moduleName at: i)].
- self storeByte: i ofObject: nameOop withValue: (moduleName at: i)].
self forceInterruptCheck.
self pop: 2 thenPush: nameOop!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveLoadImageSegment (in category 'image segment in/out') -----
primitiveLoadImageSegment
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
"This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
| outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
<var: #endSeg type: 'usqInt'>
<var: #segOop type: 'usqInt'>
<var: #fieldPtr type: 'usqInt'>
<var: #lastOut type: 'usqInt'>
<var: #outPtr type: 'usqInt'>
<var: #lastPtr type: 'usqInt'>
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
outPointerArray := self stackTop.
+ lastOut := outPointerArray + (objectMemory lastPointerOf: outPointerArray).
- lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
segmentWordArray := self stackValue: 1.
+ endSeg := segmentWordArray + (objectMemory sizeBitsOf: segmentWordArray) - objectMemory baseHeaderSize.
- endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self baseHeaderSize.
"Essential type checks"
+ ((objectMemory formatOf: outPointerArray) = 2 "Must be indexable pointers"
+ and: [(objectMemory formatOf: segmentWordArray) = 6]) "Must be indexable words"
- ((self formatOf: outPointerArray) = 2 "Must be indexable pointers"
- and: [(self formatOf: segmentWordArray) = 6]) "Must be indexable words"
ifFalse: [^ self primitiveFail].
"Version check. Byte order of the WordArray now"
+ data := self longAt: segmentWordArray + objectMemory baseHeaderSize.
- data := self longAt: segmentWordArray + self baseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
"Not readable -- try again with reversed bytes..."
+ objectMemory reverseBytesFrom: segmentWordArray + objectMemory baseHeaderSize to: endSeg + objectMemory bytesPerWord.
+ data := self longAt: segmentWordArray + objectMemory baseHeaderSize.
- self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self bytesPerWord.
- data := self longAt: segmentWordArray + self baseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
"Still NG -- put things back and fail"
+ objectMemory reverseBytesFrom: segmentWordArray + objectMemory baseHeaderSize to: endSeg + objectMemory bytesPerWord.
- self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self bytesPerWord.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^ self primitiveFail]].
"Reverse the Byte type objects if the is data from opposite endian machine."
"Test top byte. $d on the Mac or $s on the PC. Rest of word is equal."
+ (data >> 16) = (objectMemory imageSegmentVersion >> 16) ifFalse: [
- (data >> 16) = (self imageSegmentVersion >> 16) ifFalse: [
"Reverse the byte-type objects once"
+ segOop := objectMemory oopFromChunk: segmentWordArray + objectMemory baseHeaderSize + objectMemory bytesPerWord.
- segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self bytesPerWord.
"Oop of first embedded object"
+ self byteSwapByteObjectsFrom: segOop to: endSeg + objectMemory bytesPerWord].
- self byteSwapByteObjectsFrom: segOop to: endSeg + self bytesPerWord].
"Proceed through the segment, remapping pointers..."
+ segOop := objectMemory oopFromChunk: segmentWordArray + objectMemory baseHeaderSize + objectMemory bytesPerWord.
- segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self bytesPerWord.
[segOop <= endSeg] whileTrue:
+ [(objectMemory headerType: segOop) <= 1
- [(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
+ fieldPtr := segOop - objectMemory bytesPerWord. doingClass := true]
- fieldPtr := segOop - self bytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
+ fieldPtr := segOop + objectMemory baseHeaderSize. doingClass := false].
+ lastPtr := segOop + (objectMemory lastPointerOf: segOop). "last field"
- fieldPtr := segOop + self baseHeaderSize. doingClass := false].
- lastPtr := segOop + (self lastPointerOf: segOop). "last field"
lastPtr > endSeg ifTrue: [
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^ self primitiveFail "out of bounds"].
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
+ [hdrTypeBits := objectMemory headerType: fieldPtr.
- [hdrTypeBits := self headerType: fieldPtr.
fieldOop := fieldOop - hdrTypeBits].
+ (objectMemory isIntegerObject: fieldOop)
- (self isIntegerObject: fieldOop)
ifTrue:
["Integer -- nothing to do"
+ fieldPtr := fieldPtr + objectMemory bytesPerWord]
- fieldPtr := fieldPtr + self bytesPerWord]
ifFalse:
[(fieldOop bitAnd: 3) = 0 ifFalse: [^ self primitiveFail "bad oop"].
(fieldOop bitAnd: 16r80000000) = 0
ifTrue: ["Internal pointer -- add segment offset"
mapOop := fieldOop + segmentWordArray]
ifFalse: ["External pointer -- look it up in outPointers"
outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
outPtr > lastOut ifTrue: [^ self primitiveFail "out of bounds"].
mapOop := self longAt: outPtr].
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
fieldPtr := fieldPtr + 8.
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
+ fieldPtr := fieldPtr + objectMemory bytesPerWord].
+ segOop < objectMemory youngStart
+ ifTrue: [objectMemory possibleRootStoreInto: segOop value: mapOop].
- fieldPtr := fieldPtr + self bytesPerWord].
- segOop < youngStart
- ifTrue: [self possibleRootStoreInto: segOop value: mapOop].
]].
+ segOop := objectMemory objectAfter: segOop].
- segOop := self objectAfter: segOop].
"Again, proceed through the segment checking consistency..."
+ segOop := objectMemory oopFromChunk: segmentWordArray + objectMemory baseHeaderSize + objectMemory bytesPerWord.
- segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self bytesPerWord.
[segOop <= endSeg] whileTrue:
+ [(objectMemory oopHasAcceptableClass: segOop) ifFalse: [^ self primitiveFail "inconsistency"].
+ fieldPtr := segOop + objectMemory baseHeaderSize. "first field"
+ lastPtr := segOop + (objectMemory lastPointerOf: segOop). "last field"
- [(self oopHasAcceptableClass: segOop) ifFalse: [^ self primitiveFail "inconsistency"].
- fieldPtr := segOop + self baseHeaderSize. "first field"
- lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
+ (objectMemory oopHasAcceptableClass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"].
+ fieldPtr := fieldPtr + objectMemory bytesPerWord].
+ segOop := objectMemory objectAfter: segOop].
- (self oopHasAcceptableClass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"].
- fieldPtr := fieldPtr + self bytesPerWord].
- segOop := self objectAfter: segOop].
"Truncate the segment word array to size = self bytesPerWord (vers stamp only)"
+ extraSize := objectMemory extraHeaderBytes: segmentWordArray.
+ hdrTypeBits := objectMemory headerType: segmentWordArray.
- extraSize := self extraHeaderBytes: segmentWordArray.
- hdrTypeBits := self headerType: segmentWordArray.
extraSize = 8
+ ifTrue: [self longAt: segmentWordArray-extraSize put: objectMemory baseHeaderSize + objectMemory bytesPerWord + hdrTypeBits]
- ifTrue: [self longAt: segmentWordArray-extraSize put: self baseHeaderSize + self bytesPerWord + hdrTypeBits]
ifFalse: [header := self longAt: segmentWordArray.
self longAt: segmentWordArray
+ put: header - (header bitAnd: objectMemory sizeMask) + objectMemory baseHeaderSize + objectMemory bytesPerWord].
- put: header - (header bitAnd: self sizeMask) + self baseHeaderSize + self bytesPerWord].
"and return the roots array which was first in the segment"
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ self pop: 3 thenPush: (objectMemory oopFromChunk: segmentWordArray + objectMemory baseHeaderSize + objectMemory bytesPerWord).
- self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + self baseHeaderSize + self bytesPerWord).
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveLowSpaceSemaphore (in category 'memory space primitives') -----
primitiveLowSpaceSemaphore
"Register the low-space semaphore. If the argument is not a
Semaphore, unregister the current low-space Semaphore."
| arg |
arg := self popStack.
+ (objectMemory fetchClassOf: arg) = (objectMemory splObj: ClassSemaphore)
+ ifTrue: [objectMemory storePointer: TheLowSpaceSemaphore ofObject: objectMemory specialObjectsOop withValue: arg]
+ ifFalse: [objectMemory storePointer: TheLowSpaceSemaphore ofObject: objectMemory specialObjectsOop withValue: objectMemory nilObj]!
- (self fetchClassOf: arg) = (self splObj: ClassSemaphore)
- ifTrue: [self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: arg]
- ifFalse: [self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: nilObj]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveMakePoint (in category 'arithmetic integer primitives') -----
primitiveMakePoint
| rcvr argument pt |
argument := self stackTop.
rcvr := self stackValue: 1.
+ (objectMemory isIntegerObject: rcvr)
+ ifTrue: [(objectMemory isIntegerObject: argument)
+ ifTrue: [pt := self makePointwithxValue: (objectMemory integerValueOf: rcvr) yValue: (objectMemory integerValueOf: argument)]
+ ifFalse: [pt := self makePointwithxValue: (objectMemory integerValueOf: rcvr) yValue: 0.
- (self isIntegerObject: rcvr)
- ifTrue: [(self isIntegerObject: argument)
- ifTrue: [pt := self makePointwithxValue: (self integerValueOf: rcvr) yValue: (self integerValueOf: argument)]
- ifFalse: [pt := self makePointwithxValue: (self integerValueOf: rcvr) yValue: 0.
"Above may cause GC!!"
+ objectMemory storePointer: 1 ofObject: pt withValue: (self stackValue: 0)]]
- self storePointer: 1 ofObject: pt withValue: (self stackValue: 0)]]
ifFalse: [(self isFloatObject: rcvr)
ifFalse: [^ self success: false].
pt := self makePointwithxValue: 0 yValue: 0.
"Above may cause GC!!"
+ objectMemory storePointer: 0 ofObject: pt withValue: (self stackValue: 1).
+ objectMemory storePointer: 1 ofObject: pt withValue: (self stackValue: 0)].
- self storePointer: 0 ofObject: pt withValue: (self stackValue: 1).
- self storePointer: 1 ofObject: pt withValue: (self stackValue: 0)].
self pop: 2 thenPush: pt!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveMillisecondClock (in category 'system control primitives') -----
primitiveMillisecondClock
"Return the value of the millisecond clock as an integer. Note that the millisecond clock wraps around periodically. On some platforms it can wrap daily. The range is limited to SmallInteger maxVal / 2 to allow delays of up to that length without overflowing a SmallInteger."
+ self pop: 1 thenPush: (objectMemory integerObjectOf: (self ioMSecs bitAnd: MillisecondClockMask)).
- self pop: 1 thenPush: (self integerObjectOf: (self ioMSecs bitAnd: MillisecondClockMask)).
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveMillisecondClockMask (in category 'system control primitives') -----
primitiveMillisecondClockMask
"Provide access to the millisecond clock mask to support calculation
of durations based on the millisecond clock value."
<export: true>
+ self pop: 1 thenPush: (objectMemory integerObjectOf: MillisecondClockMask)
- self pop: 1 thenPush: (self integerObjectOf: MillisecondClockMask)
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveNew (in category 'object access primitives') -----
primitiveNew
"Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC"
| class spaceOkay |
class := self stackTop.
"The following may cause GC!!"
spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: 0.
self success: spaceOkay.
+ self successful ifTrue: [ self push: (objectMemory instantiateClass: self popStack indexableSize: 0) ]!
- self successful ifTrue: [ self push: (self instantiateClass: self popStack indexableSize: 0) ]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveNewMethod (in category 'compiled methods') -----
primitiveNewMethod
| header bytecodeCount class size theMethod literalCount |
header := self popStack.
bytecodeCount := self popInteger.
+ self success: (objectMemory isIntegerObject: header).
- self success: (self isIntegerObject: header).
self successful ifFalse:
[self unPop: 2. ^nil].
class := self popStack.
+ size := (self literalCountOfHeader: header) + 1 * objectMemory bytesPerWord + bytecodeCount.
+ theMethod := objectMemory instantiateClass: class indexableSize: size.
+ objectMemory storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
- size := (self literalCountOfHeader: header) + 1 * self bytesPerWord + bytecodeCount.
- theMethod := self instantiateClass: class indexableSize: size.
- self storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
literalCount := self literalCountOfHeader: header.
1 to: literalCount do:
+ [:i | objectMemory storePointer: i ofObject: theMethod withValue: objectMemory nilObj].
- [:i | self storePointer: i ofObject: theMethod withValue: nilObj].
self push: theMethod!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveNewWithArg (in category 'object access primitives') -----
primitiveNewWithArg
"Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free."
| size class spaceOkay |
<var: #size type: 'usqInt'>
self isDefinedTrueExpression: 'SQ_IMAGE64 && SQ_HOST64'
+ inSmalltalk: [objectMemory bytesPerWord = 8]
- inSmalltalk: [self bytesPerWord = 8]
comment: 'permit large object allocation on 64 bit image and host'
ifTrue: [size := self positive64BitValueOf: self stackTop]
ifFalse: [size := self positive32BitValueOf: self stackTop].
class := self stackValue: 1.
self success: size >= 0.
self successful
ifTrue: ["The following may cause GC!!"
spaceOkay := self sufficientSpaceToInstantiate: class indexableSize: size.
self success: spaceOkay.
class := self stackValue: 1].
+ self successful ifTrue: [self pop: 2 thenPush: (objectMemory instantiateClass: class indexableSize: size)]!
- self successful ifTrue: [self pop: 2 thenPush: (self instantiateClass: class indexableSize: size)]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveNextInstance (in category 'object access primitives') -----
primitiveNextInstance
| object instance |
object := self stackTop.
+ instance := objectMemory instanceAfter: object.
+ instance = objectMemory nilObj
- instance := self instanceAfter: object.
- instance = nilObj
ifTrue: [self primitiveFail]
ifFalse: [self pop: argumentCount+1 thenPush: instance]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveNextObject (in category 'object access primitives') -----
primitiveNextObject
"Return the object following the receiver in the heap. Return the SmallInteger zero when there are no more objects."
| object instance |
object := self stackTop.
+ instance := objectMemory accessibleObjectAfter: object.
- instance := self accessibleObjectAfter: object.
instance = nil
ifTrue: [ self pop: argumentCount+1 thenPushInteger: 0 ]
ifFalse: [ self pop: argumentCount+1 thenPush: instance ].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveObjectAt (in category 'object access primitives') -----
primitiveObjectAt
"Defined for CompiledMethods only"
| thisReceiver index |
index := self popInteger.
thisReceiver := self popStack.
self success: index > 0.
self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart).
self successful
+ ifTrue: [self push: (objectMemory fetchPointer: index - 1 ofObject: thisReceiver)]
- ifTrue: [self push: (self fetchPointer: index - 1 ofObject: thisReceiver)]
ifFalse: [self unPop: 2]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveObjectAtPut (in category 'object access primitives') -----
primitiveObjectAtPut
"Defined for CompiledMethods only"
| thisReceiver index newValue |
newValue := self popStack.
index := self popInteger.
thisReceiver := self popStack.
self success: index > 0.
self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart).
self successful
+ ifTrue: [objectMemory storePointer: index - 1 ofObject: thisReceiver withValue: newValue.
- ifTrue: [self storePointer: index - 1 ofObject: thisReceiver withValue: newValue.
self push: newValue]
ifFalse: [self unPop: 3]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveObjectPointsTo (in category 'object access primitives') -----
primitiveObjectPointsTo
| rcvr thang lastField |
thang := self popStack.
rcvr := self popStack.
+ (objectMemory isIntegerObject: rcvr) ifTrue: [^self pushBool: false].
- (self isIntegerObject: rcvr) ifTrue: [^self pushBool: false].
+ lastField := objectMemory lastPointerOf: rcvr.
+ objectMemory baseHeaderSize to: lastField by: objectMemory bytesPerWord do:
- lastField := self lastPointerOf: rcvr.
- self baseHeaderSize to: lastField by: self bytesPerWord do:
[:i | (self longAt: rcvr + i) = thang
ifTrue: [^ self pushBool: true]].
self pushBool: false.!
Item was changed:
----- Method: InterpreterPrimitives>>primitivePlatformSourceVersion (in category 'other primitives') -----
primitivePlatformSourceVersion
"Answer a string corresponding to the version of the external platform source
code, typically written in C and managed separately for each platform.
This is a named (not numbered) primitive in the null module (ie the VM)"
| len versionString p |
<export: true>
<var: #p type: 'char *'>
self isDefined: 'PLATFORM_SOURCE_VERSION'
inSmalltalk: [versionString := '']
comment: 'version level of platform support code'
ifTrue: [len := self cCode: 'strlen(PLATFORM_SOURCE_VERSION)' inSmalltalk: [0].
+ versionString := objectMemory instantiateClass: objectMemory classString indexableSize: len.
- versionString := self instantiateClass: self classString indexableSize: len.
p := self arrayValueOf: versionString.
self cCode: 'strncpy(p, PLATFORM_SOURCE_VERSION, len)']
ifFalse: [^self primitiveFail].
self pop: 1 thenPush: versionString!
Item was changed:
----- Method: InterpreterPrimitives>>primitivePointX (in category 'object access primitives') -----
primitivePointX
| rcvr |
<inline: false>
rcvr := self popStack.
+ self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
- self assertClassOf: rcvr is: (self splObj: ClassPoint).
self successful
+ ifTrue: [self push: (objectMemory fetchPointer: XIndex ofObject: rcvr)]
- ifTrue: [self push: (self fetchPointer: XIndex ofObject: rcvr)]
ifFalse: [self unPop: 1]!
Item was changed:
----- Method: InterpreterPrimitives>>primitivePointY (in category 'object access primitives') -----
primitivePointY
| rcvr |
<inline: false>
rcvr := self popStack.
+ self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
- self assertClassOf: rcvr is: (self splObj: ClassPoint).
self successful
+ ifTrue: [self push: (objectMemory fetchPointer: YIndex ofObject: rcvr)]
- ifTrue: [self push: (self fetchPointer: YIndex ofObject: rcvr)]
ifFalse: [self unPop: 1]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveRootTable (in category 'memory space primitives') -----
primitiveRootTable
"Primitive. Answer a copy (snapshot) element of the root table.
The primitive can cause GC itself and if so the return value may
be inaccurate - in this case one should guard the read operation
by looking at the gc counter statistics."
| oop sz |
<export: true>
+ sz := objectMemory rootTableCount.
+ oop := objectMemory instantiateClass: objectMemory classArray indexableSize: sz. "can cause GC"
+ sz > objectMemory rootTableCount ifTrue:[sz := objectMemory rootTableCount].
- sz := rootTableCount.
- oop := self instantiateClass: self classArray indexableSize: sz. "can cause GC"
- sz > rootTableCount ifTrue:[sz := rootTableCount].
1 to: sz do:[:i|
+ objectMemory storePointer: i-1 ofObject: oop withValue: (objectMemory rootTable at: i).
- self storePointer: i-1 ofObject: oop withValue: (rootTable at: i).
].
self pop: argumentCount + 1.
self push: oop.!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveRootTableAt (in category 'memory space primitives') -----
primitiveRootTableAt
"Primitive. Answer the nth element of the root table.
This primitive avoids the creation of an extra array;
it is intended for enumerations of the form:
index := 1.
[root := Smalltalk rootTableAt: index.
root == nil] whileFalse:[index := index + 1].
"
| index |
<export: true>
index := self stackIntegerValue: 0.
+ self success: (index > 0 and:[index <= objectMemory rootTableCount]).
- self success: (index > 0 and:[index <= rootTableCount]).
self successful ifTrue:[
self pop: argumentCount + 1.
+ self push: (objectMemory rootTable at: index).
- self push: (rootTable at: index).
].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveScanCharacters (in category 'I/O primitives') -----
primitiveScanCharacters
"The character scanner primitive."
| kernDelta stops sourceString scanStopIndex scanStartIndex rcvr scanDestX scanLastIndex scanXTable scanMap maxGlyph ascii stopReason glyphIndex sourceX sourceX2 nextDestX scanRightX nilOop |
self methodArgumentCount = 6
ifFalse: [^ self primitiveFail].
"Load the arguments"
kernDelta := self stackIntegerValue: 0.
stops := self stackObjectValue: 1.
+ (objectMemory isArray: stops) ifFalse: [^ self primitiveFail].
- (self isArray: stops) ifFalse: [^ self primitiveFail].
(self slotSizeOf: stops) >= 258 ifFalse: [^ self primitiveFail].
scanRightX := self stackIntegerValue: 2.
sourceString := self stackObjectValue: 3.
+ (objectMemory isBytes: sourceString) ifFalse: [^ self primitiveFail].
- (self isBytes: sourceString) ifFalse: [^ self primitiveFail].
scanStopIndex := self stackIntegerValue: 4.
scanStartIndex := self stackIntegerValue: 5.
(scanStartIndex > 0 and: [scanStopIndex > 0 and: [scanStopIndex <= (self byteSizeOf: sourceString)]])
ifFalse: [^ self primitiveFail].
"Load receiver and required instVars"
rcvr := self stackObjectValue: 6.
+ ((objectMemory isPointers: rcvr) and: [(self slotSizeOf: rcvr) >= 4]) ifFalse: [^ self primitiveFail].
- ((self isPointers: rcvr) and: [(self slotSizeOf: rcvr) >= 4]) ifFalse: [^ self primitiveFail].
scanDestX := self fetchInteger: 0 ofObject: rcvr.
scanLastIndex := self fetchInteger: 1 ofObject: rcvr.
+ scanXTable := objectMemory fetchPointer: 2 ofObject: rcvr.
+ scanMap := objectMemory fetchPointer: 3 ofObject: rcvr.
+ ((objectMemory isArray: scanXTable) and: [objectMemory isArray: scanMap]) ifFalse: [^ self primitiveFail].
- scanXTable := self fetchPointer: 2 ofObject: rcvr.
- scanMap := self fetchPointer: 3 ofObject: rcvr.
- ((self isArray: scanXTable) and: [self isArray: scanMap]) ifFalse: [^ self primitiveFail].
(self slotSizeOf: scanMap) = 256 ifFalse: [^ self primitiveFail].
self successful ifFalse: [^ nil].
maxGlyph := (self slotSizeOf: scanXTable) - 2.
"Okay, here we go. We have eliminated nearly all failure
conditions, to optimize the inner fetches."
scanLastIndex := scanStartIndex.
+ nilOop := objectMemory nilObject.
- nilOop := self nilObject.
[scanLastIndex <= scanStopIndex]
whileTrue: [
"Known to be okay since scanStartIndex > 0 and scanStopIndex <= sourceString size"
+ ascii := objectMemory fetchByte: scanLastIndex - 1 ofObject: sourceString.
- ascii := self fetchByte: scanLastIndex - 1 ofObject: sourceString.
"Known to be okay since stops size >= 258"
+ (stopReason := objectMemory fetchPointer: ascii ofObject: stops) = nilOop
- (stopReason := self fetchPointer: ascii ofObject: stops) = nilOop
ifFalse: ["Store everything back and get out of here since some stop conditionn needs to be checked"
+ (objectMemory isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
- (self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex.
self pop: 7. "args+rcvr"
^ self push: stopReason].
"Known to be okay since scanMap size = 256"
glyphIndex := self fetchInteger: ascii ofObject: scanMap.
"fail if the glyphIndex is out of range"
(self failed or: [glyphIndex < 0 or: [glyphIndex > maxGlyph]]) ifTrue: [^ self primitiveFail].
sourceX := self fetchInteger: glyphIndex ofObject: scanXTable.
sourceX2 := self fetchInteger: glyphIndex + 1 ofObject: scanXTable.
"Above may fail if non-integer entries in scanXTable"
self failed ifTrue: [^ nil].
nextDestX := scanDestX + sourceX2 - sourceX.
nextDestX > scanRightX
ifTrue: ["Store everything back and get out of here since we got to the right edge"
+ (objectMemory isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
- (self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex.
self pop: 7. "args+rcvr"
+ ^ self push: (objectMemory fetchPointer: CrossedX - 1 ofObject: stops)].
- ^ self push: (self fetchPointer: CrossedX - 1 ofObject: stops)].
scanDestX := nextDestX + kernDelta.
scanLastIndex := scanLastIndex + 1].
+ (objectMemory isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
- (self isIntegerValue: scanDestX) ifFalse: [^ self primitiveFail].
self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
self storeInteger: 1 ofObject: rcvr withValue: scanStopIndex.
self pop: 7. "args+rcvr"
+ ^ self push: (objectMemory fetchPointer: EndOfRun - 1 ofObject: stops)!
- ^ self push: (self fetchPointer: EndOfRun - 1 ofObject: stops)!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSetFullScreen (in category 'I/O primitives') -----
primitiveSetFullScreen
"On platforms that support it, set full-screen mode to the value of the boolean argument."
| argOop |
argOop := self stackTop.
+ argOop = objectMemory trueObj
- argOop = trueObj
ifTrue: [self ioSetFullScreen: true]
+ ifFalse: [ argOop = objectMemory falseObj
- ifFalse: [ argOop = falseObj
ifTrue: [self ioSetFullScreen: false]
ifFalse: [self primitiveFail]].
self successful ifTrue: [self pop: 1].
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSetGCBiasToGrow (in category 'memory space primitives') -----
primitiveSetGCBiasToGrow
"Primitive. Indicate if the GC logic should have bias to grow"
| flag |
<export: true>
flag := self stackIntegerValue: 0.
self successful ifTrue:[
+ objectMemory gcBiasToGrow: flag.
- gcBiasToGrow := flag.
self pop: argumentCount.
].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSetGCBiasToGrowGCLimit (in category 'memory space primitives') -----
primitiveSetGCBiasToGrowGCLimit
"Primitive. If the GC logic has bias to grow, set growth limit"
| value |
<export: true>
value := self stackIntegerValue: 0.
+ self successful
+ ifTrue: [objectMemory setGCBiasToGrowGCLimit: value.
+ self pop: argumentCount.].!
- self successful ifTrue:[
- gcBiasToGrowGCLimit := value.
- gcBiasToGrowThreshold := youngStart - (self cCoerce: memory to: 'int').
- self pop: argumentCount.
- ].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveShortAt (in category 'indexing primitives') -----
primitiveShortAt
"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
| index rcvr sz addr value |
index := self stackIntegerValue: 0.
rcvr := self stackValue: 1.
+ self success: ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isWordsOrBytes: rcvr]).
- self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
self successful ifFalse: [ ^ nil ].
+ sz := ((objectMemory sizeBitsOf: rcvr) - objectMemory baseHeaderSize) // 2. "number of 16-bit fields"
- sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields"
self success: ((index >= 1) and: [index <= sz]).
self successful ifTrue: [
+ addr := rcvr + objectMemory baseHeaderSize + (2 * (index - 1)).
- addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
value := self shortAt: addr.
self pop: 2 thenPushInteger: value.
]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveShortAtPut (in category 'indexing primitives') -----
primitiveShortAtPut
"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
| index rcvr sz addr value |
value := self stackIntegerValue: 0.
index := self stackIntegerValue: 1.
rcvr := self stackValue: 2.
+ self success: ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isWordsOrBytes: rcvr]).
- self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
self successful ifFalse: [ ^ nil ].
+ sz := ((objectMemory sizeBitsOf: rcvr) - objectMemory baseHeaderSize) // 2. "number of 16-bit fields"
- sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields"
self success: ((index >= 1) and: [index <= sz]).
self success: ((value >= -32768) and: [value <= 32767]).
self successful ifTrue: [
+ addr := rcvr + objectMemory baseHeaderSize + (2 * (index - 1)).
- addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
self shortAt: addr put: value.
self pop: 2. "pop index and value; leave rcvr on stack"
]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveShowDisplayRect (in category 'I/O primitives') -----
primitiveShowDisplayRect
"Force the given rectangular section of the Display to be
copied to the screen."
| bottom top right left |
bottom := self stackIntegerValue: 0.
top := self stackIntegerValue: 1.
right := self stackIntegerValue: 2.
left := self stackIntegerValue: 3.
+ self displayBitsOf: (objectMemory splObj: TheDisplay) Left: left Top: top Right: right Bottom: bottom.
- self displayBitsOf: (self splObj: TheDisplay) Left: left Top: top Right: right Bottom: bottom.
self successful
ifTrue: [self ioForceDisplayUpdate.
self pop: 4]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSignal (in category 'process primitives') -----
primitiveSignal
"synchromously signal the semaphore. This may change the active process as a result"
| sema |
sema := self stackTop. "rcvr"
+ self assertClassOf: sema is: (objectMemory splObj: ClassSemaphore).
- self assertClassOf: sema is: (self splObj: ClassSemaphore).
self successful ifTrue: [ self synchronousSignal: sema ].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSignalAtBytesLeft (in category 'memory space primitives') -----
primitiveSignalAtBytesLeft
"Set the low-water mark for free space. When the free space
falls below this level, the new and new: primitives fail and
system attempts to allocate space (e.g., to create a method
context) cause the low-space semaphore (if one is
registered) to be signalled."
| bytes |
bytes := self popInteger.
self successful
+ ifTrue: [objectMemory lowSpaceThreshold: bytes]
+ ifFalse: [objectMemory lowSpaceThreshold: 0.
- ifTrue: [lowSpaceThreshold := bytes]
- ifFalse: [lowSpaceThreshold := 0.
self unPop: 1]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSize (in category 'indexing primitives') -----
primitiveSize
| rcvr sz |
rcvr := self stackTop.
+ (objectMemory isIntegerObject: rcvr) ifTrue: [^ self primitiveFail]. "Integers are not indexable"
+ (objectMemory formatOf: rcvr) < 2 ifTrue: [^ self primitiveFail]. "This is not an indexable object"
- (self isIntegerObject: rcvr) ifTrue: [^ self primitiveFail]. "Integers are not indexable"
- (self formatOf: rcvr) < 2 ifTrue: [^ self primitiveFail]. "This is not an indexable object"
sz := self stSizeOf: rcvr.
self successful ifTrue:
[self pop: argumentCount + 1 thenPush: (self positive32BitIntegerFor: sz)]
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSomeInstance (in category 'object access primitives') -----
primitiveSomeInstance
| class instance |
class := self stackTop.
+ instance := objectMemory initialInstanceOf: class.
+ instance = objectMemory nilObj
- instance := self initialInstanceOf: class.
- instance = nilObj
ifTrue: [self primitiveFail]
ifFalse: [self pop: argumentCount+1 thenPush: instance]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSomeObject (in category 'object access primitives') -----
primitiveSomeObject
"Return the first object in the heap."
self pop: argumentCount+1.
+ self push: objectMemory firstAccessibleObject.!
- self push: self firstAccessibleObject.!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSpecialObjectsOop (in category 'system control primitives') -----
primitiveSpecialObjectsOop
"Return the oop of the SpecialObjectsArray."
+ self pop: 1 thenPush: objectMemory specialObjectsOop.!
- self pop: 1 thenPush: specialObjectsOop.!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveStoreImageSegment (in category 'image segment in/out') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: InterpreterPrimitives>>primitiveStringReplace (in category 'indexing primitives') -----
primitiveStringReplace
"
<array> primReplaceFrom: start to: stop with: replacement
startingAt: repStart
<primitive: 105>
"
| array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex |
array := self stackValue: 4.
start := self stackIntegerValue: 3.
stop := self stackIntegerValue: 2.
repl := self stackValue: 1.
replStart := self stackIntegerValue: 0.
self successful ifFalse: [^ self primitiveFail].
+ (objectMemory isIntegerObject: repl) ifTrue: ["can happen in LgInt copy"
- (self isIntegerObject: repl) ifTrue: ["can happen in LgInt copy"
^ self primitiveFail].
+ hdr := objectMemory baseHeader: array.
- hdr := self baseHeader: array.
arrayFmt := hdr >> 8 bitAnd: 15.
totalLength := self lengthOf: array baseHeader: hdr format: arrayFmt.
arrayInstSize := self fixedFieldsOf: array format: arrayFmt length: totalLength.
(start >= 1 and: [start - 1 <= stop and: [stop + arrayInstSize <= totalLength]])
ifFalse: [^ self primitiveFail].
+ hdr := objectMemory baseHeader: repl.
- hdr := self baseHeader: repl.
replFmt := hdr >> 8 bitAnd: 15.
totalLength := self lengthOf: repl baseHeader: hdr format: replFmt.
replInstSize := self fixedFieldsOf: repl format: replFmt length: totalLength.
(replStart >= 1 and: [stop - start + replStart + replInstSize <= totalLength])
ifFalse: [^ self primitiveFail].
"Array formats (without byteSize bits, if bytes array) must be same "
arrayFmt < 8
ifTrue: [arrayFmt = replFmt
ifFalse: [^ self primitiveFail]]
ifFalse: [(arrayFmt bitAnd: 12) = (replFmt bitAnd: 12)
ifFalse: [^ self primitiveFail]].
srcIndex := replStart + replInstSize - 1.
"- 1 for 0-based access"
arrayFmt <= 4
ifTrue: ["pointer type objects"
start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i |
+ objectMemory storePointer: i ofObject: array withValue: (objectMemory fetchPointer: srcIndex ofObject: repl).
- self storePointer: i ofObject: array withValue: (self fetchPointer: srcIndex ofObject: repl).
srcIndex := srcIndex + 1]]
ifFalse: [arrayFmt < 8
ifTrue: ["32-bit-word type objects"
start + arrayInstSize - 1 to: stop + arrayInstSize - 1
+ do: [:i | objectMemory storeLong32: i ofObject: array withValue: (objectMemory fetchLong32: srcIndex ofObject: repl).
- do: [:i | self storeLong32: i ofObject: array withValue: (self fetchLong32: srcIndex ofObject: repl).
srcIndex := srcIndex + 1]]
ifFalse: ["byte-type objects"
start + arrayInstSize - 1 to: stop + arrayInstSize - 1
+ do: [:i | objectMemory storeByte: i ofObject: array withValue: (objectMemory fetchByte: srcIndex ofObject: repl).
- do: [:i | self storeByte: i ofObject: array withValue: (self fetchByte: srcIndex ofObject: repl).
srcIndex := srcIndex + 1]]].
"We might consider comparing stop - start to some value here and using forceInterruptCheck"
self pop: argumentCount "leave rcvr on stack"!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveSuspend (in category 'process primitives') -----
primitiveSuspend
"Primitive. Suspend the receiver, aProcess such that it can be executed again
by sending #resume. If the given process is not currently running, take it off
its corresponding list. The primitive returns the list the receiver was previously on."
| process activeProc myList |
process := self stackTop.
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex
- activeProc := self fetchPointer: ActiveProcessIndex
ofObject: self schedulerPointer.
process == activeProc ifTrue:[
self pop: 1.
+ self push: objectMemory nilObj.
- self push: nilObj.
self transferTo: self wakeHighestPriority.
] ifFalse:[
+ myList := objectMemory fetchPointer: MyListIndex ofObject: process.
- myList := self fetchPointer: MyListIndex ofObject: process.
"XXXX Fixme. We should really check whether myList is a kind of LinkedList or not
but we can't easily so just do a quick check for nil which is the most common case."
+ myList == objectMemory nilObject ifTrue:[^self primitiveFail].
- myList == self nilObject ifTrue:[^self primitiveFail].
self removeProcess: process fromList: myList.
self successful ifTrue:[
+ objectMemory storePointer: MyListIndex ofObject: process withValue: objectMemory nilObject.
- self storePointer: MyListIndex ofObject: process withValue: self nilObject.
self pop: 1.
self push: myList.
].
].
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveTerminateTo (in category 'process primitives') -----
primitiveTerminateTo
"Primitive. Terminate up the context stack from the receiver up to but not including the argument, if previousContext is on my Context stack. Make previousContext my sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct"
| thisCntx currentCntx aContext nextCntx nilOop |
aContext := self popStack.
thisCntx := self popStack.
"make sure that aContext is in my chain"
(self context: thisCntx hasSender: aContext) ifTrue:[
+ nilOop := objectMemory nilObj.
+ currentCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
- nilOop := nilObj.
- currentCntx := self fetchPointer: SenderIndex ofObject: thisCntx.
[currentCntx = aContext] whileFalse: [
+ nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCntx.
+ objectMemory storePointer: SenderIndex ofObject: currentCntx withValue: nilOop.
+ objectMemory storePointer: InstructionPointerIndex ofObject: currentCntx withValue: nilOop.
- nextCntx := self fetchPointer: SenderIndex ofObject: currentCntx.
- self storePointer: SenderIndex ofObject: currentCntx withValue: nilOop.
- self storePointer: InstructionPointerIndex ofObject: currentCntx withValue: nilOop.
currentCntx := nextCntx]].
+ objectMemory storePointer: SenderIndex ofObject: thisCntx withValue: aContext.
- self storePointer: SenderIndex ofObject: thisCntx withValue: aContext.
^self push: thisCntx!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveUnloadModule (in category 'plugin primitives') -----
primitiveUnloadModule
"Primitive. Unload the module with the given name."
"Reloading of the module will happen *later* automatically, when a
function from it is called. This is ensured by invalidating current sessionID."
| moduleName |
self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
moduleName := self stackTop.
+ (objectMemory isIntegerObject: moduleName) ifTrue:[^self primitiveFail].
+ (objectMemory isBytes: moduleName) ifFalse:[^self primitiveFail].
- (self isIntegerObject: moduleName) ifTrue:[^self primitiveFail].
- (self isBytes: moduleName) ifFalse:[^self primitiveFail].
(self ioUnloadModule: (self oopForPointer: (self firstIndexableField: moduleName))
OfLength: (self byteSizeOf: moduleName)) ifFalse:[^self primitiveFail].
self flushExternalPrimitives.
self forceInterruptCheck.
self pop: 1 "pop moduleName; return receiver"!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveUtcWithOffset (in category 'system control primitives') -----
primitiveUtcWithOffset
"Answer an array with UTC microseconds since the Posix epoch and
the current seconds offset from GMT in the local time zone.
This is a named (not numbered) primitive in the null module (ie the VM)"
| clock offset resultArray |
<export: true>
<var: #clock type: 'sqLong'>
<var: #offset type: 'int'>
(self cCode: 'ioUtcWithOffset(&clock, &offset)' inSmalltalk: [-1]) = -1
ifTrue: [^ self primitiveFail].
+ objectMemory pushRemappableOop: (self positive64BitIntegerFor: clock).
+ resultArray := objectMemory instantiateClass: objectMemory classArray indexableSize: 2.
+ self stObject: resultArray at: 1 put: objectMemory popRemappableOop.
+ self stObject: resultArray at: 2 put: (objectMemory integerObjectOf: offset).
- self pushRemappableOop: (self positive64BitIntegerFor: clock).
- resultArray := self instantiateClass: self classArray indexableSize: 2.
- self stObject: resultArray at: 1 put: self popRemappableOop.
- self stObject: resultArray at: 2 put: (self integerObjectOf: offset).
self pop: 1 thenPush: resultArray
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveVMPath (in category 'system control primitives') -----
primitiveVMPath
"Return a string containing the path name of VM's directory."
| s sz |
sz := self vmPathSize.
+ s := objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: sz.
+ self vmPathGet: (s + objectMemory baseHeaderSize) Length: sz.
- s := self instantiateClass: (self splObj: ClassString) indexableSize: sz.
- self vmPathGet: (s + self baseHeaderSize) Length: sz.
self pop: 1 thenPush: s.
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveVMVersion (in category 'other primitives') -----
primitiveVMVersion
"Answer a string corresponding to the version of virtual machine. This
represents the version level of the Smalltalk source code (interpreter and various
plugins) that is translated to C by a CCodeGenerator, in addition to the external
platform source code, typically written in C and managed separately for each platform.
By convention, this is a string composed of the interpreter source version and the
platform source version, e.g. '4.0.2-2172'.
This is a named (not numbered) primitive in the null module (ie the VM)"
| len versionString p |
<export: true>
<var: #p type: 'char *'>
self isDefined: 'VM_VERSION'
inSmalltalk: [versionString := '']
comment: 'version level of interpreter plus platform support code'
ifTrue: [len := self cCode: 'strlen(VM_VERSION)' inSmalltalk: [0].
+ versionString := objectMemory instantiateClass: objectMemory classString indexableSize: len.
- versionString := self instantiateClass: self classString indexableSize: len.
p := self arrayValueOf: versionString.
self cCode: 'strncpy(p, VM_VERSION, len)']
ifFalse: [^self primitiveFail].
self pop: 1 thenPush: versionString
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveWait (in category 'process primitives') -----
primitiveWait
| sema excessSignals activeProc |
sema := self stackTop. "rcvr"
+ self assertClassOf: sema is: (objectMemory splObj: ClassSemaphore).
- self assertClassOf: sema is: (self splObj: ClassSemaphore).
self successful ifTrue: [
excessSignals :=
self fetchInteger: ExcessSignalsIndex ofObject: sema.
excessSignals > 0 ifTrue: [
self storeInteger: ExcessSignalsIndex
ofObject: sema withValue: excessSignals - 1.
] ifFalse: [
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex
- activeProc := self fetchPointer: ActiveProcessIndex
ofObject: self schedulerPointer.
self addLastLink: activeProc toList: sema.
self transferTo: self wakeHighestPriority.
].
].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveYield (in category 'process primitives') -----
primitiveYield
"primitively do the equivalent of Process>yield"
| activeProc priority processLists processList |
+ activeProc := objectMemory fetchPointer: ActiveProcessIndex
- activeProc := self fetchPointer: ActiveProcessIndex
ofObject: self schedulerPointer.
priority := self quickFetchInteger: PriorityIndex ofObject: activeProc.
+ processLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ processList := objectMemory fetchPointer: priority - 1 ofObject: processLists.
- processLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
- processList := self fetchPointer: priority - 1 ofObject: processLists.
(self isEmptyList: processList) ifFalse:[
self addLastLink: activeProc toList: processList.
self transferTo: self wakeHighestPriority]!
Item was changed:
----- Method: InterpreterPrimitives>>signed32BitValueOf: (in category 'primitive support') -----
signed32BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a four-byte LargeInteger."
| value largeClass negative |
<inline: false>
<returnTypeC: 'int'>
<var: 'value' type: 'int'>
+ (objectMemory isIntegerObject: oop) ifTrue: [^objectMemory integerValueOf: oop].
- (self isIntegerObject: oop) ifTrue: [^self integerValueOf: oop].
(self lengthOf: oop) > 4 ifTrue: [^ self primitiveFail].
+ largeClass := objectMemory fetchClassOf: oop.
+ largeClass = objectMemory classLargePositiveInteger
- largeClass := self fetchClassOf: oop.
- largeClass = self classLargePositiveInteger
ifTrue:[negative := false]
+ ifFalse:[largeClass = objectMemory classLargeNegativeInteger
- ifFalse:[largeClass = self classLargeNegativeInteger
ifTrue:[negative := true]
ifFalse:[^self primitiveFail]].
(self lengthOf: oop) ~= 4 ifTrue: [^ self primitiveFail].
+ value := (objectMemory fetchByte: 0 ofObject: oop) +
+ ((objectMemory fetchByte: 1 ofObject: oop) << 8) +
+ ((objectMemory fetchByte: 2 ofObject: oop) << 16) +
+ ((objectMemory fetchByte: 3 ofObject: oop) << 24).
- value := (self fetchByte: 0 ofObject: oop) +
- ((self fetchByte: 1 ofObject: oop) << 8) +
- ((self fetchByte: 2 ofObject: oop) << 16) +
- ((self fetchByte: 3 ofObject: oop) << 24).
"Fail if value exceeds range of a 32-bit twos-complement signed integer."
negative
ifTrue:["perform subtraction using unsigned int to prevent undefined result
for optimizing C compilers in the case of value = 16r80000000"
value := 0 - (self cCoerce: value to: 'unsigned int').
value >= 0 ifTrue: [^ self primitiveFail]]
ifFalse:[value < 0 ifTrue:[^ self primitiveFail]].
^ value!
Item was changed:
----- Method: InterpreterPrimitives>>signed64BitValueOf: (in category 'primitive support') -----
signed64BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a eight-byte LargeInteger."
| sz value largeClass negative szsqLong |
<inline: false>
<returnTypeC: 'sqLong'>
<var: 'value' type: 'sqLong'>
+ (objectMemory isIntegerObject: oop) ifTrue: [^self cCoerce: (objectMemory integerValueOf: oop) to: 'sqLong'].
- (self isIntegerObject: oop) ifTrue: [^self cCoerce: (self integerValueOf: oop) to: 'sqLong'].
sz := self lengthOf: oop.
sz > 8 ifTrue: [^ self primitiveFail].
+ largeClass := objectMemory fetchClassOf: oop.
+ largeClass = objectMemory classLargePositiveInteger
- largeClass := self fetchClassOf: oop.
- largeClass = self classLargePositiveInteger
ifTrue:[negative := false]
+ ifFalse:[largeClass = objectMemory classLargeNegativeInteger
- ifFalse:[largeClass = self classLargeNegativeInteger
ifTrue:[negative := true]
ifFalse:[^self primitiveFail]].
szsqLong := self
cCode: 'sizeof(sqLong)'
inSmalltalk: [8].
sz > szsqLong
ifTrue: [^ self primitiveFail].
value := 0.
0 to: sz - 1 do: [:i |
+ value := value + ((self cCoerce: (objectMemory fetchByte: i ofObject: oop) to: 'sqLong') << (i*8))].
- value := value + ((self cCoerce: (self fetchByte: i ofObject: oop) to: 'sqLong') << (i*8))].
"Fail if value exceeds range of a 64-bit twos-complement signed integer."
negative
ifTrue:["perform subtraction using unsigned usqLong to prevent undefined result
for optimizing C compilers in the case of value = 16r8000000000000000"
value := 0 - (self cCoerce: value to: 'usqLong').
value >= 0 ifTrue: [^ self primitiveFail]]
ifFalse:[value < 0 ifTrue:[^ self primitiveFail]].
^ value!
Item was changed:
Interpreter subclass: #InterpreterSimulator
instanceVariableNames: 'bytesPerWord byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries inputSem quitBlock transcript displayView logging'
classVariableNames: ''
+ poolDictionaries: 'VMObjectIndices VMSqueakV3ObjectRepresentationConstants'
- poolDictionaries: ''
category: 'VMMaker-InterpreterSimulation'!
!InterpreterSimulator commentStamp: 'dtl 5/5/2011 19:42' prior: 0!
This class defines basic memory access and primitive simulation so that the Interpreter can run simulated in the Squeak environment. It also defines a number of handy object viewing methods to facilitate pawing around in the object memory.
To see the thing actually run, you could (after backing up this image and changes), execute
(InterpreterSimulator new openOn: Smalltalk imageName) test
and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be. We usually do this with a small and simple benchmark image. You will probably have more luck using InterpreterSimulatorLSB or InterpreterSimulatorMSB as befits your machine.!
Item was changed:
----- Method: InterpreterSimulator class>>new (in category 'instance creation') -----
new
+ ^ self on: ObjectMemory new
+ !
- ^ self == InterpreterSimulator
- ifTrue: [SmalltalkImage current endianness == #big
- ifTrue: [InterpreterSimulatorMSB new]
- ifFalse: [InterpreterSimulatorLSB new]]
- ifFalse: [super new]!
Item was added:
+ ----- Method: InterpreterSimulator class>>on: (in category 'instance creation') -----
+ on: objectMemory
+ | interp |
+ interp := self == InterpreterSimulator
+ ifTrue: [SmalltalkImage current endianness == #big
+ ifTrue: [InterpreterSimulatorMSB basicNew]
+ ifFalse: [InterpreterSimulatorLSB basicNew]]
+ ifFalse: [super basicNew].
+ interp objectMemory: objectMemory.
+ ^ interp initialize
+ !
Item was changed:
----- Method: InterpreterSimulator>>allObjectsDo: (in category 'debug support') -----
allObjectsDo: objBlock
| oop |
+ oop := objectMemory firstObject.
+ [oop < objectMemory endOfMemory] whileTrue:
+ [(objectMemory isFreeObject: oop)
- oop := self firstObject.
- [oop < endOfMemory] whileTrue:
- [(self isFreeObject: oop)
ifFalse: [objBlock value: oop].
+ oop := objectMemory objectAfter: oop].
- oop := self objectAfter: oop].
!
Item was changed:
----- Method: InterpreterSimulator>>allObjectsSelect: (in category 'debug support') -----
allObjectsSelect: objBlock
"self allObjectsSelect: [:oop | (self baseHeader: oop) = 1234]"
| oop selected |
+ oop := objectMemory firstObject.
- oop := self firstObject.
selected := OrderedCollection new.
+ [oop < objectMemory endOfMemory] whileTrue:
+ [(objectMemory isFreeObject: oop)
- [oop < endOfMemory] whileTrue:
- [(self isFreeObject: oop)
ifFalse: [(objBlock value: oop) ifTrue: [selected addLast: oop]].
+ oop := objectMemory objectAfter: oop].
- oop := self objectAfter: oop].
^ selected!
Item was changed:
----- Method: InterpreterSimulator>>allocate:headerSize:h1:h2:h3:doFill:with: (in category 'debugging traps') -----
allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord
| newObj |
+ newObj := objectMemory allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord.
- newObj := super allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord.
"byteCount < 600000 ifTrue: [^ newObj]."
"(self baseHeader: newObj) = 16r0FCC0600 ifTrue: [self halt]."
^ newObj!
Item was changed:
----- Method: InterpreterSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') -----
classAndSelectorOfMethod: meth forReceiver: rcvr
| mClass dict length methodArray |
+ mClass := objectMemory fetchClassOf: rcvr.
+ [dict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: mClass.
+ length := objectMemory fetchWordLengthOf: dict.
+ methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dict.
- mClass := self fetchClassOf: rcvr.
- [dict := self fetchPointer: MessageDictionaryIndex ofObject: mClass.
- length := self fetchWordLengthOf: dict.
- methodArray := self fetchPointer: MethodArrayIndex ofObject: dict.
0 to: length-SelectorStart-1 do:
[:index |
+ meth = (objectMemory fetchPointer: index ofObject: methodArray)
- meth = (self fetchPointer: index ofObject: methodArray)
ifTrue: [^ Array
with: mClass
+ with: (objectMemory fetchPointer: index + SelectorStart ofObject: dict)]].
+ mClass := objectMemory fetchPointer: SuperclassIndex ofObject: mClass.
+ mClass = objectMemory nilObj]
- with: (self fetchPointer: index + SelectorStart ofObject: dict)]].
- mClass := self fetchPointer: SuperclassIndex ofObject: mClass.
- mClass = nilObj]
whileFalse: [].
^ Array
+ with: (objectMemory fetchClassOf: rcvr)
+ with: (objectMemory splObj: SelectorDoesNotUnderstand)!
- with: (self fetchClassOf: rcvr)
- with: (self splObj: SelectorDoesNotUnderstand)!
Item was changed:
----- Method: InterpreterSimulator>>classNameOf:Is: (in category 'plugin support') -----
classNameOf: aClass Is: className
"Check if aClass' name is className"
| name |
(self lengthOf: aClass) <= 6 ifTrue:[^false]. "Not a class but maybe behavior"
+ name := objectMemory fetchPointer: 6 ofObject: aClass.
+ (objectMemory isBytes: name) ifFalse:[^false].
- name := self fetchPointer: 6 ofObject: aClass.
- (self isBytes: name) ifFalse:[^false].
^ className = (self stringOf: name).
!
Item was changed:
----- Method: InterpreterSimulator>>clipboardWrite:From:At: (in category 'I/O primitives') -----
clipboardWrite: sz From: actualDataAddress At: ignored
+ Clipboard clipboardText: (self stringOf: actualDataAddress - objectMemory baseHeaderSize)!
- Clipboard clipboardText: (self stringOf: actualDataAddress - self baseHeaderSize)!
Item was changed:
----- Method: InterpreterSimulator>>compactClassAt: (in category 'debug support') -----
compactClassAt: ccIndex
"Index must be between 1 and compactClassArray size. (A zero compact class index in the base header indicate that the class is in the class header word.)"
| classArray |
+ classArray := objectMemory fetchPointer: CompactClasses ofObject: objectMemory specialObjectsOop.
+ ^ objectMemory fetchPointer: (ccIndex - 1) ofObject: classArray!
- classArray := self fetchPointer: CompactClasses ofObject: specialObjectsOop.
- ^ self fetchPointer: (ccIndex - 1) ofObject: classArray!
Item was changed:
----- Method: InterpreterSimulator>>convertToArray (in category 'initialization') -----
convertToArray
"I dont believe it -- this *just works*"
+ "The comment above is from the original method, stamped di 5/8/2004 16:42"
+ objectMemory memory: (objectMemory memory as: Array)!
- memory := memory as: Array!
Item was changed:
----- Method: InterpreterSimulator>>dumpHeader: (in category 'debug support') -----
dumpHeader: hdr
| cc |
^ String streamContents: [:strm |
cc := (hdr bitAnd: CompactClassMask) >> 12.
strm nextPutAll: '<cc=', cc hex.
cc > 0 ifTrue:
[strm nextPutAll: ':' , (self nameOfClass: (self compactClassAt: cc))].
strm nextPutAll: '>'.
strm nextPutAll: '<ft=', ((hdr bitShift: -8) bitAnd: 16rF) hex , '>'.
+ strm nextPutAll: '<sz=', (hdr bitAnd: objectMemory sizeMask) hex , '>'.
- strm nextPutAll: '<sz=', (hdr bitAnd: self sizeMask) hex , '>'.
strm nextPutAll: '<hdr=', (#(big class gcMark short) at: (hdr bitAnd: 3) +1) , '>']
!
Item was changed:
----- Method: InterpreterSimulator>>fileValueOf: (in category 'file primitives') -----
fileValueOf: integerPointer
"Convert the (integer) fileID to the actual fileStream it uses"
+ self success: (objectMemory isIntegerObject: integerPointer).
- self success: (self isIntegerObject: integerPointer).
self successful
+ ifTrue: [^ filesOpen at: (objectMemory integerValueOf: integerPointer)]
- ifTrue: [^ filesOpen at: (self integerValueOf: integerPointer)]
ifFalse: [^ nil]!
Item was changed:
----- Method: InterpreterSimulator>>firstIndexableField: (in category 'memory access') -----
firstIndexableField: oop
"NOTE: overridden from Interpreter to add coercion to CArray"
| hdr fmt totalLength fixedFields |
self returnTypeC: 'void *'.
+ hdr := objectMemory baseHeader: oop.
- hdr := self baseHeader: oop.
fmt := (hdr >> 8) bitAnd: 16rF.
totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
fmt < 8 ifTrue:
[fmt = 6 ifTrue:
["32 bit field objects"
+ ^ self cCoerce: (self pointerForOop: oop + objectMemory baseHeaderSize + (fixedFields << 2)) to: 'int *'].
- ^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << 2)) to: 'int *'].
"full word objects (pointer or bits)"
+ ^ self cCoerce: (self pointerForOop: oop + objectMemory baseHeaderSize + (fixedFields << objectMemory shiftForWord)) to: 'oop *']
- ^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *']
ifFalse:
["Byte objects"
+ ^ self cCoerce: (self pointerForOop: oop + objectMemory baseHeaderSize + fixedFields) to: 'char *']!
- ^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + fixedFields) to: 'char *']!
Item was changed:
----- Method: InterpreterSimulator>>fullDisplay (in category 'I/O primitives') -----
fullDisplay
| t |
displayForm == nil ifTrue: [^ self].
t := primFailCode. self initPrimCall.
+ self displayBitsOf: (objectMemory splObj: TheDisplay) Left: 0 Top: 0 Right: displayForm width Bottom: displayForm height.
- self displayBitsOf: (self splObj: TheDisplay) Left: 0 Top: 0 Right: displayForm width Bottom: displayForm height.
primFailCode := t!
Item was changed:
----- Method: InterpreterSimulator>>fullGC (in category 'debug support') -----
fullGC
transcript cr; show:'<Running full GC ...'.
+ objectMemory fullGC.
- super fullGC.
transcript show: ' done>'.!
Item was changed:
----- Method: InterpreterSimulator>>headerStart: (in category 'debug support') -----
headerStart: oop
+ ^ (objectMemory extraHeaderBytes: oop) negated!
- ^ (self extraHeaderBytes: oop) negated!
Item was changed:
----- Method: InterpreterSimulator>>hexDump: (in category 'debug support') -----
hexDump: oop
| byteSize val |
+ (objectMemory isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
- (self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
^ String streamContents:
[:strm |
+ byteSize := 256 min: (objectMemory sizeBitsOf: oop)-4.
- byteSize := 256 min: (self sizeBitsOf: oop)-4.
(self headerStart: oop) to: byteSize by: 4 do:
[:a | val := self longAt: oop+a.
strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);
space; space; space; nextPutAll: val hex8;
space; space.
a=0
ifTrue: [strm nextPutAll: (self dumpHeader: val)]
ifFalse: [strm nextPutAll: (self charsOfLong: val)]]]!
Item was changed:
----- Method: InterpreterSimulator>>initialize (in category 'initialization') -----
initialize
"Initialize the InterpreterSimulator when running the interpreter inside
Smalltalk. The primary responsibility of this method is to allocate
Smalltalk Arrays for variables that will be declared as statically-allocated
global arrays in the translated code."
"initialize class variables"
ObjectMemory initializeConstants.
Interpreter initialize.
"Note: we must initialize ConstMinusOne differently for simulation,
due to the fact that the simulator works only with +ve 32-bit values"
ConstMinusOne := self integerObjectOf: -1.
methodCache := Array new: MethodCacheSize.
atCache := Array new: AtCacheTotalSize.
self flushMethodCache.
+ objectMemory rootTable: (Array new: ObjectMemory rootTableSize).
+ objectMemory weakRoots: (Array new: ObjectMemory rootTableSize + ObjectMemory remapBufferSize + 100).
+ objectMemory remapBuffer: (Array new: ObjectMemory remapBufferSize).
- rootTable := Array new: RootTableSize.
- weakRoots := Array new: RootTableSize + RemapBufferSize + 100.
- remapBuffer := Array new: RemapBufferSize.
semaphoresUseBufferA := true.
semaphoresToSignalA := Array new: SemaphoresToSignalSize.
semaphoresToSignalB := Array new: SemaphoresToSignalSize.
externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
primitiveTable := self class primitiveTable.
pluginList := #().
mappedPluginEntries := #().
"initialize InterpreterSimulator variables used for debugging"
byteCount := 0.
sendCount := 0.
quitBlock := [^ self].
traceOn := true.
myBitBlt := BitBltSimulator new setInterpreter: self.
filesOpen := OrderedCollection new.
+ objectMemory headerTypeBytes: (CArrayAccessor on: (Array with: self bytesPerWord * 2 with: self bytesPerWord with: 0 with: 0)).
- headerTypeBytes := CArrayAccessor on: (Array with: self bytesPerWord * 2 with: self bytesPerWord with: 0 with: 0).
transcript := Transcript.
displayForm := 'Display has not yet been installed' asDisplayText form.
!
Item was changed:
----- Method: InterpreterSimulator>>integerAt: (in category 'memory access') -----
integerAt: byteAddress
"Note: Adjusted for Smalltalk's 1-based array indexing."
+ ^objectMemory memory integerAt: (byteAddress // 4) + 1!
- ^memory integerAt: (byteAddress // 4) + 1!
Item was changed:
----- Method: InterpreterSimulator>>integerAt:put: (in category 'memory access') -----
integerAt: byteAddress put: a32BitValue
"Note: Adjusted for Smalltalk's 1-based array indexing."
+ ^objectMemory memory integerAt: (byteAddress // 4) + 1 put: a32BitValue!
- ^memory integerAt: (byteAddress // 4) + 1 put: a32BitValue!
Item was changed:
----- Method: InterpreterSimulator>>longAt: (in category 'memory access') -----
longAt: byteAddress
"Note: Adjusted for Smalltalk's 1-based array indexing."
+ ^objectMemory memory at: (byteAddress // 4) + 1!
- ^memory at: (byteAddress // 4) + 1!
Item was changed:
----- Method: InterpreterSimulator>>longAt:put: (in category 'memory access') -----
longAt: byteAddress put: a32BitValue
"Note: Adjusted for Smalltalk's 1-based array indexing."
+ ^objectMemory memory at: (byteAddress // 4) + 1 put: a32BitValue!
- ^memory at: (byteAddress // 4) + 1 put: a32BitValue!
Item was changed:
----- Method: InterpreterSimulator>>longPrint: (in category 'debug support') -----
longPrint: oop
| lastPtr val lastLong hdrType prevVal |
+ (objectMemory isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
- (self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
^ String streamContents:
[:strm |
+ lastPtr := 64 * bytesPerWord min: (objectMemory lastPointerOf: oop).
+ hdrType := objectMemory headerType: oop.
- lastPtr := 64 * bytesPerWord min: (self lastPointerOf: oop).
- hdrType := self headerType: oop.
hdrType = 2 ifTrue: [lastPtr := 0].
prevVal := 0.
(self headerStart: oop) to: lastPtr by: bytesPerWord do:
[:a | val := self longAt: oop+a.
(a > 0 and: [(val = prevVal) & (a ~= lastPtr)])
ifTrue:
[prevVal = (self longAt: oop + a - (bytesPerWord * 2)) ifFalse: [strm cr; nextPutAll: ' ...etc...']]
ifFalse:
[strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);
space; space; space; nextPutAll: val hex8; space; space.
a = (bytesPerWord * 2) negated ifTrue:
[strm nextPutAll: 'size = ' , (val - hdrType) hex].
a = bytesPerWord negated ifTrue:
[strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>'].
a = 0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)].
a > 0 ifTrue: [strm nextPutAll: (self shortPrint: val)].
a = bytesPerWord ifTrue:
+ [(objectMemory fetchClassOf: oop) = (objectMemory splObj: ClassCompiledMethod) ifTrue:
- [(self fetchClassOf: oop) = (self splObj: ClassCompiledMethod) ifTrue:
[strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]].
prevVal := val].
+ lastLong := 256 min: (objectMemory sizeBitsOf: oop) - objectMemory baseHeaderSize.
- lastLong := 256 min: (self sizeBitsOf: oop) - self baseHeaderSize.
hdrType = 2
ifTrue:
["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex;
space; space; nextPutAll: (oop+(self longAt: oop)-2) printString]
ifFalse:
+ [(objectMemory formatOf: oop) = 3
- [(self formatOf: oop) = 3
ifTrue:
[strm cr; tab; nextPutAll: '/ next 3 fields are above SP... /'.
lastPtr + bytesPerWord to: lastPtr+(3 * bytesPerWord) by: bytesPerWord do:
[:a | val := self longAt: oop+a.
strm cr; nextPutAll: a hex;
space; space; space; nextPutAll: val hex8; space; space.
(self validOop: val) ifTrue: [strm nextPutAll: (self shortPrint: val)]]]
ifFalse:
[lastPtr + bytesPerWord to: lastLong by: bytesPerWord do:
[:a | val := self longAt: oop+a.
strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);
space; space; space.
strm nextPutAll: val hex8; space; space;
nextPutAll: (self charsOfLong: val)]]].
]!
Item was changed:
----- Method: InterpreterSimulator>>lookupMethodInClass: (in category 'debug support') -----
lookupMethodInClass: class
| currentClass dictionary found rclass |
"This method overrides the interp, causing a halt on MNU."
"true ifTrue: [^ super lookupMethodInClass: class]." "Defeat debug support"
currentClass := class.
+ [currentClass ~= objectMemory nilObj]
- [currentClass ~= nilObj]
whileTrue:
+ [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
+ dictionary = objectMemory nilObj ifTrue:
- [dictionary := self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
- dictionary = nilObj ifTrue:
["MethodDict pointer is nil (hopefully due a swapped out stub)
-- raise exception #cannotInterpret:."
+ objectMemory pushRemappableOop: currentClass. "may cause GC!!"
- self pushRemappableOop: currentClass. "may cause GC!!"
self createActualMessageTo: class.
+ currentClass := objectMemory popRemappableOop.
+ messageSelector := objectMemory splObj: SelectorCannotInterpret.
- currentClass := self popRemappableOop.
- messageSelector := self splObj: SelectorCannotInterpret.
^ self lookupMethodInClass: (self superclassOf: currentClass)].
found := self lookupMethodInDictionary: dictionary.
found ifTrue: [^ methodClass := currentClass].
currentClass := self superclassOf: currentClass].
"Could not find #doesNotUnderstand: -- unrecoverable error."
+ messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue:
- messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue:
[self error: 'Recursive not understood error encountered'].
self halt: (self stringOf: messageSelector).
"Cound not find a normal message -- raise exception #doesNotUnderstand:"
+ objectMemory pushRemappableOop: class. "may cause GC!!"
- self pushRemappableOop: class. "may cause GC!!"
self createActualMessageTo: class.
+ rclass := objectMemory popRemappableOop.
+ messageSelector := objectMemory splObj: SelectorDoesNotUnderstand.
- rclass := self popRemappableOop.
- messageSelector := self splObj: SelectorDoesNotUnderstand.
^ self lookupMethodInClass: rclass!
Item was changed:
----- Method: InterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') -----
makeDirEntryName: entryName size: entryNameSize
createDate: createDate modDate: modifiedDate
isDir: dirFlag fileSize: fileSize
| modDateOop createDateOop nameString results |
self var: 'entryName' type: 'char *'.
"allocate storage for results, remapping newly allocated
oops in case GC happens during allocation"
+ objectMemory pushRemappableOop:
+ (objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 5).
+ objectMemory pushRemappableOop:
+ (objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: entryNameSize)..
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: createDate).
+ objectMemory pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
- self pushRemappableOop:
- (self instantiateClass: (self splObj: ClassArray) indexableSize: 5).
- self pushRemappableOop:
- (self instantiateClass: (self splObj: ClassString) indexableSize: entryNameSize)..
- self pushRemappableOop: (self positive32BitIntegerFor: createDate).
- self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
+ modDateOop := objectMemory popRemappableOop.
+ createDateOop := objectMemory popRemappableOop.
+ nameString := objectMemory popRemappableOop.
+ results := objectMemory popRemappableOop.
- modDateOop := self popRemappableOop.
- createDateOop := self popRemappableOop.
- nameString := self popRemappableOop.
- results := self popRemappableOop.
1 to: entryNameSize do: [ :i |
+ objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
- self storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
].
+ objectMemory storePointer: 0 ofObject: results withValue: nameString.
+ objectMemory storePointer: 1 ofObject: results withValue: createDateOop.
+ objectMemory storePointer: 2 ofObject: results withValue: modDateOop.
- self storePointer: 0 ofObject: results withValue: nameString.
- self storePointer: 1 ofObject: results withValue: createDateOop.
- self storePointer: 2 ofObject: results withValue: modDateOop.
dirFlag
+ ifTrue: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory trueObj ]
+ ifFalse: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory falseObj ].
+ objectMemory storePointer: 4 ofObject: results
+ withValue: (objectMemory integerObjectOf: fileSize).
- ifTrue: [ self storePointer: 3 ofObject: results withValue: trueObj ]
- ifFalse: [ self storePointer: 3 ofObject: results withValue: falseObj ].
- self storePointer: 4 ofObject: results
- withValue: (self integerObjectOf: fileSize).
^ results
!
Item was changed:
----- Method: InterpreterSimulator>>nameOfClass: (in category 'debug support') -----
nameOfClass: classOop
+ (objectMemory sizeBitsOf: classOop) = (Metaclass instSize + 1 * bytesPerWord) ifTrue:
- (self sizeBitsOf: classOop) = (Metaclass instSize + 1 * bytesPerWord) ifTrue:
[^ (self nameOfClass:
+ (objectMemory fetchPointer: 5 "thisClass" ofObject: classOop)) , ' class'].
+ ^ self stringOf: (objectMemory fetchPointer: 6 "name" ofObject: classOop)!
- (self fetchPointer: 5 "thisClass" ofObject: classOop)) , ' class'].
- ^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)!
Item was changed:
----- Method: InterpreterSimulator>>objectBefore: (in category 'testing') -----
objectBefore: addr
| oop prev |
+ oop := objectMemory firstObject.
+ [oop < objectMemory endOfMemory] whileTrue: [
- oop := self firstObject.
- [oop < endOfMemory] whileTrue: [
prev := oop. "look here if debugging prev obj overlapping this one"
+ oop := objectMemory objectAfter: oop.
- oop := self objectAfter: oop.
oop >= addr ifTrue: [^ prev]
]!
Item was added:
+ ----- Method: InterpreterSimulator>>objectMemory: (in category 'memory access') -----
+ objectMemory: anObjectMemory
+ objectMemory := anObjectMemory!
Item was changed:
----- Method: InterpreterSimulator>>openOn:extraMemory: (in category 'initialization') -----
openOn: fileName extraMemory: extraBytes
"InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"
| f headerSize count oldBaseAddr bytesToShift swapBytes hasPlatformFloatOrdering |
"open image file and read the header"
["begin ensure block..."
f := FileStream readOnlyFileNamed: fileName.
imageName := f fullName.
f binary.
swapBytes := self checkImageVersionFrom: f startingAt: 0.
"This interpreter does not use native float word order. Clear bit 1of format number."
imageFormatVersionNumber := imageFormatInitialVersion bitAnd: -2.
"If bit 1 was set set in the image file header, float word order must be normalized."
hasPlatformFloatOrdering := (imageFormatInitialVersion bitAnd: 1) = 1.
headerSize := self nextLongFrom: f swap: swapBytes.
+ objectMemory endOfMemory: (self nextLongFrom: f swap: swapBytes). "first unused location in heap"
- endOfMemory := self nextLongFrom: f swap: swapBytes. "first unused location in heap"
oldBaseAddr := self nextLongFrom: f swap: swapBytes. "object memory base address of image"
+ objectMemory specialObjectsOop: (self nextLongFrom: f swap: swapBytes).
+ objectMemory lastHash: (self nextLongFrom: f swap: swapBytes). "Should be loaded from, and saved to the image header"
+ objectMemory lastHash = 0 ifTrue: [objectMemory lastHash: 999].
- specialObjectsOop := self nextLongFrom: f swap: swapBytes.
- lastHash := self nextLongFrom: f swap: swapBytes. "Should be loaded from, and saved to the image header"
- lastHash = 0 ifTrue: [lastHash := 999].
savedWindowSize := self nextLongFrom: f swap: swapBytes.
fullScreenFlag := self oldFormatFullScreenFlag: (self nextLongFrom: f swap: swapBytes).
extraVMMemory := self nextLongFrom: f swap: swapBytes.
"allocate interpreter memory"
+ objectMemory memoryLimit: (objectMemory endOfMemory + extraBytes).
- memoryLimit := endOfMemory + extraBytes.
"read in the image in bulk, then swap the bytes if necessary"
f position: headerSize.
+ objectMemory memory: (Bitmap new: objectMemory memoryLimit // 4).
+ count := f readInto: objectMemory memory startingAt: 1 count: objectMemory endOfMemory // 4.
+ count ~= (objectMemory endOfMemory // 4) ifTrue: [self halt].
- memory := Bitmap new: memoryLimit // 4.
- count := f readInto: memory startingAt: 1 count: endOfMemory // 4.
- count ~= (endOfMemory // 4) ifTrue: [self halt].
]
ensure: [f close].
swapBytes ifTrue: [Utilities informUser: 'Swapping bytes of foreign image...'
during: [self reverseBytesInImage]].
self initialize.
bytesToShift := 0 - oldBaseAddr. "adjust pointers for zero base address"
+ objectMemory endOfMemory: objectMemory endOfMemory.
- endOfMemory := endOfMemory.
Utilities informUser: 'Relocating object pointers...'
during: [self initializeInterpreter: bytesToShift].
hasPlatformFloatOrdering ifTrue: [
"Low order bit set, indicating that the image was saved from
a StackInterpreter (Cog) VM. Storage of all Float objects must be
returned to older object memory format."
Utilities informUser: 'Swapping words in float objects...'
during: [self normalizeFloatOrderingInImage]].
!
Item was changed:
----- Method: InterpreterSimulator>>primBitmapdecompressfromByteArrayat (in category 'other primitives') -----
primBitmapdecompressfromByteArrayat
| indexInt index baOop bmOop baSize bmSize ba bm |
indexInt := self stackTop.
+ (objectMemory isIntegerValue: indexInt) ifFalse: [^ self primitiveFail].
+ index := objectMemory integerValueOf: indexInt.
- (self isIntegerValue: indexInt) ifFalse: [^ self primitiveFail].
- index := self integerValueOf: indexInt.
baOop := self stackValue: 1.
bmOop := self stackValue: 2.
baSize := self stSizeOf: baOop.
bmSize := self stSizeOf: bmOop.
ba := ByteArray new: baSize.
bm := Bitmap new: bmSize.
"Copy the byteArray into ba"
+ 1 to: baSize do: [:i | ba at: i put: (objectMemory fetchByte: i-1 ofObject: baOop)].
- 1 to: baSize do: [:i | ba at: i put: (self fetchByte: i-1 ofObject: baOop)].
"Decompress ba into bm"
bm decompress: bm fromByteArray: ba at: index.
"Then copy bm into the Bitmap"
+ 1 to: bmSize do: [:i | objectMemory storeLong32: i-1 ofObject: bmOop withValue: (bm at: i)].
- 1 to: bmSize do: [:i | self storeLong32: i-1 ofObject: bmOop withValue: (bm at: i)].
self pop: 3!
Item was changed:
----- Method: InterpreterSimulator>>primitiveBeDisplay (in category 'I/O primitives') -----
primitiveBeDisplay
"Extended to create a scratch Form for use by showDisplayBits."
| rcvr destWidth destHeight destDepth |
rcvr := self stackTop.
+ self success: ((objectMemory isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
- self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
self successful ifTrue: [
destWidth := self fetchInteger: 1 ofObject: rcvr.
destHeight := self fetchInteger: 2 ofObject: rcvr.
destDepth := self fetchInteger: 3 ofObject: rcvr.
].
self successful ifTrue: [
"create a scratch form the same size as Smalltalk displayObj"
displayForm := Form extent: destWidth @ destHeight
depth: destDepth.
displayView ifNotNil: [displayView image: displayForm].
].
super primitiveBeDisplay.!
Item was changed:
----- Method: InterpreterSimulator>>primitiveDirectoryLookup (in category 'file primitives') -----
primitiveDirectoryLookup
| index pathName array result |
index := self stackIntegerValue: 0.
pathName := (self stringOf: (self stackValue: 1)).
self successful ifFalse: [
^self primitiveFail.
].
array := FileDirectory default primLookupEntryIn: pathName index: index.
array == nil ifTrue: [
self pop: 3.
+ self push: objectMemory nilObj.
- self push: nilObj.
^array.
].
array == #badDirectoryPath ifTrue: [self halt.
^self primitiveFail.
].
result := self makeDirEntryName: (array at: 1) size: (array at: 1) size
createDate: (array at: 2) modDate: (array at: 3)
isDir: (array at: 4) fileSize: (array at: 5).
self pop: 3.
self push: result.
!
Item was changed:
----- Method: InterpreterSimulator>>primitiveFileDelete (in category 'file primitives') -----
primitiveFileDelete
| namePointer |
namePointer := self stackTop.
+ self success: (objectMemory isBytes: namePointer).
- self success: (self isBytes: namePointer).
self success: (StandardFileStream isAFileNamed: (self stringOf: namePointer)).
self successful ifTrue: [FileDirectory deleteFilePath: (self stringOf: namePointer)].
self successful ifTrue: [self pop: 1]. "pop fileName; leave rcvr on stack"
!
Item was changed:
----- Method: InterpreterSimulator>>primitiveFileOpen (in category 'file primitives') -----
primitiveFileOpen
| namePointer writeFlag fileName f |
writeFlag := self booleanValueOf: self stackTop.
namePointer := self stackValue: 1.
+ self success: (objectMemory isBytes: namePointer).
- self success: (self isBytes: namePointer).
self successful ifTrue:
[fileName := self stringOf: namePointer.
filesOpen addLast: (writeFlag
ifTrue: [f := FileStream fileNamed: fileName.
f ifNil: [^ self primitiveFail] ifNotNil: [f binary]]
ifFalse: [(StandardFileStream isAFileNamed: fileName)
ifTrue: [f := (FileStream readOnlyFileNamed: fileName).
f ifNil:[^self primitiveFail] ifNotNil:[f binary]]
ifFalse: [^ self primitiveFail]]).
self pop: 3 thenPushInteger: filesOpen size]!
Item was changed:
----- Method: InterpreterSimulator>>primitiveFileRename (in category 'file primitives') -----
primitiveFileRename
| oldNamePointer newNamePointer f |
oldNamePointer := self stackTop.
newNamePointer := self stackValue: 1.
+ self success: (objectMemory isBytes: oldNamePointer).
+ self success: (objectMemory isBytes: newNamePointer).
- self success: (self isBytes: oldNamePointer).
- self success: (self isBytes: newNamePointer).
self success: (StandardFileStream isAFileNamed: (self stringOf: oldNamePointer)).
self success: (StandardFileStream isAFileNamed: (self stringOf: newNamePointer)) not.
self successful ifTrue: [
f := FileStream oldFileNamed: (self stringOf: oldNamePointer).
f rename: (self stringOf: newNamePointer).
f close.
].
self successful ifTrue: [
self pop: 2. "oldName, newName; leave rcvr on stack"
].!
Item was changed:
----- Method: InterpreterSimulator>>primitiveGetAttribute (in category 'other primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."
| attr s attribute |
attr := self stackIntegerValue: 0.
self successful ifTrue: [
attribute := Smalltalk getSystemAttribute: attr.
attribute ifNil: [ ^self primitiveFail ].
+ s := objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: attribute size.
- s := self instantiateClass: (self splObj: ClassString) indexableSize: attribute size.
1 to: attribute size do: [ :i |
+ objectMemory storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
- self storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
self pop: 2. "rcvr, attr"
self push: s].
!
Item was changed:
----- Method: InterpreterSimulator>>primitiveImageName (in category 'file primitives') -----
primitiveImageName
"Note: For now, this only implements getting, not setting, the image file name."
| result imageNameSize |
self pop: 1.
imageNameSize := imageName size.
+ result := objectMemory instantiateClass: (objectMemory splObj: ClassString)
- result := self instantiateClass: (self splObj: ClassString)
indexableSize: imageNameSize.
1 to: imageNameSize do:
+ [:i | objectMemory storeByte: i-1 ofObject: result
- [:i | self storeByte: i-1 ofObject: result
withValue: (imageName at: i) asciiValue].
self push: result.!
Item was changed:
----- Method: InterpreterSimulator>>primitiveKbdNext (in category 'I/O primitives') -----
primitiveKbdNext
self pop: 1.
Sensor keyboardPressed
ifTrue: [self pushInteger: Sensor primKbdNext]
+ ifFalse: [self push: objectMemory nilObj]!
- ifFalse: [self push: nilObj]!
Item was changed:
----- Method: InterpreterSimulator>>primitiveKbdPeek (in category 'I/O primitives') -----
primitiveKbdPeek
self pop: 1.
Sensor keyboardPressed
ifTrue: [self pushInteger: Sensor primKbdPeek]
+ ifFalse: [self push: objectMemory nilObj]!
- ifFalse: [self push: nilObj]!
Item was changed:
----- Method: InterpreterSimulator>>printStack: (in category 'debug support') -----
printStack: includeTemps
| ctxt |
ctxt := activeContext.
^ String streamContents:
[:strm |
[self printStackFrame: ctxt onStream: strm.
includeTemps ifTrue: [self printStackTemps: ctxt onStream: strm].
+ (ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory nilObj]
- (ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj]
whileFalse: [].
]!
Item was changed:
----- Method: InterpreterSimulator>>printStackFrame:onStream: (in category 'debug support') -----
printStackFrame: ctxt onStream: strm
| classAndSel home |
+ home := (objectMemory fetchClassOf: ctxt) = (objectMemory splObj: ClassBlockContext)
+ ifTrue: [objectMemory fetchPointer: HomeIndex ofObject: ctxt]
- home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
- ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
ifFalse: [ctxt].
classAndSel := self
+ classAndSelectorOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
+ forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
- classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
- forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
strm cr; nextPutAll: ctxt hex8.
ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
strm space; nextPutAll: (self nameOfClass: classAndSel first).
strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
!
Item was changed:
----- Method: InterpreterSimulator>>printStackTemps:onStream: (in category 'debug support') -----
printStackTemps: ctxt onStream: strm
| home cMethod nArgs nTemps oop |
+ home := (objectMemory fetchClassOf: ctxt) = (objectMemory splObj: ClassBlockContext)
+ ifTrue: [objectMemory fetchPointer: HomeIndex ofObject: ctxt]
- home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
- ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
ifFalse: [ctxt].
+ cMethod := objectMemory fetchPointer: MethodIndex ofObject: home.
- cMethod := self fetchPointer: MethodIndex ofObject: home.
nArgs := nTemps := 0.
home = ctxt ifTrue:
[strm cr; tab; nextPutAll: 'args: '.
nArgs := self argumentCountOf: cMethod.
1 to: nArgs do:
+ [:i | oop := objectMemory fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
- [:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space].
strm cr; tab; nextPutAll: 'temps: '.
nTemps := self tempCountOf: cMethod.
nArgs+1 to: nTemps do:
+ [:i | oop := objectMemory fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
- [:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space]].
strm cr; tab; nextPutAll: 'stack: '.
+ nTemps + 1 to: (objectMemory lastPointerOf: ctxt)//bytesPerWord - TempFrameStart do:
+ [:i | oop := objectMemory fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
- nTemps + 1 to: (self lastPointerOf: ctxt)//bytesPerWord - TempFrameStart do:
- [:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space].
!
Item was changed:
----- Method: InterpreterSimulator>>printTop: (in category 'debug support') -----
printTop: n
"Print important fields of the top n contexts"
| ctxt classAndSel home top ip sp |
ctxt := activeContext.
^ String streamContents:
[:strm | 1 to: n do:
[:i |
+ home := (objectMemory fetchClassOf: ctxt) = (objectMemory splObj: ClassBlockContext)
+ ifTrue: [objectMemory fetchPointer: HomeIndex ofObject: ctxt]
- home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
- ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
ifFalse: [ctxt].
classAndSel := self
+ classAndSelectorOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
+ forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
- classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
- forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
strm cr; nextPutAll: ctxt hex8.
ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
strm space; nextPutAll: (self nameOfClass: classAndSel first).
strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
ctxt = activeContext
+ ifTrue: [ip := instructionPointer - method - (objectMemory baseHeaderSize - 2).
- ifTrue: [ip := instructionPointer - method - (self baseHeaderSize - 2).
sp := self stackPointerIndex - TempFrameStart + 1.
top := self stackTop]
+ ifFalse: [ip := objectMemory integerValueOf:
+ (objectMemory fetchPointer: InstructionPointerIndex ofObject: ctxt).
+ sp := objectMemory integerValueOf:
+ (objectMemory fetchPointer: StackPointerIndex ofObject: ctxt).
+ top := self longAt: ctxt + (objectMemory lastPointerOf: ctxt)].
- ifFalse: [ip := self integerValueOf:
- (self fetchPointer: InstructionPointerIndex ofObject: ctxt).
- sp := self integerValueOf:
- (self fetchPointer: StackPointerIndex ofObject: ctxt).
- top := self longAt: ctxt + (self lastPointerOf: ctxt)].
strm cr; tab; nextPutAll: 'ip = '; print: ip.
strm cr; tab; nextPutAll: 'sp = '; print: sp.
strm cr; tab; nextPutAll: 'top = '; nextPutAll: (self shortPrint: top).
+ (ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory nilObj
- (ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj
ifTrue: [^strm contents].
].
]!
Item was added:
+ ----- Method: InterpreterSimulator>>readableFormat: (in category 'image save/restore') -----
+ readableFormat: imageVersion
+ "Anwer true if images of the given format are readable by this interpreter. Allows
+ a virtual machine to accept selected older image formats. In our case we can
+ select a newer (closure) image format as well as the existing format. Images with
+ platform-ordered floats (StackInterpreter and Cog format) are readable but will be
+ converted to traditional word ordering."
+
+ self bytesPerWord = 4
+ ifTrue: [^ (imageVersion = 6502 "Original 32-bit Squeak image format"
+ or: [imageVersion = 6504]) "32-bit with closures"
+ or: [imageVersion = 6505]] "32-bit with closures and platform-ordered floats"
+ ifFalse: [^ (imageVersion = 68000 "Original 64-bit Squeak image format"
+ or: [imageVersion = 68002]) "64-bit with closures"
+ or: [imageVersion = 68003]] "64-bit with closures and platform-ordered floats"
+ !
Item was changed:
----- Method: InterpreterSimulator>>reverseBytesFrom:to: (in category 'initialization') -----
reverseBytesFrom: begin to: end
"Byte-swap the given range of memory (not inclusive!!)."
| wordAddr |
wordAddr := begin.
+ objectMemory memory swapBytesFrom: wordAddr // 4 + 1 to: end // 4!
- memory swapBytesFrom: wordAddr // 4 + 1 to: end // 4!
Item was changed:
----- Method: InterpreterSimulator>>rewriteImageFileNamed: (in category 'image save/restore') -----
rewriteImageFileNamed: fileName
"Write an image file on a file named fileName using the window size that
was provided by the original image file. This is intended for rewriting an
image file that has been read from a disk file, but that has not yet been
run in the interpreter. This may be used to load an image file that had been
saved by another type of interpreter, and resaving it in the format used by
this interpreter. For example, an image that has been saved as format 6505
(indicating use of native float word ordering for a Cog VM) may be resaved
in format 6504."
"(InterpreterSimulator new openOn: Smalltalk imageName) rewriteImageFileNamed: 'newimagefile.image' "
| file numberOfBytesToWrite |
bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
+ numberOfBytesToWrite := objectMemory freeBlock - objectMemory startOfMemory.
- numberOfBytesToWrite := freeBlock - self startOfMemory.
[
file := (FileStream fileNamed: fileName) binary.
file == nil ifTrue: [^nil].
Utilities informUser: 'Writing image to ''', fileName, '''...'
during: [self writeImageFile: file size: numberOfBytesToWrite screenSize: savedWindowSize]
]
ensure: [file close]!
Item was changed:
----- Method: InterpreterSimulator>>shortPrint: (in category 'debug support') -----
shortPrint: oop
| name classOop |
+ (objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString ,
+ ' (' , (objectMemory integerValueOf: oop) hex , ')'].
+ classOop := objectMemory fetchClassOf: oop.
+ (objectMemory sizeBitsOf: classOop) = (Metaclass instSize + 1 * bytesPerWord) ifTrue: [
- (self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString ,
- ' (' , (self integerValueOf: oop) hex , ')'].
- classOop := self fetchClassOf: oop.
- (self sizeBitsOf: classOop) = (Metaclass instSize + 1 * bytesPerWord) ifTrue: [
^ 'class ' , (self nameOfClass: oop)].
name := self nameOfClass: classOop.
name size = 0 ifTrue: [name := '??'].
name = 'String' ifTrue: [^ (self stringOf: oop) printString].
name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
+ name = 'Character' ifTrue: [^ '=' , (Character value: (objectMemory integerValueOf:
+ (objectMemory fetchPointer: 0 ofObject: oop))) printString].
- name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf:
- (self fetchPointer: 0 ofObject: oop))) printString].
name = 'UndefinedObject' ifTrue: [^ 'nil'].
name = 'False' ifTrue: [^ 'false'].
name = 'True' ifTrue: [^ 'true'].
name = 'Float' ifTrue: [self initPrimCall. ^ '=' , (self floatValueOf: oop) printString].
name = 'Association' ifTrue: [^ '(' ,
+ (self shortPrint: (self longAt: oop + objectMemory baseHeaderSize)) ,
- (self shortPrint: (self longAt: oop + self baseHeaderSize)) ,
' -> ' ,
+ (self longAt: oop + objectMemory baseHeaderSize + bytesPerWord) hex8 , ')'].
- (self longAt: oop + self baseHeaderSize + bytesPerWord) hex8 , ')'].
('AEIOU' includes: name first)
ifTrue: [^ 'an ' , name]
ifFalse: [^ 'a ' , name]!
Item was changed:
----- Method: InterpreterSimulator>>showDisplayBits:w:h:d:left:right:top:bottom: (in category 'I/O primitives') -----
showDisplayBits: destBits w: w h: h d: d left: left right: right top: top bottom: bottom
| raster pixPerWord simDisp realDisp rect |
pixPerWord := 32 // d.
raster := displayForm width + (pixPerWord - 1) // pixPerWord.
+ simDisp := Form new hackBits: objectMemory memory.
- simDisp := Form new hackBits: memory.
displayForm unhibernate.
realDisp := Form new hackBits: displayForm bits.
realDisp
copy: (0 @ (top * raster) extent: 4 @ (bottom - top * raster))
from: 0 @ (destBits // 4 + (top * raster))
in: simDisp
rule: Form over.
displayView ifNotNil: [^ displayView changed].
"If running without a view, just blat the bits onto the screen..."
rect := 0 @ top corner: displayForm width @ bottom.
Display
copy: (rect translateBy: self displayLocation)
from: rect topLeft
in: displayForm
rule: Form over!
Item was changed:
----- Method: InterpreterSimulator>>sqGrowMemory:By: (in category 'memory access') -----
sqGrowMemory: oldLimit By: delta
transcript show: 'grow memory from ', oldLimit printString, ' by ', delta printString; cr.
+ objectMemory memory: objectMemory memory , (objectMemory memory class new: delta // 4).
+ ^ objectMemory memory size * 4!
- memory := memory , (memory class new: delta // 4).
- ^ memory size * 4!
Item was changed:
----- Method: InterpreterSimulator>>stackDepth (in category 'testing') -----
stackDepth
| ctxt n |
ctxt := activeContext.
n := 0.
+ [(ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory nilObj]
- [(ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj]
whileFalse: [n := n+1].
^ n!
Item was changed:
----- Method: InterpreterSimulator>>stats (in category 'testing') -----
stats
| oop fieldAddr fieldOop last stats v d |
stats := Bag new.
+ oop := objectMemory firstObject.
- oop := self firstObject.
'Scanning the image...' displayProgressAt: Sensor cursorPoint
+ from: oop to: objectMemory endOfMemory
- from: oop to: endOfMemory
during: [:bar |
+ [oop < objectMemory endOfMemory] whileTrue:
+ [(objectMemory isFreeObject: oop) ifFalse:
- [oop < endOfMemory] whileTrue:
- [(self isFreeObject: oop) ifFalse:
[stats add: #objects.
+ fieldAddr := oop + (objectMemory lastPointerOf: oop).
- fieldAddr := oop + (self lastPointerOf: oop).
[fieldAddr > oop] whileTrue:
[fieldOop := self longAt: fieldAddr.
+ (objectMemory isIntegerObject: fieldOop)
+ ifTrue: [v := objectMemory integerValueOf: fieldOop.
- (self isIntegerObject: fieldOop)
- ifTrue: [v := self integerValueOf: fieldOop.
(v between: -16000 and: 16000)
ifTrue: [stats add: #ints32k]
ifFalse: [stats add: #intsOther]]
+ ifFalse: [fieldOop = objectMemory nilObj ifTrue: [stats add: #nil]
- ifFalse: [fieldOop = nilObj ifTrue: [stats add: #nil]
ifFalse:
[d := fieldOop - oop.
(d between: -16000 and: 16000)
ifTrue: [stats add: #oops32k]
ifFalse: [stats add: #oopsOther]]].
fieldAddr := fieldAddr - bytesPerWord]].
bar value: oop.
last := oop.
last := last.
+ oop := objectMemory objectAfter: oop]].
- oop := self objectAfter: oop]].
^ stats sortedElements!
Item was changed:
----- Method: InterpreterSimulator>>storeAndPopReceiverVariableBytecode (in category 'bytecode routines') -----
storeAndPopReceiverVariableBytecode
"Note: This code uses storePointerUnchecked:ofObject:withValue: and does the store check explicitely in order to help the translator produce better code."
"Interpreter version has fetchNextBytecode out of order"
| rcvr top |
rcvr := receiver.
top := self internalStackTop.
+ (rcvr < objectMemory youngStart) ifTrue: [
+ objectMemory possibleRootStoreInto: rcvr value: top.
- (rcvr < youngStart) ifTrue: [
- self possibleRootStoreInto: rcvr value: top.
].
+ objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7)
- self storePointerUnchecked: (currentBytecode bitAnd: 7)
ofObject: rcvr
withValue: top.
self internalPop: 1.
self fetchNextBytecode.
!
Item was changed:
----- Method: InterpreterSimulator>>storeAndPopTemporaryVariableBytecode (in category 'bytecode routines') -----
storeAndPopTemporaryVariableBytecode
"Interpreter version has fetchNextBytecode out of order"
+ objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
- self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
ofObject: localHomeContext
withValue: self internalStackTop.
self internalPop: 1.
self fetchNextBytecode.
!
Item was changed:
----- Method: InterpreterSimulator>>stringOf: (in category 'debug support') -----
stringOf: oop
| size long nLongs chars |
^ String streamContents:
[:strm |
size := 100 min: (self stSizeOf: oop).
nLongs := size - 1 // bytesPerWord + 1.
1 to: nLongs do:
+ [:i | long := self longAt: oop + objectMemory baseHeaderSize + (i - 1 * bytesPerWord).
- [:i | long := self longAt: oop + self baseHeaderSize + (i - 1 * bytesPerWord).
chars := self charsOfLong: long.
strm nextPutAll: (i=nLongs
ifTrue: [chars copyFrom: 1 to: size - 1 \\ bytesPerWord + 1]
ifFalse: [chars])]]!
Item was changed:
----- Method: InterpreterSimulator>>testBecome (in category 'testing') -----
testBecome
"Become some young things. AA testBecome "
| array list1 list2 p1 p2 p3 p4 |
+ array := objectMemory splObj: ClassArray.
+ list1 := objectMemory instantiateClass: array indexableSize: 2.
+ list2 := objectMemory instantiateClass: array indexableSize: 2.
+ p1 := objectMemory instantiateClass: (objectMemory splObj: ClassPoint) indexableSize: 0.
- array := self splObj: ClassArray.
- list1 := self instantiateClass: array indexableSize: 2.
- list2 := self instantiateClass: array indexableSize: 2.
- p1 := self instantiateClass: (self splObj: ClassPoint) indexableSize: 0.
self push: p1.
+ objectMemory storePointer: 0 ofObject: list1 withValue: p1.
+ p2 := objectMemory instantiateClass: (objectMemory splObj: ClassPoint) indexableSize: 0.
- self storePointer: 0 ofObject: list1 withValue: p1.
- p2 := self instantiateClass: (self splObj: ClassPoint) indexableSize: 0.
self push: p2.
+ objectMemory storePointer: 1 ofObject: list1 withValue: p2.
+ p3 := objectMemory instantiateClass: (objectMemory splObj: ClassMessage) indexableSize: 0.
- self storePointer: 1 ofObject: list1 withValue: p2.
- p3 := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
self push: p3.
+ objectMemory storePointer: 0 ofObject: list2 withValue: p3.
+ p4 := objectMemory instantiateClass: (objectMemory splObj: ClassMessage) indexableSize: 0.
- self storePointer: 0 ofObject: list2 withValue: p3.
- p4 := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
self push: p4.
+ objectMemory storePointer: 1 ofObject: list2 withValue: p4.
+ (objectMemory become: list1 with: list2 twoWay: true copyHash: true) ifFalse: [self error: 'failed'].
- self storePointer: 1 ofObject: list2 withValue: p4.
- (self become: list1 with: list2 twoWay: true copyHash: true) ifFalse: [self error: 'failed'].
self popStack = p2 ifFalse: [self halt].
self popStack = p1 ifFalse: [self halt].
self popStack = p4 ifFalse: [self halt].
self popStack = p3 ifFalse: [self halt].
+ (objectMemory fetchPointer: 0 ofObject: list1) = p3 ifFalse: [self halt].
+ (objectMemory fetchPointer: 1 ofObject: list1) = p4 ifFalse: [self halt].
+ (objectMemory fetchPointer: 0 ofObject: list2) = p1 ifFalse: [self halt].
+ (objectMemory fetchPointer: 1 ofObject: list2) = p2 ifFalse: [self halt].!
- (self fetchPointer: 0 ofObject: list1) = p3 ifFalse: [self halt].
- (self fetchPointer: 1 ofObject: list1) = p4 ifFalse: [self halt].
- (self fetchPointer: 0 ofObject: list2) = p1 ifFalse: [self halt].
- (self fetchPointer: 1 ofObject: list2) = p2 ifFalse: [self halt].!
Item was changed:
----- Method: InterpreterSimulator>>validOop: (in category 'testing') -----
validOop: oop
" Return true if oop appears to be valid "
(oop bitAnd: 1) = 1 ifTrue: [^ true]. "Integer"
(oop bitAnd: 3) = 0 ifFalse: [^ false]. "Uneven address"
+ oop >= objectMemory endOfMemory ifTrue: [^ false]. "Out of range"
- oop >= endOfMemory ifTrue: [^ false]. "Out of range"
"could test if within the first large freeblock"
(self longAt: oop) = 4 ifTrue: [^ false].
+ (objectMemory headerType: oop) = 2 ifTrue: [^ false]. "Free object"
- (self headerType: oop) = 2 ifTrue: [^ false]. "Free object"
^ true!
Item was changed:
----- Method: InterpreterSimulator>>validate (in category 'testing') -----
validate
| oop prev |
transcript show: 'Validating...'.
+ oop := objectMemory firstObject.
+ [oop < objectMemory endOfMemory] whileTrue: [
- oop := self firstObject.
- [oop < endOfMemory] whileTrue: [
self validate: oop.
prev := oop. "look here if debugging prev obj overlapping this one"
+ oop := objectMemory objectAfter: oop.
- oop := self objectAfter: oop.
].
prev := prev. "Don't offer to delete this please"
transcript show: 'done.'; cr!
Item was changed:
----- Method: InterpreterSimulator>>validate: (in category 'testing') -----
validate: oop
| header type cc sz fmt nextChunk |
header := self longAt: oop.
type := header bitAnd: 3.
+ type = 2 ifFalse: [type = (objectMemory rightType: header) ifFalse: [self halt]].
+ sz := (header bitAnd: objectMemory sizeMask) >> 2.
+ (objectMemory isFreeObject: oop)
+ ifTrue: [ nextChunk := oop + (objectMemory sizeOfFree: oop) ]
+ ifFalse: [ nextChunk := oop + (objectMemory sizeBitsOf: oop) ].
+ nextChunk > objectMemory endOfMemory
+ ifTrue: [oop = objectMemory endOfMemory ifFalse: [self halt]].
+ (objectMemory headerType: nextChunk) = 0 ifTrue: [
+ (objectMemory headerType: (nextChunk + (bytesPerWord * 2))) = 0 ifFalse: [self halt]].
+ (objectMemory headerType: nextChunk) = 1 ifTrue: [
+ (objectMemory headerType: (nextChunk + bytesPerWord)) = 1 ifFalse: [self halt]].
- type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].
- sz := (header bitAnd: self sizeMask) >> 2.
- (self isFreeObject: oop)
- ifTrue: [ nextChunk := oop + (self sizeOfFree: oop) ]
- ifFalse: [ nextChunk := oop + (self sizeBitsOf: oop) ].
- nextChunk > endOfMemory
- ifTrue: [oop = endOfMemory ifFalse: [self halt]].
- (self headerType: nextChunk) = 0 ifTrue: [
- (self headerType: (nextChunk + (bytesPerWord * 2))) = 0 ifFalse: [self halt]].
- (self headerType: nextChunk) = 1 ifTrue: [
- (self headerType: (nextChunk + bytesPerWord)) = 1 ifFalse: [self halt]].
type = 2 ifTrue:
["free block" ^ self].
fmt := (header >> 8) bitAnd: 16rF.
cc := (header >> 12) bitAnd: 31.
cc > 16 ifTrue: [self halt]. "up to 32 are legal, but not used"
type = 0 ifTrue:
["three-word header"
((self longAt: oop - bytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
((self longAt: oop-(bytesPerWord * 2)) bitAnd: 3) = type ifFalse: [self halt].
((self longAt: oop - bytesPerWord) = type) ifTrue: [self halt]. "Class word is 0"
sz = 0 ifFalse: [self halt]].
type = 1 ifTrue:
["two-word header"
((self longAt: oop - bytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
sz = 0 ifTrue: [self halt]].
type = 3 ifTrue:
["one-word header"
cc = 0 ifTrue: [self halt]].
fmt = 5 ifTrue: [self halt].
fmt = 7 ifTrue: [self halt].
fmt >= 12 ifTrue:
["CompiledMethod -- check for integer header"
+ (objectMemory isIntegerObject: (self longAt: oop + bytesPerWord)) ifFalse: [self halt]].!
- (self isIntegerObject: (self longAt: oop + bytesPerWord)) ifFalse: [self halt]].!
Item was changed:
----- Method: InterpreterSimulator>>validateOopsIn: (in category 'testing') -----
validateOopsIn: object
| fieldPtr limit former header |
"for each oop in me see if it is legal"
+ fieldPtr := object + objectMemory baseHeaderSize. "first field"
+ limit := object + (objectMemory lastPointerOf: object). "a good field"
- fieldPtr := object + self baseHeaderSize. "first field"
- limit := object + (self lastPointerOf: object). "a good field"
[fieldPtr > limit] whileFalse: [
former := self longAt: fieldPtr.
(self validOop: former) ifFalse: [self error: 'invalid oop in pointers object'].
fieldPtr := fieldPtr + bytesPerWord].
"class"
+ header := objectMemory baseHeader: object.
- header := self baseHeader: object.
(header bitAnd: CompactClassMask) = 0 ifTrue: [
+ former := (objectMemory classHeader: object) bitAnd: objectMemory allButTypeMask.
- former := (self classHeader: object) bitAnd: self allButTypeMask.
(self validOop: former) ifFalse: [self halt]].!
Item was changed:
----- Method: InterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') -----
vmPathGet: stringBase Length: stringSize
| pathName stringOop |
pathName := Smalltalk vmPath.
+ stringOop := stringBase - objectMemory baseHeaderSize. "Due to C call in Interp"
- stringOop := stringBase - self baseHeaderSize. "Due to C call in Interp"
1 to: stringSize do:
+ [:i | objectMemory storeByte: i-1 ofObject: stringOop
- [:i | self storeByte: i-1 ofObject: stringOop
withValue: (pathName at: i) asciiValue].
!
Item was changed:
----- Method: InterpreterSimulator>>writeImageFile:size:screenSize: (in category 'image save/restore') -----
writeImageFile: file size: numberOfBytesToWrite screenSize: screenSize
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize |
self bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
+ headerSize := 16 * self bytesPerWord.
- headerSize := 16 * bytesPerWord.
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
+ objectMemory startOfMemory.
+ objectMemory specialObjectsOop.
+ objectMemory lastHash.
- self startOfMemory.
- specialObjectsOop.
- lastHash.
screenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
"Pad the rest of the header."
7 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
1 to: numberOfBytesToWrite // 4
do: [:index |
self
+ putLong: (objectMemory memory at: index)
- putLong: (memory at: index)
toFile: file].
self success: true
!
Item was changed:
----- Method: InterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: numberOfBytesToWrite
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize file |
+ bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
- self bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
headerSize := 16 * bytesPerWord.
[
file := (FileStream fileNamed: imageName) binary.
file == nil ifTrue: [^nil].
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
+ objectMemory startOfMemory.
+ objectMemory specialObjectsOop.
+ objectMemory lastHash.
- self startOfMemory.
- specialObjectsOop.
- lastHash.
self ioScreenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
"Pad the rest of the header."
7 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
1
to: numberOfBytesToWrite // 4
do: [:index |
self
+ putLong: (objectMemory memory at: index)
- putLong: (memory at: index)
toFile: file].
self success: true
]
ensure: [file close]!
Item was changed:
----- Method: InterpreterSimulatorLSB>>displayForm: (in category 'debug support') -----
displayForm: f
| width height depth bits realForm simDisp realDisp |
+ bits := objectMemory fetchPointer: 0 ofObject: f.
- bits := self fetchPointer: 0 ofObject: f.
width := self fetchInteger: 1 ofObject: f.
height := self fetchInteger: 2 ofObject: f.
depth := self fetchInteger: 3 ofObject: f.
realForm := Form extent: width@height depth: depth.
+ simDisp := Form new hackBits: objectMemory memory.
- simDisp := Form new hackBits: memory.
realDisp := Form new hackBits: realForm bits.
realDisp
copy: (0 @ 0 extent: 4 @ realForm bits size)
from: (0 @ (bits + 4 // 4))
in: simDisp
rule: Form over.
realForm displayOn: Display at: 0@0.!
Item was changed:
----- Method: Object class>>prepareToBeAddedToCodeGenerator: (in category '*VMMaker-translation') -----
prepareToBeAddedToCodeGenerator: aCCodeGenerator
"Hook for translation. e.g. allows a subclass to override its
superclass's methods by deleting them before it adds its own."!
Item was changed:
+ VMClass subclass: #ObjectMemory
+ instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcSemaphoreIndex gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statFullGCMSecs statFullGCUsecs statIncrGCs statIncrGCMSecs statIncrGCUsecs statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statGCTime statSpecialMarkCount statIGCDeltaTime statpendingFinalizationSignals forceTenureFlag gcStartUsecs'
+ classVariableNames: 'Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask ClassPseudoContext ClassTranslatedMethod ContextFixedSizePlusHeader Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeFree HeaderTypeGC InvokeCallbackSelector NilContext RemapBufferSize RootTableRedZone RootTableSize StartField StartObj Upward'
+ poolDictionaries: 'VMBasicConstants VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants'
- Object subclass: #ObjectMemory
- instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcSemaphoreIndex gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statFullGCMSecs statFullGCUsecs statIncrGCs statIncrGCMSecs statIncrGCUsecs statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statGCTime statSpecialMarkCount statIGCDeltaTime statpendingFinalizationSignals forceTenureFlag gcStartUsecs'
- classVariableNames: 'BlockContextProto Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask ClassPseudoContext ClassTranslatedMethod ContextFixedSizePlusHeader DoAssertionChecks DoBalanceChecks Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeFree HeaderTypeGC InvokeCallbackSelector MethodContextProto NilContext RemapBufferSize RootTableRedZone RootTableSize StackStart StartField StartObj Upward'
- poolDictionaries: 'VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants'
category: 'VMMaker-Interpreter'!
ObjectMemory class
instanceVariableNames: 'timeStamp'!
!ObjectMemory commentStamp: '<historical>' prior: 0!
This class describes a 32-bit direct-pointer object memory for Smalltalk. The model is very simple in principle: a pointer is either a SmallInteger or a 32-bit direct object pointer.
SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.
All object pointers point to a header, which may be followed by a number of data fields. This object memory achieves considerable compactness by using a variable header size (the one complexity of the design). The format of the 0th header word is as follows:
3 bits reserved for gc (mark, root, unused)
12 bits object hash (for HashSets)
5 bits compact class index
4 bits object format
6 bits object size in 32-bit words
2 bits header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)
If a class is in the compact class table, then this is the only header information needed. If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits. It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.
The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).
This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers. It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.
There is now a simple 64-bit version of the object memory. It is the simplest possible change that could work. It merely sign-extends all integer oops, and extends all object headers and oops by adding 32 zeroes in the high bits. The format of the base header word is changed in one minor, not especially elegant, way. Consider the old 32-bit header:
ggghhhhhhhhhhhhcccccffffsssssstt
The 64-bit header is almost identical, except that the size field (now being in units of 8 bytes, has a zero in its low-order bit. At the same time, the byte-size residue bits for byte objects, which are in the low order bits of formats 8-11 and 12-15, are now in need of another bit of residue. So, the change is as follows:
ggghhhhhhhhhhhhcccccffffsssssrtt
where bit r supplies the 4's bit of the byte size residue for byte objects. Oh, yes, this is also needed now for 'variableWord' objects, since their size in 32-bit words requires a low-order bit.
See the comment in formatOf: for the change allowing for 64-bit wide bitmaps, now dubbed 'variableLong'.!
ObjectMemory class
instanceVariableNames: 'timeStamp'!
Item was removed:
- ----- Method: ObjectMemory class>>declareCAsOop:in: (in category 'translation') -----
- declareCAsOop: arrayOfVariableNames in: aCCodeGenerator
- "Declare the variables in arrayOfVariableNames with type representing position in object memory."
-
- arrayOfVariableNames
- do: [:varName | aCCodeGenerator var: varName type: 'usqInt']!
Item was changed:
----- Method: ObjectMemory class>>initialize (in category 'initialization') -----
initialize
+ "ObjectMemory initialize"
self initializeConstants.
+ self initializePrimitiveErrorCodes.
+ self initializeCompactClassIndices.
+ self initializeObjectHeaderConstants.
+ self initializeObjectWordConstants.
+ self initializePrimitiveErrorCodes.
+ self initializeSmallIntegers.
+ self initializeSpecialObjectIndices!
- self initializePrimitiveErrorCodes.!
Item was removed:
- ----- Method: ObjectMemory 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.
- VMMaker addMemoryAccessTo: cg.
- ^cg
- !
Item was changed:
----- Method: ObjectMemory class>>initializeConstants (in category 'initialization') -----
initializeConstants
"ObjectMemory initializeConstants"
self initializeObjectWordConstants.
"Translation flags (booleans that control code generation via conditional translation):"
DoAssertionChecks := false. "generate assertion checks"
- DoBalanceChecks := false. "generate stack balance checks"
self initializeSpecialObjectIndices.
self initializeObjectHeaderConstants.
CtxtTempFrameStart := 6. "Copy of TempFrameStart in Interp"
ContextFixedSizePlusHeader := CtxtTempFrameStart + 1.
LargeContextBit := 16r40000. "This bit set in method headers if large context is needed."
NilContext := 1. "the oop for the integer 0; used to mark the end of context lists"
RemapBufferSize := 25.
RootTableSize := 2500. "number of root table entries (4 bytes/entry)"
RootTableRedZone := RootTableSize - 100. "red zone of root table - when reached we force IGC"
"tracer actions"
StartField := 1.
StartObj := 2.
Upward := 3.
Done := 4.
ExtraRootSize := 2048. "max. # of external roots"!
Item was added:
+ ----- Method: ObjectMemory class>>initializeSmallIntegers (in category 'initialization') -----
+ initializeSmallIntegers
+ "SmallIntegers"
+ ConstMinusOne := ObjectMemory new integerObjectOf: -1.
+ ConstZero := ObjectMemory new integerObjectOf: 0.
+ ConstOne := ObjectMemory new integerObjectOf: 1.
+ ConstTwo := ObjectMemory new integerObjectOf: 2!
Item was added:
+ ----- Method: ObjectMemory class>>remapBufferSize (in category 'accessing') -----
+ remapBufferSize
+ ^RemapBufferSize!
Item was added:
+ ----- Method: ObjectMemory class>>rootTableSize (in category 'accessing') -----
+ rootTableSize
+ ^RootTableSize!
Item was removed:
- ----- Method: ObjectMemory class>>timeStamp (in category 'translation') -----
- timeStamp
- ^timeStamp ifNil:[0]!
Item was added:
+ ----- Method: ObjectMemory>>allocationCount (in category 'accessing') -----
+ allocationCount
+ ^allocationCount!
Item was added:
+ ----- Method: ObjectMemory>>allocationsBetweenGCs (in category 'accessing') -----
+ allocationsBetweenGCs
+ ^allocationsBetweenGCs!
Item was added:
+ ----- Method: ObjectMemory>>allocationsBetweenGCs: (in category 'accessing') -----
+ allocationsBetweenGCs: count
+ allocationsBetweenGCs := count!
Item was added:
+ ----- Method: ObjectMemory>>byte4Shift (in category 'accessing') -----
+ byte4Shift
+ ^Byte4Shift!
Item was added:
+ ----- Method: ObjectMemory>>byte4ShiftNegated (in category 'accessing') -----
+ byte4ShiftNegated
+ ^Byte4ShiftNegated!
Item was added:
+ ----- Method: ObjectMemory>>byteSwapped: (in category 'image save/restore') -----
+ byteSwapped: w
+ "Answer the given integer with its bytes in the reverse order."
+
+ <inline: true>
+ self isDefinedTrueExpression: 'BYTES_PER_WORD == 4'
+ inSmalltalk: [self bytesPerWord = 4]
+ comment: 'swap bytes in an object word'
+ ifTrue:
+ [^ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte0Mask)
+ + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte1Mask)
+ + ((w bitShift: Byte1Shift ) bitAnd: Byte2Mask)
+ + ((w bitShift: Byte3Shift ) bitAnd: Byte3Mask)]
+ ifFalse:
+ [^ ((w bitShift: Byte7ShiftNegated) bitAnd: Byte0Mask)
+ + ((w bitShift: Byte5ShiftNegated) bitAnd: Byte1Mask)
+ + ((w bitShift: Byte3ShiftNegated) bitAnd: Byte2Mask)
+ + ((w bitShift: Byte1ShiftNegated) bitAnd: Byte3Mask)
+ + ((w bitShift: Byte1Shift ) bitAnd: Byte4Mask)
+ + ((w bitShift: Byte3Shift ) bitAnd: Byte5Mask)
+ + ((w bitShift: Byte5Shift ) bitAnd: Byte6Mask)
+ + ((w bitShift: Byte7Shift ) bitAnd: Byte7Mask)]!
Item was added:
+ ----- Method: ObjectMemory>>bytes3to0Mask (in category 'accessing') -----
+ bytes3to0Mask
+ ^Bytes3to0Mask!
Item was added:
+ ----- Method: ObjectMemory>>bytes7to4Mask (in category 'accessing') -----
+ bytes7to4Mask
+ ^Bytes7to4Mask!
Item was added:
+ ----- Method: ObjectMemory>>endOfMemory (in category 'accessing') -----
+ endOfMemory
+ "Simulation support"
+ ^endOfMemory!
Item was added:
+ ----- Method: ObjectMemory>>endOfMemory: (in category 'accessing') -----
+ endOfMemory: position
+ "Simulation support"
+ endOfMemory := position!
Item was added:
+ ----- Method: ObjectMemory>>falseObj (in category 'accessing') -----
+ falseObj
+ ^falseObj!
Item was added:
+ ----- Method: ObjectMemory>>falseObj: (in category 'accessing') -----
+ falseObj: oop
+ falseObj := oop!
Item was added:
+ ----- Method: ObjectMemory>>forceTenureFlag: (in category 'accessing') -----
+ forceTenureFlag: arg
+ forceTenureFlag := arg!
Item was added:
+ ----- Method: ObjectMemory>>freeBlock (in category 'accessing') -----
+ freeBlock
+ ^freeBlock!
Item was added:
+ ----- Method: ObjectMemory>>freeContexts (in category 'accessing') -----
+ freeContexts
+ ^freeContexts!
Item was added:
+ ----- Method: ObjectMemory>>freeContexts: (in category 'accessing') -----
+ freeContexts: arg
+ freeContexts := arg!
Item was added:
+ ----- Method: ObjectMemory>>freeLargeContexts: (in category 'accessing') -----
+ freeLargeContexts: arg
+ freeLargeContexts := arg!
Item was added:
+ ----- Method: ObjectMemory>>gcBiasToGrow: (in category 'accessing') -----
+ gcBiasToGrow: arg
+ gcBiasToGrow := arg!
Item was added:
+ ----- Method: ObjectMemory>>gcSemaphoreIndex (in category 'accessing') -----
+ gcSemaphoreIndex
+ ^gcSemaphoreIndex!
Item was added:
+ ----- Method: ObjectMemory>>gcSemaphoreIndex: (in category 'accessing') -----
+ gcSemaphoreIndex: index
+ gcSemaphoreIndex := index!
Item was added:
+ ----- Method: ObjectMemory>>growHeadroom (in category 'accessing') -----
+ growHeadroom
+ ^growHeadroom!
Item was added:
+ ----- Method: ObjectMemory>>growHeadroom: (in category 'accessing') -----
+ growHeadroom: arg
+ growHeadroom := arg!
Item was added:
+ ----- Method: ObjectMemory>>headerTypeBytes (in category 'accessing') -----
+ headerTypeBytes
+ ^headerTypeBytes!
Item was added:
+ ----- Method: ObjectMemory>>headerTypeBytes: (in category 'accessing') -----
+ headerTypeBytes: array
+ "Simulation support"
+ headerTypeBytes := array!
Item was added:
+ ----- Method: ObjectMemory>>headerTypeClass (in category 'accessing') -----
+ headerTypeClass
+ ^HeaderTypeClass!
Item was added:
+ ----- Method: ObjectMemory>>headerTypeFree (in category 'accessing') -----
+ headerTypeFree
+ ^HeaderTypeFree!
Item was added:
+ ----- Method: ObjectMemory>>lastHash (in category 'accessing') -----
+ lastHash
+ "Simulation support"
+ ^lastHash!
Item was added:
+ ----- Method: ObjectMemory>>lastHash: (in category 'accessing') -----
+ lastHash: hash
+ "Simulation support"
+ lastHash := hash!
Item was added:
+ ----- Method: ObjectMemory>>lowSpaceThreshold: (in category 'accessing') -----
+ lowSpaceThreshold: arg
+ lowSpaceThreshold := arg!
Item was added:
+ ----- Method: ObjectMemory>>memory (in category 'accessing') -----
+ memory
+ ^memory!
Item was added:
+ ----- Method: ObjectMemory>>memory: (in category 'accessing') -----
+ memory: loc
+ memory := loc!
Item was added:
+ ----- Method: ObjectMemory>>memoryLimit (in category 'accessing') -----
+ memoryLimit
+ "Simulation support"
+ ^memoryLimit!
Item was added:
+ ----- Method: ObjectMemory>>memoryLimit: (in category 'accessing') -----
+ memoryLimit: limit
+ "Simulation support"
+ memoryLimit := limit!
Item was added:
+ ----- Method: ObjectMemory>>nilContext (in category 'accessing') -----
+ nilContext
+ ^NilContext!
Item was added:
+ ----- Method: ObjectMemory>>nilObj (in category 'accessing') -----
+ nilObj
+ ^nilObj!
Item was added:
+ ----- Method: ObjectMemory>>nilObj: (in category 'accessing') -----
+ nilObj: oop
+ nilObj := oop!
Item was added:
+ ----- Method: ObjectMemory>>remapBuffer (in category 'accessing') -----
+ remapBuffer
+ ^remapBuffer!
Item was added:
+ ----- Method: ObjectMemory>>remapBuffer: (in category 'accessing') -----
+ remapBuffer: table
+ "Simulation support"
+ remapBuffer := table!
Item was added:
+ ----- Method: ObjectMemory>>remapBufferCount (in category 'accessing') -----
+ remapBufferCount
+ ^remapBufferCount!
Item was added:
+ ----- Method: ObjectMemory>>reverseBytesFrom:to: (in category 'image save/restore') -----
+ reverseBytesFrom: startAddr to: stopAddr
+ "Byte-swap the given range of memory (not inclusive of stopAddr!!)."
+ | addr |
+ self flag: #Dan.
+ addr := startAddr.
+ [self oop: addr isLessThan: stopAddr] whileTrue:
+ [self longAt: addr put: (self byteSwapped: (self longAt: addr)).
+ addr := addr + self bytesPerWord].!
Item was added:
+ ----- Method: ObjectMemory>>reverseWordsFrom:to: (in category 'image save/restore') -----
+ reverseWordsFrom: startAddr to: stopAddr
+ "Word-swap the given range of memory, excluding stopAddr."
+
+ | addr |
+ addr := startAddr.
+ [self oop: addr isLessThan: stopAddr] whileTrue:
+ [self longAt: addr put: (self wordSwapped: (self longAt: addr)).
+ addr := addr + self bytesPerWord].!
Item was added:
+ ----- Method: ObjectMemory>>rootTable (in category 'accessing') -----
+ rootTable
+ ^rootTable!
Item was added:
+ ----- Method: ObjectMemory>>rootTable: (in category 'accessing') -----
+ rootTable: table
+ "Simulation support"
+ rootTable := table!
Item was added:
+ ----- Method: ObjectMemory>>rootTableCount (in category 'accessing') -----
+ rootTableCount
+ ^rootTableCount!
Item was added:
+ ----- Method: ObjectMemory>>setGCBiasToGrowGCLimit: (in category 'allocation') -----
+ setGCBiasToGrowGCLimit: value
+ "Primitive support. If the GC logic has bias to grow, set growth limit"
+ gcBiasToGrowGCLimit := value.
+ gcBiasToGrowThreshold := youngStart - (self cCoerce: memory to: 'int').
+ !
Item was added:
+ ----- Method: ObjectMemory>>shrinkThreshold (in category 'accessing') -----
+ shrinkThreshold
+ ^shrinkThreshold!
Item was added:
+ ----- Method: ObjectMemory>>shrinkThreshold: (in category 'accessing') -----
+ shrinkThreshold: arg
+ shrinkThreshold := arg!
Item was added:
+ ----- Method: ObjectMemory>>signalLowSpace (in category 'accessing') -----
+ signalLowSpace
+ ^signalLowSpace!
Item was added:
+ ----- Method: ObjectMemory>>signalLowSpace: (in category 'accessing') -----
+ signalLowSpace: boolean
+ signalLowSpace := boolean!
Item was added:
+ ----- Method: ObjectMemory>>specialObjectsOop (in category 'accessing') -----
+ specialObjectsOop
+ "Simulation support"
+ ^specialObjectsOop!
Item was added:
+ ----- Method: ObjectMemory>>specialObjectsOop: (in category 'accessing') -----
+ specialObjectsOop: oop
+ "Simulation support"
+ specialObjectsOop := oop!
Item was added:
+ ----- Method: ObjectMemory>>statAllocationCount (in category 'accessing') -----
+ statAllocationCount
+ ^statAllocationCount!
Item was added:
+ ----- Method: ObjectMemory>>statCompMoveCount (in category 'accessing') -----
+ statCompMoveCount
+ ^statCompMoveCount!
Item was added:
+ ----- Method: ObjectMemory>>statFullGCMSecs (in category 'accessing') -----
+ statFullGCMSecs
+ ^statFullGCMSecs!
Item was added:
+ ----- Method: ObjectMemory>>statFullGCs (in category 'accessing') -----
+ statFullGCs
+ ^statFullGCs!
Item was added:
+ ----- Method: ObjectMemory>>statGCTime (in category 'accessing') -----
+ statGCTime
+ ^statGCTime!
Item was added:
+ ----- Method: ObjectMemory>>statGrowMemory (in category 'accessing') -----
+ statGrowMemory
+ ^statGrowMemory!
Item was added:
+ ----- Method: ObjectMemory>>statIGCDeltaTime (in category 'accessing') -----
+ statIGCDeltaTime
+ ^statIGCDeltaTime!
Item was added:
+ ----- Method: ObjectMemory>>statIncrGCMSecs (in category 'accessing') -----
+ statIncrGCMSecs
+ ^statIncrGCMSecs!
Item was added:
+ ----- Method: ObjectMemory>>statIncrGCs (in category 'accessing') -----
+ statIncrGCs
+ ^statIncrGCs!
Item was added:
+ ----- Method: ObjectMemory>>statMarkCount (in category 'accessing') -----
+ statMarkCount
+ ^statMarkCount!
Item was added:
+ ----- Method: ObjectMemory>>statMkFwdCount (in category 'accessing') -----
+ statMkFwdCount
+ ^statMkFwdCount!
Item was added:
+ ----- Method: ObjectMemory>>statRootTableCount (in category 'accessing') -----
+ statRootTableCount
+ ^statRootTableCount!
Item was added:
+ ----- Method: ObjectMemory>>statRootTableOverflows (in category 'accessing') -----
+ statRootTableOverflows
+ ^statRootTableOverflows!
Item was added:
+ ----- Method: ObjectMemory>>statShrinkMemory (in category 'accessing') -----
+ statShrinkMemory
+ ^statShrinkMemory!
Item was added:
+ ----- Method: ObjectMemory>>statSpecialMarkCount (in category 'accessing') -----
+ statSpecialMarkCount
+ ^statSpecialMarkCount!
Item was added:
+ ----- Method: ObjectMemory>>statSurvivorCount (in category 'accessing') -----
+ statSurvivorCount
+ ^statSurvivorCount!
Item was added:
+ ----- Method: ObjectMemory>>statSweepCount (in category 'accessing') -----
+ statSweepCount
+ ^statSweepCount!
Item was added:
+ ----- Method: ObjectMemory>>statTenures (in category 'accessing') -----
+ statTenures
+ ^statTenures!
Item was added:
+ ----- Method: ObjectMemory>>statpendingFinalizationSignals (in category 'accessing') -----
+ statpendingFinalizationSignals
+ ^statpendingFinalizationSignals!
Item was added:
+ ----- Method: ObjectMemory>>statpendingFinalizationSignals: (in category 'accessing') -----
+ statpendingFinalizationSignals: arg
+ statpendingFinalizationSignals := arg!
Item was added:
+ ----- Method: ObjectMemory>>tenuringThreshold (in category 'accessing') -----
+ tenuringThreshold
+ ^tenuringThreshold!
Item was added:
+ ----- Method: ObjectMemory>>tenuringThreshold: (in category 'accessing') -----
+ tenuringThreshold: arg
+ tenuringThreshold := arg!
Item was added:
+ ----- Method: ObjectMemory>>trueObj (in category 'accessing') -----
+ trueObj
+ ^trueObj!
Item was added:
+ ----- Method: ObjectMemory>>trueObj: (in category 'accessing') -----
+ trueObj: oop
+ trueObj := oop!
Item was added:
+ ----- Method: ObjectMemory>>weakRoots: (in category 'accessing') -----
+ weakRoots: table
+ "Simulation support"
+ weakRoots := table!
Item was added:
+ ----- Method: ObjectMemory>>youngStart (in category 'accessing') -----
+ youngStart
+ ^youngStart!
Item was added:
+ ----- Method: ObjectMemory>>youngStart: (in category 'accessing') -----
+ youngStart: arg
+ youngStart := arg!
Item was added:
+ ----- Method: SlangTest>>testSetInstanceVariableWithAnAccessorMethod (in category 'testing intermediate variable removal') -----
+ testSetInstanceVariableWithAnAccessorMethod
+ "Intermediate variable from parameter of accessor method should be removed"
+
+ | s |
+ s := (SlangTestSupportInterpreter asInlinedCString: #setInstanceVariableWithAnAccessorMethod)
+ copyReplaceAll: 'setInstanceVariableWithAnAccessorMethod'
+ with: 'methodName'.
+ self assert: (s includesSubString: 'aVariable = remap(objectMemory, nilObj);').
+
+ "Should be translated like this:
+ aVariable = remap(objectMemory, nilObj);
+
+ Not like this:
+ oop = remap(objectMemory, nilObj);
+ aVariable = oop;"
+ !
Item was changed:
ObjectMemory subclass: #SlangTestSupportInterpreter
+ instanceVariableNames: 'primFailCode aVarWithOneReference aVarWithTwoReferences objectMemory aVariable'
- instanceVariableNames: 'primFailCode aVarWithOneReference aVarWithTwoReferences'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-Tests'!
!SlangTestSupportInterpreter commentStamp: 'dtl 9/19/2010 21:36' prior: 0!
SlangTestSupport implements translatable methods for use in SlangTest unit tests.
"VMMaker clearCacheEntriesFor: SlangTestSupportInterpreter.
SlangTestSupportInterpreter asCString"!
Item was added:
+ ----- Method: SlangTestSupportInterpreter>>setAVariable: (in category 'local and instance vars') -----
+ setAVariable: oop
+ aVariable := oop!
Item was added:
+ ----- Method: SlangTestSupportInterpreter>>setInstanceVariableWithAnAccessorMethod (in category 'local and instance vars') -----
+ setInstanceVariableWithAnAccessorMethod
+ objectMemory setAVariable: (objectMemory remap: objectMemory nilObj).
+ !
Item was added:
+ ----- Method: TAssignmentNode>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ expression mapReceiversIn: aDictionary
+ !
Item was added:
+ ----- Method: TCaseStmtNode>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ expression mapReceiversIn: aDictionary.
+ cases do: [ :c | c mapReceiversIn: aDictionary ]
+ !
Item was added:
+ ----- Method: TInlineNode>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ method mapReceiversIn: aDictionary
+ !
Item was added:
+ ----- Method: TMethod>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ parseTree mapReceiversIn: aDictionary.!
Item was added:
+ ----- Method: TParseNode>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ ^self!
Item was added:
+ ----- Method: TReturnNode>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ expression mapReceiversIn: aDictionary
+ !
Item was added:
+ ----- Method: TSendNode>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ receiver mapReceiversIn: aDictionary.
+ arguments collect: [:a | a mapReceiversIn: aDictionary]!
Item was added:
+ ----- Method: TStmtListNode>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ statements do: [ :s | s mapReceiversIn: aDictionary ]
+ !
Item was added:
+ ----- Method: TVariableNode>>mapReceiversIn: (in category 'transformations') -----
+ mapReceiversIn: aDictionary
+ "Remap the receiver, as when converting a send to objectMemory into a send to self"
+
+ aDictionary
+ at: name
+ ifPresent: [:newName | name := newName]
+ !
Item was changed:
SharedPool subclass: #VMBasicConstants
instanceVariableNames: ''
+ classVariableNames: 'DoAssertionChecks DoExpensiveAssertionChecks PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectMayMove PrimErrUnsupported PrimNoErr'
- classVariableNames: 'DoExpensiveAssertionChecks PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectMayMove PrimErrUnsupported PrimNoErr'
poolDictionaries: ''
category: 'VMMaker-Interpreter'!
!VMBasicConstants commentStamp: 'dtl 4/21/2011 22:44' prior: 0!
I am a shared pool for basic constants upon which the VM as a whole depends.!
Item was added:
+ Object subclass: #VMClass
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: 'VMBasicConstants'
+ category: 'VMMaker-Support'!
+ VMClass class
+ instanceVariableNames: 'timeStamp'!
+
+ !VMClass commentStamp: '<historical>' prior: 0!
+ I am an abstract superclass for all classes in the VM that want to maintain a source timeStamp.!
+ VMClass class
+ instanceVariableNames: 'timeStamp'!
Item was added:
+ ----- Method: VMClass class>>declareCAsOop:in: (in category 'translation') -----
+ declareCAsOop: arrayOfVariableNames in: aCCodeGenerator
+ "Declare the variables in arrayOfVariableNames with type representing position in object memory."
+
+ arrayOfVariableNames
+ do: [:varName | aCCodeGenerator var: varName type: 'usqInt']!
Item was added:
+ ----- Method: VMClass 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.
+ VMMaker addMemoryAccessTo: cg.
+ ^cg
+ !
Item was added:
+ ----- Method: VMClass class>>timeStamp (in category 'translation') -----
+ timeStamp
+ ^timeStamp ifNil:[0]!
Item was changed:
----- Method: VMMaker class>>addMemoryAccessTo: (in category 'utilities') -----
addMemoryAccessTo: aCodeGenerator
"Add MemoryAccess is if assigned to a variable. To do: add instance var and reference
low level memory though as an instance of MemoryAccess."
Smalltalk at: #MemoryAccess ifPresent: [ :ma |
+ ma isEnabled ifTrue: [ aCodeGenerator addClass: ma selectorPrefix: 'bits' ]]!
- ma isEnabled ifTrue: [ aCodeGenerator addClass: ma asInstanceVariable: 'bits' ]]!
Item was changed:
----- Method: VMMaker class>>versionString (in category 'version testing') -----
versionString
"VMMaker versionString"
+ ^'4.8'!
- ^'4.7.20'!
Item was changed:
----- Method: VMMakerTool class>>initialize (in category 'instance creation') -----
initialize
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"
- (method sendsSelector: #deprecated:)
ifFalse: [ class registerOpenCommand: (Array with: 'VMMaker' with: (Array with: self with: #openInWorld)) ] ] ]!
Item was changed:
----- Method: VMMakerTool class>>unload (in category 'unloading') -----
unload
Smalltalk at: #TheWorldMenu ifPresent: [ :class |
class class methodDict at: #unregisterOpenCommandWithReceiver: ifPresent: [ :method |
+ (method hasLiteral: #deprecated:)
- (method sendsSelector: #deprecated:)
ifFalse: [ class unregisterOpenCommandWithReceiver: self ] ] ]!
Item was changed:
SharedPool subclass: #VMObjectIndices
instanceVariableNames: ''
+ classVariableNames: 'ActiveProcessIndex CharacterTable ClassAlien ClassArray ClassBitmap ClassBlockClosure ClassBlockContext ClassByteArray ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassPoint ClassProcess ClassSemaphore ClassString ClassUnsafeAlien ClassWeakFinalizer ClosureCopiedValuesIndex CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero ExcessSignalsIndex ExternalObjectsArray FalseObject HeaderIndex InstructionPointerIndex LiteralStart MyListIndex NilObject PrimErrTableIndex PriorityIndex ProcessListsIndex ProcessSignalingLowSpace ReceiverIndex SchedulerAssociation SelectorAboutToReturn SelectorAttemptToAssign SelectorCannotInterpret SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SelectorRunWithIn SenderIndex SpecialSelectors TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject XIndex YIndex'
- classVariableNames: 'ActiveProcessIndex CharacterTable ClassAlien ClassArray ClassBitmap ClassBlockClosure ClassBlockContext ClassByteArray ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassPoint ClassProcess ClassSemaphore ClassString ClassUnsafeAlien ClassWeakFinalizer CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero ExcessSignalsIndex ExternalObjectsArray FalseObject HeaderIndex InstructionPointerIndex LiteralStart MyListIndex NilObject PrimErrTableIndex PriorityIndex ProcessListsIndex ProcessSignalingLowSpace ReceiverIndex SchedulerAssociation SelectorAboutToReturn SelectorAttemptToAssign SelectorCannotInterpret SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SelectorRunWithIn SenderIndex SpecialSelectors TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject XIndex YIndex'
poolDictionaries: ''
category: 'VMMaker-Interpreter'!
!VMObjectIndices commentStamp: '<historical>' prior: 0!
I am a shared pool for the constants that define object layout and well-known objects shared between the object memories (e.g. ObjectMemory, NewObjectMemory), the interpreters (e.g. StackInterpreter, CoInterpreter) and the object representations (e.g. ObjectRepresentationForSqueakV3).
self classPool declare: #Foo from: StackInterpreter classPool
(ObjectMemory classPool keys select: [:k| (k beginsWith: 'Class') and: [(k endsWith: 'Index') not]]) do:
[:k| self classPool declare: k from: ObjectMemory classPool]!
1
0
10 Feb '12
this is well written, relatively short, and extremely informative.
http://tratt.net/laurie/tech_articles/articles/fast_enough_vms_in_fast_enou…
thanks to Bob Westergaard for pointing it out to me.
--
best,
Eliot
5
5
Interesting article on PyPy (P{ython's tracing JIT) by Laurence Tratt
by Chris Cunnington 09 Feb '12
by Chris Cunnington 09 Feb '12
09 Feb '12
That taught me a lot in a hurry. I now make the distinction in our vm confecting process between the methodology and the language.
The methodology is versatile and not tied to Smalltalk. It can be adapted to Newspeak, Converge, a new language, or Commodore BASIC.
That's impressive.
Chris
1
0
i just built a threaded cog VM for win32,
and when i starting an image, a console window shows warnings:
# Debug console
# To close: F2 -> 'debug options' -> 'show output console'
# To disable: F2 -> 'debug options' -> 'show console on errors'
warning, processHasThreadId flag is unset; cannot function as a
threaded VM if so.
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
warning: Process doesn't have threadId; VM will not thread
however, in pharo we already introduced the threadId ivar:
Link subclass: #Process
instanceVariableNames: 'suspendedContext priority myList threadId
errorHandler name env'
classVariableNames: ''
poolDictionaries: ''
category: 'Kernel-Processes'
could it be because of initial "warning, processHasThreadId flag is
unset; cannot function as a threaded VM if so."?
--
Best regards,
Igor Stasenko.
3
8
Igor Stasenko uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-oscog-IgorStasenko.143.mcz
==================== Summary ====================
Name: VMMaker-oscog-IgorStasenko.143
Author: IgorStasenko
Time: 7 February 2012, 4:28:02 am
UUID: 25049516-19fb-3647-9ca4-6328c656f3f0
Ancestors: VMMaker-oscog-EstebanLorenzano.140, VMMaker.oscog-eem.142
- clean merge with VMMaker.oscog-eem.142
=============== Diff against VMMaker-oscog-EstebanLorenzano.140 ===============
Item was changed:
TestCase subclass: #AbstractInstructionTests
instanceVariableNames: 'processor opcodes'
classVariableNames: ''
poolDictionaries: 'CogRTLOpcodes'
category: 'VMMaker-Tests'!
+
+ !AbstractInstructionTests commentStamp: 'BenjaminVanRyseghem 9/27/2011 14:04' prior: 0!
+ Use for a test: ClosureCompilerTest>>#closureCases!
Item was changed:
----- Method: CoInterpreter>>longUnconditionalJump (in category 'jump bytecodes') -----
longUnconditionalJump
| offset switched |
offset := (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte.
localIP := localIP + offset.
"backward jump means we're in a loop.
- check for possible interrupts.
- check for long-running loops and JIT if appropriate."
offset < 0 ifTrue:
[localSP < stackLimit ifTrue:
[self externalizeIPandSP.
switched := self checkForEventsMayContextSwitch: true.
self returnToExecutive: true postContextSwitch: switched.
self browserPluginReturnIfNeeded.
self internalizeIPandSP].
method = lastBackwardJumpMethod
ifTrue:
[(backwardJumpCount := backwardJumpCount - 1) <= 0 ifTrue:
[(self methodWithHeaderShouldBeCogged: (self headerOf: method))
ifTrue:
[self externalizeFPandSP.
+ self resetBackwardJumpVariables. "only to force variables to be global"
self attemptToSwitchToMachineCode: (self oopForPointer: localIP) - offset - method - BaseHeaderSize - 1]
ifFalse: "don't ask if one should compile a second time..."
[backwardJumpCount := 1 bitShift: BytesPerWord * 8 - 2]]]
ifFalse:
[lastBackwardJumpMethod := method.
backwardJumpCount := minBackwardJumpCountForCompile]].
self fetchNextBytecode!
Item was added:
+ ----- Method: CoInterpreter>>resetBackwardJumpVariables (in category 'jump bytecodes') -----
+ resetBackwardJumpVariables
+ "Reference these variables from outside interpret to avoid them being localised to interpret.
+ Oh the hacks we commit for Slang..."
+ <cmacro: '() /* nada */'>
+ <inline: #false>
+ lastBackwardJumpMethod := lastBackwardJumpMethod.
+ backwardJumpCount := backwardJumpCount!
Item was added:
+ ----- Method: CogAbstractInstruction class>>specificOpcodes (in category 'verification') -----
+ specificOpcodes
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: CogAbstractInstruction class>>unimplementedOpcodes (in category 'verification') -----
+ unimplementedOpcodes
+ "Check computeMaximumSize and dispatchConcretize for unimplemented opcodes."
+ "self subclasses collect: [:compiler| {compiler. compiler unimplementedOpcodes}]"
+ | opcodes cmsLiterals dcLiterals |
+ opcodes := CogRTLOpcodes opcodes, self specificOpcodes.
+ cmsLiterals := (self >> #computeMaximumSize) literals
+ select: [:l| l isVariableBinding]
+ thenCollect: [:l| l key].
+ dcLiterals := (self >> #dispatchConcretize) literals
+ select: [:l| l isVariableBinding]
+ thenCollect: [:l| l key].
+ ^Dictionary new
+ at: #computeMaximumSize put: (opcodes reject: [:opcode| cmsLiterals includes: opcode]);
+ at: #dispatchConcretize put: (opcodes reject: [:opcode| dcLiterals includes: opcode]);
+ yourself!
Item was added:
+ ----- Method: CogAbstractInstruction class>>usedUnimplementedOpcodes (in category 'verification') -----
+ usedUnimplementedOpcodes
+ "Check for uses of unimplemented opcodes"
+ "self subclasses collect: [:compiler| {compiler. compiler usedUnimplementedOpcodes}]"
+ | genericUnimplementedOpcodeBindings specificUnimplementedOpcodeBindings |
+ genericUnimplementedOpcodeBindings := Set new.
+ specificUnimplementedOpcodeBindings := Set new.
+ self unimplementedOpcodes do:
+ [:arrayOfOpcodes|
+ arrayOfOpcodes do:
+ [:opcode|
+ (self bindingOf: opcode)
+ ifNotNil: [:b| specificUnimplementedOpcodeBindings add: b]
+ ifNil: [genericUnimplementedOpcodeBindings add: (CogRTLOpcodes bindingOf: opcode)]]].
+ ^ { (SystemNavigation new allCallsOn: genericUnimplementedOpcodeBindings localToPackage: #VMMaker)
+ inject: Set new
+ into: [:them :methodRef| "These should be in Cogit's abstract instructions category"
+ them
+ addAll: (SystemNavigation new allCallsOn: methodRef method selector localToPackage: #VMMaker);
+ yourself].
+ SystemNavigation new allCallsOn: specificUnimplementedOpcodeBindings localToPackage: #VMMaker }!
Item was added:
+ ----- Method: CogIA32Compiler class>>specificOpcodes (in category 'verification') -----
+ specificOpcodes
+ "Answer the processor-specific opcodes for this class.
+ They're all in an Array literal in the initialize method."
+ ^(self class >> #initialize) literals detect: [:l| l isArray and: [l includes: #LOCK]]!
Item was changed:
----- Method: CogIA32Compiler>>computeMaximumSize (in category 'generate machine code') -----
computeMaximumSize
"Compute the maximum size for each opcode. This allows jump offsets to
be determined, provided that all backward branches are long branches."
"N.B. The ^maxSize := N forms are to get around the compiler's long branch
limits which are exceeded when each case jumps around the otherwise."
opcode caseOf: {
"Noops & Pseudo Ops"
[Label] -> [^maxSize := 0].
[AlignmentNops] -> [^maxSize := (operands at: 0) - 1].
[Fill16] -> [^maxSize := 2].
[Fill32] -> [^maxSize := 4].
[FillFromWord] -> [^maxSize := 4].
[Nop] -> [^maxSize := 1].
"Specific Control/Data Movement"
[CDQ] -> [^maxSize := 1].
[IDIVR] -> [^maxSize := 2].
[IMULRR] -> [^maxSize := 3].
[CPUID] -> [^maxSize := 2].
[CMPXCHGAwR] -> [^maxSize := 7].
[CMPXCHGMwrR] -> [^maxSize := 8].
[LFENCE] -> [^maxSize := 3].
[MFENCE] -> [^maxSize := 3].
[SFENCE] -> [^maxSize := 3].
[LOCK] -> [^maxSize := 1].
[XCHGAwR] -> [^maxSize := 6].
[XCHGMwrR] -> [^maxSize := 7].
[XCHGRR] -> [^maxSize := 2].
"Control"
[Call] -> [^maxSize := 5].
[JumpR] -> [^maxSize := 2].
[Jump] -> [self resolveJumpTarget. ^maxSize := 5].
[JumpLong] -> [self resolveJumpTarget. ^maxSize := 5].
[JumpZero] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpNonZero] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpNegative] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpNonNegative] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpOverflow] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpNoOverflow] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpCarry] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpNoCarry] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpLess] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpGreaterOrEqual] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpGreater] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpLessOrEqual] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpBelow] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpAboveOrEqual] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpAbove] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpBelowOrEqual] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpLongZero] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpLongNonZero] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpFPEqual] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpFPNotEqual] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpFPLess] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpFPGreaterOrEqual] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpFPGreater] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpFPLessOrEqual] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpFPOrdered] -> [self resolveJumpTarget. ^maxSize := 6].
[JumpFPUnordered] -> [self resolveJumpTarget. ^maxSize := 6].
[RetN] -> [^maxSize := (operands at: 0) = 0
ifTrue: [1]
ifFalse: [3]].
"Arithmetic"
[AddCqR] -> [^maxSize := (self isQuick: (operands at: 0))
ifTrue: [3]
ifFalse: [(self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]]].
[AndCqR] -> [^maxSize := (self isQuick: (operands at: 0))
ifTrue: [3]
ifFalse: [(self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]]].
[CmpCqR] -> [^maxSize := (self isQuick: (operands at: 0))
ifTrue: [3]
ifFalse: [(self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]]].
[OrCqR] -> [^maxSize := (self isQuick: (operands at: 0))
ifTrue: [3]
ifFalse: [(self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]]].
[SubCqR] -> [^maxSize := (self isQuick: (operands at: 0))
ifTrue: [3]
ifFalse: [(self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]]].
[AddCwR] -> [^maxSize := (self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]].
+ [AndCwR] -> [^maxSize := (self concreteRegister: (operands at: 1)) = EAX
+ ifTrue: [5]
+ ifFalse: [6]].
[CmpCwR] -> [^maxSize := (self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]].
+ [OrCwR] -> [^maxSize := (self concreteRegister: (operands at: 1)) = EAX
+ ifTrue: [5]
+ ifFalse: [6]].
[SubCwR] -> [^maxSize := (self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]].
[XorCwR] -> [^maxSize := (self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]].
[AddRR] -> [^maxSize := 2].
[AndRR] -> [^maxSize := 2].
[CmpRR] -> [^maxSize := 2].
[OrRR] -> [^maxSize := 2].
[XorRR] -> [^maxSize := 2].
[SubRR] -> [^maxSize := 2].
[NegateR] -> [^maxSize := 2].
[LoadEffectiveAddressMwrR]
-> [^maxSize := ((self isQuick: (operands at: 0))
ifTrue: [3]
ifFalse: [6])
+ ((self concreteRegister: (operands at: 1)) = ESP
ifTrue: [1]
ifFalse: [0])].
[LogicalShiftLeftCqR] -> [^maxSize := (operands at: 0) = 1
ifTrue: [2]
ifFalse: [3]].
[LogicalShiftRightCqR] -> [^maxSize := (operands at: 0) = 1
ifTrue: [2]
ifFalse: [3]].
[ArithmeticShiftRightCqR] -> [^maxSize := (operands at: 0) = 1
ifTrue: [2]
ifFalse: [3]].
[LogicalShiftLeftRR] -> [self computeShiftRRSize].
[LogicalShiftRightRR] -> [self computeShiftRRSize].
[ArithmeticShiftRightRR] -> [self computeShiftRRSize].
[AddRdRd] -> [^maxSize := 4].
[CmpRdRd] -> [^maxSize := 4].
[SubRdRd] -> [^maxSize := 4].
[MulRdRd] -> [^maxSize := 4].
[DivRdRd] -> [^maxSize := 4].
[SqrtRd] -> [^maxSize := 4].
"Data Movement"
[MoveCqR] -> [^maxSize := (operands at: 0) = 0 ifTrue: [2] ifFalse: [5]].
[MoveCwR] -> [^maxSize := 5].
[MoveRR] -> [^maxSize := 2].
+ [MoveRdRd] -> [^maxSize := 4].
[MoveAwR] -> [^maxSize := (self concreteRegister: (operands at: 1)) = EAX
ifTrue: [5]
ifFalse: [6]].
[MoveRAw] -> [^maxSize := (self concreteRegister: (operands at: 0)) = EAX
ifTrue: [5]
ifFalse: [6]].
[MoveRMwr] -> [^maxSize := ((self isQuick: (operands at: 1))
ifTrue: [3]
ifFalse: [6])
+ ((self concreteRegister: (operands at: 2)) = ESP
ifTrue: [1]
ifFalse: [0])].
[MoveRdM64r] -> [^maxSize := ((self isQuick: (operands at: 1))
ifTrue: [5]
ifFalse: [8])
+ ((self concreteRegister: (operands at: 2)) = ESP
ifTrue: [1]
ifFalse: [0])].
[MoveMbrR] -> [^maxSize := ((self isQuick: (operands at: 0))
ifTrue: [3]
ifFalse: [6])
+ ((self concreteRegister: (operands at: 1)) = ESP
ifTrue: [1]
ifFalse: [0])].
[MoveRMbr] -> [^maxSize := ((self isQuick: (operands at: 1))
ifTrue: [3]
ifFalse: [6])
+ ((self concreteRegister: (operands at: 2)) = ESP
ifTrue: [1]
ifFalse: [0])].
[MoveM16rR] -> [^maxSize := ((self isQuick: (operands at: 0))
ifTrue: [4]
ifFalse: [7])
+ ((self concreteRegister: (operands at: 1)) = ESP
ifTrue: [1]
ifFalse: [0])].
[MoveM64rRd] -> [^maxSize := ((self isQuick: (operands at: 0))
ifTrue: [5]
ifFalse: [8])
+ ((self concreteRegister: (operands at: 1)) = ESP
ifTrue: [1]
ifFalse: [0])].
[MoveMwrR] -> [^maxSize := ((self isQuick: (operands at: 0))
ifTrue: [3]
ifFalse: [6])
+ ((self concreteRegister: (operands at: 1)) = ESP
ifTrue: [1]
ifFalse: [0])].
[MoveXbrRR] -> [self assert: (self concreteRegister: (operands at: 0)) ~= ESP.
^maxSize := (self concreteRegister: (operands at: 1)) = EBP
ifTrue: [5]
ifFalse: [4]].
[MoveXwrRR] -> [self assert: (self concreteRegister: (operands at: 0)) ~= ESP.
^maxSize := (self concreteRegister: (operands at: 1)) = EBP
ifTrue: [4]
ifFalse: [3]].
[MoveRXwrR] -> [self assert: (self concreteRegister: (operands at: 1)) ~= ESP.
^maxSize := (self concreteRegister: (operands at: 2)) = EBP
ifTrue: [4]
ifFalse: [3]].
[PopR] -> [^maxSize := 1].
[PushR] -> [^maxSize := 1].
[PushCw] -> [^maxSize := 5].
[PrefetchAw] -> [^maxSize := self hasSSEInstructions ifTrue: [7] ifFalse: [0]].
"Conversion"
[ConvertRRd] -> [^maxSize := 4] }.
^0 "to keep C compiler quiet"!
Item was added:
+ ----- Method: CogIA32Compiler>>concretizeAndCwR (in category 'generate machine code') -----
+ concretizeAndCwR
+ "Will get inlined into concretizeAt: switch."
+ <inline: true>
+ | value reg |
+ value := operands at: 0.
+ reg := self concreteRegister: (operands at: 1).
+ reg = EAX ifTrue:
+ [machineCode
+ at: 0 put: 16r25;
+ at: 1 put: (value bitAnd: 16rFF);
+ at: 2 put: (value >> 8 bitAnd: 16rFF);
+ at: 3 put: (value >> 16 bitAnd: 16rFF);
+ at: 4 put: (value >> 24 bitAnd: 16rFF).
+ ^machineCodeSize := 5].
+ machineCode
+ at: 0 put: 16r83;
+ at: 1 put: (self mod: ModReg RM: reg RO: 4);
+ at: 2 put: (value bitAnd: 16rFF);
+ at: 3 put: (value >> 8 bitAnd: 16rFF);
+ at: 4 put: (value >> 16 bitAnd: 16rFF);
+ at: 5 put: (value >> 24 bitAnd: 16rFF).
+ ^machineCodeSize := 6!
Item was added:
+ ----- Method: CogIA32Compiler>>concretizeOrCwR (in category 'generate machine code') -----
+ concretizeOrCwR
+ "Will get inlined into concretizeAt: switch."
+ <inline: true>
+ | value reg |
+ value := operands at: 0.
+ reg := self concreteRegister: (operands at: 1).
+ reg = EAX ifTrue:
+ [machineCode
+ at: 0 put: 16r0D;
+ at: 1 put: (value bitAnd: 16rFF);
+ at: 2 put: (value >> 8 bitAnd: 16rFF);
+ at: 3 put: (value >> 16 bitAnd: 16rFF);
+ at: 4 put: (value >> 24 bitAnd: 16rFF).
+ ^machineCodeSize := 5].
+ machineCode
+ at: 0 put: 16r83;
+ at: 1 put: (self mod: ModReg RM: reg RO: 1);
+ at: 2 put: (value bitAnd: 16rFF);
+ at: 3 put: (value >> 8 bitAnd: 16rFF);
+ at: 4 put: (value >> 16 bitAnd: 16rFF);
+ at: 5 put: (value >> 24 bitAnd: 16rFF).
+ ^machineCodeSize := 6!
Item was changed:
----- Method: CogIA32Compiler>>dispatchConcretize (in category 'generate machine code') -----
dispatchConcretize
"Attempt to generate concrete machine code for the instruction at address.
This is the inner dispatch of concretizeAt: actualAddress which exists only
to get around the branch size limits in the SqueakV3 (blue book derived)
bytecode set."
opcode caseOf: {
"Noops & Pseudo Ops"
[Label] -> [^self concretizeLabel].
[AlignmentNops] -> [^self concretizeAlignmentNops].
[Fill16] -> [^self concretizeFill16].
[Fill32] -> [^self concretizeFill32].
[FillFromWord] -> [^self concretizeFillFromWord].
[Nop] -> [^self concretizeNop].
"Specific Control/Data Movement"
[CDQ] -> [^self concretizeCDQ].
[IDIVR] -> [^self concretizeIDIVR].
[IMULRR] -> [^self concretizeMulRR].
[CPUID] -> [^self concretizeCPUID].
[CMPXCHGAwR] -> [^self concretizeCMPXCHGAwR].
[CMPXCHGMwrR] -> [^self concretizeCMPXCHGMwrR].
[LFENCE] -> [^self concretizeFENCE: 5].
[MFENCE] -> [^self concretizeFENCE: 6].
[SFENCE] -> [^self concretizeFENCE: 7].
[LOCK] -> [^self concretizeLOCK].
[XCHGAwR] -> [^self concretizeXCHGAwR].
[XCHGMwrR] -> [^self concretizeXCHGMwrR].
[XCHGRR] -> [^self concretizeXCHGRR].
"Control"
[Call] -> [^self concretizeCall].
[JumpR] -> [^self concretizeJumpR].
[JumpLong] -> [^self concretizeJumpLong].
[JumpLongZero] -> [^self concretizeConditionalJumpLong: 16r4].
[JumpLongNonZero] -> [^self concretizeConditionalJumpLong: 16r5].
[Jump] -> [^self concretizeJump].
"Table B-1 Intel® 64 and IA-32 Architectures Software Developer's Manual Volume 1: Basic Architecture"
[JumpZero] -> [^self concretizeConditionalJump: 16r4].
[JumpNonZero] -> [^self concretizeConditionalJump: 16r5].
[JumpNegative] -> [^self concretizeConditionalJump: 16r8].
[JumpNonNegative] -> [^self concretizeConditionalJump: 16r9].
[JumpOverflow] -> [^self concretizeConditionalJump: 16r0].
[JumpNoOverflow] -> [^self concretizeConditionalJump: 16r1].
[JumpCarry] -> [^self concretizeConditionalJump: 16r2].
[JumpNoCarry] -> [^self concretizeConditionalJump: 16r3].
[JumpLess] -> [^self concretizeConditionalJump: 16rC].
[JumpGreaterOrEqual] -> [^self concretizeConditionalJump: 16rD].
[JumpGreater] -> [^self concretizeConditionalJump: 16rF].
[JumpLessOrEqual] -> [^self concretizeConditionalJump: 16rE].
[JumpBelow] -> [^self concretizeConditionalJump: 16r2].
[JumpAboveOrEqual] -> [^self concretizeConditionalJump: 16r3].
[JumpAbove] -> [^self concretizeConditionalJump: 16r7].
[JumpBelowOrEqual] -> [^self concretizeConditionalJump: 16r6].
[JumpFPEqual] -> [^self concretizeConditionalJump: 16r4].
[JumpFPNotEqual] -> [^self concretizeConditionalJump: 16r5].
[JumpFPLess] -> [^self concretizeConditionalJump: 16r2].
[JumpFPGreaterOrEqual] -> [^self concretizeConditionalJump: 16r3].
[JumpFPGreater] -> [^self concretizeConditionalJump: 16r7].
[JumpFPLessOrEqual] -> [^self concretizeConditionalJump: 16r6].
[JumpFPOrdered] -> [^self concretizeConditionalJump: 16rB].
[JumpFPUnordered] -> [^self concretizeConditionalJump: 16rA].
[RetN] -> [^self concretizeRetN].
"Arithmetic"
[AddCqR] -> [^self concretizeAddCqR].
[AddCwR] -> [^self concretizeAddCwR].
[AddRR] -> [^self concretizeAddRR].
[AddRdRd] -> [^self concretizeSEE2OpRdRd: 16r58].
[AndCqR] -> [^self concretizeAndCqR].
+ [AndCwR] -> [^self concretizeAndCwR].
[AndRR] -> [^self concretizeAndRR].
[CmpCqR] -> [^self concretizeCmpCqR].
[CmpCwR] -> [^self concretizeCmpCwR].
[CmpRR] -> [^self concretizeCmpRR].
[CmpRdRd] -> [^self concretizeCmpRdRd].
[DivRdRd] -> [^self concretizeSEE2OpRdRd: 16r5E].
[MulRdRd] -> [^self concretizeSEE2OpRdRd: 16r59].
[OrCqR] -> [^self concretizeOrCqR].
+ [OrCwR] -> [^self concretizeOrCwR].
[OrRR] -> [^self concretizeOrRR].
[SubCqR] -> [^self concretizeSubCqR].
[SubCwR] -> [^self concretizeSubCwR].
[SubRR] -> [^self concretizeSubRR].
[SubRdRd] -> [^self concretizeSEE2OpRdRd: 16r5C].
[SqrtRd] -> [^self concretizeSqrtRd].
[XorCwR] -> [^self concretizeXorCwR].
[XorRR] -> [^self concretizeXorRR].
[NegateR] -> [^self concretizeNegateR].
[LoadEffectiveAddressMwrR] -> [^self concretizeLoadEffectiveAddressMwrR].
[ArithmeticShiftRightCqR] -> [^self concretizeArithmeticShiftRightCqR].
[LogicalShiftRightCqR] -> [^self concretizeLogicalShiftRightCqR].
[LogicalShiftLeftCqR] -> [^self concretizeLogicalShiftLeftCqR].
[ArithmeticShiftRightRR] -> [^self concretizeArithmeticShiftRightRR].
[LogicalShiftLeftRR] -> [^self concretizeLogicalShiftLeftRR].
"Data Movement"
[MoveCqR] -> [^self concretizeMoveCqR].
[MoveCwR] -> [^self concretizeMoveCwR].
[MoveRR] -> [^self concretizeMoveRR].
[MoveAwR] -> [^self concretizeMoveAwR].
[MoveRAw] -> [^self concretizeMoveRAw].
[MoveMbrR] -> [^self concretizeMoveMbrR].
[MoveRMbr] -> [^self concretizeMoveRMbr].
[MoveM16rR] -> [^self concretizeMoveM16rR].
[MoveM64rRd] -> [^self concretizeMoveM64rRd].
[MoveMwrR] -> [^self concretizeMoveMwrR].
[MoveXbrRR] -> [^self concretizeMoveXbrRR].
[MoveXwrRR] -> [^self concretizeMoveXwrRR].
[MoveRXwrR] -> [^self concretizeMoveRXwrR].
[MoveRMwr] -> [^self concretizeMoveRMwr].
[MoveRdM64r] -> [^self concretizeMoveRdM64r].
[PopR] -> [^self concretizePopR].
[PushR] -> [^self concretizePushR].
[PushCw] -> [^self concretizePushCw].
[PrefetchAw] -> [^self concretizePrefetchAw].
"Conversion"
[ConvertRRd] -> [^self concretizeConvertRRd] }!
Item was added:
+ ----- Method: CogRTLOpcodes class>>opcodes (in category 'accessing') -----
+ opcodes
+ "CogRTLOpcodes opcodes"
+ "CogRTLOpcodes opcodes select:
+ [:opcode|
+ (Cogit organization listAtCategoryNamed: #'abstract instructions') noneSatisfy:
+ [:s|
+ (Cogit compiledMethodAt: s) literals anySatisfy:
+ [:l|
+ l isVariableBinding and: [l key = opcode]]]]"
+ ^(classPool keys reject:
+ [:k|
+ (#('First' 'Last' 'DPFP') anySatisfy: [:prefix| k beginsWith: prefix])
+ or: [#('Reg' 'Min' 'Max') anySatisfy: [:postfix| k endsWith: postfix]]]) asArray sort!
Item was changed:
----- Method: TMethod>>tryToInlineMethodsIn: (in category 'inlining') -----
tryToInlineMethodsIn: aCodeGen
"Expand any (complete) inline methods called by this method. Set the complete bit when all inlining has been done. Return true if something was inlined."
| stmtLists didSomething newStatements sendsToInline |
+ self definedAsMacro ifTrue:
- (properties includesKey: #cmacro:) ifTrue:
[complete := true.
^false].
didSomething := false.
sendsToInline := Dictionary new: 100.
parseTree
nodesDo:
[ :n |
(self inlineableFunctionCall: n in: aCodeGen) ifTrue:
[sendsToInline at: n put: (self inlineFunctionCall: n in: aCodeGen)]]
unless: "Don't inline the arguments to asserts to keep the asserts readable"
[:n| n isSend and: [#(cCode:inSmalltalk: assert:) includes: n selector]].
sendsToInline isEmpty ifFalse:
[didSomething := true.
parseTree := parseTree replaceNodesIn: sendsToInline].
didSomething ifTrue:
[writtenToGlobalVarsCache := nil.
^didSomething].
stmtLists := self statementsListsForInlining.
stmtLists do:
[ :stmtList |
newStatements := OrderedCollection new: 100.
stmtList statements do:
[ :stmt |
(self inlineCodeOrNilForStatement: stmt in: aCodeGen)
ifNil: [newStatements addLast: stmt]
ifNotNil: [:inlinedStmts|
didSomething := true.
newStatements addAllLast: inlinedStmts]].
stmtList setStatements: newStatements asArray].
didSomething ifTrue:
[writtenToGlobalVarsCache := nil.
^didSomething].
complete ifFalse:
[self checkForCompleteness: stmtLists in: aCodeGen.
complete ifTrue: [ didSomething := true ]]. "marking a method complete is progress"
^didSomething!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiCall:ArgArrayOrNil:NumArgs: (in category 'callout support') -----
ffiCall: externalFunction ArgArrayOrNil: argArrayOrNil NumArgs: nArgs
"Generic callout. Does the actual work. If argArrayOrNil is nil it takes args from the stack
and the spec from the method. If argArrayOrNil is not nil takes args from argArrayOrNil
and the spec from the receiver."
| flags argTypeArray address argType oop argSpec argClass err theCalloutState calloutState requiredStackSize stackSize allocation result |
<inline: true>
<var: #theCalloutState type: #'CalloutState'>
<var: #calloutState type: #'CalloutState *'>
<var: #allocation type: #'char *'>
(interpreterProxy is: externalFunction KindOfClass: interpreterProxy classExternalFunction) ifFalse:
[^self ffiFail: FFIErrorNotFunction].
"Load and check the values in the externalFunction before we call out"
flags := interpreterProxy fetchInteger: ExternalFunctionFlagsIndex ofObject: externalFunction.
interpreterProxy failed ifTrue:
[^self ffiFail: FFIErrorBadArgs].
+
+ "This must come early for compatibility with the old FFIPlugin. Image-level code
+ may assume the function pointer is loaded eagerly. Thanks to Nicolas Cellier."
+ address := self ffiLoadCalloutAddress: externalFunction.
+ interpreterProxy failed ifTrue:
+ [^0 "error code already set by ffiLoadCalloutAddress:"].
+
argTypeArray := interpreterProxy fetchPointer: ExternalFunctionArgTypesIndex ofObject: externalFunction.
"must be array of arg types"
((interpreterProxy isArray: argTypeArray)
and: [(interpreterProxy slotSizeOf: argTypeArray) = (nArgs + 1)]) ifFalse:
[^self ffiFail: FFIErrorBadArgs].
"check if the calling convention is supported"
self cppIf: COGMTVM
ifTrue:
[(self ffiSupportsCallingConvention: (flags bitAnd: FFICallTypesMask)) ifFalse:
[^self ffiFail: FFIErrorCallType]]
ifFalse: "not masking causes threaded calls to fail, which is as they should if the plugin is not threaded."
[(self ffiSupportsCallingConvention: flags) ifFalse:
[^self ffiFail: FFIErrorCallType]].
+
-
- address := self ffiLoadCalloutAddress: externalFunction.
- interpreterProxy failed ifTrue:
- [^0 "error code already set by ffiLoadCalloutAddress:"].
requiredStackSize := self externalFunctionHasStackSizeSlot
ifTrue: [interpreterProxy
fetchInteger: ExternalFunctionStackSizeIndex
ofObject: externalFunction]
ifFalse: [-1].
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: (argArrayOrNil isNil
ifTrue: [PrimErrBadMethod]
ifFalse: [PrimErrBadReceiver])].
stackSize := requiredStackSize < 0 ifTrue: [DefaultMaxStackSize] ifFalse: [requiredStackSize].
self cCode: [] inSmalltalk: [theCalloutState := self class calloutStateClass new].
calloutState := self addressOf: theCalloutState.
self cCode: [self me: calloutState ms: 0 et: (self sizeof: #CalloutState asSymbol)].
calloutState callFlags: flags.
"Fetch return type and args"
argType := interpreterProxy fetchPointer: 0 ofObject: argTypeArray.
argSpec := interpreterProxy fetchPointer: 0 ofObject: argType.
argClass := interpreterProxy fetchPointer: 1 ofObject: argType.
(err := self ffiCheckReturn: argSpec With: argClass in: calloutState) ~= 0 ifTrue:
[^self ffiFail: err]. "cannot return"
"alloca the outgoing stack frame, leaving room for register args while marshalling, and including space for the return struct, if any."
allocation := self alloca: stackSize + calloutState structReturnSize + self registerArgsSlop + self cStackAlignment.
self allocaLiesSoUseGetsp ifTrue:
[allocation := self getsp].
self cStackAlignment ~= 0 ifTrue:
[allocation := self cCoerce: (allocation asUnsignedInteger bitAnd: (self cStackAlignment - 1) bitInvert32)
to: #'char *'].
calloutState
argVector: allocation;
currentArg: allocation + self registerArgsSlop;
limit: allocation + stackSize + self registerArgsSlop.
(calloutState structReturnSize > 0
and: [self nonRegisterStructReturnIsViaImplicitFirstArgument
and: [(self returnStructInRegisters: calloutState structReturnSize) not]]) ifTrue:
[self ffiPushPointer: calloutState limit in: calloutState].
1 to: nArgs do:
[:i|
argType := interpreterProxy fetchPointer: i ofObject: argTypeArray.
argSpec := interpreterProxy fetchPointer: 0 ofObject: argType.
argClass := interpreterProxy fetchPointer: 1 ofObject: argType.
oop := argArrayOrNil isNil
ifTrue: [interpreterProxy stackValue: nArgs - i]
ifFalse: [interpreterProxy fetchPointer: i - 1 ofObject: argArrayOrNil].
err := self ffiArgument: oop Spec: argSpec Class: argClass in: calloutState.
err ~= 0 ifTrue:
[self cleanupCalloutState: calloutState.
self cppIf: COGMTVM ifTrue:
[err = PrimErrObjectMayMove negated ifTrue:
[^PrimErrObjectMayMove]]. "N.B. Do not fail if object may move because caller will GC and retry."
^self ffiFail: err]]. "coercion failed or out of stack space"
"Failures must be reported back from ffiArgument:Spec:Class:in:.
Should not fail from here on in."
self assert: interpreterProxy failed not.
self ffiLogCallout: externalFunction.
(requiredStackSize < 0
and: [self externalFunctionHasStackSizeSlot]) ifTrue:
[stackSize := calloutState currentArg - calloutState argVector.
interpreterProxy storeInteger: ExternalFunctionStackSizeIndex ofObject: externalFunction withValue: stackSize].
"Go out and call this guy"
result := self ffiCalloutTo: address SpecOnStack: argArrayOrNil notNil in: calloutState.
self cleanupCalloutState: calloutState.
^result!
1
0
Hi Eliot. Me again :) I was checking the changes Igor did some time ago
for the fast become where he basically swapped the bytes contents between
the objects when they were the same size and same header type. He put such
code in separate primtives and some changes in the image side to call them.
I have just played with them and they seem to work. I have 2 questions for
you:
1) Do you think that this new fast become can have problems when becoming
CompiledMethods? I am asking because of the JIT/Pic. Maybe I need a
flushCache or something?
So far, I tried for example the following:
| methods |
methods := IdentitySet new.
(PackageInfo allPackages select: [:each|
(#( 'AST' 'Autotest' 'AutomaticMethodCategorizer' "'Bogus'
'CodeStats' 'Gofer' 'Metacello' 'FreeType' 'HelpSystem' 'ProfStef'
'ScriptManager' 'Zinc' 'Sound' 'Tests' 'ConfigurationOf'
'ImageForDevelopers' 'LED' 'MemoryMonitor' 'SUnit' 'TrueType' 'Monticello'
'Network' 'Refactoring' 'Regex' 'ToolBuilder'" ) anySatisfy: [:aString |
(each packageName includesSubString: aString)])
] )
do: [:aPackage |
aPackage classes do: [:each | methods addAll: each methods ].
].
methods do: [:each |
each become: each copy
]
and I run the tests of that package before and after... no crash. Is there
something better I could test?
2) If I prepare a nice script with some small modifications to Igor's
proposal would you take a look and integrate it if it is ok? Just to know
whether I should spend time on that or not.
Thanks in advance,
--
Mariano
http://marianopeck.wordpress.com
3
14
Squeak4.3
VM.r2522/
1.
$ uname -a
Darwin Macintosh-4.local 11.3.0 Darwin Kernel Version 11.3.0: Thu Jan 12 18:47:41 PST 2012; root:xnu-1699.24.23~1/RELEASE_X86_64 x86_64
$ /Users/chriscunnington/Desktop/Cog.app/Contents/MacOS/Croquet /Users/chriscunnington/Desktop/Squeak4\ 2.3/Squeak4.3.image&
[1] 841
2.
Entered in Workspace:
StdioListener new run
3.
$ squeak> DateAndTime now!
-bash: DateAndTime: command not found
[1]+ Stopped /Users/chriscunnington/Desktop/Cog.app/Contents/MacOS/Croquet /Users/chriscunnington/Desktop/Squeak4\ 2.3/Squeak4.3.image
4.
Activity Monitor
Croquet ( Not Responding ) pid 841 chriscunnington 0.0 (CPU) 5 (threads)
Chris
1
0
[commit] r2531 - -Wno-pragmas is a blunt instrument that is not understood on 3.x gccs.
by commits＠squeakvm.org 04 Feb '12
by commits＠squeakvm.org 04 Feb '12
04 Feb '12
Author: eliot
Date: 2012-02-03 15:35:12 -0800 (Fri, 03 Feb 2012)
New Revision: 2531
Modified:
branches/Cog/nscogsrc/vm/cogit.h
branches/Cog/platforms/unix/vm-display-fbdev/Makefile.in
Log:
-Wno-pragmas is a blunt instrument that is not understood on 3.x gccs.
Newspeak's cogit.h was accidentally unofficial.
Modified: branches/Cog/nscogsrc/vm/cogit.h
===================================================================
--- branches/Cog/nscogsrc/vm/cogit.h 2012-02-03 23:02:38 UTC (rev 2530)
+++ branches/Cog/nscogsrc/vm/cogit.h 2012-02-03 23:35:12 UTC (rev 2531)
@@ -1,5 +1,5 @@
/* Automatically generated by
- CCodeGenerator * VMMaker.oscog-eem.139 uuid: c2849383-9768-4948-b9b2-a5c22d482b07
+ CCodeGenerator VMMaker.oscog-eem.139 uuid: c2849383-9768-4948-b9b2-a5c22d482b07
*/
Modified: branches/Cog/platforms/unix/vm-display-fbdev/Makefile.in
===================================================================
--- branches/Cog/platforms/unix/vm-display-fbdev/Makefile.in 2012-02-03 23:02:38 UTC (rev 2530)
+++ branches/Cog/platforms/unix/vm-display-fbdev/Makefile.in 2012-02-03 23:35:12 UTC (rev 2531)
@@ -43,7 +43,7 @@
TARGET = vm-display-fbdev$a
OBJS = sqUnixFBDev$o
-XCFLAGS = $(X_CFLAGS) -Wall -Werror -Wno-unknown-pragmas -Wno-pragmas
+XCFLAGS = $(X_CFLAGS) -Wall -Werror -Wno-unknown-pragmas
XINCLUDES = [includes] $(X_INCLUDES) \
-I$(topdir)/platforms/Cross/plugins/FilePlugin \
1
0
[commit] r2530 - Add 1007, 1008 & 1009 attribute info to version info on linux, & 1009 on Windows.
by commits＠squeakvm.org 04 Feb '12
by commits＠squeakvm.org 04 Feb '12
04 Feb '12
Author: eliot
Date: 2012-02-03 15:02:38 -0800 (Fri, 03 Feb 2012)
New Revision: 2530
Modified:
branches/Cog/platforms/Cross/vm/sqSCCSVersion.h
branches/Cog/platforms/Mac OS/vm/sqMacMain.c
branches/Cog/platforms/Mac OS/vm/sqMacUnixCommandLineInterface.c
branches/Cog/platforms/unix/vm/sqUnixMain.c
branches/Cog/platforms/win32/vm/sqWin32Intel.c
branches/Cog/platforms/win32/vm/sqWin32PluginSupport.c
Log:
Add 1007,1008 & 1009 attribute info to version info on linux, & 1009 on Windows.
Add -version option to Mac VM (with similar info to linux).
Fix compilation warning in sqWin32PluginSupport.c
Property changes on: branches/Cog/platforms/Cross/vm/sqSCCSVersion.h
___________________________________________________________________
Modified: checkindate
- Thu Feb 2 14:44:43 PST 2012
+ Fri Feb 3 15:01:19 PST 2012
Modified: branches/Cog/platforms/Mac OS/vm/sqMacMain.c
===================================================================
--- branches/Cog/platforms/Mac OS/vm/sqMacMain.c 2012-02-02 22:45:39 UTC (rev 2529)
+++ branches/Cog/platforms/Mac OS/vm/sqMacMain.c 2012-02-03 23:02:38 UTC (rev 2530)
@@ -152,6 +152,7 @@
extern void dumpPrimTraceLog(void);
extern BOOL NSApplicationLoad(void);
static void fetchPrefrences(void);
+char *getVersionInfo(int verbose);
/*** errors ***/
@@ -170,6 +171,7 @@
static sqInt printingStack = false;
printf("\n%s%s%s\n\n", msg, date ? " " : "", date ? date : "");
+ printf("%s\n\n", getVersionInfo(1));
#if !defined(NOEXECINFO)
printf("C stack backtrace:\n");
@@ -262,13 +264,12 @@
}
static void
-sigusr1(int sig, siginfo_t *info, ucontext_t *uap)
+sigusr1(int sig, siginfo_t *info, void *uap)
{
int saved_errno = errno;
time_t now = time(NULL);
char ctimebuf[32];
char crashdump[IMAGE_NAME_SIZE+1];
- unsigned long pc;
if (!ioOSThreadsEqual(ioCurrentOSThread(),getVMOSThread())) {
pthread_kill(getVMOSThread(),sig);
@@ -287,7 +288,7 @@
}
static void
-sigsegv(int sig, siginfo_t *info, ucontext_t *uap)
+sigsegv(int sig, siginfo_t *info, void *uap)
{
time_t now = time(NULL);
char ctimebuf[32];
@@ -907,7 +908,45 @@
}
+char *
+getVersionInfo(int verbose)
+{
+#if STACKVM
+ extern char *__interpBuildInfo;
+# define INTERP_BUILD __interpBuildInfo
+# if COGVM
+ extern char *__cogitBuildInfo;
+# endif
+#else
+# define INTERP_BUILD interpreterVersion
+#endif
+ extern char vmBuildString[];
+ CFStringRef versionString;
+ char *info= (char *)malloc(4096);
+ info[0]= '\0';
+
+ if (verbose)
+ sprintf(info+strlen(info), IMAGE_DIALECT_NAME " VM version: ");
+ sprintf(info+strlen(info), "%s ", VM_VERSION);
+ if ((versionString = CFBundleGetValueForInfoDictionaryKey(
+ CFBundleGetMainBundle(),
+ CFSTR("CFBundleVersion"))))
+ CFStringGetCString(versionString, info+strlen(info), 4095-strlen(info), gCurrentVMEncoding);
+ sprintf(info+strlen(info), " %s\n", vmBuildString);
+ if (verbose)
+ sprintf(info+strlen(info), "Built from: ");
+ sprintf(info+strlen(info), "%s\n", INTERP_BUILD);
#if COGVM
+ if (verbose)
+ sprintf(info+strlen(info), "With: ");
+ sprintf(info+strlen(info), "%s\n", GetAttributeString(1008)); /* __cogitBuildInfo */
+#endif
+ if (verbose)
+ sprintf(info+strlen(info), "Revision: ");
+ sprintf(info+strlen(info), "%s\n", sourceVersionString());
+ return info;
+}
+#if COGVM
/*
* Support code for Cog.
* a) Answer whether the C frame pointer is in use, for capture of the C stack
Modified: branches/Cog/platforms/Mac OS/vm/sqMacUnixCommandLineInterface.c
===================================================================
--- branches/Cog/platforms/Mac OS/vm/sqMacUnixCommandLineInterface.c 2012-02-02 22:45:39 UTC (rev 2529)
+++ branches/Cog/platforms/Mac OS/vm/sqMacUnixCommandLineInterface.c 2012-02-03 23:02:38 UTC (rev 2530)
@@ -152,6 +152,11 @@
if (!strcmp(argv[0], "-help")) {
usage();
return 1; }
+ else if (!strcmp(argv[0], "-version")) {
+ extern char *getVersionInfo(int verbose);
+ printf("%s\n", getVersionInfo(0));
+ exit(0);
+ }
else if (!strncmp(argv[0], "-psn_", 5)) { return 1; }
else if (!strcmp(argv[0], "-headless")) { gSqueakHeadless = true; return 1; }
else if (!strcmp(argv[0], "-headfull")) { gSqueakHeadless = false; return 1; }
@@ -280,6 +285,7 @@
#endif
printf(" -pathenc <enc> set encoding for pathnames (default: macintosh)\n");
printf(" -headless run in headless (no window) mode (default: false)\n");
+ printf(" -version print version information, then exit\n");
}
static void printUsageNotes(void)
Modified: branches/Cog/platforms/unix/vm/sqUnixMain.c
===================================================================
--- branches/Cog/platforms/unix/vm/sqUnixMain.c 2012-02-02 22:45:39 UTC (rev 2529)
+++ branches/Cog/platforms/unix/vm/sqUnixMain.c 2012-02-03 23:02:38 UTC (rev 2530)
@@ -137,6 +137,7 @@
struct SqSound *snd= 0;
extern void dumpPrimTraceLog(void);
+char *getVersionInfo(int verbose);
/*
@@ -779,6 +780,7 @@
static sqInt printingStack = false;
printf("\n%s%s%s\n\n", msg, date ? " " : "", date ? date : "");
+ printf("%s\n\n", getVersionInfo(1));
#if !defined(NOEXECINFO)
printf("C stack backtrace:\n");
@@ -860,7 +862,7 @@
}
static void
-sigusr1(int sig, siginfo_t *info, ucontext_t *uap)
+sigusr1(int sig, siginfo_t *info, void *uap)
{
int saved_errno = errno;
time_t now = time(NULL);
@@ -885,7 +887,7 @@
}
static void
-sigsegv(int sig, siginfo_t *info, ucontext_t *uap)
+sigsegv(int sig, siginfo_t *info, void *uap)
{
time_t now = time(NULL);
char ctimebuf[32];
@@ -1405,7 +1407,7 @@
# if !STACKVM
printf(" -jit enable the dynamic compiler (if available)\n");
# endif
- printf(" -notimer disable interval timer for low-res clock \n");
+ printf(" -notimer disable interval timer for low-res clock\n");
printf(" -display <dpy> quivalent to '-vm-display-X11 -display <dpy>'\n");
printf(" -headless quivalent to '-vm-display-X11 -headless'\n");
printf(" -nodisplay quivalent to '-vm-display-null'\n");
@@ -1473,6 +1475,15 @@
char *getVersionInfo(int verbose)
{
+#if STACKVM
+ extern char *__interpBuildInfo;
+# define INTERP_BUILD __interpBuildInfo
+# if COGVM
+ extern char *__cogitBuildInfo;
+# endif
+#else
+# define INTERP_BUILD interpreterVersion
+#endif
extern int vm_serial;
extern char *vm_date, *cc_version, *ux_version;
char *info= (char *)malloc(4096);
@@ -1487,8 +1498,16 @@
sprintf(info+strlen(info), " %s %s\n", vm_date, cc_version);
if (verbose)
sprintf(info+strlen(info), "Built from: ");
- sprintf(info+strlen(info), "%s\n", interpreterVersion);
+ sprintf(info+strlen(info), "%s\n", INTERP_BUILD);
+#if COGVM
if (verbose)
+ sprintf(info+strlen(info), "With: ");
+ sprintf(info+strlen(info), "%s\n", GetAttributeString(1008)); /* __cogitBuildInfo */
+#endif
+ if (verbose)
+ sprintf(info+strlen(info), "Revision: ");
+ sprintf(info+strlen(info), "%s\n", sourceVersionString());
+ if (verbose)
sprintf(info+strlen(info), "Build host: ");
sprintf(info+strlen(info), "%s\n", ux_version);
sprintf(info+strlen(info), "plugin path: %s [default: %s]\n", squeakPlugins, vmPath);
Modified: branches/Cog/platforms/win32/vm/sqWin32Intel.c
===================================================================
--- branches/Cog/platforms/win32/vm/sqWin32Intel.c 2012-02-02 22:45:39 UTC (rev 2529)
+++ branches/Cog/platforms/win32/vm/sqWin32Intel.c 2012-02-03 23:02:38 UTC (rev 2530)
@@ -20,6 +20,7 @@
#include <ole2.h>
#include "sq.h"
#include "sqWin32Backtrace.h"
+#include "sqSCCSVersion.h"
#if COGVM
# include "cogmethod.h"
# if COGMTVM
@@ -854,6 +855,7 @@
fprintf(f,"Cogit Build: %s\n", __cogitBuildInfo);
# endif
#endif
+ fprintf(f,"Source Version: %s\n", sourceVersionString());
fflush(f);
fprintf(f,"\n"
"Current byte code: %d\n"
Modified: branches/Cog/platforms/win32/vm/sqWin32PluginSupport.c
===================================================================
--- branches/Cog/platforms/win32/vm/sqWin32PluginSupport.c 2012-02-02 22:45:39 UTC (rev 2529)
+++ branches/Cog/platforms/win32/vm/sqWin32PluginSupport.c 2012-02-03 23:02:38 UTC (rev 2530)
@@ -250,7 +250,7 @@
#endif
fileHandle = instantiateClassindexableSize(classByteArray(), fileRecordSize());
fBrowserMode = false;
- sqFileOpen(fileValueOf(fileHandle),(int)req->localName, strlen(req->localName), 0);
+ sqFileOpen(fileValueOf(fileHandle),req->localName,strlen(req->localName),0);
fBrowserMode = true;
if(failed()) return 0;
}
1
0
On Tue, Jan 31, 2012 at 8:35 PM, S Krish
<krishnamachari.sudhakar(a)gmail.com>wrote:
> I cant get the stdin on FileStream to work. Just blocks irrespective of
> what I do in sending characters with enter.. or any other trials .. will
> check a little more
I assure you it does work with the right image-level code. Here's an
interaction with a 3.8/Qwaq derived image on Mac OS:
McStalker.macbuild$ uname -a
Darwin McStalker 10.8.0 Darwin Kernel Version 10.8.0: Tue Jun 7 16:32:41
PDT 2011; root:xnu-1504.15.3~1/RELEASE_X86_64 x86_64 i386
McStalker.macbuild$ oscfvm ~/Cog/startreader.image
squeak> DateAndTime now!
2012-02-03T13:04:24-08:00
squeak> Smalltalk quit!
McStalker.macbuild$
On linux:
[eliot@mcqfes ~]$ oscogvm/coglinux/squeak Cog/startreader.image
squeak> Smalltalk quit!
[eliot@mcqfes ~]$ uname -a
Linux mcqfes 2.6.18-128.el5 #1 SMP Wed Jan 21 10:44:23 EST 2009 i686 i686
i386 GNU/Linux
[eliot@mcqfes ~]$ oscogvm/coglinux/squeak Cog/startreader.image
squeak> DateAndTime now!
2012-02-03T13:05:58-08:00
squeak> Smalltalk quit!
[eliot@mcqfes ~]$
And windows:
U:\Cog>ver
Microsoft Windows XP [Version 5.1.2600]
U:\Cog>oscogvm\cygwinbuild\build\vm\CroquetConsole.exe startreader.image
squeak> DateAndTime now!
2012-02-03T13:07:39-08:00
squeak> Smalltalk quit!
U:\Cog>
It's crude, using chunk format, but demonstrates the functionality and is
very simple. To get this to work requires the attached nextChunkNoTag hack
since restoreState:with: seems unreliable (it implements skip: -1, which is
used in peek). For Windows you need the 2519 or newer Cog VM.
>
> On Wed, Feb 1, 2012 at 5:06 AM, Eliot Miranda <eliot.miranda(a)gmail.com>wrote:
>
>>
>>
>> On Tue, Jan 31, 2012 at 4:10 AM, Damien Pollet <damien.pollet(a)gmail.com>wrote:
>>
>>> On 29 January 2012 21:11, Guillermo Polito <guillermopolito(a)gmail.com>
>>> wrote:
>>> > I've spent a few hours playing with Alien+FFI and I did want to have a
>>> > Command line interface to play and use as a quick browser.
>>>
>>> This is something I'd like to have as a part of Coral.
>>>
>>> What's your opinion on the FFI-libc approach compared to OSProcess? I
>>> was actually thinking of doing something like that using NativeBoost
>>> :)
>>>
>>
>> There is a third option which just uses the stdio streams in
>> StandardFileStream. this has been working in the Cog VMs for some time now.
>>
>>
>>> > Gofer it
>>> > squeaksource: 'CLInterface';
>>> > package: 'ConfigurationOfCLInterface';
>>> > load.
>>> >
>>> > ConfigurationOfCLInterface load.
>>> >
>>> >
>>> > To play with it write a script, for example startCLI.st, with the
>>> following:
>>> >
>>> > CLInterface start
>>> >
>>> >
>>> >
>>> > And then, from the command line
>>> >
>>> > CogVM -vm-display-null <image> startCLI.st
>>> >
>>> >
>>> > What it does support?
>>> > - executes smalltalk expressions
>>> > - handles the errors and shows them into the stdout (so it does not
>>> explode
>>> > :P)
>>> > - stores variables as a workspace
>>> > Since I used standard C functions (fgets and printf only) this should
>>> work
>>> > on every platform from scratch (having a VM with FFI working, of
>>> course)...
>>> >
>>> > The problems I've ran so far:
>>> > - blocking FFI blocks the vm. I've not tried yet to use threads
>>> through FFI
>>> > (and I don't know if it works. Does it?). But It should be great to
>>> start
>>> > a headless seaside server with a command line :/.
>>> >
>>> > Ok, it's a very simple thing, but it allows to execute a expression
>>> from a
>>> > remote server via ssh without doing much :).
>>> >
>>> > Guille
>>>
>>>
>>>
>>> --
>>> Damien Pollet
>>> type less, do more [ | ] http://people.untyped.org/damien.pollet
>>>
>>>
>>
>>
>> --
>> best,
>> Eliot
>>
>>
>
--
best,
Eliot
1
0