[Vm-dev] VM Maker: VMMaker-tfel.362.mcz

Tim Felgentreff uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-tfel.362.mcz

==================== Summary ====================

Name: VMMaker-tfel.362 Author: tfel Time: 30 April 2015, 12:24:19.119 am UUID: 9aa35714-bf9e-5a47-a06f-b8b5c9c08520 Ancestors: VMMaker-MattSpr.361

Refactor InterpreterProxy to always go through primitiveFailFor: to set the primFailCode. In primitiveFailFor: primitive 255 is called to indicate that we are currently simulating a primitive that is about to fail for VMs (like RSqueakVM) that need to handle that case

=============== Diff against VMMaker-tfel.360 ===============

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'! SystemOrganization addCategory: #'VMMaker-JIT'! - SystemOrganization addCategory: #'VMMaker-JITSimulation'!

Item was changed: ----- Method: BalloonEngineSimulation class>>simulatePrimitive:receiver:args: (in category 'simulation') ----- simulatePrimitive: aString receiver: rcvr args: args

| proxy bb | proxy := InterpreterProxy new. proxy synthesizeStackFor: rcvr with: args. bb := self simulatorClass new. bb setInterpreter: proxy. bb initialiseModule. "rendering state is loaded in the primitive implementations" + [bb perform: aString asSymbol] on: Exception do: [:ex| + RSqueak log: 'got an error trying to simulate ', aString. + RSqueak log: ex messageText. + RSqueak log: ex signalerContext shortStack]. - [bb perform: aString asSymbol] on: Exception do: [:ex | - proxy success: false]. ^ proxy stackValue: 0 !

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 abstractDeclarations uncheckedAbstractMethods selectorTranslations breakSrcInlineSelector breakDestInlineSelector inlineReturnTypes' - instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations scopeStack methods macros apiMethods preparedMethodList variablesSetCache headerFiles globalVariableUsage useSymbolicConstants generateDeadCode doNotRemoveMethodList asArgumentTranslationDict receiverDict vmClass currentMethod logger declareMethodsStatic permitMethodPruning pools abstractDeclarations uncheckedAbstractMethods selectorTranslations breakSrcInlineSelector breakDestInlineSelector inlineReturnTypes' 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 removed: - ReadStream subclass: #FakeStdinStream - instanceVariableNames: 'atEnd simulator' - classVariableNames: '' - poolDictionaries: 'VMBasicConstants' - category: 'VMMaker-JITSimulation'! - - !FakeStdinStream commentStamp: '<historical>' prior: 0! - Fake Standard input using a dialog to prompt for a line of input at a time.!

Item was removed: - ----- Method: FakeStdinStream class>>for: (in category 'instance creation') ----- - for: aCogVMSimulator - ^(self basicNew simulator: aCogVMSimulator) - on: (String new: 80) from: 1 to: 0 - - "self new next"!

Item was removed: - ----- Method: FakeStdinStream class>>new (in category 'instance creation') ----- - new - ^super on: (String new: 80) from: 1 to: 0 - - "self new next"!

Item was removed: - ----- Method: FakeStdinStream>>atEnd (in category 'testing') ----- - atEnd - ^atEnd ifNil: [atEnd := false]!

Item was removed: - ----- Method: FakeStdinStream>>atEnd: (in category 'accessing') ----- - atEnd: aBoolean - atEnd := aBoolean!

Item was removed: - ----- Method: FakeStdinStream>>close (in category 'accessing') ----- - close - atEnd := true!

Item was removed: - ----- Method: FakeStdinStream>>next (in category 'accessing') ----- - next - "Answer the next object in the Stream represented by the receiver. - If there are no more elements in the stream fill up the buffer by prompting for input" - | sem inputLine next | - position >= readLimit ifTrue: - [simulator isThreadedVM - ifTrue: - ["(simulator cogit singleStep not - and: [UIManager confirm: 'Single step?']) ifTrue: - [simulator cogit singleStep: true]." - "threadIndex := simulator disownVM: DisownVMLockOutFullGC." self flag: #FIXME. "oscog" - simulator forceInterruptCheckFromHeartbeat. - sem := Semaphore new. - WorldState addDeferredUIMessage: - [inputLine := UIManager default request: 'Input please!!'. - sem signal]. - sem wait] - ifFalse: - [inputLine := UIManager default request: 'Input please!!']. - collection size <= inputLine size ifTrue: - [collection := collection species new: inputLine size + 1]. - collection - replaceFrom: 1 to: inputLine size with: inputLine startingAt: 1; - at: (readLimit := inputLine size + 1) put: Character lf. - position := 0. - "simulator isThreadedVM ifTrue: - [simulator ownVM: threadIndex]" self flag: #FiXME "oscog"]. - next := collection at: (position := position + 1). - "This is set temporarily to allow (FilePluginSimulator>>#sqFile:Read:Into:At: - to brwak out of its loop. sqFile:Read:Into:At: resets it on the way out." - atEnd := position >= readLimit. - ^next - - - " This does it with workspaces: - | ws r s | - s := Semaphore new. - ws := Workspace new contents: ''. - ws acceptAction: [:t| r := t asString. s signal]. - [ws openLabel: 'Yo!!'; shouldStyle: false. - (ws dependents detect: [:dep | dep isKindOf: PluggableTextMorph] ifNone: [nil]) ifNotNil: - [:textMorph| textMorph acceptOnCR: true; hasUnacceptedEdits: true]] fork. - Processor activeProcess == Project uiProcess - ifTrue: [[r isNil] whileTrue: [World doOneCycle]] - ifFalse: [s wait]. - ws topView delete. - s wait. s signal. - r"!

Item was removed: - ----- Method: FakeStdinStream>>simulator: (in category 'initialize-release') ----- - simulator: aCogVMSimulator - simulator := aCogVMSimulator. - atEnd := false!

Item was changed: ----- Method: FilePlugin class>>requiredMethodNames (in category 'translation') ----- requiredMethodNames + "fileValueOf: is called (questionably so) by support code for DropPlugin" - "fileValueOf: nd fileRecordSize are called (questionably so) by support code for DropPlugin"

+ ^ super requiredMethodNames, #( fileValueOf: )! - ^ super requiredMethodNames, #( fileValueOf: fileRecordSize )!

Item was changed: ----- Method: FilePlugin>>fileRecordSize (in category 'file primitives') ----- fileRecordSize "Return the size of a Smalltalk file record in bytes." <static: false> + ^ self cCode: 'sizeof(SQFile)'.! - ^self sizeof: #SQFile!

Item was changed: FilePlugin subclass: #FilePluginSimulator + instanceVariableNames: 'openFiles' - instanceVariableNames: 'openFiles states' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-InterpreterSimulation'!

!FilePluginSimulator commentStamp: 'tpr 5/5/2003 12:02' prior: 0! File plugin simulation for the VM simulator!

Item was removed: - ----- Method: FilePluginSimulator>>createDirectory: (in category 'simulation') ----- - createDirectory: aString - ^[FileDirectory default primCreateDirectory: aString. - true] - on: Error - do: [:ex| false] - !

Item was changed: ----- Method: FilePluginSimulator>>fileValueOf: (in category 'simulation') ----- fileValueOf: objectPointer + | index | - | index file | index := (interpreterProxy isIntegerObject: objectPointer) ifTrue: [interpreterProxy integerValueOf: objectPointer] ifFalse: [((interpreterProxy isBytes: objectPointer) + and: [(interpreterProxy byteSizeOf: objectPointer) = self bytesPerWord]) ifFalse: - and: [(interpreterProxy byteSizeOf: objectPointer) = (self sizeof: #SQFile)]) ifFalse: [interpreterProxy primitiveFail. ^nil]. + interpreterProxy longAt: objectPointer + self baseHeaderSize]. + ^openFiles at: index! - interpreterProxy longAt: objectPointer + interpreterProxy baseHeaderSize]. - file := openFiles at: index. - "this attempts to preserve file positions across snapshots when debugging the VM - requires saving an image in full flight and pushing it over the cliff time after time..." - (file closed and: [states includesKey: file]) ifTrue: - [[:pos :isBinary| - file reopen; position: pos. - isBinary ifTrue: - [file binary]] valueWithArguments: (states at: file)]. - ^file!

Item was changed: ----- Method: FilePluginSimulator>>initialiseModule (in category 'initialize-release') ----- initialiseModule "See FilePluginSimulator>>sqFileStdioHandlesInto:" (openFiles := Dictionary new) at: 0 put: (FakeStdinStream for: interpreterProxy interpreter); "stdin" at: 1 put: Transcript; "stdout" at: 2 put: Transcript. "stderr" - states := IdentityDictionary new. ^super initialiseModule!

Item was removed: - ----- Method: FilePluginSimulator>>recordStateOf: (in category 'simulation') ----- - recordStateOf: file - ([file position] - on: Error - do: [:ex| nil]) ifNotNil: - [:position| - states at: file put: {position. file isBinary}]!

Item was changed: ----- Method: FilePluginSimulator>>sqFile:Read:Into:At: (in category 'simulation') ----- sqFile: file Read: count Into: byteArrayIndex At: startIndex | interpreter | interpreter := interpreterProxy interpreter. + startIndex to: startIndex + count - 1 do: - [[startIndex to: startIndex + count - 1 do: [ :i | + file atEnd ifTrue: [^i - startIndex]. + interpreter byteAt: byteArrayIndex + i put: file next asInteger]. - file atEnd ifTrue: - [(file isKindOf: FakeStdinStream) ifTrue: [file atEnd: false]. - ^i - startIndex]. - interpreter - byteAt: byteArrayIndex + i - put: file next asInteger]] - on: Error - do: [:ex| - (file isKindOf: TranscriptStream) ifFalse: [ex pass]. - ^0]] - ensure: [self recordStateOf: file]. ^count!

Item was changed: ----- Method: FilePluginSimulator>>sqFile:SetPosition: (in category 'simulation') ----- sqFile: file SetPosition: newPosition + file position: newPosition! - file position: newPosition. - self recordStateOf: file!

Item was changed: ----- Method: FilePluginSimulator>>sqFile:Truncate: (in category 'simulation') ----- sqFile: file Truncate: truncatePosition + file truncate: truncatePosition! - file truncate: truncatePosition. - self recordStateOf: file!

Item was changed: ----- Method: FilePluginSimulator>>sqFile:Write:From:At: (in category 'simulation') ----- sqFile: file Write: count From: byteArrayIndex At: startIndex | interpreter | interpreter := interpreterProxy interpreter. file isBinary ifTrue: [startIndex to: startIndex + count - 1 do: [ :i | file nextPut: (interpreter byteAt: byteArrayIndex + i)]] ifFalse: [startIndex to: startIndex + count - 1 do: [ :i | | byte | byte := interpreter byteAt: byteArrayIndex + i. file nextPut: (Character value: (byte == 12 "lf" ifTrue: [15"cr"] ifFalse: [byte]))]]. - self recordStateOf: file. ^count!

Item was changed: ----- Method: FilePluginSimulator>>sqFileClose: (in category 'simulation') ----- sqFileClose: file + file close! - file close. - self recordStateOf: file!

Item was added: + ----- Method: Interpreter>>isBigEnder (in category 'plugin support') ----- + isBigEnder + "Answer true (non-zero) if running on a big endian machine." + | endianness anInt cString len i | + <var: 'cString' type: 'char *'> + <var: 'endianness' declareC: 'static sqInt endianness = -1'> + (endianness == -1) ifFalse: [^ endianness]. "answer cached value" + len := self cCode: 'sizeof(anInt)' + inSmalltalk: [^ (Smalltalk endianness == #little) not]. + cString := self cCode: '(char *) &anInt' inSmalltalk: []. + i := 0. + [i < len] whileTrue: + [cString at: i put: i. + i := i + 1]. + endianness := anInt bitAnd: 255. + ^ endianness + !

Item was removed: - ----- Method: InterpreterPlugin class>>newFor: (in category 'simulation') ----- - newFor: anUnsimulatedInterpreterPluginClass - "Overridden by SmartSyntaxPluginSimulator to wrap a specific plugin class." - ^self new!

Item was changed: + ----- Method: InterpreterPlugin class>>simulatorClass (in category 'accessing') ----- - ----- Method: InterpreterPlugin class>>simulatorClass (in category 'simulation') ----- simulatorClass "For running from Smalltalk - answer a class that can be used to simulate the receiver, or nil if you want the primitives in this module to always fail, causing simulation to fall through to the Smalltalk code. By default every non-TestInterpreterPlugin can simulate itself."

^ self!

Item was changed: ----- Method: InterpreterPrimitives class>>requiredMethodNames (in category 'translation') ----- requiredMethodNames + "return the list of method names that should be retained for export or other support reasons" - "Return the list of method names that should be retained for export or other support reasons. - Include all of the selectors for primitives to ensure translation in slang browser."

+ ^super requiredMethodNames, #(floatArg: integerArg: methodArg: methodReturnValue: objectArg: primitiveMethod)! - ^super requiredMethodNames, - #(floatArg: integerArg: methodArg: methodReturnValue: objectArg: primitiveMethod), - (self selectors select: [:e | 'primitive*' match: e])!

Item was removed: - ----- Method: InterpreterPrimitives>>isBigEnder (in category 'primitive support') ----- - isBigEnder - "Answer true (non-zero) if running on a big endian machine." - | endianness anInt cString len i | - <var: 'cString' type: 'char *'> - <var: 'endianness' declareC: 'static sqInt endianness = -1'> - (endianness == -1) ifFalse: [^ endianness]. "answer cached value" - len := self cCode: 'sizeof(anInt)' - inSmalltalk: [^ (Smalltalk endianness == #little) not]. - cString := self cCode: '(char *) &anInt' inSmalltalk: []. - i := 0. - [i < len] whileTrue: - [cString at: i put: i. - i := i + 1]. - endianness := anInt bitAnd: 255. - ^ endianness - !

Item was removed: - ----- Method: InterpreterPrimitives>>primitiveIsBigEnder (in category 'other primitives') ----- - primitiveIsBigEnder - "Answer true if running on a big endian machine." - <export: true> - self isBigEnder - ifTrue: [self pop: 1 thenPush: objectMemory trueObject] - ifFalse: [self pop: 1 thenPush: objectMemory falseObject] - !

Item was changed: ----- Method: InterpreterPrimitives>>success: (in category 'primitive support') ----- success: successBoolean "Set the state of the primitive failure code/success flag, iff successBoolean is false. If primFailCode is non-zero a primitive has failed. If primFailCode is greater than one then its value indicates the reason for failure."

"Use returnTypeC: #sqInt because that's the way it is defined in sq.h. + Use no explicit return so that Slang doesn't fail an inlin ingtype-check when - Use no explicit return so that Slang doesn't fail an inlining type-check when a primitive with return type void uses ^self success: false to exit." <returnTypeC: #sqInt> <inline: true> successBoolean ifFalse: ["Don't overwrite an error code that has already been set." self successful ifTrue: [primFailCode := 1]]!

Item was changed: ----- Method: InterpreterProxy>>initialize (in category 'initialize') ----- initialize + successFlag := true. remapBuffer := OrderedCollection new. stack := OrderedCollection new. primFailCode := 0. !

Item was changed: ----- Method: InterpreterProxy>>primitiveFailFor: (in category 'other') ----- primitiveFailFor: reasonCode + "Set specific primitive failure. N.B. primitiveFailFor: PrimNoErr is expected to clear the primFailCode. + Primitive 255 is called to indicate that we are currently simulating a primitive that should fail and the VM should handle that case appropriately (if supported by the VM)." + <primitive: 255> + ^ primFailCode := reasonCode! - "Set specific primitive failure. - N.B. primitiveFailFor: PrimNoErr is expected to clear the primFailCode." - (self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt]. - ^primFailCode := reasonCode!

Item was changed: ----- Method: InterpreterProxy>>success: (in category 'other') ----- success: aBoolean + self failed ifTrue: [^ self]. - self failed ifTrue:[^self]. aBoolean ifFalse: [ + self primitiveFailFor: 1. + (self confirm: 'A primitive is failing -- Stop simulation?') ifTrue: [self halt]].! - primFailCode := 1. - (self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt]] - !

Item was changed: ----- Method: InterpreterProxy>>synthesizeStackFor:with: (in category 'initialize') ----- synthesizeStackFor: receiver with: args - <doNotGenerate> self push: receiver. argumentCount := args size. 1 to: argumentCount do: [:i | self push: (args at: i)].!

Item was removed: - ----- Method: InterpreterSimulator>>interpreter (in category 'interpreter shell') ----- - interpreter - ^self!

Item was removed: - ----- Method: InterpreterSimulator>>isIntegerObject: (in category 'interpreter access') ----- - isIntegerObject: objectPointer - "In simulation, an interpreter simulator serves as the interpreter proxy" - ^ objectMemory isIntegerObject: objectPointer!

Item was changed: ----- Method: InterpreterSimulator>>loadNewPlugin: (in category 'plugin support') ----- loadNewPlugin: pluginString + | plugin simClass | + transcript cr; show:'Looking for module ', pluginString. + (#('FloatArrayPlugin' 'Matrix2x3Plugin') + includes: pluginString) ifTrue: + [transcript show: ' ... defeated'. ^ nil]. + plugin := simClass := nil. + InterpreterPlugin allSubclassesDo:[:plg| + plg moduleName asString = pluginString asString ifTrue:[ + simClass := plg simulatorClass. + plugin ifNil:[plugin := simClass] + ifNotNil:[plugin == simClass ifFalse:[^self error:'This won''t work...']]. + ]. + ]. + plugin ifNil:[transcript show: ' ... not found'. ^nil]. + plugin := plugin new. - | plugin plugins simulatorClasses | - transcript cr; show: 'Looking for module ', pluginString. - "but *why*??" - (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: pluginString) ifTrue: - [transcript show: ' ... defeated'. ^nil]. - plugins := InterpreterPlugin allSubclasses select: [:psc| psc moduleName asString = pluginString asString]. - simulatorClasses := (plugins - select: [:psc| psc simulatorClass notNil] - thenCollect: [:psc| psc simulatorClass]) asSet. - simulatorClasses isEmpty ifTrue: [transcript show: ' ... not found'. ^nil]. - simulatorClasses size > 1 ifTrue: [^self error: 'This won''t work...']. - plugins size > 1 ifTrue: - [transcript show: '...multiple plugin classes; choosing ', plugins last name]. - plugin := simulatorClasses anyOne newFor: plugins last. "hopefully lowest in the hierarchy..." plugin setInterpreter: self. "Ignore return value from setInterpreter" + (plugin respondsTo: #initialiseModule) ifTrue:[ + plugin initialiseModule ifFalse:[transcript show: ' ... initialiser failed'.^nil]. "module initialiser failed" + ]. - (plugin respondsTo: #initialiseModule) ifTrue: - [plugin initialiseModule ifFalse: - [transcript show: ' ... initialiser failed'. ^nil]]. "module initialiser failed" pluginList := pluginList copyWith: (pluginString asString -> plugin). + transcript show:' ... loaded'. - transcript show: ' ... loaded'. ^pluginList last!

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 *'. - <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: ClassByteString) 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 getTrueObj ] + ifFalse: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory getFalseObj ]. + objectMemory storePointer: 4 ofObject: results + withValue: (objectMemory integerObjectOf: fileSize). - ifTrue: [ self storePointer: 3 ofObject: results withValue: objectMemory trueObject ] - ifFalse: [ self storePointer: 3 ofObject: results withValue: objectMemory falseObject ]. - self storePointer: 4 ofObject: results - withValue: (self integerObjectOf: fileSize). ^ results !

Item was removed: - ----- Method: InterpreterSimulator>>primitiveDirectoryEntry (in category 'file primitives') ----- - primitiveDirectoryEntry - | name pathName array result | - name := self stringOf: self stackTop. - pathName := self stringOf: (self stackValue: 1). - - self successful ifFalse: - [^self primitiveFail]. - - array := FileDirectory default primLookupEntryIn: pathName name: name. - array == nil ifTrue: - [self pop: 3 thenPush: objectMemory nilObj. - ^array]. - array == #badDirectoryPath ifTrue: - [self halt. - ^self primitiveFail]. - array == #primFailed 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>>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 getNilObj. - self push: objectMemory 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>>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 | objectMemory bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet']. + headerSize := 16 * self bytesPerWord. - headerSize := 16 * objectMemory bytesPerWord.

{ self imageFormatVersion. headerSize. numberOfBytesToWrite. objectMemory startOfMemory. objectMemory getSpecialObjectsOop. objectMemory getLastHash. 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 getMemory at: index) toFile: file].

self success: true !

Item was changed: ----- Method: InterpreterStackPages>>extraStackBytes (in category 'initialization') ----- extraStackBytes "See initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom: ``Because stack pages grow down...''" + ^self cCode: 'BytesPerWord' inSmalltalk: [0]! - ^self cCode: 'BYTES_PER_WORD' inSmalltalk: [0]!

Item was added: + ----- Method: NewObjectMemory>>objectRepresentationClass (in category 'cog jit support') ----- + objectRepresentationClass + <doNotGenerate> + ^CogObjectRepresentationForSqueakV3!

Item was changed: InterpreterPlugin subclass: #SmartSyntaxInterpreterPlugin + instanceVariableNames: '' - instanceVariableNames: 'simulator' classVariableNames: '' poolDictionaries: '' category: 'VMMaker-SmartSyntaxPlugins'!

!SmartSyntaxInterpreterPlugin commentStamp: '<historical>' prior: 0! Subclass of InterpreterPlugin, used in connection with TestCodeGenerator for named primitives with type coercion specifications!

Item was changed: + ----- Method: SmartSyntaxInterpreterPlugin class>>simulatorClass (in category 'instance creation') ----- - ----- Method: SmartSyntaxInterpreterPlugin class>>simulatorClass (in category 'simulation') ----- simulatorClass "For running from Smalltalk - answer a class that can be used to simulate the receiver, or nil if you want the primitives in this module to always fail, causing simulation to fall through to the Smalltalk code. By default SmartSyntaxInterpreterPlugin answers nil because methods in these plugins are intended to be embedded in code that pushes and pops from the stack and therefore cannot be run independently. This wrapper code is generated when translated to C. But, unfortunately, this code is missing during simulation. There was an attempt to simulate this, but only the prologue code (getting arg from the stack) is simulated (see simulatePrologInContext:). The epologue code (popping args and pushing result) is not. So I am making this nil until this can be fixed. Also, beware that primitive methods that take no args exactly match their primitive name (faking out InterpreterSimulator>>callExternalPrimitive:). They should only be called from within wrapper code that simulates the prologue and epilogue. Primitive method that take args don't have this accidental matching problem since their names contain colons while their primitive names do not. - ajh 8/21/2002"

^ nil!

Item was removed: - ----- Method: SmartSyntaxInterpreterPlugin>>simulator (in category 'accessing') ----- - simulator - <doNotGenerate> - ^simulator!

Item was removed: - ----- Method: SmartSyntaxInterpreterPlugin>>simulator: (in category 'accessing') ----- - simulator: aSmartSyntaxPluginSimulator - <doNotGenerate> - simulator := aSmartSyntaxPluginSimulator!

Item was changed: ----- Method: SmartSyntaxPluginSimulator>>setInterpreter: (in category 'initialize') ----- setInterpreter: anInterpreterProxy interpreterProxy := anInterpreterProxy. actualPlugin setInterpreter: anInterpreterProxy. + self computeSignatureMap! - "self computeSignatureMap" self flag: #FIXME "part of the oscog type inferencing"!

Item was changed: ----- Method: SocketPlugin>>socketRecordSize (in category 'primitives') ----- socketRecordSize "Return the size of a Smalltalk socket record in bytes." + + ^ self cCode: 'sizeof(SQSocket)' inSmalltalk: [12]! - <inline: true> - ^ self sizeof: #SQSocket!

Item was changed: ----- Method: StackInterpreter>>activateNewClosureMethod:numArgs:mayContextSwitch: (in category 'control primitives') ----- activateNewClosureMethod: blockClosure numArgs: numArgs mayContextSwitch: mayContextSwitch "Similar to activateNewMethod but for Closure and newMethod." | numCopied outerContext theMethod closureIP | <inline: true> outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure. numCopied := self copiedValueCountOfClosure: blockClosure.

theMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext. self push: instructionPointer. self push: framePointer. framePointer := stackPointer. self push: theMethod. self push: (self encodeFrameFieldHasContext: false isBlock: true numArgs: numArgs). self push: objectMemory nilObject. "FxThisContext field" self push: (objectMemory fetchPointer: ReceiverIndex ofObject: outerContext).

"Copy the copied values..." 0 to: numCopied - 1 do: [:i| self push: (objectMemory fetchPointer: i + ClosureFirstCopiedValueIndex ofObject: blockClosure)].

self assert: (self frameIsBlockActivation: framePointer). self assert: (self frameHasContext: framePointer) not.

"The initial instructions in the block nil-out remaining temps."

"the instruction pointer is a pointer variable equal to + method oop + ip + BaseHeaderSize - method oop + ip + objectMemory baseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" closureIP := self quickFetchInteger: ClosureStartPCIndex ofObject: blockClosure. + instructionPointer := theMethod + closureIP + self baseHeaderSize - 2. - instructionPointer := theMethod + closureIP + objectMemory baseHeaderSize - 2. self setMethod: theMethod.

"Now check for stack overflow or an event (interrupt, must scavenge, etc)" stackPointer < stackLimit ifTrue: [self handleStackOverflowOrEventAllowContextSwitch: mayContextSwitch]!

Item was changed: ----- Method: StackInterpreter>>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 isNonIntegerObject: arrayOop) and: [objectMemory isWordsOrBytes: arrayOop]) ifTrue: + [^self cCoerceSimple: (self pointerForOop: arrayOop + self baseHeaderSize) to: #'void *']. - [^self cCoerceSimple: (self pointerForOop: arrayOop + objectMemory baseHeaderSize) to: #'void *']. self primitiveFail!

Item was changed: ----- Method: StackInterpreter>>checkStackIntegrity (in category 'object memory support') ----- checkStackIntegrity "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccesibleObjects has set a bit at each object's header. Scan all objects accessible from the stack checking that every pointer points to a header. Answer if no dangling pointers were detected." | ok | <inline: false> <var: #thePage type: #'StackPage *'> <var: #theSP type: #'char *'> <var: #theFP type: #'char *'> <var: #callerFP type: #'char *'> ok := true. 0 to: numStackPages - 1 do: [:i| | thePage theSP theFP callerFP oop | thePage := stackPages stackPageAt: i. (stackPages isFree: thePage) ifFalse: [thePage = stackPage ifTrue: [theSP := stackPointer. theFP := framePointer] ifFalse: [theSP := thePage headSP. theFP := thePage headFP]. "Skip the instruction pointer on top of stack of inactive pages." thePage = stackPage ifFalse: + [theSP := theSP + self bytesPerWord]. - [theSP := theSP + objectMemory bytesPerWord]. [[theSP <= (theFP + FoxReceiver)] whileTrue: [oop := stackPages longAt: theSP. ((objectMemory isNonIntegerObject: oop) and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue: [self printFrameThing: 'object leak in frame temp' at: theSP; cr. ok := false]. + theSP := theSP + self bytesPerWord]. - theSP := theSP + objectMemory bytesPerWord]. (self frameHasContext: theFP) ifTrue: [oop := self frameContext: theFP. ((objectMemory isIntegerObject: oop) or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue: [self printFrameThing: 'object leak in frame ctxt' at: theFP + FoxThisContext; cr. ok := false]. (self isContext: oop) ifFalse: [self printFrameThing: 'frame ctxt should be context' at: theFP + FoxThisContext; cr. ok := false]]. oop := self frameMethod: theFP. ((objectMemory isIntegerObject: oop) or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue: [self printFrameThing: 'object leak in frame mthd' at: theFP + FoxMethod; cr. ok := false]. (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: + [theSP := theFP + FoxCallerSavedIP + self bytesPerWord. - [theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord. theFP := callerFP]. theSP := theFP + FoxCallerContext "a.k.a. FoxCallerSavedIP". [theSP <= thePage baseAddress] whileTrue: [oop := stackPages longAt: theSP. ((objectMemory isNonIntegerObject: oop) and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue: [self printFrameThing: 'object leak in frame arg' at: theSP; cr. ok := false]. + theSP := theSP + self bytesPerWord]]]. - theSP := theSP + objectMemory bytesPerWord]]]. ^ok!

Item was changed: ----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:copiedValues: (in category 'control primitives') ----- closureIn: context numArgs: numArgs instructionPointer: initialIP copiedValues: copiedValues | newClosure numCopied | <inline: true> "numCopied should be zero for nil" numCopied := objectMemory fetchWordLengthOf: copiedValues. newClosure := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure) + sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize. - sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize. "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores." objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context. objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP). objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs). 0 to: numCopied - 1 do: [:i| objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex ofObject: newClosure withValue: (objectMemory fetchPointer: i ofObject: copiedValues)]. ^newClosure!

Item was changed: ----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:numCopiedValues: (in category 'control primitives') ----- closureIn: context numArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied | newClosure | <inline: true> + self assert: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize <= 252. - self assert: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize <= 252. newClosure := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure) + sizeInBytes: (self bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize. - sizeInBytes: (objectMemory bytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + objectMemory baseHeaderSize. "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores." objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context. objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP). objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs). ^newClosure!

Item was changed: ----- Method: StackInterpreter>>commonReturn (in category 'return bytecodes') ----- commonReturn "Note: Assumed to be inlined into the dispatch loop."

| closure home unwindContextOrNilOrZero frameToReturnTo contextToReturnTo theFP callerFP newPage | <var: #frameToReturnTo type: #'char *'> <var: #theFP type: #'char *'> <var: #callerFP type: #'char *'> <var: #newPage type: #'StackPage *'> <var: #thePage type: #'StackPage *'> <sharedCodeNamed: 'commonReturn' inCase: 120>

"If this is a method simply return to the sender/caller." (self frameIsBlockActivation: localFP) ifFalse: [^self commonCallerReturn].

"Since this is a block activation the closure is on the stack above any args and the frame." closure := self pushedReceiverOrClosureOfFrame: localFP.

home := nil. "Walk the closure's lexical chain to find the context or frame to return from (home)." [closure ~~ objectMemory nilObject] whileTrue: [home := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closure. closure := objectMemory fetchPointer: ClosureIndex ofObject: home]. "home is to be returned from provided there is no unwind-protect activation between this frame and home's sender. Search for an unwind. findUnwindThroughContext: will answer either the context for an unwind-protect activation or nilObj if the sender cannot be found or 0 if no unwind is found but the sender is. We must update the current page's headFrame pointers to enable the search to identify widowed contexts correctly." self writeBackHeadFramePointers. unwindContextOrNilOrZero := self internalFindUnwindThroughContext: home. unwindContextOrNilOrZero = objectMemory nilObject ifTrue: ["error: can't find home on chain; cannot return" ^self internalCannotReturn: localReturnValue]. unwindContextOrNilOrZero ~~ 0 ifTrue: [^self internalAboutToReturn: localReturnValue through: unwindContextOrNilOrZero].

"Now we know home is on the sender chain. We could be returning to either a context or a frame. Find out which." contextToReturnTo := nil. (self isMarriedOrWidowedContext: home) ifTrue: [self assert: (self checkIsStillMarriedContext: home currentFP: localFP). theFP := self frameOfMarriedContext: home. (self isBaseFrame: theFP) ifTrue: [contextToReturnTo := self frameCallerContext: theFP] ifFalse: [frameToReturnTo := self frameCallerFP: theFP]] ifFalse: [contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home. ((self isContext: contextToReturnTo) and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue: [self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP). frameToReturnTo := self frameOfMarriedContext: contextToReturnTo. contextToReturnTo := nil]].

"If returning to a context we must make a frame for it unless it is dead." contextToReturnTo ~= nil ifTrue: [frameToReturnTo := self establishFrameForContextToReturnTo: contextToReturnTo. frameToReturnTo == 0 ifTrue: ["error: home's sender is dead; cannot return" ^self internalCannotReturn: localReturnValue]].

"Now we have a frame to return to. If it is on a different page we must free intervening pages and nil out intervening contexts. We must free intervening stack pages because if we leave the pages to be divorced then their contexts will be divorced with intact senders and instruction pointers. This code is similar to primitiveTerminateTo. We must move any frames on itervening pages above the frame linked to because these may be in use, e.g. via co-routining (see baseFrameReturn)." self assert: stackPages pageListIsWellFormed. newPage := stackPages stackPageFor: frameToReturnTo. newPage ~~ stackPage ifTrue: [| currentCtx thePage nextCntx | currentCtx := self frameCallerContext: stackPage baseFP. self assert: (self isContext: currentCtx). stackPages freeStackPage: stackPage. [self assert: (self isContext: currentCtx). (self isMarriedOrWidowedContext: currentCtx) and: [(stackPages stackPageFor: (theFP := self frameOfMarriedContext: currentCtx)) = newPage]] whileFalse: [(self isMarriedOrWidowedContext: currentCtx) ifTrue: [thePage := stackPages stackPageFor: theFP. theFP ~= thePage headFP ifTrue: ["Since we've just deallocated a page we know that newStackPage won't deallocate an existing one." self moveFramesIn: thePage through: (self findFrameAbove: theFP inPage: thePage) toPage: self newStackPage]. currentCtx := self frameCallerContext: thePage baseFP. self freeStackPage: thePage] ifFalse: [nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx. self markContextAsDead: currentCtx. currentCtx := nextCntx]]. self setStackPageAndLimit: newPage. localSP := stackPage headSP. localFP := stackPage headFP].

"Two cases. Returning to the top frame on a new page or an interior frame on the current page. The top frame has its instruction pointer on top of stack. An interior frame has its instruction pointer in the caller frame. We need to peel back any frames on the page until we get to the correct frame."

localFP = frameToReturnTo ifTrue: "pop the saved IP, push the return value and continue." [localIP := self pointerForOop: self internalStackTop] ifFalse: [[callerFP := localFP. localFP := self frameCallerFP: localFP. localFP ~~ frameToReturnTo] whileTrue. localIP := self frameCallerSavedIP: callerFP. + localSP := (self frameCallerSP: callerFP) - self bytesPerWord]. - localSP := (self frameCallerSP: callerFP) - objectMemory bytesPerWord]. self internalStackTopPut: localReturnValue. self setMethod: (self frameMethod: localFP). ^self fetchNextBytecode!

Item was changed: ----- Method: StackInterpreter>>commonSend (in category 'message sending') ----- commonSend "Send a message, starting lookup with the receiver's class." "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." <sharedCodeNamed: 'commonSend' inCase: 131> + self sendBreak: messageSelector + self baseHeaderSize - self sendBreak: messageSelector + objectMemory baseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: (self internalStackValue: argumentCount). self internalFindNewMethod. self internalExecuteNewMethod. self fetchNextBytecode!

Item was changed: ----- Method: StackInterpreter>>contextInstructionPointer:frame: (in category 'frame access') ----- contextInstructionPointer: theIP frame: theFP <var: #theFP type: #'char *'> self assert: (self validInstructionPointer: theIP inFrame: theFP). + ^objectMemory integerObjectOf: theIP - (self iframeMethod: theFP) - self baseHeaderSize + 2! - ^objectMemory integerObjectOf: theIP - (self iframeMethod: theFP) - objectMemory baseHeaderSize + 2!

Item was changed: ----- Method: StackInterpreter>>convertFloatsToPlatformOrderFrom:to: (in category 'image save/restore') ----- convertFloatsToPlatformOrderFrom: 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. Ensure floats are in platform-order." | oop temp | objectMemory vmEndianness = imageFloatsBigEndian ifTrue: [^self]. self assert: ClassFloatCompactIndex ~= 0. oop := startOop. [self oop: oop isLessThan: stopAddr] whileTrue: [(objectMemory isFreeObject: oop) ifFalse: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex ifTrue: + [temp := self longAt: oop + self baseHeaderSize. + self longAt: oop + self baseHeaderSize put: (self longAt: oop + self baseHeaderSize + 4). + self longAt: oop + self baseHeaderSize + 4 put: temp]]. - [temp := self longAt: oop + objectMemory baseHeaderSize. - self longAt: oop + objectMemory baseHeaderSize put: (self longAt: oop + objectMemory baseHeaderSize + 4). - self longAt: oop + objectMemory baseHeaderSize + 4 put: temp]]. oop := objectMemory objectAfter: oop]!

Item was changed: ----- Method: StackInterpreter>>createActualMessageTo: (in category 'message sending') ----- createActualMessageTo: lookupClass "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:" | argumentArray message | <inline: false> "This is a useful break-point" self assert: ((objectMemory isIntegerObject: messageSelector) or: [objectMemory addressCouldBeObj: messageSelector]). argumentArray := objectMemory eeInstantiateClass: (objectMemory splObj: ClassArray) indexableSize: argumentCount. message := objectMemory eeInstantiateClass: (objectMemory splObj: ClassMessage) indexableSize: 0.

"Since the array is new can use unchecked stores." + (argumentCount - 1) * self bytesPerWord to: 0 by: self bytesPerWord negated do: - (argumentCount - 1) * objectMemory bytesPerWord to: 0 by: objectMemory bytesPerWord negated do: [:i| + self longAt: argumentArray + self baseHeaderSize + i put: self popStack]. - self longAt: argumentArray + objectMemory baseHeaderSize + i put: self popStack]. "Since message is new can use unchecked stores." objectMemory storePointerUnchecked: MessageSelectorIndex ofObject: message withValue: messageSelector. objectMemory storePointerUnchecked: MessageArgumentsIndex ofObject: message withValue: argumentArray. objectMemory storePointerUnchecked: MessageLookupClassIndex ofObject: message withValue: lookupClass.

self push: message.

argumentCount := 1.!

Item was changed: ----- Method: StackInterpreter>>dbgFloatValueOf: (in category 'utilities') ----- dbgFloatValueOf: oop "This version answers the value of a float or nil if not a flat *WITHOUT* setting successFlag or any other such nonsense. It is hence safe for use in debug printing. Sheesh."

| result | <returnTypeC: #double> <var: #result type: #double> self flag: #Dan. "None of the float stuff has been converted for 64 bits" ((objectMemory isNonIntegerObject: oop) and: [(objectMemory fetchClassOfNonInt: oop) = (objectMemory splObj: ClassFloat)]) ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. + objectMemory fetchFloatAt: oop + self baseHeaderSize into: result. - objectMemory fetchFloatAt: oop + objectMemory baseHeaderSize into: result. ^result]. ^nil!

Item was changed: ----- Method: StackInterpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') ----- displayBitsOf: aForm Left: l Top: t Right: r Bottom: b "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."

| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle | displayObj := objectMemory splObj: TheDisplay. aForm = displayObj ifFalse: [^ nil]. self success: ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]). self successful ifTrue: [ dispBits := objectMemory fetchPointer: 0 ofObject: displayObj. w := self fetchInteger: 1 ofObject: displayObj. h := self fetchInteger: 2 ofObject: displayObj. d := self fetchInteger: 3 ofObject: displayObj. ]. l < 0 ifTrue:[left := 0] ifFalse: [left := l]. r > w ifTrue: [right := w] ifFalse: [right := r]. t < 0 ifTrue: [top := 0] ifFalse: [top := t]. b > h ifTrue: [bottom := h] ifFalse: [bottom := b]. ((left <= right) and: [top <= bottom]) ifFalse: [^nil]. self successful ifTrue: [ (objectMemory isIntegerObject: dispBits) ifTrue: [ surfaceHandle := objectMemory integerValueOf: dispBits. showSurfaceFn = 0 ifTrue: [ showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'. showSurfaceFn = 0 ifTrue: [^self success: false]]. self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'. ] ifFalse: [ + dispBitsIndex := dispBits + self baseHeaderSize. "index in memory byte array" - dispBitsIndex := dispBits + objectMemory baseHeaderSize. "index in memory byte array" self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)' inSmalltalk: [self showDisplayBits: dispBitsIndex w: w h: h d: d left: left right: right top: top bottom: bottom] ]. ]!

Item was changed: ----- Method: StackInterpreter>>divorceFramesIn: (in category 'frame access') ----- divorceFramesIn: aStackPage | theFP calleeFP theSP theIP calleeContext theContext | <inline: false> <var: #aStackPage type: #'StackPage *'> <var: #theFP type: #'char *'> <var: #calleeFP type: #'char *'> <var: #theSP type: #'char *'>

statStackPageDivorce := statStackPageDivorce + 1.

theFP := aStackPage headFP. theSP := aStackPage headSP. theIP := stackPages longAt: theSP. + theSP := theSP + self bytesPerWord. "theSP points at hottest item on frame's stack" - theSP := theSP + objectMemory bytesPerWord. "theSP points at hottest item on frame's stack" calleeContext := nil.

[theContext := self ensureFrameIsMarried: theFP SP: theSP. self updateStateOfSpouseContextForFrame: theFP WithSP: theSP. objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: theContext withValue: (self contextInstructionPointer: theIP frame: theFP). self assert: (self frameReceiver: theFP) = (objectMemory fetchPointer: ReceiverIndex ofObject: theContext). calleeContext ~~ nil ifTrue: [objectMemory storePointer: SenderIndex ofObject: calleeContext withValue: theContext]. calleeContext := theContext. calleeFP := theFP. theIP := (self frameCallerSavedIP: theFP) asInteger. theFP := self frameCallerFP: theFP. theFP ~= 0] whileTrue: ["theSP points at stacked hottest item on frame's stack" theSP := self frameCallerSP: calleeFP].

objectMemory storePointer: SenderIndex ofObject: theContext withValue: (self frameCallerContext: calleeFP).

"The page is now free; mark it so." aStackPage baseFP: 0!

Item was changed: ----- Method: StackInterpreter>>encodeFrameFieldHasContext:isBlock:numArgs: (in category 'frame access') ----- encodeFrameFieldHasContext: hasContext "<Boolean>" isBlock: isBlock "<Boolean>" numArgs: numArgs "For ``fast'' temporary access (ok, to mitigate slower temp access) we need fast access to a method's numArgs. Could have a variable set on save and return. We'll investigate this. For the moment we just use a byte in the frameFlags field. This is endian dependent. Store numArgs in byte at FoxFrameFields + 1. Store hasContext flag in top bit (allows for 64-bit tags) of byte at FoxFrameFields. Make frameFields look like a SmallInteger for the benefit of gc (dubious)." "bitsPerWord := BytesPerWord * 8" <inline: true> ^VMBIGENDIAN ifTrue: [1 + + (numArgs << ((self bytesPerWord * 8) - 8)) + + (hasContext ifTrue: [1 << ((self bytesPerWord * 8) - 16)] ifFalse: [0]) + + (isBlock ifTrue: [1 << ((self bytesPerWord * 8) - 24)] ifFalse: [0])] - + (numArgs << ((objectMemory bytesPerWord * 8) - 8)) - + (hasContext ifTrue: [1 << ((objectMemory bytesPerWord * 8) - 16)] ifFalse: [0]) - + (isBlock ifTrue: [1 << ((objectMemory bytesPerWord * 8) - 24)] ifFalse: [0])] ifFalse: [1 + (numArgs << 8) + (hasContext ifTrue: [1 << 16] ifFalse: [0]) + (isBlock ifTrue: [1 << 24] ifFalse: [0])]!

Item was changed: ----- Method: StackInterpreter>>externalDivorceFrame:andContext: (in category 'frame access') ----- externalDivorceFrame: theFP andContext: ctxt "Divorce a single frame and its context. If it is not the top frame of a stack this means splitting its stack." | thePage onCurrent theSP callerCtx newPage frameAbove callerFP callerSP callerIP theIP | <inline: false> <var: #theFP type: #'char *'> <var: #thePage type: #'StackPage *'> <var: #theSP type: #'char *'> <var: #newPage type: #'StackPage *'> <var: #frameAbove type: #'char *'> <var: #callerFP type: #'char *'> <var: #callerSP type: #'char *'> "stackPage needs to have current head pointers to avoid confusion." self assert: theFP ~= framePointer. self assert: (stackPage = 0 or: [stackPage = stackPages mostRecentlyUsedPage]). thePage := stackPages stackPageFor: theFP. (onCurrent := thePage = stackPage) ifFalse: [stackPages markStackPageNextMostRecentlyUsed: thePage]. theSP := self findSPOf: theFP on: thePage. self updateStateOfSpouseContextForFrame: theFP WithSP: theSP. callerCtx := self ensureCallerContext: theFP. (frameAbove := self findFrameAbove: theFP inPage: thePage) == 0 ifTrue: "If we're divorcing the top frame we can simply peel it off." [theIP := stackPages longAt: thePage headSP] ifFalse: "othewise move all frames above to a new stack and then peel the frame off." [newPage := self newStackPage. theIP := self oopForPointer: (self frameCallerSavedIP: frameAbove). frameAbove := self moveFramesIn: thePage through: frameAbove toPage: newPage. onCurrent ifTrue: [self setStackPageAndLimit: newPage. framePointer := stackPage headFP. stackPointer := stackPage headSP] ifFalse: [stackPages markStackPageMostRecentlyUsed: newPage]. self assert: (self frameCallerContext: frameAbove) = ctxt]. objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: ctxt withValue: (self contextInstructionPointer: theIP frame: theFP). objectMemory storePointer: SenderIndex ofObject: ctxt withValue: callerCtx. callerFP := self frameCallerFP: theFP. callerFP == 0 "theFP is a base frame; it is now alone; free the entire page" ifTrue: [stackPages freeStackPage: thePage] ifFalse: [callerIP := self oopForPointer: (self frameCallerSavedIP: theFP). + callerSP := (self frameCallerSP: theFP) - self bytesPerWord. - callerSP := (self frameCallerSP: theFP) - objectMemory bytesPerWord. stackPages longAt: callerSP put: callerIP. self setHeadFP: callerFP andSP: callerSP inPage: thePage] !

Item was changed: ----- Method: StackInterpreter>>findSPOrNilOf:on:startingFrom: (in category 'frame access') ----- findSPOrNilOf: theFP on: thePage startingFrom: startFrame "Search for the stack pointer for theFP. This points to the hottest item on the frame's stack. DO NOT CALL THIS WITH theFP == localFP OR theFP == framePointer!!" <var: #aFrame type: #'char *'> <var: #theFP type: #'char *'> <var: #thePage type: #'StackPage *'> <returnTypeC: #'char *'> | aFrame theSP | <inline: true> <asmLabel: false> <var: #startFrame type: #'char *'> <var: #theSP type: #'char *'> self assert: (stackPages isFree: thePage) not. aFrame := startFrame. theSP := thePage headSP. aFrame = theFP ifTrue: [theSP >= aFrame ifTrue: ["If the SP is invalid return the pointer to the receiver field." ^self frameReceiverOffset: aFrame]. "Skip the instruction pointer on top of stack of inactive pages." ^thePage = stackPage ifTrue: [theSP] + ifFalse: [theSP + self bytesPerWord]]. - ifFalse: [theSP + objectMemory bytesPerWord]]. [theSP := self frameCallerSP: aFrame. aFrame := self frameCallerFP: aFrame. aFrame ~= 0] whileTrue: [theFP = aFrame ifTrue: [^theSP]]. ^nil!

Item was changed: ----- Method: StackInterpreter>>floatObjectOf: (in category 'object format') ----- floatObjectOf: aFloat | newFloatObj | <inline: false> <var: #aFloat type: #double> self flag: #Dan. + newFloatObj := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + self baseHeaderSize. + objectMemory storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat. - newFloatObj := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassFloat) sizeInBytes: 8 + objectMemory baseHeaderSize. - objectMemory storeFloatAt: newFloatObj + objectMemory baseHeaderSize from: aFloat. ^ newFloatObj. !

Item was changed: ----- Method: StackInterpreter>>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" "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex: (because assertClassOf:is:compactClassIndex: has an inline: pragma) the phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if ClassArrayCompactIndex is non-zero." self assertClassOf: oop is: (objectMemory splObj: ClassFloat) compactClassIndex: ClassFloatCompactIndex. self successful ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. + objectMemory fetchFloatAt: oop + self baseHeaderSize into: result. - objectMemory fetchFloatAt: oop + objectMemory baseHeaderSize into: result. ^result]. ^0.0!

Item was changed: ----- Method: StackInterpreter>>frameCallerSP: (in category 'frame access') ----- frameCallerSP: theFP "Answer the SP of the caller provided theFP is not a base frame. This points to the hottest item on the caller frame's stack." <var: #theFP type: #'char *'> <returnTypeC: 'char *'> <asmLabel: false> self assert: (self isBaseFrame: theFP) not. + ^theFP + (self frameStackedReceiverOffset: theFP) + self bytesPerWord! - ^theFP + (self frameStackedReceiverOffset: theFP) + objectMemory bytesPerWord!

Item was changed: ----- Method: StackInterpreter>>frameCallerStackPointer: (in category 'frame access') ----- frameCallerStackPointer: theFP "Answer the stack pointer of the caller frame." <var: #theFP type: #'char *'> <returnTypeC: #'char *'> <inline: true> <asmLabel: false> self assert: (self isBaseFrame: theFP) not. + ^theFP + (self frameStackedReceiverOffset: theFP) + self bytesPerWord! - ^theFP + (self frameStackedReceiverOffset: theFP) + objectMemory bytesPerWord!

Item was changed: ----- Method: StackInterpreter>>frameInstructionPointerForContext:method: (in category 'frame access') ----- frameInstructionPointerForContext: aContext method: aMethod "Answer the instruction pointer for usage in a frame (a pointer to a bytecode) from the index instructionPointer in the given context." ^aMethod + (self quickFetchInteger: InstructionPointerIndex ofObject: aContext) + + self baseHeaderSize - + objectMemory baseHeaderSize - 2!

Item was changed: ----- Method: StackInterpreter>>frameStackedReceiver:numArgs: (in category 'frame access') ----- frameStackedReceiver: theFP numArgs: numArgs "Answer the stacked receiver given the frame's argument count. The receiver of a message send or the closure of a block activation is always on the stack above any arguments and the frame itself. See the diagram in StackInterpreter class>>initializeFrameIndices." <inline: true> <var: #theFP type: #'char *'> + ^stackPages longAt: theFP + FoxCallerSavedIP + self bytesPerWord + (numArgs << self shiftForWord)! - ^stackPages longAt: theFP + FoxCallerSavedIP + objectMemory bytesPerWord + (numArgs << self shiftForWord)!

Item was changed: ----- Method: StackInterpreter>>frameStackedReceiverOffset: (in category 'frame access') ----- frameStackedReceiverOffset: theFP "Answer the offset in bytes from the a frame pointer to its stacked receiver. The receiver of a message send or the closure of a block activation is always on the stack above any arguments and the frame itself. See the diagram in StackInterpreter class>>initializeFrameIndices." <inline: true> <var: #theFP type: #'char *'> + ^FoxCallerSavedIP + self bytesPerWord + ((self frameNumArgs: theFP) << self shiftForWord)! - ^FoxCallerSavedIP + objectMemory bytesPerWord + ((self frameNumArgs: theFP) << self shiftForWord)!

Item was changed: ----- Method: StackInterpreter>>frameStackedReceiverOffset:numArgs: (in category 'frame access') ----- frameStackedReceiverOffset: theFP numArgs: numArgs "Answer the offset in bytes from the a frame pointer to its stacked receiver. The receiver of a message send or the closure of a block activation is always on the stack above any arguments and the frame itself. See the diagram in StackInterpreter class>>initializeFrameIndices." <inline: true> <var: #theFP type: #'char *'> + ^FoxCallerSavedIP + self bytesPerWord + (numArgs << self shiftForWord)! - ^FoxCallerSavedIP + objectMemory bytesPerWord + (numArgs << self shiftForWord)!

Item was changed: ----- Method: StackInterpreter>>getErrorObjectFromPrimFailCode (in category 'message sending') ----- getErrorObjectFromPrimFailCode "Answer the errorCode object to supply to a failing primitive method that accepts one. If there is a primitive error table and the primFailCode is a valid index there-in answer the coprresponding entry in the table, otherwise simply answer the code as an integer." | table | primFailCode > 0 ifTrue: [table := objectMemory splObj: PrimErrTableIndex. + primFailCode <= ((objectMemory lastPointerOf: table) // self bytesPerWord) ifTrue: - primFailCode <= ((objectMemory lastPointerOf: table) // objectMemory bytesPerWord) ifTrue: [^objectMemory fetchPointer: primFailCode - 1 ofObject: table]]. ^objectMemory integerObjectOf: primFailCode!

Item was changed: ----- Method: StackInterpreter>>highBit: (in category 'stack pages') ----- highBit: anUnsignedValue "This is a C implementation needed by stackPageByteSize when translated." | shifted bitNo | <var: #anUnsignedValue type: #usqInt> <var: #shifted type: #usqInt> shifted := anUnsignedValue. bitNo := 0. + self cppIf: [self bytesPerWord > 4] - self cppIf: [objectMemory bytesPerWord > 4] ifTrue: [shifted < (1 << 32) ifFalse: [shifted := shifted >> 32. bitNo := bitNo + 32]]. shifted < (1 << 16) ifFalse: [shifted := shifted >> 16. bitNo := bitNo + 16]. shifted < (1 << 8) ifFalse: [shifted := shifted >> 8. bitNo := bitNo + 8]. shifted < (1 << 4) ifFalse: [shifted := shifted >> 4. bitNo := bitNo + 4]. shifted < (1 << 2) ifFalse: [shifted := shifted >> 2. bitNo := bitNo + 2]. shifted < (1 << 1) ifFalse: [shifted := shifted >> 1. bitNo := bitNo + 1]. "shifted 0 or 1 now" ^bitNo + shifted!

Item was changed: ----- Method: StackInterpreter>>imageFormatCompatibilityVersion (in category 'image save/restore') ----- imageFormatCompatibilityVersion "This VM is backward-compatible with the immediately preceeding version."

+ ^self bytesPerWord == 4 ifTrue: [6504] ifFalse: [68002]! - ^objectMemory bytesPerWord == 4 ifTrue: [6504] ifFalse: [68002]!

Item was changed: ----- Method: StackInterpreter>>imageFormatVersion (in category 'image save/restore') ----- imageFormatVersion "Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."

+ ^self bytesPerWord == 4 ifTrue: [6505] ifFalse: [68003]! - ^objectMemory bytesPerWord == 4 ifTrue: [6505] ifFalse: [68003]!

Item was changed: ----- Method: StackInterpreter>>initStackPages (in category 'initialization') ----- initStackPages "Initialize the stackPages. This version is only for simulation because Slang refuses to inline it, which makes the alloca invalid." | stackPageBytes stackPagesBytes theStackMemory | stackPageBytes := self stackPageByteSize. stackPagesBytes := self computeStackZoneSize. theStackMemory := self cCode: 'alloca(stackPagesBytes)' inSmalltalk: [stackPages := self stackPagesClass new. stackPages initializeWithByteSize: stackPagesBytes for: self]. stackPages initializeStack: theStackMemory + numSlots: stackPagesBytes / self bytesPerWord + pageSize: stackPageBytes / self bytesPerWord - numSlots: stackPagesBytes / objectMemory bytesPerWord - pageSize: stackPageBytes / objectMemory bytesPerWord stackLimitOffset: self stackLimitOffset stackPageHeadroom: self stackPageHeadroom!

Item was changed: ----- Method: StackInterpreter>>initStackPagesAndInterpret (in category 'initialization') ----- initStackPagesAndInterpret "Initialize the stack pages and enter interpret. Use alloca'ed memory so that when we have a JIT its stack pointer will be on the native stack since alloca allocates memory on the stack. Certain thread systems use the native stack pointer as the frame ID so putting the stack anywhere else can confuse the thread system."

"This should be in its own initStackPages method but Slang can't inline C code strings." | stackPageBytes stackPagesBytes theStackMemory | <var: #theStackMemory type: #'void *'> stackPageBytes := self stackPageByteSize. stackPagesBytes := self computeStackZoneSize. theStackMemory := self cCode: 'alloca(stackPagesBytes)' inSmalltalk: [stackPages := self stackPagesClass new. stackPages initializeWithByteSize: stackPagesBytes for: self]. stackPages initializeStack: theStackMemory + numSlots: stackPagesBytes / self bytesPerWord + pageSize: stackPageBytes / self bytesPerWord - numSlots: stackPagesBytes / objectMemory bytesPerWord - pageSize: stackPageBytes / objectMemory bytesPerWord stackLimitOffset: self stackLimitOffset stackPageHeadroom: self stackPageHeadroom.

"Once the stack pages are initialized we can continue to bootstrap the system." self loadInitialContext. "We're ready for the heartbeat (poll interrupt)" self ioInitHeartbeat. self interpret. ^nil!

Item was changed: ----- Method: StackInterpreter>>initialPCForHeader:method: (in category 'compiled methods') ----- initialPCForHeader: methodHeader method: theMethod + ^theMethod + ((LiteralStart + (self literalCountOfHeader: methodHeader)) * self bytesPerWord) + self baseHeaderSize! - ^theMethod + ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + objectMemory baseHeaderSize!

Item was changed: ----- Method: StackInterpreter>>internalPop: (in category 'internal interpreter access') ----- internalPop: nItems "In the StackInterpreter stacks grow down." + localSP := localSP + (nItems * self bytesPerWord)! - localSP := localSP + (nItems * objectMemory bytesPerWord)!

Item was changed: ----- Method: StackInterpreter>>internalPop:thenPush: (in category 'internal interpreter access') ----- internalPop: nItems thenPush: oop "In the StackInterpreter stacks grow down." + stackPages longAtPointer: (localSP := localSP + ((nItems - 1) * self bytesPerWord)) put: oop! - stackPages longAtPointer: (localSP := localSP + ((nItems - 1) * objectMemory bytesPerWord)) put: oop!

Item was changed: ----- Method: StackInterpreter>>internalPopStack (in category 'internal interpreter access') ----- internalPopStack "In the StackInterpreter stacks grow down." | top | top := stackPages longAt: localSP. + localSP := localSP + self bytesPerWord. - localSP := localSP + objectMemory bytesPerWord. ^top!

Item was changed: ----- Method: StackInterpreter>>internalPush: (in category 'internal interpreter access') ----- internalPush: object "In the StackInterpreter stacks grow down." + stackPages longAtPointer: (localSP := localSP - self bytesPerWord) put: object! - stackPages longAtPointer: (localSP := localSP - objectMemory bytesPerWord) put: object!

Item was changed: ----- Method: StackInterpreter>>internalStackValue: (in category 'internal interpreter access') ----- internalStackValue: offset "In the StackInterpreter stacks grow down." + ^stackPages longAtPointer: localSP + (offset * self bytesPerWord)! - ^stackPages longAtPointer: localSP + (offset * objectMemory bytesPerWord)!

Item was changed: ----- Method: StackInterpreter>>interpreterAllocationReserveBytes (in category 'stack pages') ----- interpreterAllocationReserveBytes "At a rough approximation we may need to allocate up to a couple of page's worth of contexts when switching stack pages, assigning to senders, etc. But the snapshot primitive voids all stack pages. So a safe margin is the size of a large context times the maximum number of frames per page times the number of pages." | availableBytesPerPage maxFramesPerPage | availableBytesPerPage := self stackPageByteSize - self stackLimitOffset - self stackPageHeadroom. + maxFramesPerPage := availableBytesPerPage / self bytesPerWord // FrameSlots. - maxFramesPerPage := availableBytesPerPage / objectMemory bytesPerWord // FrameSlots. ^2 raisedTo: (maxFramesPerPage * LargeContextSize * numStackPages) highBit!

Item was changed: ----- Method: StackInterpreter>>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 primErrorCode non-zero."

| result | <inline: true> <asmLabel: false> <returnTypeC: #double> <var: #result type: #double>

(objectMemory isIntegerObject: floatOrInt) ifTrue: [^(objectMemory integerValueOf: floatOrInt) asFloat]. self assertClassOf: floatOrInt is: (objectMemory splObj: ClassFloat) compactClassIndex: ClassFloatCompactIndex. self cCode: '' inSmalltalk: [result := Float new: 2]. self successful ifTrue: + [objectMemory fetchFloatAt: floatOrInt + self baseHeaderSize into: result]. - [objectMemory fetchFloatAt: floatOrInt + objectMemory baseHeaderSize into: result]. ^result!

Item was changed: ----- Method: StackInterpreter>>lookupMethodInClass: (in category 'message sending') ----- lookupMethodInClass: class | currentClass dictionary found | <inline: false> self assert: class ~~ objectMemory nilObject. currentClass := class. [currentClass ~= objectMemory nilObject] whileTrue: [dictionary := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currentClass. dictionary = objectMemory nilObject ifTrue: ["MethodDict pointer is nil (hopefully due a swapped out stub) -- raise exception #cannotInterpret:." self createActualMessageTo: class. messageSelector := objectMemory splObj: SelectorCannotInterpret. + self sendBreak: messageSelector + self baseHeaderSize - self sendBreak: messageSelector + objectMemory baseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: nil. ^self lookupMethodInClass: (self superclassOf: currentClass)]. found := self lookupMethodInDictionary: dictionary. found ifTrue: [^currentClass]. currentClass := self superclassOf: currentClass].

"Could not find #doesNotUnderstand: -- unrecoverable error." messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue: [self error: 'Recursive not understood error encountered'].

"Cound not find a normal message -- raise exception #doesNotUnderstand:" self createActualMessageTo: class. messageSelector := objectMemory splObj: SelectorDoesNotUnderstand. + self sendBreak: messageSelector + self baseHeaderSize - self sendBreak: messageSelector + objectMemory baseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: nil. ^self lookupMethodInClass: class!

Item was changed: ----- Method: StackInterpreter>>makeBaseFrameFor: (in category 'frame access') ----- makeBaseFrameFor: aContext "<Integer>" "Marry aContext with the base frame of a new stack page. Build the base frame to reflect the context's state. Answer the new page." | page pointer theMethod numArgs stackPtrIndex maybeClosure | <inline: false> <var: #page type: #'StackPage *'> <var: #pointer type: #'char *'> <returnTypeC: 'StackPage *'> self assert: (self isSingleContext: aContext). page := self newStackPage. pointer := page baseAddress. theMethod := objectMemory fetchPointer: MethodIndex ofObject: aContext. "If the frame is a closure activation then the closure should be on the stack in the pushed receiver position (closures receiver the value[:value:] messages). Otherwise it should be the receiver proper." maybeClosure := (objectMemory fetchPointer: ClosureIndex ofObject: aContext). maybeClosure ~= objectMemory nilObject ifTrue: [numArgs := self argumentCountOfClosure: maybeClosure. stackPages longAt: pointer put: maybeClosure] ifFalse: [numArgs := self argumentCountOf: theMethod. stackPages longAt: pointer put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext)]. "Put the arguments on the stack" 1 to: numArgs do: [:i| stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)]. "saved caller ip is sender context in base frame" stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: (objectMemory fetchPointer: SenderIndex ofObject: aContext). "base frame's saved fp is null" stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: 0. page baseFP: pointer; headFP: pointer. stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: theMethod. stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: (self encodeFrameFieldHasContext: true isBlock: maybeClosure ~= objectMemory nilObject numArgs: numArgs). self assert: (self frameHasContext: page baseFP). self assert: (self frameNumArgs: page baseFP) == numArgs. stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: aContext. stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext). stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext. self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext). numArgs + 1 to: stackPtrIndex do: [:i| stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)]. "last thing on stack is the instruction pointer" (objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)) ifFalse: [self error: 'context is not resumable']. stackPages + longAt: (pointer := pointer - self bytesPerWord) - longAt: (pointer := pointer - objectMemory bytesPerWord) put: (self frameInstructionPointerForContext: aContext method: theMethod). self assert: (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext) = (self contextInstructionPointer: (stackPages longAt: pointer) frame: page baseFP). page headSP: pointer.

"Mark context as married by setting its sender to the frame pointer plus SmallInteger tags and the InstructionPointer to the saved fp (which ensures correct alignment w.r.t. the frame when we check for validity)" objectMemory storePointerUnchecked: SenderIndex ofObject: aContext withValue: (self withSmallIntegerTags: page baseFP). objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: aContext withValue: (self withSmallIntegerTags: 0). self assert: (objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)). self assert: (self frameOfMarriedContext: aContext) = page baseFP.

^page!

Item was changed: ----- Method: StackInterpreter>>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 eeInstantiateSmallClass: (objectMemory splObj: ClassPoint) sizeInBytes: 3 * self bytesPerWord. - pointResult := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassPoint) sizeInBytes: 3 * objectMemory bytesPerWord. objectMemory storePointerUnchecked: XIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: xValue). objectMemory storePointerUnchecked: YIndex ofObject: pointResult withValue: (objectMemory integerObjectOf: yValue). ^ pointResult!

Item was changed: ----- Method: StackInterpreter>>mapStackPages (in category 'object memory support') ----- mapStackPages <inline: false> <var: #thePage type: #'StackPage *'> <var: #theSP type: #'char *'> <var: #theFP type: #'char *'> <var: #callerFP type: #'char *'> <var: #theIPPtr type: #'char *'> "Need to write back the frame pointers unless all pages are free (as in snapshot)" stackPage ~= 0 ifTrue: [self externalWriteBackHeadFramePointers]. 0 to: numStackPages - 1 do: [:i| | thePage theSP theFP callerFP theIPPtr theIP oop | thePage := stackPages stackPageAt: i. thePage isFree ifFalse: [theSP := thePage headSP. theFP := thePage headFP. "Skip the instruction pointer on top of stack of inactive pages." thePage = stackPage ifTrue: [theIPPtr := 0] ifFalse: [theIPPtr := theSP. + theSP := theSP + self bytesPerWord]. - theSP := theSP + objectMemory bytesPerWord]. [self assert: (thePage addressIsInPage: theFP). self assert: (thePage addressIsInPage: theSP). self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theFP]). [theSP <= (theFP + FoxReceiver)] whileTrue: [oop := stackPages longAt: theSP. (objectMemory isIntegerObject: oop) ifFalse: [stackPages longAt: theSP put: (objectMemory remap: oop)]. + theSP := theSP + self bytesPerWord]. - theSP := theSP + objectMemory bytesPerWord]. (self frameHasContext: theFP) ifTrue: [stackPages longAt: theFP + FoxThisContext put: (objectMemory remap: (self frameContext: theFP))]. theIPPtr ~= 0 ifTrue: [self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP). theIP := (stackPages longAt: theIPPtr) - (self frameMethod: theFP)]. stackPages longAt: theFP + FoxMethod put: (objectMemory remap: (self frameMethod: theFP)). theIPPtr ~= 0 ifTrue: [stackPages longAt: theIPPtr put: theIP + (self frameMethod: theFP)]. (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: + [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + self bytesPerWord. - [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + objectMemory bytesPerWord. theFP := callerFP]. theSP := theFP + FoxCallerContext. "a.k.a. FoxCallerSavedIP" [theSP <= thePage baseAddress] whileTrue: [oop := stackPages longAt: theSP. (objectMemory isIntegerObject: oop) ifFalse: [stackPages longAt: theSP put: (objectMemory remap: oop)]. + theSP := theSP + self bytesPerWord]]]! - theSP := theSP + objectMemory bytesPerWord]]]!

Item was changed: ----- Method: StackInterpreter>>markAndTraceStackPage: (in category 'object memory support') ----- markAndTraceStackPage: thePage | theSP theFP frameRcvrOffset callerFP oop | <var: #thePage type: #'StackPage *'> <var: #theSP type: #'char *'> <var: #theFP type: #'char *'> <var: #frameRcvrOffset type: #'char *'> <var: #callerFP type: #'char *'> <inline: false> self assert: (stackPages isFree: thePage) not. theSP := thePage headSP. theFP := thePage headFP. "Skip the instruction pointer on top of stack of inactive pages." thePage = stackPage ifFalse: + [theSP := theSP + self bytesPerWord]. - [theSP := theSP + objectMemory bytesPerWord]. [frameRcvrOffset := self frameReceiverOffset: theFP. [theSP <= frameRcvrOffset] whileTrue: [oop := stackPages longAt: theSP. (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]. + theSP := theSP + self bytesPerWord]. - theSP := theSP + objectMemory bytesPerWord]. (self frameHasContext: theFP) ifTrue: [self assert: (self isContext: (self frameContext: theFP)). objectMemory markAndTrace: (self frameContext: theFP)]. objectMemory markAndTrace: (self iframeMethod: theFP). (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: + [theSP := theFP + FoxCallerSavedIP + self bytesPerWord. - [theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord. theFP := callerFP]. theSP := self isCog + ifTrue: [theFP + FoxCallerSavedIP + self bytesPerWord] "caller ip is ceBaseReturnPC" - ifTrue: [theFP + FoxCallerSavedIP + objectMemory bytesPerWord] "caller ip is ceBaseReturnPC" ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame" [theSP <= thePage baseAddress] whileTrue: [oop := stackPages longAt: theSP. (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]. + theSP := theSP + self bytesPerWord]! - theSP := theSP + objectMemory bytesPerWord]!

Item was changed: ----- Method: StackInterpreter>>marriedContext:pointsTo:stackDeltaForCurrentFrame: (in category 'frame access') ----- marriedContext: spouseContext pointsTo: anOop stackDeltaForCurrentFrame: stackDeltaForCurrentFrame "This is a helper for primitiveObjectPointsTo so it *does not* check the frameContext field because that is an implicit self-reference not present in the stale ." | theFP thePage theSP rcvrOffset | <inline: false> <var: #theFP type: #'char *'> <var: #thePage type: #'StackPage *'> <var: #theSP type: #'char *'> <var: #rcvrOffset type: #'char *'> theFP := self frameOfMarriedContext: spouseContext. theFP = framePointer + ifTrue: [theSP := stackPointer + (stackDeltaForCurrentFrame * self bytesPerWord)] - ifTrue: [theSP := stackPointer + (stackDeltaForCurrentFrame * objectMemory bytesPerWord)] ifFalse: [thePage := stackPages stackPageFor: theFP. theSP := self findSPOf: theFP on: thePage]. (objectMemory isIntegerObject: anOop) ifTrue: "Check stack and instruction pointer fields." [(anOop = (objectMemory integerObjectOf: (self stackPointerIndexForFrame: theFP WithSP: theSP)) or: [anOop = (self externalInstVar: InstructionPointerIndex ofContext: spouseContext)]) ifTrue: [^true]] ifFalse: "Check method and sender fields, avoiding unnecessarily reifying sender context." [anOop = (self frameMethodObject: theFP) ifTrue: [^true]. (self isBaseFrame: theFP) ifTrue: [anOop = (self frameCallerContext: theFP) ifTrue: [^true]] ifFalse: [((self frameHasContext: (self frameCallerFP: theFP)) and: [anOop = (self frameContext: (self frameCallerFP: theFP))]) ifTrue: [^true]]]. "Now check receiver, temps and stack contents" rcvrOffset := self frameReceiverOffset: theFP. [theSP <= rcvrOffset] whileTrue: [anOop = (stackPages longAt: theSP) ifTrue: [^true]. + theSP := theSP + self bytesPerWord]. - theSP := theSP + objectMemory bytesPerWord]. "Finally check stacked receiver (closure field or duplicate of receiver) and arguments" + theSP := theFP + FoxCallerSavedIP + self bytesPerWord. - theSP := theFP + FoxCallerSavedIP + objectMemory bytesPerWord. rcvrOffset := theFP + (self frameStackedReceiverOffset: theFP). [theSP <= rcvrOffset] whileTrue: [anOop = (stackPages longAt: theSP) ifTrue: [^true]. + theSP := theSP + self bytesPerWord]. - theSP := theSP + objectMemory bytesPerWord]. ^false!

Item was changed: ----- Method: StackInterpreter>>marryFrame:SP: (in category 'frame access') ----- marryFrame: theFP SP: theSP "Marry an unmarried frame. This means creating a spouse context initialized with a subset of the frame's state (state through the last argument) that references the frame." | theContext methodHeader byteSize numArgs numStack closureOrNil | <inline: false> <var: #theFP type: #'char *'> <var: #theSP type: #'char *'> self assert: (self frameHasContext: theFP) not.

methodHeader := self headerOf: (self frameMethod: theFP). "Decide how much of the stack to preserve in widowed contexts. Preserving too much state will potentially hold onto garbage. Holding onto too little may mean that a dead context isn't informative enough in a debugging situation. We compromise, retaining only the arguments with no temporaries. Note that we still set the stack pointer to its current value, but stack contents other than the arguments are nil." numArgs := self frameNumArgs: theFP. numStack := self stackPointerIndexForFrame: theFP WithSP: theSP.

closureOrNil := (self frameIsBlockActivation: theFP) ifTrue: [self pushedReceiverOrClosureOfFrame: theFP] ifFalse: [objectMemory nilObject].

byteSize := (methodHeader bitAnd: LargeContextBit) ~= 0 ifTrue: [LargeContextSize] ifFalse: [SmallContextSize]. theContext := objectMemory eeInstantiateMethodContextByteSize: byteSize. + self assert: numStack + ReceiverIndex << self shiftForWord + self baseHeaderSize <= byteSize. - self assert: numStack + ReceiverIndex << self shiftForWord + objectMemory baseHeaderSize <= byteSize. "Mark context as married by setting its sender to the frame pointer plus SmallInteger tags and the InstructionPointer to the saved fp (which ensures correct alignment w.r.t. the frame when we check for validity)" objectMemory storePointerUnchecked: SenderIndex ofObject: theContext withValue: (self withSmallIntegerTags: theFP). objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: theContext withValue: (self withSmallIntegerTags: (self frameCallerFP: theFP)). objectMemory storePointerUnchecked: StackPointerIndex ofObject: theContext withValue: (objectMemory integerObjectOf: numStack). objectMemory storePointerUnchecked: MethodIndex ofObject: theContext withValue: (self frameMethod: theFP). objectMemory storePointerUnchecked: ClosureIndex ofObject: theContext withValue: closureOrNil. objectMemory storePointerUnchecked: ReceiverIndex ofObject: theContext withValue: (self frameReceiver: theFP). "Store just the arguments. If the frame is divorced the context will have valid arguments but all temporaries will be nil." 1 to: numArgs do: [:i| objectMemory storePointerUnchecked: ReceiverIndex + i ofObject: theContext "inline self temporary: i - 1 in:theFP" withValue: (stackPages longAt: theFP + FoxCallerSavedIP + + ((numArgs - i + 1) * self bytesPerWord))]. - + ((numArgs - i + 1) * objectMemory bytesPerWord))]. numArgs + 1 to: numStack do: [:i| objectMemory storePointerUnchecked: ReceiverIndex + i ofObject: theContext withValue: objectMemory nilObject].

stackPages longAt: theFP + FoxThisContext put: theContext. stackPages byteAt: theFP + FoxFrameFlags + 2 put: 1.

self assert: (self frameHasContext: theFP). self assert: (self frameOfMarriedContext: theContext) = theFP. self assert: numStack + ReceiverIndex < (objectMemory lengthOf: theContext).

^theContext !

Item was changed: ----- Method: StackInterpreter>>moveFramesIn:through:toPage: (in category 'frame access') ----- moveFramesIn: oldPage through: theFP toPage: newPage "Move frames from the hot end of oldPage through to theFP to newPage. This has the effect of making theFP a base frame which can be stored into. Answer theFP's new location." | newSP newFP stackedReceiverOffset delta callerFP callerIP fpInNewPage offsetCallerFP theContext | <inline: false> <var: #oldPage type: #'StackPage *'> <var: #theFP type: #'char *'> <var: #newPage type: #'StackPage *'> <var: #newSP type: #'char *'> <var: #newFP type: #'char *'> <var: #callerFP type: #'char *'> <var: #fpInNewPage type: #'char *'> <var: #offsetCallerFP type: #'char *'> <var: #source type: #'char *'> <returnTypeC: 'char *'> + newSP := newPage baseAddress + self bytesPerWord. - newSP := newPage baseAddress + objectMemory bytesPerWord. stackedReceiverOffset := self frameStackedReceiverOffset: theFP. "First move the data. We will fix up frame pointers later." theFP + stackedReceiverOffset to: oldPage headSP + by: self bytesPerWord negated - by: objectMemory bytesPerWord negated do: [:source| + newSP := newSP - self bytesPerWord. - newSP := newSP - objectMemory bytesPerWord. stackPages longAt: newSP put: (stackPages longAt: source)]. "newSP = oldSP + delta => delta = newSP - oldSP" delta := newSP - oldPage headSP. newFP := newPage baseAddress - stackedReceiverOffset. self setHeadFP: oldPage headFP + delta andSP: newSP inPage: newPage. newPage baseFP: newFP. callerFP := self frameCallerFP: theFP. self assert: (self isBaseFrame: theFP) not. self assert: (self frameHasContext: callerFP). callerIP := self oopForPointer: (self frameCallerSavedIP: theFP). stackPages longAt: theFP + stackedReceiverOffset put: callerIP. oldPage headFP: callerFP; headSP: theFP + stackedReceiverOffset. "Mark the new base frame in the new page (FoxCallerContext a.k.a. FoxCallerSavedIP)" stackPages longAt: newFP + FoxCallerContext put: (self frameContext: callerFP). stackPages longAt: newFP + FoxSavedFP put: 0. "Now relocate frame pointers, updating married contexts to refer to their moved spouse frames." fpInNewPage := newPage headFP. [offsetCallerFP := self frameCallerFP: fpInNewPage. offsetCallerFP ~= 0 ifTrue: [offsetCallerFP := offsetCallerFP + delta]. stackPages longAt: fpInNewPage + FoxSavedFP put: (self oopForPointer: offsetCallerFP). (self frameHasContext: fpInNewPage) ifTrue: [theContext := self frameContext: fpInNewPage. objectMemory storePointerUnchecked: SenderIndex ofObject: theContext withValue: (self withSmallIntegerTags: fpInNewPage). objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: theContext withValue: (self withSmallIntegerTags: offsetCallerFP)]. fpInNewPage := offsetCallerFP. fpInNewPage ~= 0] whileTrue. ^newFP!

Item was changed: ----- Method: StackInterpreter>>pop: (in category 'internal interpreter access') ----- pop: nItems <inline: true> "In the StackInterpreter stacks grow down." + stackPointer := stackPointer + (nItems * self bytesPerWord). - stackPointer := stackPointer + (nItems * objectMemory bytesPerWord). ^nil!

Item was changed: ----- Method: StackInterpreter>>pop:thenPush: (in category 'internal interpreter access') ----- pop: nItems thenPush: oop "In the StackInterpreter stacks grow down." | sp | <inline: true> <var: #sp type: #'char *'> + stackPages longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord)) put: oop. - stackPages longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord)) put: oop. stackPointer := sp!

Item was changed: ----- Method: StackInterpreter>>pop:thenPushBool: (in category 'internal interpreter access') ----- pop: nItems thenPushBool: trueOrFalse "In the StackInterpreter stacks grow down." | sp | <inline: true> <var: #sp type: #'char *'> stackPages + longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord)) - longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord)) put: (trueOrFalse ifTrue: [objectMemory trueObject] ifFalse: [objectMemory falseObject]). stackPointer := sp!

Item was changed: ----- Method: StackInterpreter>>pop:thenPushFloat: (in category 'internal interpreter access') ----- pop: nItems thenPushFloat: f "In the StackInterpreter stacks grow down." | sp | <inline: true> <var: #f type: #double> <var: #sp type: #'char *'> stackPages + longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord)) - longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord)) put: (self floatObjectOf: f). stackPointer := sp!

Item was changed: ----- Method: StackInterpreter>>pop:thenPushInteger: (in category 'internal interpreter access') ----- pop: nItems thenPushInteger: integerVal "lots of places pop a few items off the stack and then push an integer. Make it convenient. In the StackInterpreter stacks grow down." | sp | <var: #sp type: #'char *'> stackPages + longAt: (sp := stackPointer + ((nItems - 1) * self bytesPerWord)) - longAt: (sp := stackPointer + ((nItems - 1) * objectMemory bytesPerWord)) put: (objectMemory integerObjectOf: integerVal). stackPointer := sp!

Item was changed: ----- Method: StackInterpreter>>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. "N.B. Because Slang always inlines assertClassOf:is:compactClassIndex: (because assertClassOf:is:compactClassIndex: has an inline: pragma) the phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if ClassArrayCompactIndex is non-zero." self assertClassOf: top is: (objectMemory splObj: ClassFloat) compactClassIndex: ClassFloatCompactIndex. self successful ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. + objectMemory fetchFloatAt: top + self baseHeaderSize into: result]. - objectMemory fetchFloatAt: top + objectMemory baseHeaderSize into: result]. ^ result!

Item was changed: ----- Method: StackInterpreter>>popStack (in category 'internal interpreter access') ----- popStack "In the StackInterpreter stacks grow down." | top | <inline: true> top := stackPages longAt: stackPointer. + stackPointer := stackPointer + self bytesPerWord. - stackPointer := stackPointer + objectMemory bytesPerWord. ^top!

Item was changed: ----- Method: StackInterpreter>>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]].

+ self cppIf: self bytesPerWord = 4 - self cppIf: objectMemory bytesPerWord = 4 ifTrue: "Faster instantiateSmallClass: currently only works with integral word size." [newLargeInteger := objectMemory eeInstantiateSmallClass: (objectMemory splObj: ClassLargePositiveInteger) + sizeInBytes: self baseHeaderSize + 4] - sizeInBytes: objectMemory baseHeaderSize + 4] ifFalse: "Cant use instantiateSmallClass: due to integral word requirement." [newLargeInteger := objectMemory eeInstantiateClass: (objectMemory splObj: ClassLargePositiveInteger) indexableSize: 4]. objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF). objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF). objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF). objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF). ^newLargeInteger!

Item was changed: ----- Method: StackInterpreter>>primitiveObject:perform:withArguments:lookedUpIn: (in category 'control primitives') ----- primitiveObject: actualReceiver perform: selector withArguments: argumentArray lookedUpIn: lookupClass "Common routine used by perform:withArgs:, perform:withArgs:inSuperclass:, object:perform:withArgs:inClass: et al. Answer nil on success.

NOTE: The case of doesNotUnderstand: is not a failure to perform. The only failures are arg types and consistency of argumentCount.

Since we're in the stack VM we can assume there is space to push the arguments provided they are within limits (max argument count is 15). We can therefore deal with the arbitrary amount of state to remove from the stack (lookup class, selector, mirror receiver) and arbitrary argument orders by deferring popping anything until we know whether the send has succeeded. So on failure we merely have to remove the actual receiver and arguments pushed, and on success we have to slide the actual receiver and arguments down to replace the original ones."

| arraySize performArgCount delta | (objectMemory isArray: argumentArray) ifFalse: [^self primitiveFailFor: PrimErrBadArgument].

"Check if number of arguments is reasonable; MaxNumArgs isn't available so just use LargeContextSize" arraySize := objectMemory fetchWordLengthOf: argumentArray. + arraySize > (LargeContextSize / self bytesPerWord) ifTrue: - arraySize > (LargeContextSize / objectMemory bytesPerWord) ifTrue: [^self primitiveFailFor: PrimErrBadNumArgs].

performArgCount := argumentCount. "Push newMethod to save it in case of failure, then push the actual receiver and args out of the array." self push: newMethod. self push: actualReceiver. "Copy the arguments to the stack, and execute" 1 to: arraySize do: [:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)]. argumentCount := arraySize. messageSelector := selector. + self sendBreak: messageSelector + self baseHeaderSize - self sendBreak: messageSelector + objectMemory baseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: actualReceiver. self findNewMethodInClass: lookupClass.

"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances" ((objectMemory isOopCompiledMethod: newMethod) and: [(self argumentCountOf: newMethod) ~= argumentCount]) ifTrue: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail" self pop: arraySize + 1. newMethod := self popStack. ^self primitiveFailFor: PrimErrBadNumArgs].

"Cannot fail this primitive from here-on. Slide the actual receiver and arguments down to replace the perform arguments and saved newMethod and then execute the new method. Use argumentCount not arraySize because an MNU may have changed it." + delta := self bytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod" + argumentCount * self bytesPerWord to: 0 by: self bytesPerWord negated do: - delta := objectMemory bytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod" - argumentCount * objectMemory bytesPerWord to: 0 by: objectMemory bytesPerWord negated do: [:offset| stackPages longAt: stackPointer + offset + delta put: (stackPages longAt: stackPointer + offset)]. self pop: performArgCount + 2. self executeNewMethod. self initPrimCall. "Recursive xeq affects primErrorCode" ^nil!

Item was changed: ----- Method: StackInterpreter>>printFrame:WithSP: (in category 'debug printing') ----- printFrame: theFP WithSP: theSP | theMethod numArgs topThing | <inline: false> <var: #theFP type: #'char *'> <var: #theSP type: #'char *'> <var: #addr type: #'char *'> self cCode: '' inSmalltalk: [self transcript ensureCr]. theMethod := self frameMethod: theFP. numArgs := self frameNumArgs: theFP. self shortPrintFrame: theFP. self printFrameOop: 'rcvr/clsr' + at: theFP + FoxCallerSavedIP + ((numArgs + 1) * self bytesPerWord). - at: theFP + FoxCallerSavedIP + ((numArgs + 1) * objectMemory bytesPerWord). numArgs to: 1 by: -1 do: + [:i| self printFrameOop: 'arg' at: theFP + FoxCallerSavedIP + (i * self bytesPerWord)]. - [:i| self printFrameOop: 'arg' at: theFP + FoxCallerSavedIP + (i * objectMemory bytesPerWord)]. self printFrameThing: 'cllr ip/ctxt' at: theFP + FoxCallerSavedIP. self printFrameThing: 'saved fp' at: theFP + FoxSavedFP. self printFrameOop: 'method' at: theFP + FoxMethod. self printFrameFlagsForFP: theFP. self printFrameThing: 'context' at: theFP + FoxThisContext. self printFrameOop: 'receiver' at: theFP + FoxReceiver. topThing := stackPages longAt: theSP. (topThing >= theMethod and: [topThing <= (theMethod + (objectMemory sizeBitsOfSafe: theMethod))]) ifTrue: + [theFP + FoxReceiver - self bytesPerWord to: theSP + self bytesPerWord by: self bytesPerWord negated do: - [theFP + FoxReceiver - objectMemory bytesPerWord to: theSP + objectMemory bytesPerWord by: objectMemory bytesPerWord negated do: [:addr| self printFrameOop: 'temp/stck' at: addr]. self printFrameThing: 'frame ip' at: theSP] ifFalse: + [theFP + FoxReceiver - self bytesPerWord to: theSP by: self bytesPerWord negated do: - [theFP + FoxReceiver - objectMemory bytesPerWord to: theSP by: objectMemory bytesPerWord negated do: [:addr| self printFrameOop: 'temp/stck' at: addr]]!

Item was changed: ----- Method: StackInterpreter>>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." <inline: false> (classOop = 0 or: [cnt <= 0]) ifTrue: [^self print: 'bad class']. ((objectMemory sizeBitsOf: classOop) = metaclassSizeBytes + and: [metaclassSizeBytes > (thisClassIndex * self bytesPerWord)]) "(Metaclass instSize * 4)" - and: [metaclassSizeBytes > (thisClassIndex * objectMemory bytesPerWord)]) "(Metaclass instSize * 4)" ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1. self print: ' class'] ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]!

Item was changed: ----- Method: StackInterpreter>>printOop: (in category 'debug printing') ----- printOop: oop | cls fmt lastIndex startIP bytecodesPerLine | <inline: false> self printHex: oop. (objectMemory isIntegerObject: oop) ifTrue: [^self cCode: 'printf("=%ld\n", integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [self printHex: oop; print: ' is not on the heap'; cr. ^nil]. + (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue: - (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'; cr. ^nil]. (objectMemory isFreeObject: oop) ifTrue: [self print: ' free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr. ^nil]. self print: ': a(n) '. self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5. cls = (objectMemory splObj: ClassFloat) ifTrue: [self cr; printFloat: (self dbgFloatValueOf: oop); cr. ^nil]. fmt := objectMemory formatOf: oop. fmt > 4 ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)]. self cr. (fmt > 4 and: [fmt < 12]) ifTrue: ["This will answer false if splObj: ClassAlien is nilObject" (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue: [self print: ' datasize '; printNum: (self sizeOfAlienData: oop). self print: ((self isIndirectAlien: oop) ifTrue: [' indirect @ '] ifFalse: [(self isPointerAlien: oop) ifTrue: [' pointer @ '] ifFalse: [' direct @ ']]). self printHex: (self startOfAlienData: oop); cr. ^nil]. (objectMemory isWords: oop) ifTrue: + [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / self bytesPerWord). - [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / objectMemory bytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop). (index \ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. ^nil]. ^self printStringOf: oop; cr]. + lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / self bytesPerWord). - lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / objectMemory bytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')' inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space. self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))]. (index \ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. (objectMemory isCompiledMethod: oop) ifFalse: [startIP > 64 ifTrue: [self print: '...'; cr]] ifTrue: + [startIP := startIP * self bytesPerWord + 1. - [startIP := startIP * objectMemory bytesPerWord + 1. lastIndex := objectMemory lengthOf: oop. lastIndex - startIP > 100 ifTrue: [lastIndex := startIP + 100]. bytecodesPerLine := 10. startIP to: lastIndex do: [:index| | byte | byte := objectMemory fetchByte: index - 1 ofObject: oop. self cCode: 'printf(" %02x/%-3d", byte,byte)' inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte]. ((index - startIP + 1) \ bytecodesPerLine) = 0 ifTrue: [self cr]]. ((lastIndex - startIP + 1) \ bytecodesPerLine) = 0 ifFalse: [self cr]]!

Item was changed: ----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') ----- printOopShortInner: oop | classOop name nameLen | <var: #name type: #'char *'> <inline: true> self printChar: $=. (objectMemory isIntegerObject: oop) ifTrue: [self printNum: (objectMemory integerValueOf: oop); printChar: $(; printHex: (objectMemory integerValueOf: oop); printChar: $). ^nil]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [self printHex: oop; print: ' is not on the heap'. ^nil]. + (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue: - (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'. ^nil]. (self isFloatObject: oop) ifTrue: [self printFloat: (self dbgFloatValueOf: oop). ^nil]. classOop := objectMemory fetchClassOf: oop. (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [self printNameOfClass: oop count: 5. ^nil]. oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil]. oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil]. oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil]. nameLen := self lengthOfNameOfClass: classOop. nameLen = 0 ifTrue: [self print: 'a ??'. ^nil]. name := self nameOfClass: classOop. nameLen = 10 ifTrue: [(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $"; printStringOf: oop; printChar: $". ^nil]. (self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $#; printStringOf: oop. ^nil]]. (nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue: [self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)). ^nil]. self cCode: [self prin: 'a(n) %.*s' t: nameLen f: name] inSmalltalk: [self print: 'a(n) '; print: name]!

Item was changed: ----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') ----- printStringOf: oop | fmt cnt i | <inline: false> (objectMemory isIntegerObject: oop) ifTrue: [^nil]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [^nil]. + (oop bitAnd: (self bytesPerWord - 1)) ~= 0 ifTrue: - (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue: [^nil]. fmt := objectMemory formatOf: oop. fmt < 8 ifTrue: [ ^nil ].

cnt := 100 min: (objectMemory lengthOf: oop). i := 0.

((objectMemory is: oop instanceOf: (objectMemory splObj: ClassByteArray) compactClassIndex: classByteArrayCompactIndex) or: [(objectMemory is: oop instanceOf: (objectMemory splObj: ClassLargePositiveInteger) compactClassIndex: ClassLargePositiveIntegerCompactIndex) or: [(objectMemory is: oop instanceOf: (objectMemory splObj: ClassLargeNegativeInteger) compactClassIndex: ClassLargeNegativeIntegerCompactIndex)]]) ifTrue: [[i < cnt] whileTrue: [ self printHex: (objectMemory fetchByte: i ofObject: oop). i := i + 1]] ifFalse: [[i < cnt] whileTrue: [ self printChar: (objectMemory fetchByte: i ofObject: oop). i := i + 1]]. self flush!

Item was changed: ----- Method: StackInterpreter>>push: (in category 'internal interpreter access') ----- push: object "In the StackInterpreter stacks grow down." | sp | <inline: true> <var: #sp type: #'char *'> + stackPages longAt: (sp := stackPointer - self bytesPerWord) put: object. - stackPages longAt: (sp := stackPointer - objectMemory bytesPerWord) put: object. stackPointer := sp!

Item was changed: ----- Method: StackInterpreter>>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 context | 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. "No need to record the pushed copied values in the outerContext." + context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * self bytesPerWord). - context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * objectMemory bytesPerWord). newClosure := self closureIn: context numArgs: numArgs + instructionPointer: (self oopForPointer: localIP) + 2 - (method+self baseHeaderSize) - instructionPointer: (self oopForPointer: localIP) + 2 - (method+objectMemory baseHeaderSize) numCopiedValues: numCopied. numCopied > 0 ifTrue: [0 to: numCopied - 1 do: [:i| "Assume: have just allocated a new BlockClosure; it must be young. Thus, can use unchecked stores." objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex ofObject: newClosure withValue: (self internalStackValue: numCopied - i - 1)]. self internalPop: numCopied]. localIP := localIP + blockSize. self fetchNextBytecode. self internalPush: newClosure!

Item was changed: ----- Method: StackInterpreter>>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 hdrNumStackPages minimumMemory memStart bytesRead bytesToShift heapSize hdrEdenBytes headerFlags hdrMaxExtSemTabSize | <var: #f type: 'sqImageFile '> <var: #memStart type: 'usqInt'> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '>

+ metaclassSizeBytes := 6 * self bytesPerWord. "guess (Metaclass instSize * BPW)" - metaclassSizeBytes := 6 * objectMemory bytesPerWord. "guess (Metaclass instSize * BPW)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. + headerStart := (self sqImageFilePosition: f) - self bytesPerWord. "record header start position" - headerStart := (self sqImageFilePosition: f) - objectMemory bytesPerWord. "record header start position"

headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. objectMemory setSpecialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory setLastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used." savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n. Can be set as a preference (Info.plist, VM.ini, command line etc). If desiredNumStackPages is already non-zero then it has been set as a preference. Ignore (but preserve) the header's default." numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to images run on Cog." theUnknownShort := self getShortFromFile: f swap: swapBytes. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory setEdenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "decrease Squeak object heap to leave extra memory for the VM" heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.

"compare memory requirements with availability". minimumMemory := dataSize + objectMemory edenBytes + self interpreterAllocationReserveBytes. heapSize < minimumMemory ifTrue: [self insufficientMemorySpecifiedError].

"allocate a contiguous block of memory for the Squeak heap" objectMemory setMemory: (self cCode: 'sqAllocateMemory(minimumMemory, heapSize)'). objectMemory getMemory = nil ifTrue: [self insufficientMemoryAvailableError].

memStart := objectMemory startOfMemory. objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety" objectMemory setEndOfMemory: memStart + dataSize.

"position file after the header" self sqImageFile: f Seek: headerStart + headerSize.

"read in the image in bulk, then swap the bytes if necessary" bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'. bytesRead ~= dataSize ifTrue: [self unableToReadImageError].

self ensureImageFormatIsUpToDate: swapBytes.

"compute difference between old and new memory base addresses" bytesToShift := memStart - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" ^dataSize !

Item was changed: ----- Method: StackInterpreter>>reestablishContextPriorToCallback: (in category 'callback support') ----- reestablishContextPriorToCallback: callbackContext "callbackContext is an activation of invokeCallback:[stack:registers:jmpbuf:]. Its sender is the VM's state prior to the callback. Reestablish that state, and mark calloutContext as dead." | calloutContext theFP thePage | <export: true> <var: #theFP type: #'char *'> <var: #thePage type: #'StackPage *'> self flag: #obsolete. (self isLiveContext: callbackContext) ifFalse: [^false]. calloutContext := self externalInstVar: SenderIndex ofContext: callbackContext. (self isLiveContext: calloutContext) ifFalse: [^false]. "Mark callbackContext as dead; the common case is that it is the current frame. We go the extra mile for the debugger." (self isSingleContext: callbackContext) ifTrue: [self markContextAsDead: callbackContext] ifFalse: [theFP := self frameOfMarriedContext: callbackContext. framePointer = theFP "common case" ifTrue: [(self isBaseFrame: theFP) ifTrue: [stackPages freeStackPage: stackPage] ifFalse: "calloutContext is immediately below on the same page. Make it current." [instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger. + stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + self bytesPerWord. - stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory bytesPerWord. framePointer := self frameCallerFP: framePointer. ^true]] ifFalse: [self externalDivorceFrame: theFP andContext: callbackContext. self markContextAsDead: callbackContext]]. "Make the calloutContext the active frame. The case where calloutContext is immediately below callbackContext on the same page is handled above." (self isStillMarriedContext: calloutContext) ifTrue: [theFP := self frameOfMarriedContext: calloutContext. thePage := stackPages stackPageFor: theFP. "findSPOf:on: points to the word beneath the instructionPointer, but there is no instructionPointer on the top frame of the current page." self assert: thePage ~= stackPage. + stackPointer := (self findSPOf: theFP on: thePage) - self bytesPerWord. - stackPointer := (self findSPOf: theFP on: thePage) - objectMemory bytesPerWord. framePointer := theFP] ifFalse: [thePage := self makeBaseFrameFor: calloutContext. framePointer := thePage headFP. stackPointer := thePage headSP]. instructionPointer := self popStack. self setStackPageAndLimit: thePage. ^true!

Item was changed: ----- Method: StackInterpreter>>returnAs:ThroughCallback:Context: (in category 'callback support') ----- returnAs: returnTypeOop ThroughCallback: vmCallbackContext Context: callbackMethodContext "callbackMethodContext is an activation of invokeCallback:[stack:registers:jmpbuf:]. Its sender is the VM's state prior to the callback. Reestablish that state (via longjmp), and mark callbackMethodContext as dead." <export: true> <var: #vmCallbackContext type: #'VMCallbackContext *'> | calloutMethodContext theFP thePage | <var: #theFP type: #'char *'> <var: #thePage type: #'StackPage *'> ((self isIntegerObject: returnTypeOop) and: [self isLiveContext: callbackMethodContext]) ifFalse: [^false]. calloutMethodContext := self externalInstVar: SenderIndex ofContext: callbackMethodContext. (self isLiveContext: calloutMethodContext) ifFalse: [^false]. "Mark callbackMethodContext as dead; the common case is that it is the current frame. We go the extra mile for the debugger." (self isSingleContext: callbackMethodContext) ifTrue: [self markContextAsDead: callbackMethodContext] ifFalse: [theFP := self frameOfMarriedContext: callbackMethodContext. framePointer = theFP "common case" ifTrue: [(self isBaseFrame: theFP) ifTrue: [stackPages freeStackPage: stackPage] ifFalse: "calloutMethodContext is immediately below on the same page. Make it current." [instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger. + stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + self bytesPerWord. - stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory bytesPerWord. framePointer := self frameCallerFP: framePointer. self restoreCStackStateForCallbackContext: vmCallbackContext. "N.B. siglongjmp is defines as _longjmp on non-win32 platforms. This matches the use of _setjmp in ia32abicc.c." self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop). ^true]] ifFalse: [self externalDivorceFrame: theFP andContext: callbackMethodContext. self markContextAsDead: callbackMethodContext]]. "Make the calloutMethodContext the active frame. The case where calloutMethodContext is immediately below callbackMethodContext on the same page is handled above." (self isStillMarriedContext: calloutMethodContext) ifTrue: [theFP := self frameOfMarriedContext: calloutMethodContext. thePage := stackPages stackPageFor: theFP. "findSPOf:on: points to the word beneath the instructionPointer, but there is no instructionPointer on the top frame of the current page." self assert: thePage ~= stackPage. + stackPointer := (self findSPOf: theFP on: thePage) - self bytesPerWord. - stackPointer := (self findSPOf: theFP on: thePage) - objectMemory bytesPerWord. framePointer := theFP] ifFalse: [thePage := self makeBaseFrameFor: calloutMethodContext. framePointer := thePage headFP. stackPointer := thePage headSP]. instructionPointer := self popStack. self setStackPageAndLimit: thePage. self restoreCStackStateForCallbackContext: vmCallbackContext. "N.B. siglongjmp is defines as _longjmp on non-win32 platforms. This matches the use of _setjmp in ia32abicc.c." self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop). "NOTREACHED" ^true!

Item was changed: ----- Method: StackInterpreter>>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 displayBits w wordStartIndex wordEndIndex primFailCodeValue | displayObj := objectMemory splObj: TheDisplay. ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifFalse: [^ nil]. w := objectMemory fetchPointer: 1 ofObject: displayObj. displayBits := objectMemory fetchPointer: 0 ofObject: displayObj. ((objectMemory isIntegerObject: displayBits) or: [(objectMemory isNonIntegerObject: w) or: [objectMemory isPointersNonInt: displayBits]]) ifTrue: [^ nil]. wordStartIndex := startIndex * 4. wordEndIndex := endIndex * 4 min: (objectMemory sizeBitsOf: displayBits). + displayBits := displayBits + self baseHeaderSize. - displayBits := displayBits + objectMemory baseHeaderSize. displayBits + wordStartIndex to: displayBits + wordEndIndex by: 4 do: [:ptr | | reversed | reversed := (objectMemory long32At: ptr) bitXor: 16rFFFFFFFF. objectMemory longAt: ptr put: reversed]. primFailCodeValue := primFailCode. self initPrimCall. self displayBitsOf: displayObj Left: 0 Top: 0 Right: (objectMemory integerValueOf: w) Bottom: 1. self ioForceDisplayUpdate. primFailCode := primFailCodeValue!

Item was changed: ----- Method: StackInterpreter>>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 assert: method = (stackPages longAt: framePointer + FoxMethod). cntxSize := ((self headerOf: method) bitAnd: LargeContextBit) ~= 0 + ifTrue: [LargeContextSize / self bytesPerWord - ReceiverIndex] + ifFalse: [SmallContextSize / self bytesPerWord - ReceiverIndex]. - ifTrue: [LargeContextSize / objectMemory bytesPerWord - ReceiverIndex] - ifFalse: [SmallContextSize / objectMemory bytesPerWord - ReceiverIndex]. ^self stackPointerIndex + n <= cntxSize!

Item was changed: ----- Method: StackInterpreter>>sendInvokeCallbackContext: (in category 'callback support') ----- sendInvokeCallbackContext: vmCallbackContext "Send the calllback message to Alien class with the supplied arg(s). Use either the 1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf: message, depending on what selector is installed in the specialObjectsArray. Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:). The arguments are raw C addresses and are converted to integer objects on the way." <export: true> <var: #vmCallbackContext type: #'VMCallbackContext *'> lkupClass := self fetchClassOfNonInt: (self splObj: ClassAlien). messageSelector := self splObj: SelectorInvokeCallback. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue: [^false]]. primitiveFunctionPointer ~= 0 ifTrue: [^false]. self saveCStackStateForCallbackContext: vmCallbackContext. self push: (self splObj: ClassAlien). "receiver" + self cppIf: [self bytesPerWord = 8] - self cppIf: [objectMemory bytesPerWord = 8] ifTrue: [(self argumentCountOf: newMethod) = 4 ifTrue: [self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger). self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger). self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)]. self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)] ifFalse: [(self argumentCountOf: newMethod) = 4 ifTrue: [self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger). self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger). self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)]. self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)]. self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector. self justActivateNewMethod. (self isMachineCodeFrame: framePointer) ifFalse: [self maybeFlagMethodAsInterpreted: newMethod]. self externalWriteBackHeadFramePointers. self handleStackOverflow. self enterSmalltalkExecutiveFromCallback. "not reached" ^true!

Item was changed: ----- Method: StackInterpreter>>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: cPtr) - self baseHeaderSize. - oop := (self oopForPointer: cPtr) - objectMemory baseHeaderSize. (objectMemory isWordsOrBytes: oop) ifFalse: [ self primitiveFail. ^0]. ^objectMemory lengthOf: oop !

Item was changed: ----- Method: StackInterpreter>>slowPrimitiveResponse (in category 'primitive support') ----- slowPrimitiveResponse "Called under the assumption that primFunctionPtr has been preloaded" | nArgs savedFramePointer savedStackPointer | <inline: true> <asmLabel: false> <var: #savedFramePointer type: #'char *'> <var: #savedStackPointer type: #'char *'> FailImbalancedPrimitives ifTrue: [nArgs := argumentCount. savedStackPointer := stackPointer. savedFramePointer := framePointer]. self initPrimCall. self dispatchFunctionPointer: primitiveFunctionPointer. (FailImbalancedPrimitives and: [self successful and: [framePointer = savedFramePointer]]) ifTrue:"Don't fail if primitive has done something radical, e.g. perform:" + [stackPointer ~= (savedStackPointer + (nArgs * self bytesPerWord)) ifTrue: - [stackPointer ~= (savedStackPointer + (nArgs * objectMemory bytesPerWord)) ifTrue: [self flag: 'Would be nice to make this a message send of e.g. unbalancedPrimitive to the current process or context'. "This is necessary but insufficient; the result may still have been written to the stack. At least we'll know something is wrong." stackPointer := savedStackPointer. self failUnbalancedPrimitive]]. "If we are profiling, take accurate primitive measures" nextProfileTick > 0 ifTrue: [self checkProfileTick: newMethod]. ^self successful!

Item was changed: ----- Method: StackInterpreter>>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 * bereaving widowed contexts. By ensuring that all contexts are single in a snapshot (i.e. that no married contexts exist) we can maintain the invariant that a married or widowed context's frame reference (in its sender field) must point into the stack pages since no married or widowed contexts are present from older runs of the system." | oop header fmt sz | oop := objectMemory firstObject. [self oop: oop isLessThan: objectMemory freeStart] whileTrue: [(objectMemory isFreeObject: oop) ifFalse: [header := self longAt: oop. fmt := objectMemory formatOfHeader: header. "Clean out context" (fmt = 3 and: [self isContextHeader: header]) ifTrue: ["All contexts have been divorced. Bereave remaining widows." (self isMarriedOrWidowedContext: oop) ifTrue: [self markContextAsDead: oop]. sz := objectMemory sizeBitsOf: oop. + (objectMemory lastPointerOf: oop) + self bytesPerWord + to: sz - self baseHeaderSize by: self bytesPerWord - (objectMemory lastPointerOf: oop) + objectMemory bytesPerWord - to: sz - objectMemory baseHeaderSize by: objectMemory bytesPerWord do: [:i | self longAt: oop + i put: objectMemory nilObject]]. "Clean out external functions" fmt >= 12 ifTrue: ["This is a compiled method" (self primitiveIndexOf: oop) = PrimitiveExternalCallIndex ifTrue: ["Its primitiveExternalCall" self flushExternalPrimitiveOf: oop]]]. oop := objectMemory objectAfter: oop]. objectMemory clearRootsTable!

Item was changed: ----- Method: StackInterpreter>>stackFloatValue: (in category 'internal interpreter access') ----- stackFloatValue: offset "In the StackInterpreter stacks grow down." | result floatPointer | <returnTypeC: #double> <var: #result type: #double> + floatPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord). - floatPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord).

"N.B. Because Slang always inlines assertClassOf:is:compactClassIndex: (because assertClassOf:is:compactClassIndex: has an inline: pragma) the phrase (self splObj: ClassArray) is expanded in-place and is _not_ evaluated if ClassArrayCompactIndex is non-zero." self assertClassOf: floatPointer is: (objectMemory splObj: ClassFloat) compactClassIndex: ClassFloatCompactIndex. self successful ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. + objectMemory fetchFloatAt: floatPointer + self baseHeaderSize into: result. - objectMemory fetchFloatAt: floatPointer + objectMemory baseHeaderSize into: result. ^result]. ^0.0!

Item was changed: ----- Method: StackInterpreter>>stackLimitOffset (in category 'stack pages') ----- stackLimitOffset "Answer the amount of slots needed to fit a new frame at the point the stack limit is checked. A frame looks like this at the point the stack limit is checked: stacked receiver/closure arg0 ... argN caller's method ip/base frame's sender context fp-> saved fp method method header fields context (uninitialized) receiver first temp ... sp-> Nth temp So the amount of headroom is the maximum number of arguments + 1 (for stacked receiver and arguments) + the frame size + the max number of temps. Since a method's number of temps includes its arguments the actual offset is:" + ^(FrameSlots + 64) * self bytesPerWord! - ^(FrameSlots + 64) * objectMemory bytesPerWord!

Item was changed: ----- Method: StackInterpreter>>stackPositiveMachineIntegerValue: (in category 'internal interpreter access') ----- stackPositiveMachineIntegerValue: offset <api> "In the StackInterpreter stacks grow down." | integerPointer | + integerPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord). - integerPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord). ^self positiveMachineIntegerValueOf: integerPointer!

Item was changed: ----- Method: StackInterpreter>>stackSignedMachineIntegerValue: (in category 'internal interpreter access') ----- stackSignedMachineIntegerValue: offset <api> "In the StackInterpreter stacks grow down." | integerPointer | + integerPointer := stackPages longAt: stackPointer + (offset * self bytesPerWord). - integerPointer := stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord). ^self signedMachineIntegerValueOf: integerPointer!

Item was changed: ----- Method: StackInterpreter>>stackValue: (in category 'internal interpreter access') ----- stackValue: offset <api> "In the StackInterpreter stacks grow down." + ^stackPages longAt: stackPointer + (offset * self bytesPerWord)! - ^stackPages longAt: stackPointer + (offset * objectMemory bytesPerWord)!

Item was changed: ----- Method: StackInterpreter>>stackValue:put: (in category 'internal interpreter access') ----- stackValue: offset put: oop "In the StackInterpreter stacks grow down." ^stackPages + longAt: stackPointer + (offset * self bytesPerWord) - longAt: stackPointer + (offset * objectMemory bytesPerWord) put: oop!

Item was changed: ----- Method: StackInterpreter>>sufficientSpaceToInstantiate:indexableSize: (in category 'object access primitives') ----- sufficientSpaceToInstantiate: classOop indexableSize: size "Return the number of bytes required 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 atomSize| <inline: true> format := self instSpecOfClass: classOop.

"fail if attempting to call new: on non-indexable class" ((self cCoerce: size to: 'usqInt ') > 0 and: [format < 2]) ifTrue: [^ false].

format < 8 + ifTrue: ["indexable fields are words or pointers" atomSize := self bytesPerWord] - ifTrue: ["indexable fields are words or pointers" atomSize := objectMemory bytesPerWord] ifFalse: ["indexable fields are bytes" atomSize := 1]. ^objectMemory sufficientSpaceToAllocate: 2500 + (size * atomSize)!

Item was changed: ----- Method: StackInterpreter>>temporary:in: (in category 'internal interpreter access') ----- temporary: offset in: theFP "See StackInterpreter class>>initializeFrameIndices" | frameNumArgs | <inline: true> <var: #theFP type: #'char *'> ^offset < (frameNumArgs := self frameNumArgs: theFP) + ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * self bytesPerWord)] - ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory bytesPerWord)] ifFalse: [stackPages longAt: theFP + FoxReceiver - self bytesPerWord + ((frameNumArgs - offset) * self bytesPerWord)]!

Item was changed: ----- Method: StackInterpreter>>temporary:in:put: (in category 'internal interpreter access') ----- temporary: offset in: theFP put: valueOop "See StackInterpreter class>>initializeFrameIndices" | frameNumArgs | <inline: true> <var: #theFP type: #'char *'> offset < (frameNumArgs := self frameNumArgs: theFP) + ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * self bytesPerWord) put: valueOop] - ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory bytesPerWord) put: valueOop] ifFalse: [stackPages longAt: theFP + FoxReceiver - self bytesPerWord + ((frameNumArgs - offset) * self bytesPerWord) put: valueOop]!

Item was changed: ----- Method: StackInterpreter>>temporaryLocation:in:numArgs: (in category 'internal interpreter access') ----- temporaryLocation: offset in: theFP numArgs: numArgs "Answer the pointer to a given temporary (for debug frame printing in odd circumstances)" <var: #theFP type: #'char *'> <returnTypeC: #'char *'> <asmLabel: false> ^offset < numArgs + ifTrue: [theFP + FoxCallerSavedIP + ((numArgs - offset) * self bytesPerWord)] - ifTrue: [theFP + FoxCallerSavedIP + ((numArgs - offset) * objectMemory bytesPerWord)] ifFalse: [theFP + FoxReceiver - self bytesPerWord + ((numArgs - offset) * self bytesPerWord)]!

Item was changed: ----- Method: StackInterpreter>>unPop: (in category 'internal interpreter access') ----- unPop: nItems "In the StackInterpreter stacks grow down." + stackPointer := stackPointer - (nItems * self bytesPerWord)! - stackPointer := stackPointer - (nItems * objectMemory bytesPerWord)!

Item was changed: ----- Method: StackInterpreter>>updateObjectsPostByteSwapFrom:to: (in category 'image save/restore') ----- updateObjectsPostByteSwapFrom: 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. Ensure floats are in platform-order." | oop fmt wordAddr methodHeader swapFloatWords temp | swapFloatWords := objectMemory vmEndianness ~= imageFloatsBigEndian. self assert: ClassFloatCompactIndex ~= 0. oop := startOop. [self oop: oop isLessThan: stopAddr] whileTrue: [(objectMemory isFreeObject: oop) ifFalse: [fmt := objectMemory formatOf: oop. fmt >= 8 ifTrue: "oop contains bytes" + [wordAddr := oop + self baseHeaderSize. - [wordAddr := oop + objectMemory baseHeaderSize. fmt >= 12 ifTrue: "compiled method; start after methodHeader and literals" + [methodHeader := self longAt: oop + self baseHeaderSize. + wordAddr := wordAddr + self bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * self bytesPerWord)]. - [methodHeader := self longAt: oop + objectMemory baseHeaderSize. - wordAddr := wordAddr + objectMemory bytesPerWord + ((methodHeader >> 10 bitAnd: 255) * objectMemory bytesPerWord)]. objectMemory reverseBytesFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)]. fmt = 6 ifTrue: "Bitmap, Float etc" [(swapFloatWords and: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex]) ifTrue: + [temp := self longAt: oop + self baseHeaderSize. + self longAt: oop + self baseHeaderSize put: (self longAt: oop + self baseHeaderSize + 4). + self longAt: oop + self baseHeaderSize + 4 put: temp] - [temp := self longAt: oop + objectMemory baseHeaderSize. - self longAt: oop + objectMemory baseHeaderSize put: (self longAt: oop + objectMemory baseHeaderSize + 4). - self longAt: oop + objectMemory baseHeaderSize + 4 put: temp] ifFalse: + [self bytesPerWord = 8 ifTrue: "Object contains 32-bit half-words packed into 64-bit machine words." + [wordAddr := oop + self baseHeaderSize. - [objectMemory bytesPerWord = 8 ifTrue: "Object contains 32-bit half-words packed into 64-bit machine words." - [wordAddr := oop + objectMemory baseHeaderSize. objectMemory reverseWordsFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)]]]]. oop := objectMemory objectAfter: oop]!

Item was changed: ----- Method: StackInterpreter>>updateStateOfSpouseContextForFrame:WithSP: (in category 'frame access') ----- updateStateOfSpouseContextForFrame: theFP WithSP: theSP "Update the frame's spouse context with the frame's current state except for the sender and instruction pointer, which are used to mark the context as married." | theContext tempIndex pointer | <inline: false> <var: #theFP type: #'char *'> <var: #theSP type: #'char *'> <var: #pointer type: #'char *'> self assert: (self frameHasContext: theFP). theContext := self frameContext: theFP. self assert: (self frameReceiver: theFP) = (objectMemory fetchPointer: ReceiverIndex ofObject: theContext). tempIndex := self frameNumArgs: theFP. + pointer := theFP + FoxReceiver - self bytesPerWord. - pointer := theFP + FoxReceiver - objectMemory bytesPerWord. [pointer >= theSP] whileTrue: [self assert: (objectMemory addressCouldBeOop: (stackPages longAt: pointer)). tempIndex := tempIndex + 1. objectMemory storePointer: ReceiverIndex + tempIndex ofObject: theContext withValue: (stackPages longAt: pointer). + pointer := pointer - self bytesPerWord]. - pointer := pointer - objectMemory bytesPerWord]. self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext). objectMemory storePointerUnchecked: StackPointerIndex ofObject: theContext withValue: (objectMemory integerObjectOf: tempIndex)!

Item was changed: ----- Method: StackInterpreter>>validInstructionPointer:inMethod:framePointer: (in category 'debug support') ----- validInstructionPointer: instrPointer inMethod: aMethod framePointer: fp <var: #instrPointer type: #usqInt> <var: #aMethod type: #usqInt> ^instrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + self bytesPerWord - 1) + and: [instrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + self baseHeaderSize)]! - and: [instrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + objectMemory baseHeaderSize)]!

Item was changed: ----- Method: StackInterpreter>>withSmallIntegerTags: (in category 'frame access') ----- withSmallIntegerTags: value <inline: true> <var: #value type: #'char *'> + self assert: ((self oopForPointer: value) bitAnd: self bytesPerWord - 1) = 0. - self assert: ((self oopForPointer: value) bitAnd: objectMemory bytesPerWord - 1) = 0. ^(self oopForPointer: value) + 1!

Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') ----- primitiveClosureCopyWithCopiedValues | newClosure numArgs | numArgs := self stackIntegerValue: 1. self successful ifFalse: [^self primitiveFail].

newClosure := self closureIn: (self stackValue: 2) numArgs: numArgs "greater by 1 due to preIncrement of localIP" + instructionPointer: instructionPointer + 2 - (method + self baseHeaderSize) - instructionPointer: instructionPointer + 2 - (method + objectMemory baseHeaderSize) copiedValues: self stackTop. self pop: 3 thenPush: newClosure!

Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveDoNamedPrimitiveWithArgs (in category 'plugin primitives') ----- primitiveDoNamedPrimitiveWithArgs "Simulate an primitiveExternalCall invocation (e.g. for the Debugger). Do not cache anything. e.g. ContextPart>>tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments" | argumentArray arraySize methodArg methodHeader moduleName functionName moduleLength functionLength spec addr primRcvr ctxtRcvr | <var: #addr declareC: 'void (*addr)()'> argumentArray := self stackTop. (objectMemory isArray: argumentArray) ifFalse: [^self primitiveFailFor: -2]. "invalid args" arraySize := objectMemory fetchWordLengthOf: argumentArray. self success: (self roomToPushNArgs: arraySize).

methodArg := self stackObjectValue: 2. self successful ifFalse: [^self primitiveFailFor: -2]. "invalid args"

(objectMemory isOopCompiledMethod: methodArg) ifFalse: [^self primitiveFailFor: -2]. "invalid args"

methodHeader := self headerOf: methodArg.

(self literalCountOfHeader: methodHeader) > 2 ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state" (self assertClassOf: (spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg) is: (objectMemory splObj: ClassArray) compactClassIndex: ClassArrayCompactIndex). (self successful and: [(objectMemory lengthOf: spec) = 4 and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state"

(self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse: [^self primitiveFailFor: -2]. "invalid args (Array args wrong size)"

"The function has not been loaded yet. Fetch module and function name." moduleName := objectMemory fetchPointer: 0 ofObject: spec. moduleName = objectMemory nilObject ifTrue: [moduleLength := 0] ifFalse: [self success: (objectMemory isBytes: moduleName). moduleLength := objectMemory lengthOf: moduleName. self cCode: '' inSmalltalk: [ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??" ifTrue: [moduleLength := 0 "Cause all of these to fail"]]]. functionName := objectMemory fetchPointer: 1 ofObject: spec. self success: (objectMemory isBytes: functionName). functionLength := objectMemory lengthOf: functionName. self successful ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state"

+ addr := self ioLoadExternalFunction: functionName + self baseHeaderSize - addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize OfLength: functionLength + FromModule: moduleName + self baseHeaderSize - FromModule: moduleName + objectMemory baseHeaderSize OfLength: moduleLength. addr = 0 ifTrue: [^self primitiveFailFor: -1]. "could not find function; answer generic failure (see below)"

"Cannot fail this primitive from now on. Can only fail the external primitive." objectMemory pushRemappableOop: (argumentArray := self popStack). objectMemory pushRemappableOop: (primRcvr := self popStack). objectMemory pushRemappableOop: self popStack. "the method" objectMemory pushRemappableOop: self popStack. "the context receiver" self push: primRcvr. "replace context receiver with actual receiver" argumentCount := arraySize. 1 to: arraySize do: [:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)]. "Run the primitive (sets primFailCode)" lkupClass := objectMemory nilObject. self callExternalPrimitive: addr. ctxtRcvr := objectMemory popRemappableOop. methodArg := objectMemory popRemappableOop. primRcvr := objectMemory popRemappableOop. argumentArray := objectMemory popRemappableOop. self successful ifFalse: "If primitive failed, then restore state for failure code" [self pop: arraySize + 1. self push: ctxtRcvr. self push: methodArg. self push: primRcvr. self push: argumentArray. argumentCount := 3. "Hack. A nil prim error code (primErrorCode = 1) is interpreted by the image as meaning this primitive is not implemented. So to pass back nil as an error code we use -1 to indicate generic failure." primFailCode = 1 ifTrue: [primFailCode := -1]]!

Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveExternalCall (in category 'plugin primitives') ----- primitiveExternalCall "Call an external primitive. External primitive methods first literals are an array 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 interpreter dispatch in subsequent invocations the primitiveFunctionPointer in the method cache is rewritten, either to the function itself, or to zero if the external function is not found. This allows for fast responses as long as the method stays in the cache. The cache rewrite relies on lastMethodCacheProbeWrite which is set in addNewMethodToCache:. Now that the VM flushes function addresses from its tables, the session ID is obsolete, but it is kept for backward compatibility. 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 (i.e., the SmallInteger -1 to distinguish from 16rFFFFFFFF which may be returned from lookup), and the primitive fails with PrimErrNotFound." | lit addr moduleName functionName moduleLength functionLength index | <var: #addr declareC: 'void (*addr)()'> "Fetch the first literal of the method" (self literalCountOf: newMethod) > 0 ifFalse: [^self primitiveFailFor: PrimErrBadMethod].

lit := self literal: 0 ofMethod: newMethod. "Check if it's an array of length 4" ((objectMemory isArray: lit) and: [(objectMemory lengthOf: lit) = 4]) ifFalse: [^self primitiveFailFor: PrimErrBadMethod].

"Look at the function index in case it has been loaded before" index := objectMemory fetchPointer: 3 ofObject: lit. (objectMemory isIntegerObject: index) ifFalse: [^self primitiveFailFor: PrimErrBadMethod]. index := objectMemory integerValueOf: index. "Check if we have already looked up the function and failed." index < 0 ifTrue: ["Function address was not found in this session, Void the primitive function." self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0. ^self primitiveFailFor: PrimErrNotFound].

"Try to call the function directly" (index > 0 and: [index <= MaxExternalPrimitiveTableSize]) ifTrue: [addr := externalPrimitiveTable at: index - 1. addr ~= 0 ifTrue: [self rewriteMethodCacheEntryForExternalPrimitiveToFunction: (self cCode: 'addr' inSmalltalk: [1000 + index]). 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 primitiveFailFor: PrimErrNamedInternal].

"Clean up session id and external primitive index" objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero. objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.

"The function has not been loaded yet. Fetch module and function name." moduleName := objectMemory fetchPointer: 0 ofObject: lit. moduleName = objectMemory nilObject ifTrue: [moduleLength := 0] ifFalse: [(objectMemory isBytes: moduleName) ifFalse: [self primitiveFailFor: PrimErrBadMethod]. moduleLength := objectMemory lengthOf: moduleName]. functionName := objectMemory fetchPointer: 1 ofObject: lit. (objectMemory isBytes: functionName) ifFalse: [self primitiveFailFor: PrimErrBadMethod]. functionLength := objectMemory lengthOf: functionName.

+ addr := self ioLoadExternalFunction: functionName + self baseHeaderSize - addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize OfLength: functionLength + FromModule: moduleName + self baseHeaderSize - FromModule: moduleName + objectMemory baseHeaderSize OfLength: moduleLength. addr = 0 ifTrue: [index := -1] ifFalse: ["add the function to the external primitive table" index := self addToExternalPrimitiveTable: addr].

"Store the index (or -1 if failure) back in the literal" objectMemory storePointerUnchecked: 3 ofObject: lit withValue: (objectMemory integerObjectOf: index).

"If the function has been successfully loaded cache and call it" index >= 0 ifTrue: [self rewriteMethodCacheEntryForExternalPrimitiveToFunction: (self cCode: [addr] inSmalltalk: [1000 + index]). self callExternalPrimitive: addr] ifFalse: ["Otherwise void the primitive function and fail" self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0. ^self primitiveFailFor: PrimErrNotFound]!

Item was changed: ----- Method: StackInterpreterPrimitives>>primitivePerform (in category 'control primitives') ----- primitivePerform <returnTypeC: #void> | performSelector newReceiver 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 will work."

"Slide arguments down over selector" argumentCount := argumentCount - 1. argumentCount to: 1 by: -1 do: [:i| stackPages + longAt: stackPointer + (i * BytesPerWord) + put: (stackPages longAt: stackPointer + ((i - 1) * BytesPerWord))]. - longAt: stackPointer + (i * objectMemory bytesPerWord) - put: (stackPages longAt: stackPointer + ((i - 1) * objectMemory bytesPerWord))]. self pop: 1. lookupClass := objectMemory fetchClassOf: newReceiver. + self sendBreak: messageSelector + self baseHeaderSize - self sendBreak: messageSelector + objectMemory baseHeaderSize point: (objectMemory lengthOf: messageSelector) receiver: newReceiver. self findNewMethodInClass: lookupClass.

"Only test CompiledMethods for argument count - other objects will have to take their chances" ((objectMemory isOopCompiledMethod: newMethod) and: [(self argumentCountOf: newMethod) = argumentCount]) ifFalse: ["Slide the args back up (sigh) and re-insert the selector." self unPop: 1. 1 to: argumentCount by: 1 do: [:i | + stackPages longAt: stackPointer + ((i - 1) * BytesPerWord) + put: (stackPages longAt: stackPointer + (i * BytesPerWord))]. + stackPages longAt: stackPointer + (argumentCount * BytesPerWord) put: messageSelector. - stackPages longAt: stackPointer + ((i - 1) * objectMemory bytesPerWord) - put: (stackPages longAt: stackPointer + (i * objectMemory bytesPerWord))]. - stackPages longAt: stackPointer + (argumentCount * objectMemory bytesPerWord) put: messageSelector. argumentCount := argumentCount + 1. newMethod := performMethod. messageSelector := performSelector. ^self primitiveFail].

self executeNewMethod. "Recursive xeq affects primErrorCode" self initPrimCall!

Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveTerminateTo (in category 'control 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." | thisCtx currentCtx aContextOrNil contextsFP contextsSP contextsIP nextCntx stackedReceiverOffset theFP newFP newSP pageToStopOn thePage frameAbove | <var: #contextsFP type: #'char *'> <var: #theFP type: #'char *'> <var: #newFP type: #'char *'> <var: #newSP type: #'char *'> <var: #contextsIP type: #usqInt> <var: #frameAbove type: #'char *'> <var: #contextsSP type: #'char *'> <var: #source type: #'char *'> <var: #pageToStopOn type: #'StackPage *'> <var: #thePage type: #'StackPage *'>

aContextOrNil := self stackTop. (aContextOrNil = objectMemory nilObject or: [self isContext: aContextOrNil]) ifFalse: [^self primitiveFail]. thisCtx := self stackValue: 1. thisCtx = aContextOrNil ifTrue: [^self primitiveFail].

"All stackPages need to have current head pointers to avoid confusion." self externalWriteBackHeadFramePointers.

"If we're searching for aContextOrNil it might be on a stack page. Helps to know if we can free a whole page or not, or if we can short-cut the termination." (aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil]) ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil. pageToStopOn := stackPages stackPageFor: contextsFP] ifFalse: [pageToStopOn := 0].

"if thisCtx is married ensure it is a base frame. Then we can assign its sender." (self isStillMarriedContext: thisCtx) ifTrue: [theFP := self frameOfMarriedContext: thisCtx. "Optimize terminating thisContext. Move its frame down to be next to aContextOrNil's frame. Common in the exception system and so helps to be fast." (theFP = framePointer and: [pageToStopOn = stackPage]) ifTrue: [(self frameCallerFP: theFP) ~= contextsFP ifTrue: [stackedReceiverOffset := self frameStackedReceiverOffset: theFP. frameAbove := self findFrameAbove: contextsFP inPage: pageToStopOn. contextsIP := self frameCallerSavedIP: frameAbove. newSP := self frameCallerSP: frameAbove. + newFP := newSP - stackedReceiverOffset - BytesPerWord. - newFP := newSP - stackedReceiverOffset - objectMemory bytesPerWord. theFP + stackedReceiverOffset to: stackPointer + by: BytesPerWord negated - by: objectMemory bytesPerWord negated do: [:source| + newSP := newSP - BytesPerWord. - newSP := newSP - objectMemory bytesPerWord. stackPages longAt: newSP put: (stackPages longAt: source)]. stackPages longAt: newFP + FoxSavedFP put: contextsFP. stackPages longAt: newFP + FoxCallerSavedIP put: contextsIP. self assert: (self isContext: thisCtx). objectMemory storePointerUnchecked: SenderIndex ofObject: thisCtx withValue: (self withSmallIntegerTags: newFP). objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: thisCtx withValue: (self withSmallIntegerTags: contextsFP). framePointer := newFP. stackPointer := newSP]. self pop: 1. self assert: stackPage = stackPages mostRecentlyUsedPage. ^nil]. theFP := self externalEnsureIsBaseFrame: theFP. "May cause a GC!!!!" currentCtx := self frameCallerContext: theFP. "May also reclaim aContextOrNil's page, hence..." (aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil]) ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil. pageToStopOn := stackPages stackPageFor: contextsFP] ifFalse: [pageToStopOn := 0]] ifFalse: [currentCtx := objectMemory fetchPointer: SenderIndex ofObject: thisCtx].

(self context: thisCtx hasSender: aContextOrNil) ifTrue: ["Need to walk the stack freeing stack pages and nilling contexts." [currentCtx = aContextOrNil or: [currentCtx = objectMemory nilObject]] whileFalse: [self assert: (self isContext: currentCtx). (self isMarriedOrWidowedContext: currentCtx) ifTrue: [theFP := self frameOfMarriedContext: currentCtx. thePage := stackPages stackPageFor: theFP. "If externalEnsureIsBaseFrame: above has moved thisContext to its own stack then we will always terminate to a frame on a different page. But if we are terminating some other context to a context somewhere on the current page we must save the active frames above that context. Things will look e.g. like this: thisCtx 499383332 s MethodContext(ContextPart)>resume: 499380484 s BlockClosure>ensure: 499377320 s MethodContext(ContextPart)>handleSignal: 499373760 s MethodContext(ContextPart)>handleSignal: 499372772 s MessageNotUnderstood(Exception)>signal 499369068 s CodeSimulationTests(Object)>doesNotUnderstand: absentMethod 499368708 s [] in CodeSimulationTests>testDNU (sender is 0xbffc2480 I CodeSimulationTests>runSimulated:) ------------ framePointer 0xbffc234c M MethodContext(ContextPart)>doPrimitive:method:receiver:args: 0xbffc2378 M MethodContext(ContextPart)>tryPrimitiveFor:receiver:args: 0xbffc23ac M MethodContext(ContextPart)>send:to:with:super: 0xbffc23e4 M MethodContext(ContextPart)>send:super:numArgs: 0xbffc2418 M MethodContext(InstructionStream)>interpretNextInstructionFor: 0xbffc2434 M MethodContext(ContextPart)>step 0xbffc2458 I MethodContext(ContextPart)>runSimulated:contextAtEachStep: ------------ (499368708's sender) 0xbffc2480 I CodeSimulationTests>runSimulated: 0xbffc249c M CodeSimulationTests>testDNU 0xbffc24bc I CodeSimulationTests(TestCase)>performTest 0xbffc24dc I [] in CodeSimulationTests(TestCase)>runCase aContextOrNil 0xbffc24fc M BlockClosure>ensure: 0xbffc2520 I CodeSimulationTests(TestCase)>runCase 0xbffc253c M [] in TestResult>runCase: When we find this case we move the frames above to a new page by making the frame above currentCtx a base frame, i.e. making 0xbffc2458 in the above example a base frame. But in this iteration of the loop we don't move down a frame i.e. currentCtx doesn't change on this iteration." thePage = stackPage ifTrue: [frameAbove := self findFrameAbove: theFP inPage: thePage. self assert: frameAbove ~= 0. frameAbove := self externalEnsureIsBaseFrame: frameAbove. "May cause a GC!!!! May also reclaim aContextOrNil's page, hence..." (aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil]) ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil. pageToStopOn := stackPages stackPageFor: contextsFP] ifFalse: [pageToStopOn := 0]] ifFalse: [thePage = pageToStopOn ifTrue: ["We're here. Cut back the stack to aContextOrNil's frame, push its instructionPointer if it's not already a head frame, and we're done." frameAbove := self findFrameAbove: contextsFP inPage: thePage. frameAbove ~= 0 ifTrue: + [contextsSP := (self frameCallerSP: frameAbove) - BytesPerWord. - [contextsSP := (self frameCallerSP: frameAbove) - objectMemory bytesPerWord. stackPages longAt: contextsSP put: (self frameCallerSavedIP: frameAbove). self setHeadFP: contextsFP andSP: contextsSP inPage: thePage]. currentCtx := aContextOrNil] ifFalse: ["We can free the entire page without further ado." currentCtx := self frameCallerContext: thePage baseFP. "for a short time invariant is violated; assert follows" stackPages freeStackPageNoAssert: thePage]]] ifFalse: [nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx. self markContextAsDead: currentCtx. currentCtx := nextCntx]]]. self assert: stackPages pageListIsWellFormed. (self isMarriedOrWidowedContext: thisCtx) ifTrue: [self assert: (self checkIsStillMarriedContext: thisCtx currentFP: framePointer). self assert: (self isBaseFrame: (self frameOfMarriedContext: thisCtx)). theFP := self frameOfMarriedContext: thisCtx. self frameCallerContext: theFP put: aContextOrNil] ifFalse: [objectMemory storePointer: SenderIndex ofObject: thisCtx withValue: aContextOrNil]. self pop: 1. self assert: stackPage = stackPages mostRecentlyUsedPage. ^nil!

Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveVMParameter (in category 'system control primitives') ----- (excessive size, no diff calculated)

Item was changed: ----- Method: StackInterpreterSimulator>>clipboardWrite:From:At: (in category 'I/O primitives') ----- clipboardWrite: sz From: actualDataAddress At: ignored

+ Clipboard clipboardText: (self stringOf: actualDataAddress - BaseHeaderSize)! - Clipboard clipboardText: (self stringOf: actualDataAddress - objectMemory baseHeaderSize)!

Item was changed: ----- Method: StackInterpreterSimulator>>shortPrint: (in category 'debug support') ----- shortPrint: oop | name classOop | (objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString , ' (' , (objectMemory integerValueOf: oop) hex , ')']. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [^' is not on the heap']. + (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue: [^' is misaligned']. classOop := objectMemory fetchClassOf: oop. (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [ ^ 'class ' , (self nameOfClass: oop)]. name := self nameOfClass: classOop. name size = 0 ifTrue: [name := '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'Character' ifTrue: [^ '=' , (Character value: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString]. name = 'Association' ifTrue: [^ '(' , + (self shortPrint: (self longAt: oop + BaseHeaderSize)) , - (self shortPrint: (self longAt: oop + objectMemory baseHeaderSize)) , ' -> ' , + (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')']. - (self longAt: oop + objectMemory baseHeaderSize + objectMemory bytesPerWord) hex8 , ')']. ('AEIOU' includes: name first) ifTrue: [^ 'an ' , name] ifFalse: [^ 'a ' , name]!

Item was changed: ----- Method: StackInterpreterSimulator>>shortPrintRelative: (in category 'debug support') ----- shortPrintRelative: oop | name classOop | (objectMemory isIntegerObject: oop) ifTrue: [^'=' , (objectMemory integerValueOf: oop) printString , ' (' , (objectMemory integerValueOf: oop) hex , ')']. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [^' is not on the heap']. + (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - (oop bitAnd: (objectMemory bytesPerWord - 1)) ~= 0 ifTrue: [^' is misaligned']. classOop := objectMemory fetchClassOfNonInt: oop. (objectMemory sizeBitsOf: classOop) = metaclassSizeBytes ifTrue: [ ^'class ' , (self nameOfClass: oop)]. name := self nameOfClass: classOop. name size = 0 ifTrue: [name := '??']. name = 'String' ifTrue: [^(self stringOf: oop) printString]. name = 'ByteString' ifTrue: [^(self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^'#' , (self stringOf: oop)]. name = 'ByteSymbol' ifTrue: [^'#' , (self stringOf: oop)]. name = 'Character' ifTrue: [^'=' , (Character value: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^'nil']. name = 'False' ifTrue: [^'false']. name = 'True' ifTrue: [^'true']. name = 'Float' ifTrue: [^'=' , (self dbgFloatValueOf: oop) printString]. name = 'Association' ifTrue: [| valOop | + valOop := self longAt: oop + BaseHeaderSize + BytesPerWord. - valOop := self longAt: oop + objectMemory baseHeaderSize + objectMemory bytesPerWord. ^'(' , + (self shortPrint: (self longAt: oop + BaseHeaderSize)) , - (self shortPrint: (self longAt: oop + objectMemory baseHeaderSize)) , ' -> ' , ((objectMemory isIntegerObject: valOop) ifTrue: [valOop] ifFalse: [valOop - objectMemory startOfMemory]) hex8 , ')']. ^(('AEIOU' includes: name first) ifTrue: ['an '] ifFalse: ['a ']) , name!

Item was changed: ----- Method: StackInterpreterSimulator>>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. - nLongs := size-1//objectMemory bytesPerWord+1. 1 to: nLongs do: + [:i | long := self longAt: oop + BaseHeaderSize + (i-1*BytesPerWord). - [:i | long := self longAt: oop + objectMemory baseHeaderSize + (i-1*objectMemory bytesPerWord). chars := self charsOfLong: long. strm nextPutAll: (i=nLongs + ifTrue: [chars copyFrom: 1 to: size-1\BytesPerWord+1] - ifTrue: [chars copyFrom: 1 to: size-1\objectMemory bytesPerWord+1] ifFalse: [chars])]]!

Item was changed: ----- Method: StackInterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') ----- vmPathGet: stringBase Length: stringSize | pathName stringOop | pathName := Smalltalk vmPath. + stringOop := stringBase - BaseHeaderSize. "Due to C call in Interp" - stringOop := stringBase - objectMemory baseHeaderSize. "Due to C call in Interp" 1 to: stringSize do: [:i | objectMemory storeByte: i-1 ofObject: stringOop withValue: (pathName at: i) asciiValue]. !

Item was changed: ----- Method: StackInterpreterSimulator>>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']. - objectMemory bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet']. headerSize := 64.

[ file := (FileStream fileNamed: imageName) binary. file == nil ifTrue: [^nil]. { self imageFormatVersion. headerSize. numberOfBytesToWrite. objectMemory startOfMemory. (objectMemory getSpecialObjectsOop). (objectMemory getLastHash). self ioScreenSize. fullScreenFlag. extraVMMemory } do: [:long | self putLong: long toFile: file].

{ desiredNumStackPages. self unknownShortOrCodeSizeInKs } do: [:short| self putShort: short toFile: file].

self putLong: desiredEdenBytes toFile: file.

{ maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do: [:short| self putShort: short toFile: file].

"Pad the rest of the header." 4 timesRepeat: [self putLong: 0 toFile: file]. "Position the file after the header." file position: headerSize. "Write the object memory." objectMemory startOfMemory // 4 + 1 to: numberOfBytesToWrite // 4 do: [:index | self putLong: (objectMemory getMemory at: index) toFile: file]. self success: true ] ensure: [file close]!

Item was changed: ----- Method: StackInterpreterSimulatorLSB>>nextLongFrom: (in category 'initialization') ----- nextLongFrom: aStream "Read a 32- or 64-bit quantity from the given (binary) stream."

+ ^ aStream nextLittleEndianNumber: BytesPerWord! - ^ aStream nextLittleEndianNumber: objectMemory bytesPerWord!

Item was removed: - ----- Method: TMethod>>superExpansionNodeFor:args: (in category 'inlining') ----- - superExpansionNodeFor: aSelector args: argumentNodes - "Answer the expansion of a super send. Merge the super expansion's - locals, properties and comment into this method's properties." - (definingClass superclass lookupSelector: aSelector) - ifNil: [self error: 'superclass does not define super method'] - ifNotNil: - [:superMethod| | superTMethod commonVars varMap | - superTMethod := superMethod methodNode asTranslationMethodOfClass: self class. - ((argumentNodes allSatisfy: [:parseNode| parseNode isVariableNode]) - and: [(argumentNodes asOrderedCollection collect: [:parseNode| parseNode key]) = superTMethod args]) ifFalse: - [self error: definingClass name, '>>',selector, ' args ~= ', - superTMethod definingClass name, '>>', aSelector, - (String with: $. with: Character cr), - 'For super expansions to be translated correctly each argument must be a variable with the same name as the corresponding argument in the super method.']. - self mergePropertiesOfSuperMethod: superTMethod. - (commonVars := superTMethod locals intersection: self locals) notEmpty ifTrue: - [varMap := Dictionary new. - commonVars do: - [:k| varMap at: k put: (superTMethod unusedNamePrefixedBy: k avoiding: self allLocals)]. - superTMethod renameVariablesUsing: varMap]. - self assert: (superTMethod locals allSatisfy: [:var| (self locals includes: var) not]). - locals addAll: superTMethod locals. - superTMethod declarations keysAndValuesDo: - [:var :decl| - self declarationAt: var put: decl]. - superTMethod comment ifNotNil: - [:superComment| - comment := comment - ifNil: [superComment] - ifNotNil: [superComment, comment]]. - superTMethod extraVariableNumber ifNotNil: - [:scvn| - extraVariableNumber := extraVariableNumber ifNil: [scvn] ifNotNil: [:cvn| cvn + scvn]]. - superTMethod elideAnyFinalReturn. - ^superTMethod parseTree]!

Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString

"VMMaker versionString"

+ ^'4.13.10'! - ^'4.13.12'!

Item was changed: ----- Method: VMStackFrameOffsets class>>initializeFrameIndices (in category 'class initialization') ----- initializeFrameIndices "Format of a stack frame. Word-sized indices relative to the frame pointer. Terminology Frames are either single (have no context) or married (have a context). Contexts are either single (exist on the heap), married (have a context) or widowed (had a frame that has exited). Stacks grow down:

receiver for method activations/closure for block activations arg0 ... argN caller's method ip/base frame's sender context fp-> saved fp method frame flags context (uninitialized) receiver first temp ... sp-> Nth temp

frame flags holds the number of arguments (since argument temporaries are above the frame) the flag for a block activation and the flag indicating if the context field is valid (whether the frame is married).

The first frame in a stack page is the baseFrame and is marked as such by a null saved fp, in which case the saved method ip is actually the context (possibly hybrid) beneath the base frame"

| fxCallerSavedIP fxSavedFP fxMethod fxFrameFlags fxThisContext fxReceiver | fxCallerSavedIP := 1. fxSavedFP := 0. fxMethod := -1. fxFrameFlags := -2. "Can find numArgs, needed for fast temp access. args are above fxCallerSavedIP. Can find ``is block'' bit Can find ``has context'' bit" fxThisContext := -3. fxReceiver := -4.

FrameSlots := fxCallerSavedIP - fxReceiver + 1.

+ FoxCallerSavedIP := fxCallerSavedIP * BytesPerWord. - FoxCallerSavedIP := fxCallerSavedIP * self bytesPerWord. "In base frames the caller saved ip field holds the caller context." FoxCallerContext := FoxCallerSavedIP. + FoxSavedFP := fxSavedFP * BytesPerWord. + FoxMethod := fxMethod * BytesPerWord. + FoxFrameFlags := fxFrameFlags * BytesPerWord. + FoxThisContext := fxThisContext * BytesPerWord. + FoxReceiver := fxReceiver * BytesPerWord! - FoxSavedFP := fxSavedFP * self bytesPerWord. - FoxMethod := fxMethod * self bytesPerWord. - FoxFrameFlags := fxFrameFlags * self bytesPerWord. - FoxThisContext := fxThisContext * self bytesPerWord. - FoxReceiver := fxReceiver * self bytesPerWord!